为啥闪亮的动态 UI + 模块没有提供所需的输出？

Posted 2023-03-24

【中文标题】为啥闪亮的动态 UI + 模块没有提供所需的输出？

【英文标题】：Why the shiny dynamic UI + modules does not give the desired output?为什么闪亮的动态 UI + 模块没有提供所需的输出？

【发布时间】：2021-12-09 22:25:53

【问题描述】：

我试图模块化这个堆栈溢出问题shiny: better way to create tables in loop across tab panels 中提出的闪亮应用程序。下面是 模块化 表示代码（与链接帖子中的原始代码不同，但结构相同）。但是，输出为空。我无法弄清楚这里的问题是什么，我怀疑这可能与动态 UI renderUI 部分中的 id 有关，其中 output[[id]] = renderDataTable() 和 DataTableOutput(id) 都出现（通常出现 render* 函数在服务器中，而*Output 出现在 UI 中。）。

我知道当使用闪亮的模块时，我们必须使用NS(id, 'name') 作为 UI 中的输出元素。在这里，我们似乎无法在服务器动态 UI 中做同样的事情，即output[[NS(id, 'name')]]。我不确定这是否是问题所在。

如果有任何建议，我将不胜感激。谢谢。

## library
library(shiny)
library(shinydashboard)
library(datasets)
library(dplyr)
library(DT)

## data
cars <- mtcars
irises <- iris
cars$team <- sample(c("Team1", "Team2"), nrow(cars), replace = TRUE)
irises$team <-
  sample(c("Team1", "Team2"), nrow(irises), replace = TRUE)

## module UI
tab_ui <- function(id) 
  uiOutput(NS(id, "content"))


## module Server
tab_server <- function(id, data, Team, var) 
  moduleServer(id, function(input, output, session) 
    table <- reactive(
      data %>% filter(team == Team)
    )

    output$content <- renderUI(
      lapply(sort(unique(table()[[var]])), function(i) 
        id <- paste0("content_", i)

        output[[id]] <-
          DT::renderDataTable(datatable(table()[table()[[var]] == i, ]))

        fluidRow(
          box(
            width = "100%",
            title = paste0(var, " ", i),
            status = "info",
            solidHeader = TRUE,
            collapsible = TRUE,
            DT::dataTableOutput(id)
          )
        )
      )
    )
  )


## UI
ui <- dashboardPage(
  dashboardHeader(title = "Teams"),
  dashboardSidebar(sidebarMenu(
    menuItem("Team 1",
      tabName = "tab_team1"
    ),
    menuItem("Team 2",
      tabName = "tab_team2"
    )
  )),
  dashboardBody(tabItems(
    tabItem(
      tabName = "tab_team1",
      fluidRow(
        tabBox(
          title = "",
          width = "100%",
          tabPanel(
            title = "A",
            tab_ui("team1_tabA")
          ), # module ui
          tabPanel(
            title = "B",
            tab_ui("team1_tabB")
          ) # module ui
        )
      )
    ),
    tabItem(
      tabName = "tab_team2",
      fluidRow(
        tabBox(
          title = "",
          width = "100%",
          tabPanel(
            title = "A",
            tab_ui("team2_tabA")
          ), # module ui
          tabPanel(
            title = "B",
            tab_ui("team2_tabB")
          ) # module ui
        )
      )
    )
  ))
)

## server
server <- function(input, output, session) 

  # module server
  tab_server("team1_tabA", data = cars, Team = "Team1", var = "gear")
  tab_server("team1_tabB", data = irises, Team = "Team1", var = "Species")
  tab_server("team2_tabA", data = cars, Team = "Team2", var = "gear")
  tab_server("team2_tabB", data = irises, Team = "Team2", var = "Species")


shinyApp(ui, server)

【参考方案1】：

试试这个

team_ui <- function(id) 
  ns <- NS(id)
  fluidRow(
    column(12,
           shinydashboard::box(width=12,
             title = "My Table",
              uiOutput(ns("Team_content"))
           )
    )
  )


team_server <- function(id,df,t,var) 
  moduleServer(
    id,
    function(input, output, session) 
      ns <- session$ns
      table <- df %>% dplyr::filter(team == as.character(t))
      
      output$Team_content <- renderUI(
        lapply(sort(unique(table[[as.character(var)]])), function(i) 
          idd <- paste0(t, "_content_A_", i)
          
          output[[idd]] <- DT::renderDataTable(datatable(table[table[[as.character(var)]] == i, ]))
          
          fluidRow(
            box(
              width = "100%",
              title = paste0(as.character(var),": ", i),
              status = "info",
              solidHeader = TRUE,
              collapsible = TRUE,
              DT::dataTableOutput(ns(idd))
            )
          )
        )
      )
      
    )

    

cars <- mtcars
irises <- iris
cars$team <- sample(c("Team1", "Team2"), nrow(cars), replace = TRUE)
irises$team <-
  sample(c("Team1", "Team2"), nrow(irises), replace = TRUE)

# UI
ui <- dashboardPage(
  dashboardHeader(title = "Teams"),
  dashboardSidebar(sidebarMenu(
    menuItem("Team 1",
             tabName = "tab_team1",
             icon = icon("dashboard")),
    menuItem("Team 2",
             tabName = "tab_team2",
             icon = icon("dashboard"))
  )),
  dashboardBody(tabItems(
    tabItem(tabName = "tab_team1",
            fluidRow(
              tabBox(
                title = "",
                width = "100%",
                tabPanel(title = "A", team_ui("Team1_content_A")),
                tabPanel(title = "B", team_ui("Team1_content_B"))
              )
            )) ,
    tabItem(tabName = "tab_team2",
            fluidRow(
              tabBox(
                title = "",
                width = "100%",
                tabPanel(title = "A", team_ui("Team2_content_A")),
                tabPanel(title = "B", team_ui("Team2_content_B"))
              )
            ))
  ))
)



server <- function(input, output, session) 
 
  team_server("Team1_content_A",cars,"Team1",'gear')
  team_server("Team1_content_B",irises,"Team1",'Species')
  team_server("Team2_content_A",cars,"Team2",'gear')
  team_server("Team2_content_B",irises,"Team2",'Species')
  

shinyApp(ui, server)

【讨论】：

谢谢@YBS！我在模块UI函数中添加ns = NS(id)，在服务器函数中添加ns = session$ns并修改DT::dataTableOutput(ns(id))，现在可以使用了！事实证明，即使它在动态 UI redenerUI() 中，我仍然应该考虑命名空间作为输出元素 id。

是的，您只需要在服务器模块中使用ns = session$ns，并适当地使用它。

请问为什么我们调用session$ns而不是直接使用ns？是不是因为ns是模块UI中的一个函数，而每当我们从配对的模块UI中调用模块服务器中的一个函数时，这个函数实际上是session列表中的一个元素？

这就是你在服务器端调用命名空间的方式。或许您可以再次查看documentation，了解更多详情。