Shinysurvey依赖型多选项select动态子集加载及性能优化问题

问题场景 #

为政府机构开发Shinysurvey问卷时，遇到两个核心问题：

• code选择框依赖entidad（联邦实体）字段，需要根据选中的实体加载对应CODE子集
• code选项数量过多，触发性能警告：The select input "code" contains a large number of options; consider using server-side selectize for massively improved performance.

现有问卷数据结构示例：

数据头部 #

数据尾部 #

当前可运行代码：

library(shiny)
library(shinysurveys)

df <- read.csv("cuestionario_previa.csv", encoding = "latin1")
ui <- fluidPage(
  surveyOutput(df = df,
               survey_title = "Servicios de Energia Electrica e Internet",
               survey_description = "Cuestionario rápido para el diagnostico de los servicios de luz e internet")
)

server <- function(input, output, session) {
  renderSurvey()
  
  observeEvent(input$submit, {
    showModal(modalDialog(
      title = "Congrats, you completed your first shinysurvey!",
      "You can customize what actions happen when a user finishes a survey using input$submit."
    ))
    
  })
}

shinyApp(ui, server)

解决方案 #

核心思路是开启server-side selectize渲染提升性能，同时根据entidad的选中值动态加载对应code选项子集。

步骤1：预处理数据，构建实体与CODE的映射表 #

先整理entidad到对应code选项的映射，方便后续快速调用：

# 需先安装dplyr包：install.packages("dplyr")
library(dplyr)

df <- read.csv("cuestionario_previa.csv", encoding = "latin1")

# 构建entidad到code选项的映射
code_mapping <- df %>%
  filter(input_type == "select", input_id == "code") %>%
  group_by(dependency_value) %>%
  summarise(options = list(option)) %>%
  tibble::deframe()

步骤2：修改Server逻辑，实现动态更新与server-side渲染 #

在server中监听entidad的变化，动态更新code选项并开启server-side处理：

server <- function(input, output, session) {
  renderSurvey()
  
  # 监听entidad变化，动态更新code选项
  observeEvent(input$entidad, {
    # 获取当前选中实体对应的CODE选项
    target_codes <- code_mapping[[input$entidad]]
    
    # 更新selectizeInput，开启server端渲染解决性能问题
    updateSelectizeInput(
      session = session,
      inputId = "code",
      choices = if(!is.null(target_codes)) target_codes else character(0),
      server = TRUE # 关键参数：启用server-side处理
    )
  }, ignoreNULL = FALSE, ignoreInit = FALSE)
  
  observeEvent(input$submit, {
    showModal(modalDialog(
      title = "问卷提交成功",
      "感谢您完成电力与互联网服务诊断问卷。"
    ))
  })
}

完整可运行代码 #

library(shiny)
library(shinysurveys)
library(dplyr)

# 读取并预处理数据
df <- read.csv("cuestionario_previa.csv", encoding = "latin1")

# 构建联邦实体与CODE的映射表
code_mapping <- df %>%
  filter(input_type == "select", input_id == "code") %>%
  group_by(dependency_value) %>%
  summarise(options = list(option)) %>%
  tibble::deframe()

ui <- fluidPage(
  surveyOutput(df = df,
               survey_title = "Servicios de Energia Electrica e Internet",
               survey_description = "Cuestionario rápido para el diagnostico de los servicios de luz e internet")
)

server <- function(input, output, session) {
  renderSurvey()
  
  # 动态更新CODE选项，启用server-side selectize
  observeEvent(input$entidad, {
    target_codes <- code_mapping[[input$entidad]]
    updateSelectizeInput(
      session = session,
      inputId = "code",
      choices = if(!is.null(target_codes)) target_codes else character(0),
      server = TRUE
    )
  }, ignoreNULL = FALSE, ignoreInit = FALSE)
  
  observeEvent(input$submit, {
    showModal(modalDialog(
      title = "问卷提交成功",
      "感谢您完成电力与互联网服务诊断问卷。"
    ))
  })
}

shinyApp(ui, server)

方案说明 #

• server = TRUE：将selectize的渲染逻辑转移到服务器端，避免大量选项加载到客户端导致的性能问题
• ignoreNULL = FALSE, ignoreInit = FALSE：确保页面初始化时以及entidad未选中时也能正确更新选项
• 映射表code_mapping：提前整理好实体与CODE的对应关系，避免每次更新时重复遍历原始数据

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