R Shiny应用新增子集筛选及分组箱线图绘制功能问题求助

修改方案 #

核心修改点

• 侧边栏新增通用筛选控件，支持先选筛选字段、再选该字段下要保留的取值，适配真实业务的多变量需求
• 服务端新增动态更新筛选选项的逻辑，上传数据后自动匹配字段可选值
• 新增数据子集过滤逻辑，用户选定筛选范围后自动应用到绘图数据源

完整可运行代码

library(shiny)
library(shinythemes)
library(dplyr)
library(readxl)
library(ggplot2)

not_sel <- "Not Selected"

main_page <- tabPanel(
  title = "Romans",
  titlePanel("Romans"),
  sidebarLayout(
    sidebarPanel(
      title = "Inputs",
      fileInput("xlsx_input", "Select XLSX file to import", accept = c(".xlsx")),
      selectInput("num_var_1", "Variable X axis", choices = c(not_sel)),
      selectInput("num_var_2", "Variable Y axis", choices = c(not_sel)),
      selectInput("factor", "Select factor", choices = c(not_sel)),
      # 新增筛选相关控件
      hr(),
      h4("数据筛选设置"),
      selectInput("filter_col", "选择筛选字段", choices = c(not_sel)),
      uiOutput("filter_values_ui"),
      br(),
      actionButton("run_button", "Run Analysis", icon = icon("play"))
    ),
    mainPanel(
      tabsetPanel(
        tabPanel(
          title = "Plot",
          plotOutput("plot_1")
        )
      )
    )
  )
)

draw_plot_1 <- function(data_input, num_var_1, num_var_2, factor){
  if(num_var_1 != not_sel & num_var_2 != not_sel & factor == not_sel){
    ggplot(data = data_input, aes(x = .data[[num_var_1]], y = .data[[num_var_2]], fill= .data[[num_var_2]])) +
      geom_boxplot() + 
      theme_bw()
  } else if(num_var_1 != not_sel & num_var_2 != not_sel & factor != not_sel){
    ggplot(data = data_input, aes(x = .data[[num_var_1]], y = .data[[num_var_2]], fill = .data[[factor]])) +
      geom_boxplot() + 
      theme_bw()
  }
}

ui <- navbarPage(
  title = "Plotter",
  theme = shinytheme("yeti"),
  main_page
)

server <- function(input, output){
  options(shiny.maxRequestSize=10*1024^2)
  
  data_input <- reactive({
    req(input$xlsx_input)
    inFile <- input$xlsx_input
    read_excel(inFile$datapath, 1)
  })
  
  # 上传数据后更新所有下拉框选项
  observeEvent(data_input(),{
    choices <- c(not_sel, names(data_input()))
    updateSelectInput(inputId = "num_var_1", choices = choices)
    updateSelectInput(inputId = "num_var_2", choices = choices)
    updateSelectInput(inputId = "factor", choices = choices)
    updateSelectInput(inputId = "filter_col", choices = choices)
  })
  
  # 动态生成筛选值多选框
  output$filter_values_ui <- renderUI({
    req(input$filter_col != not_sel)
    col_vals <- unique(data_input()[[input$filter_col]])
    checkboxGroupInput("filter_values", "选择要保留的取值", 
                       choices = col_vals, selected = col_vals)
  })
  
  # 过滤后的数据集
  filtered_data <- eventReactive(input$run_button, {
    req(data_input())
    raw_data <- data_input()
    # 没有开启筛选则返回全量数据
    if(input$filter_col == not_sel || is.null(input$filter_values)) {
      return(raw_data)
    }
    # 应用筛选条件
    raw_data %>%
      filter(.data[[input$filter_col]] %in% input$filter_values)
  })
  
  num_var_1 <- eventReactive(input$run_button, input$num_var_1)
  num_var_2 <- eventReactive(input$run_button, input$num_var_2)
  factor <- eventReactive(input$run_button, input$factor)
  
  plot_1 <- eventReactive(input$run_button,{
    req(filtered_data())
    draw_plot_1(filtered_data(), num_var_1(), num_var_2(), factor())
  })
  
  output$plot_1 <- renderPlot(plot_1())
}

shinyApp(ui = ui, server = server)

使用说明

上传包含军团字段的数据集后，在「数据筛选设置」区域的「选择筛选字段」下拉框选Legion字段，下方会自动出现两个军团的选项，勾选要展示的军团即可，绘图会自动使用筛选后的子集生成。

内容的提问来源于stack exchange，提问作者PassaroBagante