pickerInput 显示绘图上不同颜色的一条或多条 geom_hlines

问题描述 投票：0回答：1

这是我的应用程序：

我希望用户能够显示一个或多个类别的控制平均值，并且线条显示为与横条上的条形颜色相同的类别颜色相对应的水平线阴谋。像这样的东西（在画图中粗略地编辑过）：

由于我希望用户可以选择多行，因此我第一次尝试使用 pickerInput。输入部分看起来可以正常工作。但是，我该如何添加

geom_hline(aes(yintercept = Control), linetype = "dashed", size = 1.5)

到图中，颜色应与条形图位于相同的 cbPalette_4 中，并且仅在选择器菜单中选择它们时才显示？

我的代码是：

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)

和

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")))
r ggplot2 shiny geom-hline pickerinput
1个回答
0
投票

我已将平均值添加到过滤后的数据中（

mutate
）。我们还需要将调色板设为命名向量，以便我们可以根据 
input$controls
对其进行过滤。然后，我们可以有一个 if 语句并检查用户是否在下拉菜单中选择了任何变量。如果是，那么就像您的其他
layer_...
一样，我们可以创建一个
layer_h
，它会添加一个
geom_hline
。我（大部分）保留了已更改的行并删除了其余行以使答案更清晰。

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)

创建于 2024-04-06，使用 reprex v2.0.2

最新问题
© www.soinside.com 2019 - 2024. All rights reserved.