基于Shiny模块化实现下载按钮的显示与隐藏

问题概述 #

已开发一款连接数据库的Shiny应用，包含三个关联数据库的输入组件及一个下载按钮。除下载按钮的显隐逻辑外，其余功能均正常运行，数据下载功能本身可用，但需添加逻辑：当myvars$var3为空时隐藏下载按钮，预期逻辑框架如下：

observe({
   if (is.null(myvars$var3)) {shinyjs::hide("???")}
   else {shinyjs::show("???")}
})

代码结构说明 #

• server_tab2.R：
  • dropdownTab2Server函数：定义ID为daterange_tab2的日期范围逻辑，以及ID为var_list_tab2的最后一个下拉输入逻辑
  • downloadTab2Server函数：定义下载按钮的核心下载逻辑
• server.R（原代码无法正常工作）：需实现仅当第三个输入（myvars$var3）非空时才显示下载按钮
• ui_tab2.R：定义三个输入组件：
  • var_lab_tab2：仅含Choice1和Choice2两个选项的静态下拉输入
  • daterange_tab2_ui：日期范围选择组件
  • subid_dropdown_tab2_ui：依赖前两个输入的动态下拉输入

修复后的完整代码 #

server_tab2.R #

#### Function 1 - 依赖日期范围的下拉输入
dropdownTab2Server <- function(id) {
  moduleServer(id, function(input, output, session) {
    
    ns <- session$ns 
    rv <- reactiveValues()
    
    output$daterange_tab2_ui <- renderUI({
      req(input$var_lab_tab2) 
      dateRangeInput(ns("daterange_tab2"), "日期范围:", start = min_max_date_df$min_date, end = min_max_date_df$max_date) # 从global.R获取
    })
    
    unique_lists_tab2 <- reactive({
      sql <- glue_sql("
      SELECT
        DISTINCT list AS unique_list
      FROM table1
      WHERE date BETWEEN date ({dateid1_tab2*}) AND date ({dateid2_tab2*})
",
                      dateid1_tab2 = input$daterange_tab2[1],
                      dateid2_tab2 = input$daterange_tab2[2],
                      .con = pool
      )
      dbGetQuery(pool, sql) 
    })
    
    output$subid_dropdown_tab2_ui <- renderUI({
      req(input$daterange_tab2[1], input$daterange_tab2[2])
      
      shinyWidgets::pickerInput(
        ns("var_list_tab2"),
        "站点:",
        choices = unique_lists_tab2(),
        multiple = T
      )
    })
    
    observe({
      rv$var1 <- input$daterange_tab2[1]
      rv$var2 <- input$daterange_tab2[2]
      rv$var3 <- input$var_list_tab2
    })
    
    return(rv)
    
  })
}


#### Function 2 - 下载按钮逻辑
downloadTab2Server <- function(id, df, filename) { 
  moduleServer(id, function(input, output, session) {
    output$downloadbttn_tab2 <- downloadHandler(
      filename = function() { 
        paste0(filename, ".xlsx")
      },
      
      content = function(file) {
        WriteXLS::WriteXLS(df, file) 
      }
    )
  })
}

server.R（修复后） #

function(input, output, session) {
  # 只调用一次dropdown模块，获取返回的reactiveValues
  myvars <- dropdownTab2Server("dropdown_ui_tab2") 
  
  # 初始化隐藏下载按钮
  shinyjs::hide("download_ui_tab2-downloadbttn_tab2")
  
  # 监听myvars$var3的变化，控制下载按钮显隐
  observe({
    req(myvars)
    if (is.null(myvars$var3) || length(myvars$var3) == 0) {
      shinyjs::hide("download_ui_tab2-downloadbttn_tab2")
    } else {
      shinyjs::show("download_ui_tab2-downloadbttn_tab2")
    }
  })
  
  downloadTab2Server(
    id = "download_ui_tab2", 
    df = fake_data(), # 假设fake_data()是返回数据集的反应式函数
    filename = "数据"
  )
}

ui_tab2.R #

downloadTab2UI <- function(id) {
  ns <- NS(id) 
  
  tagList(
    shinyWidgets::pickerInput(
      ns("var_lab_tab2"),
      "ID:",
      choices = c("选项1", "选项2"), multiple = T
    ),
    
    uiOutput(ns("daterange_tab2_ui")),
    
    uiOutput(ns("subid_dropdown_tab2_ui")),
    
    downloadButton(ns("downloadbttn_tab2"), "下载数据")
  )
}

ui.R #

shinyUI(fluidPage(
  # 必须加载shinyjs以启用显隐功能
  shinyjs::useShinyjs(),
  downloadTab2UI("download_ui_tab2")
))

关键修改说明 #

1. 移除重复模块调用：原server.R中重复调用dropdownTab2Server，修复后仅调用一次并将返回值赋值给myvars
2. 正确的按钮ID：下载按钮的完整ID为download_ui_tab2-downloadbttn_tab2，由模块IDdownload_ui_tab2和按钮内部IDdownloadbttn_tab2拼接而成
3. 初始化隐藏：页面加载时默认隐藏下载按钮，避免初始状态不符合预期
4. 完善判断逻辑：增加length(myvars$var3) == 0的判断，覆盖多选下拉框被清空的场景
5. 加载shinyjs：在ui.R中添加shinyjs::useShinyjs()，确保显隐功能生效

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