如何在Shiny模块实例间传递值，实现地区与区县下拉联动？

需求说明 #

搭建包含两个标签页的模块化Shiny应用：

• Region（地区）标签页：通过下拉选择框选择地区，展示对应数据集表格
• District（区县）标签页：结合Region页选中的地区和当前页的区县选择，展示对应数据集表格；且District页的区县下拉选项需根据Region页的选择动态更新

遇到的问题 #

无法将Region页选中的地区值传递到District页的逻辑处理中，推测是Shiny模块作用域问题导致。

原始代码 #

library(shiny)
library(shinydashboard)
library(tidyr)

locations = tribble(
  ~region,~district,
  "Morogoro","Morogoro DC",
  "Morogoro","Gairo DC",
  "Lindi","Tandahima DC",
  "Lindi", "Kilwa DC"
)

get_regional_dataset = function(region){
  if(region=="Morogoro"){
    mtcars
  }else{
    iris
  }
}

get_district_dataset = function(region,district){
  if(region=="Morogoro" & district=="Morogoro DC"){
    mtcars
  }else{
    iris
  }
}

table_UI1 <- function(id) {
  ns <- NS(id)
  tagList(
    sidebarPanel(width = 2,
                 uiOutput(ns("selector")),
    )
  )
}

table_UI2 <- function(id) {
  ns <- NS(id)
  tagList(
    mainPanel(
      DT::dataTableOutput(ns('table'))
    )
  )
}

table_Server1 <- function(id) {
  moduleServer(id,function(input, output, session) {
    ns <- session$ns
    output$selector <- renderUI({
      if(id %in% c("ER_district")) {
        choices <- locations$district 
        label <- "Council"
      }
      else { 
        choices <- locations$region
        label <- "Region"
      }
      
      selectInput(inputId=NS(id,"choice"),
                  label = label,
                  choices = choices)
    })
    return(reactive(input$choice))
  })
}

table_Server <- function(id, mychoice, mychoice2) {
  moduleServer(id,function(input, output, session) {
    rv <- reactiveValues()
    
    observe({
      
      rv$reg <<- mychoice()
      rv$dist <<- mychoice2()
      
      if (!is.null(mychoice())) rv$df <- get_regional_dataset(rv$reg)
      if(id=="ER_district"){
        if (!is.null(mychoice2())) rv$df <- get_district_dataset(rv$reg,rv$dist)
        
      }
    })
    
    output$table = DT::renderDataTable({
      rv$df
    })
    
  })
}

ui = fluidPage(
  tabsetPanel(id = 'cqi_indicators',
              tabPanel('Region',
                       tabsetPanel(
                         id='region_indicators',
                         tabPanel("Early Retention",table_UI1("ER"), table_UI2("ER"))
                       )
              ),
              tabPanel('District',
                       tabsetPanel(
                         id='district_indicators',
                         tabPanel("Early Retention",table_UI1("ER_district"), table_UI2("ER_district"))
                       )
              )
  )
}

server = function(input,output,session){
  
  choice1 <- table_Server1("ER")
  choice2 <- table_Server1("ER_district")
  
  table_Server("ER", choice1, choice2)
  table_Server("ER_district", choice1, choice2)
  
}

shinyApp(ui,server)

问题分析与修复方案 #

核心问题点 #

1. 模块命名空间错误：table_Server1中创建selectInput时使用NS(id,"choice")，应该用模块内的ns("choice")，否则无法正确绑定模块内的输入值
2. 区县选项未动态更新：District页的区县下拉选项没有关联Region页的选择，需要将Region的选择值作为参数传入选择器模块
3. 不必要的全局赋值：rv$reg <<- mychoice()使用全局赋值符号，应改为普通赋值rv$reg <- mychoice()

修正后的完整代码 #

library(shiny)
library(shinydashboard)
library(tidyr)
library(DT)

locations = tribble(
  ~region,~district,
  "Morogoro","Morogoro DC",
  "Morogoro","Gairo DC",
  "Lindi","Tandahima DC",
  "Lindi", "Kilwa DC"
)

get_regional_dataset = function(region){
  if(region == "Morogoro"){
    mtcars
  }else{
    iris
  }
}

get_district_dataset = function(region, district){
  if(region == "Morogoro" & district == "Morogoro DC"){
    mtcars
  }else{
    iris
  }
}

# 选择器UI模块
selector_UI <- function(id) {
  ns <- NS(id)
  sidebarPanel(
    width = 2,
    uiOutput(ns("selector"))
  )
}

# 表格UI模块
table_UI <- function(id) {
  ns <- NS(id)
  mainPanel(
    DTOutput(ns('table'))
  )
}

# 选择器服务器模块：根据类型和父选择值生成选项
selector_Server <- function(id, parent_choice = NULL) {
  moduleServer(id, function(input, output, session) {
    ns <- session$ns
    
    output$selector <- renderUI({
      # 判断是地区选择还是区县选择
      if(grepl("district", id)){
        # 依赖父选择（地区）生成区县选项
        req(parent_choice())
        choices <- locations$district[locations$region == parent_choice()]
        label <- "Council"
      } else {
        choices <- unique(locations$region)
        label <- "Region"
      }
      
      selectInput(
        inputId = ns("choice"),
        label = label,
        choices = choices,
        selected = choices[1]
      )
    })
    
    # 返回当前选择值
    return(reactive(input$choice))
  })
}

# 表格服务器模块：根据选择值加载数据
table_Server <- function(id, region_choice, district_choice = NULL) {
  moduleServer(id, function(input, output, session) {
    # 动态获取数据集
    dataset <- reactive({
      req(region_choice())
      if(grepl("district", id)){
        req(district_choice())
        get_district_dataset(region_choice(), district_choice())
      } else {
        get_regional_dataset(region_choice())
      }
    })
    
    output$table <- renderDT({
      dataset()
    })
  })
}

# 主UI
ui = fluidPage(
  tabsetPanel(
    id = 'cqi_indicators',
    tabPanel(
      'Region',
      tabsetPanel(
        id='region_indicators',
        tabPanel("Early Retention", selector_UI("ER"), table_UI("ER"))
      )
    ),
    tabPanel(
      'District',
      tabsetPanel(
        id='district_indicators',
        tabPanel("Early Retention", selector_UI("ER_district"), table_UI("ER_district"))
      )
    )
  )
)

# 主服务器
server = function(input, output, session){
  # 地区选择模块
  region_choice <- selector_Server("ER")
  
  # 区县选择模块：传入地区选择值作为依赖
  district_choice <- selector_Server("ER_district", parent_choice = region_choice)
  
  # 地区表格模块
  table_Server("ER", region_choice = region_choice)
  
  # 区县表格模块：传入地区和区县选择值
  table_Server("ER_district", region_choice = region_choice, district_choice = district_choice)
}

shinyApp(ui, server)

修复说明 #

1. 拆分并简化模块命名，让职责更清晰（selector_UI/selector_Server负责选择器，table_UI/table_Server负责表格）
2. selector_Server新增parent_choice参数，实现District页区县选项依赖Region页的选择
3. 修正命名空间使用，确保模块内输入输出正确绑定
4. 简化数据加载逻辑，使用reactive直接生成数据集，替代复杂的reactiveValues和observe
5. 添加req()确保依赖值存在后再执行逻辑，避免空值报错

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