pickerInput to show one or multiple geom_hlines that are different colors on plot
This is my app: 
I'd like the user to be able to show the control mean for one or more categories, and for the line(s) to show as horizontal line(s) corresponding to the same category color as the bar(s) across the plot. Something like this (crudely edited in Paint):
As I'd like the user to have the option to choose multiple lines, I'm trying to use pickerInput for the first time. The input part looks like it's working. But, how do I add
geom_hline(aes(yintercept = Control), linetype = "dashed", size = 1.5)
to the plot where the colors should be in the same cbPalette_4 as the bars and only show when they are selected in the picker menu?
My code is:
ui <- fluidPage(
sidebarLayout(
sidebarPanel(
selectInput('cat','Select Category', unique(table_E.9_9$Ent_or_Rev)),
pickerInput(
inputId = "controls",
label = "Show average of non-recipients",
choices = unique(table_E.9_9$variable),
multiple = TRUE,
selected = "Retail Trade"
),
checkboxInput("p_values",label = "Show p-value levels", value = FALSE),
checkboxInput("error_bars",label = "Show 95% confidence intervals", value = FALSE),
actionButton("Explain_p_values", "Explain p-values"),
actionButton("Explain_error_bars", "Explain 95% confidence intervals")
),
mainPanel(plotOutput('plot_overall'))
)
)
server <- function(input, output, session) {
observeEvent(input$Explain_p_values, {showModal(modalDialog(p_value_text))})
observeEvent(input$Explain_error_bars, {showModal(modalDialog(CI_text))})
output$plot_overall <- renderPlot({
cbPalette_4 <- c("#999999", "#F0E442", "#0072B2", "#D55E00")
fun_select_cat <- function(table, cat) {
table %>%
filter(Ent_or_Rev == cat)
}
table_E.9_9_filtered <- fun_select_cat(table_E.9_9, input$cat) |>
ungroup()
control_y <- table_E.9_9_filtered %>% pull(Control) |> unique()
title <- if (input$cat == "Number of Enterprises") {
input$cat
} else {
paste(input$cat, "(USD)", sep = " ")
}
layer_error <- if (input$error_bars) {
geom_errorbar(aes(ymin = lower, ymax = higher), width = 0.25, position = position_dodge(width = 0.9))
}
layer_p <- if (input$p_values) {
column_y_text <- if (input$error_bars) {
"higher" #if p-values and error_bars checked then add stars at higher CI otherwise at the obs
} else {
"new_est"
}
max_y_text <- table_E.9_9_filtered |> # if asterisks column not NA then either put asterisks higher than error bars if error_bar checked
filter(!is.na(Sig)) |> # or put it at bar height if not checked
pull(column_y_text) |> # keep the height of tallest bar
max()
list(
geom_text(aes(label = Sig, y = 1.05 * .data[[column_y_text]], group=variable), position = position_dodge(width = 0.9), na.rm = TRUE), # asterisks go just above either bar or obs
if (!is.na(max_y_text)) expand_limits(y = c(0, max_y_text * 1.05)) # if tallest bar has asterisk then expand limit
)
}
table_E.9_9_filtered |>
ggplot(aes(x = Treatment, y = new_est, fill = variable)) +
geom_col(position = position_dodge(width = 0.9)) +
scale_fill_manual(values = cbPalette_4) +
scale_y_continuous(labels = label_comma(), expand = c(0, 0)) +
theme_classic() +
scale_x_discrete(drop = FALSE) +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.text = element_text(size = 12),
legend.title = element_blank(),
legend.text = element_text(size = 12)
) +
layer_p +
layer_error +
labs(title = title, x = NULL, y = NULL)
})
}
shinyApp(ui = ui, server = server)
and dput(table_E.9_9):
structure(list(Treatment = structure(c(1L, 1L, 1L, 1L, 1L, 1L,
1L, 1L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 3L, 2L, 2L, 2L, 2L, 2L, 2L,
2L, 2L), levels = c("Long Term", "Short Term", "Lump Sum"), class = "factor"),
variable = c("Manufacturing", "Manufacturing", "Retail Trade",
"Retail Trade", "Services", "Services", "Transportation",
"Transportation", "Manufacturing", "Manufacturing", "Retail Trade",
"Retail Trade", "Services", "Services", "Transportation",
"Transportation", "Manufacturing", "Manufacturing", "Retail Trade",
"Retail Trade", "Services", "Services", "Transportation",
"Transportation"), Control = c(0.89, 185.99, 11.05, 1356.55,
1.56, 233.14, 0.94, 136.04, 0.89, 185.99, 11.05, 1356.55,
1.56, 233.14, 0.94, 136.04, 0.89, 185.99, 11.05, 1356.55,
1.56, 233.14, 0.94, 136.04), Estimate = c(0.02, 51.9, 3.89,
1601.42, 0.23, 198.64, 0.53, 100.76, 0.28, 254.11, 4.24,
770.01, 0.45, 718.68, 0.38, 101, 0.03, 17.82, 2.34, 464.6,
-0.04, 70.95, -0.12, -3.85), SE = c(0.27, 120.79, 1.28, 824.74,
0.33, 205.6, 0.29, 85.37, 0.23, 221.06, 1.03, 338.12, 0.38,
440.08, 0.29, 61.26, 0.21, 133.58, 0.95, 273.59, 0.29, 218.2,
0.18, 48.33), Sig = c(NA, NA, "∗∗∗", "∗", NA, NA,
"∗", NA, NA, NA, "∗∗∗", "∗∗", NA, NA, NA, NA,
NA, NA, "∗∗", "∗", NA, NA, NA, NA), Ent_or_Rev = c("Number of Enterprises",
"Net Revenues", "Number of Enterprises", "Net Revenues",
"Number of Enterprises", "Net Revenues", "Number of Enterprises",
"Net Revenues", "Number of Enterprises", "Net Revenues",
"Number of Enterprises", "Net Revenues", "Number of Enterprises",
"Net Revenues", "Number of Enterprises", "Net Revenues",
"Number of Enterprises", "Net Revenues", "Number of Enterprises",
"Net Revenues", "Number of Enterprises", "Net Revenues",
"Number of Enterprises", "Net Revenues"), new_est = c(0.91,
237.89, 14.94, 2957.97, 1.79, 431.78, 1.47, 236.8, 1.17,
440.1, 15.29, 2126.56, 2.01, 951.82, 1.32, 237.04, 0.92,
203.81, 13.39, 1821.15, 1.52, 304.09, 0.82, 132.19), lower = c(0.3808,
1.14160000000001, 12.4312, 1341.4796, 1.1432, 28.804, 0.9016,
69.4748, 0.7192, 6.82240000000002, 13.2712, 1463.8448, 1.2652,
89.2632, 0.7516, 116.9704, 0.5084, -58.0068, 11.528, 1284.9136,
0.9516, -123.582, 0.4672, 37.4632), higher = c(1.4392, 474.6384,
17.4488, 4574.4604, 2.4368, 834.756, 2.0384, 404.1252, 1.6208,
873.3776, 17.3088, 2789.2752, 2.7548, 1814.3768, 1.8884,
357.1096, 1.3316, 465.6268, 15.252, 2357.3864, 2.0884, 731.762,
1.1728, 226.9168)), class = c("grouped_df", "tbl_df", "tbl",
"data.frame"), row.names = c(NA, -24L), groups = structure(list(
Ent_or_Rev = c("Net Revenues", "Net Revenues", "Net Revenues",
"Net Revenues", "Number of Enterprises", "Number of Enterprises",
"Number of Enterprises", "Number of Enterprises"), variable = c("Manufacturing",
"Retail Trade", "Services", "Transportation", "Manufacturing",
"Retail Trade", "Services", "Transportation"), .rows = structure(list(
c(2L, 10L, 18L), c(4L, 12L, 20L), c(6L, 14L, 22L), c(8L,
16L, 24L), c(1L, 9L, 17L), c(3L, 11L, 19L), c(5L, 13L,
21L), c(7L, 15L, 23L)), ptype = integer(0), class = c("vctrs_list_of",
"vctrs_vctr", "list"))), row.names = c(NA, -8L), .drop = TRUE, class = c("tbl_df",
"tbl", "data.frame")))
Solution
I have added the average values to the filtered data (mutate). We also need to make the color palette a named vector so we can filter it based on input$controls. Then, we can have an if-statement and check if user has any of the variables selected in the drop-down menu. If yes, then like your other layer_... we can create a layer_h which would add a geom_hline. I (mostly) kept the lines that I have changed and removed the rest to make the answer more legible.
library(shiny)
library(shinyWidgets)
library(tidyverse)
library(scales)
### no changes to UI ###
server <- function(input, output, session) {
observeEvent(input$Explain_p_values, {showModal(modalDialog(p_value_text))})
observeEvent(input$Explain_error_bars, {showModal(modalDialog(CI_text))})
output$plot_overall <- renderPlot({
cbPalette_4 <- c("Manufacturing" = "#999999",
"Retail Trade" = "#F0E442",
"Services" = "#0072B2",
"Transportation" = "#D55E00")
fun_select_cat <- function(table, cat) {
table %>%
filter(Ent_or_Rev == cat)
}
table_E.9_9_filtered <- fun_select_cat(table_E.9_9, input$cat) %>%
ungroup() %>%
mutate(havg = mean(new_est), .by = variable)
### no changes to these lines ...
layer_h <- if(!is.null(input$controls)){
geom_hline(data = {table_E.9_9_filtered %>% filter(variable %in% input$controls)},
aes(yintercept = havg, color = variable))
}
table_E.9_9_filtered %>%
ggplot(aes(x = Treatment, y = new_est, fill = variable)) +
geom_col(position = position_dodge(width = 0.9)) +
scale_fill_manual(values = cbPalette_4) +
scale_color_manual(values = subset(cbPalette_4,
names(cbPalette_4) %in% input$controls)) +
scale_y_continuous(labels = label_comma(), expand = c(0, 0)) +
theme_classic() +
scale_x_discrete(drop = FALSE) +
theme(
plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
axis.text = element_text(size = 12),
legend.title = element_blank(),
legend.text = element_text(size = 12)
) +
layer_p +
layer_error +
layer_h +
guides(colour="none") +
labs(title = title, x = NULL, y = NULL)
})
}
shinyApp(ui = ui, server = server)
Created on 2024-04-06 with reprex v2.0.2
- Retrieving expected data.frame for testthat expectation
- How to use an anonymous function with pipe operator?
- R passing RSelenium driver environment as function argument
- Keep file names merging list with lapply?
- replace strings that contains one another
- Stop parsing out zeros after decimals in ggplot2's annotate
- Plot data.tree coloring and labelling by level
- Extracting the date and time out of a date and time format
- How to reshape a dataframe into wide format with specified column pairs
- Show partial segments removed after limit scales for `geom_pointrange`
- Control ggplot2 legend look without affecting the plot
- Concatenate strings over all rows in a single column of a data frame
- Is there some way to keep variable names from.SD+.SDcols together with non .SD variable names in data.table?
- How to create mutually dependent checkbox columns in a DT table?
- A problem with an stacked, grouped and faceted graph y gg plot
- Installing R on Linux: configure: error: libcurl >= 7.28.0 library and headers are required with support for https
- Create a column conditional on multiple other character and numerical columns
- data.frame to array (2 columns)
- Changing options() in a function environment without changing options() in global environment in R?
- pivot(), group_by() and summarise() with nested data
- Why legend is not showing up in plot layout using patchwork in R?
- in dplyr::mutate, dplyr::starts_with works for .before but not .after?
- Finding optimal cut-off points for dividing a variable into equal groups considering ties in which quantiles do not work
- How to add a legend to hline?
- R Shiny Suppress slider handle for sliderInput until click
- brmultinom brglm2 vifs and dredge dont work
- R, how to get current time miliseconds, without extra information ? (Sys.time(), format("%X"))
- Installing multiple versions of R
- Command to see 'R' path that RStudio is using
- Fast pairwise longest common substring from start