Shiny模块中使用lapply生成动态tabBox时表格输出渲染失效问题

我想在Shiny中构建一个模块，渲染出tabBox，其中tabPanel的数量由导入数据决定。模拟数据包含水箱/池塘（葡萄牙语为viveiro）列，其数量是可变的，因此面板数量也随该变量变化。
我需要在每个tabPanel中用renderTable()渲染对应viveiro分组的子集表格，目前分别用lapply()构建renderUI、给输出绑定反应式表达式。nCiclo()是一个反应式变量，代表viveiro的数量，例如对应1:6序列。第一个用于output$tab_box的renderUI()内的lapply()运行正常，但第二个给output[[paste0('outCiclo',j)]]绑定renderTable的lapply()无法正常运行。

具体疑问 #

如何让最后这个lapply()的遍历序列随模拟数据中viveiro（水箱/池塘）的数量动态变化？尝试将固定序列1:6替换为反应式变量nCiclo()但无法生效。

可复现代码 #

library(shiny)
library(shinydashboard)
library(openxlsx) 
rm(list = ls())
#--------------------------------------------------
# 应用模拟数据
(n = 2*sample(3:8,1)) # 水箱/池塘（葡萄牙语viveiro）数量，为数据中的随机变量
bio <- data.frame(
  semana = rep(1:5,n),
  peso = rnorm(5*n,85,15),
  viveiro = rep(1:2,each=(5*n)/2),
  ciclo = rep(1:n,each=5)
)
# 运行后Excel文件会保存到你的工作目录，可导入应用测试
write.xlsx(bio,'bio.xlsx')

#--------------------------------------------------

####### 模块 #######

# UI模块
dashMenuUI <- function(id){
  ns <- NS(id)
  uiOutput(ns("tab_box"))
}

# 服务端模块
dashMenuServer <- function(id,df){
  moduleServer(id,function(input,output,session){
    
    ns <- session$ns
    nCiclo <- reactive(unique(df()$ciclo)) # nCycle对应ciclo的取值序列，如1:6
    
    output$tab_box <- renderUI({
      do.call(tabBox, c(id='tabCiclo',
                        lapply(nCiclo(), function(i) {
                          tabPanel(
                            paste('ciclo', i),
                            tableOutput(outputId =  ns(paste0('outCiclo',i)) )
                          )
                        }))
      )
    })
    
    # 问题出在此处：想让lapply的遍历序列随数据中的池塘数量动态变化
    # 但把1:6替换为nCiclo()后无法运行
    lapply(1:6, function(j) {
      output[[paste0('outCiclo',j)]] <- renderTable({
        subset(df(), ciclo==j)
      })
    })
    
  })
}

#------------------------------------------------------

ui <- dashboardPage(
  dashboardHeader(title = "Teste Módulo TabBox Dinâmico"),
  dashboardSidebar(
    sidebarMenu(
      menuItem('Ciclo e viveiro',tabName = 'box_din')
    )
  ),
  dashboardBody(
    tabItems(
      tabItem(tabName='box_din',
              fileInput(inputId = "upload",label = "Carregue seu arquivo", accept = c(".xlsx")),
              dashMenuUI('tabRender')
      )
    )
  )
  
)

server <- function(input, output, session) {
  dados <- reactive({
    req(input$upload)
    file <- input$upload
    ext <- tools::file_ext(file$datapath)
    req(file)
    validate(need(ext == "xlsx", "Por gentileza insira um arquivo de Excel (extensão .xlsx)"))
    df <- read.xlsx(file$datapath,sheet = 1)
    df
  })
  dashMenuServer('tabRender',dados)
}

shinyApp(ui, server)

问题根源 #

反应式变量nCiclo()只能在反应式上下文中调用，这类上下文包括reactive()、render*()、observe()/observeEvent()等函数内部。你原来的lapply直接写在模块服务端的顶层，不属于反应式上下文，因此无法读取nCiclo()的动态返回值，替换后运行失败。

修正方法 #

将动态绑定输出的lapply逻辑包裹在observe()中，监听nCiclo()的变化：每次导入的数据集更新、ciclo数量变化时，自动重新给所有对应输出绑定renderTable。

修正后的模块服务端代码 #

仅需要替换原dashMenuServer中动态绑定输出的部分即可：

# 修正后的服务端模块
dashMenuServer <- function(id,df){
  moduleServer(id,function(input,output,session){
    
    ns <- session$ns
    nCiclo <- reactive(unique(df()$ciclo)) 
    
    output$tab_box <- renderUI({
      do.call(tabBox, c(id='tabCiclo',
                        lapply(nCiclo(), function(i) {
                          tabPanel(
                            paste('ciclo', i),
                            tableOutput(outputId =  ns(paste0('outCiclo',i)) )
                          )
                        }))
      )
    })
    
    # 修正后的动态绑定逻辑
    observe({
      req(nCiclo()) # 等待nCiclo有有效值后再执行后续逻辑
      lapply(nCiclo(), function(j) {
        output[[paste0('outCiclo',j)]] <- renderTable({
          subset(df(), ciclo==j)
        })
      })
    })
    
  })
}

效果说明 #

修改后无需固定1:6的遍历序列，导入任意ciclo数量的数据集，都会自动生成对应数量的tab面板，且每个面板可以正确渲染对应ciclo分组的子集表格。 #

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