如何在多个嵌套模块中显示带有 DT 的动态 tabPanel

Question

我真的需要以下代码的帮助，我使用 2 个嵌套模块按某些列在多个 tabPanels（tabsetPanel 内）中显示 sampledata，但是 table 没有显示，我还没有发现任何错误。

PS：这只是一个可重现的例子，sampledata是用户在真实场景中上传的

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

ui <- function() {
  dashboardPage(
    dashboardHeader(title = "abc"),
    dashboardSidebar(uiOutput("sidebarpanel")), 
    dashboardBody(uiOutput("body")))
}

server <- function(input, output, session) {
  output$sidebarpanel <- renderUI({
    tags$div(
      sidebarMenu(id = "tabs",
                  menuItem("Data", tabName = "data"))
    )
  })
  
  output$body <- renderUI({ 
    tabItems(ui_data1("data1", tabName = "data"))
  })
  
  input_data1 <- new.env()
  input_data1$a <- reactive(1)
  input_data1$b <- reactive(2)
  
  input_data2 <- server_data1("data1", input_data1)
}

ui_data1 <- function(id, tabName){ 
  ns <- NS(id)
  tabItem(tabName = tabName,
          uiOutput(ns("body")))
}

server_data1 <- function(id, input_data1) {
  ns <- NS(id)
  moduleServer(id, function(input, output, session) {
    output$body <- renderUI({
      tabsetPanel(
        ui_data2(ns("info1"), "Info1")
      )
    })
    
    data2 <- new.env()
    data2$input_data2 <- server_data2("info1", input_data1)
    
    return(data2)
  })
}

ui_data2 <- function(id, title) {
  ns <- NS(id)
  tabPanel(title = title,
           uiOutput(ns("body")))
}

server_data2 <- function(id, input_data1) {
  ns <- NS(id)
  moduleServer(id, function(input, output, session) {
    c <- eventReactive(input_data1$a(), {
      2
    })
    
    sampledata <- reactive(mtcars)
    
    output$body <- renderUI({
      all_cyl <- unique(sampledata()$cyl)
      tbl_by_cyl <- lapply(seq_along(all_cyl), function(i) {
        tabPanel(all_cyl[i],
                     column(12, br(),
                            box(width = "auto",
                                DT::dataTableOutput(ns(paste0("cyl", i)), 
                                                    width = "100%"))))
      })
      do.call(tabsetPanel, tbl_by_cyl)
    })
    
    observe({
      sampledata <- sampledata()
      all_cyl <- unique(sampledata$cyl)
      
      lapply(seq_along(all_cyl), function(i) {
        output[[paste0("cyl", i)]] <- DT::renderDataTable({
          datatable(sampledata[sampledata$cyl == all_cyl[i], ])
        })
      })
    })
    
    return(sampledata)
  })
}

shinyApp(ui, server)

输出： output of above code

Answer 1

你们非常亲密。您只需要 server_data1 和 server_data2 中的 ns <- session$ns。试试这个

  library(shiny)
  library(shinydashboard)
  library(DT)
  
  ui <- function() {
    dashboardPage(
      dashboardHeader(title = "abc"),
      dashboardSidebar(uiOutput("sidebarpanel")), 
      dashboardBody(uiOutput("body")))
  }
  
  server <- function(input, output, session) {
    output$sidebarpanel <- renderUI({
      tags$div(
        sidebarMenu(id = "tabs",
                    menuItem("Data", tabName = "data"))
      )
    })
    
    output$body <- renderUI({ 
      tabItems(ui_data1("data1", tabName = "data"))
    })
    
    input_data1 <- new.env()
    input_data1$a <- reactive(1)
    input_data1$b <- reactive(2)
    
    input_data2 <- server_data1("data1", input_data1)
  }
  
  ui_data1 <- function(id, tabName){ 
    ns <- NS(id)
    tabItem(tabName = tabName,
            uiOutput(ns("body1")))
  }
  
  server_data1 <- function(id, input_data1) {
    #ns <- NS(id)
    moduleServer(id, function(input, output, session) {
      ns <- session$ns
      output$body1 <- renderUI({
        tabsetPanel(
          ui_data2(ns("info1"), "Info1")
        )
      })
      
      data2 <- new.env()
      data2$input_data2 <- server_data2("info1", input_data1)
      
      return(data2)
    })
  }
  
  ui_data2 <- function(id, title) {
    ns <- NS(id)
    tabPanel(title = title,
             uiOutput(ns("body2")))
  }
  
  server_data2 <- function(id, input_data1) {
    #ns <- NS(id)
    moduleServer(id, function(input, output, session) {
      ns <- session$ns
      c <- eventReactive(input_data1$a(), {
        2
      })
      
      sampledata <- reactive(mtcars)
      
      output$body2 <- renderUI({
        all_cyl <- unique(sampledata()$cyl)
        tbl_by_cyl <- lapply(seq_along(all_cyl), function(i) {
          tabPanel(all_cyl[i],
                   fluidRow(column(12, br(),
                          shinydashboard::box( width = "auto",
                              DTOutput(ns(paste0("cyl", i)),width = "100%")))))
        })
        do.call(tabsetPanel, tbl_by_cyl)
      })
      
      observe({
        sampledata <- sampledata()
        all_cyl <- unique(sampledata$cyl)
        
        lapply(seq_along(all_cyl), function(i) {
          output[[paste0("cyl", i)]] <- renderDT({
            datatable(sampledata[sampledata$cyl == all_cyl[i], ])
          })
        })
      })
      
      return(sampledata)
    })
  }
  
  shinyApp(ui, server)

如何在多个嵌套模块中显示带有 DT 的动态 tabPanel

how to display dynamic tabPanels with DT inside multiple nested modules

r

shiny

shinydashboard

dt

shiny-reactivity