This is my app: enter image description here

我希望用户能够显示一个或多个类别的控制手段,并为线显示为水平线(s)对应于相同类别 colored颜色 的条(s)跨越图.类似这样的东西(在Paint中粗略编辑):

enter image description here

因为我希望用户可以 Select 多行,所以我try 第一次使用pickerInput.输入部分看起来像是在工作.但是,我怎么加上

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

图中的 colored颜色 应与条形图相同,并且仅在 Select 器菜单中选中时才显示?

我的代码是:

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")))

推荐答案

我已经将平均值添加到过滤数据(mutate)中.我们还需要使调色板成为一个命名向量,以便我们可以根据input$controls过滤它.然后,我们可以有一个if语句,并判断用户是否有下拉菜单中 Select 的任何变量.如果是的话,那么就像你的其他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

R相关问答推荐

ggplot 2中的地块底图(basemaps_gglayer()不起作用)

汇总数据表中两个特定列条目的值

使用across,starts_with和ifelse语句变更多个变量

R:从geom_ol()中删除轮廓并导出为pdf

try 将 colored颜色 编码添加到ggploly的标题中

当我们有多个反斜杠和/特殊字符时使用Gsubing

Geom_Hline将不会出现,而它以前出现了

在保留列表元素属性的同时替换列表元素

R -如何分配夜间GPS数据(即跨越午夜的数据)相同的开始日期?

如何在使用Alpha时让geom_curve在箭头中显示恒定透明度

以任意顺序提取具有多个可能匹配项的组匹配项

在r中整理图例和堆叠图的问题

如何使用ggplot2根据绘图中生成的斜率对小平面进行排序?

使用R、拼图和可能的网格包绘制两个地块的公共垂直线

无法保存gglot的所有pdf元素

Ggplot2:添加更多特定 colored颜色 的线条

从单个html段落中提取键-值对

在R中,有没有什么方法可以根据一列中的多个值来过滤行?

在子图内和子图之间对齐行数不均匀的表格罗布对

如何将数据框压缩为更宽,同时将行输入保持为行输入,而不是R中的列名?