R shinydashboard：各种菜单子项的动态和静态选项卡项的混合

Question

我正在构建一个包含三个部分的应用程序：

1. 概述
2. 详细结果
3. 帮助

详细结果部分应显示多个子项的结果，一次显示一个。

我对将结果部分作为单个选项卡感兴趣，因为我不想为每个子项的每个选项卡编写代码。每个子项都有相同的，在示例中为直方图。

但是，当我运行示例时，我丢失了子项的 ID。 是否可以有这样的布局但保留所有菜单项和菜单子项的 ID？

很高兴看到替代方法。

下面是一个例子来说明这个问题。该解决方案将在概览中显示表格、任何子项的结果直方图以及帮助部分中的 HTML 输出。

library(shiny)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(), 
  dashboardSidebar(
    sidebarMenu(id = "SideBarMENU", 

                menuItem("Overview", tabName = "OVERVIEW", selected = TRUE),
                menuItem("Results",  startExpanded = TRUE,
                         menuSubItem("Sepal.Length", tabName = "RESULTS"),
                         menuSubItem("Sepal.Width" , tabName = "RESULTS"),
                         menuSubItem("Petal.Length", tabName = "RESULTS"),
                         menuSubItem("Petal.Width" , tabName = "RESULTS")
                ), 
                menuItem("Help", tabName = "HELP")
    )

  ),
  dashboardBody(
    tabItems(
      tabItem("OVERVIEW", 
              box("Overview box", 
                  tableOutput("overview"))
      ),
      tabItem("RESULTS", 
              box("Results box", 
                  plotOutput("results")
              )
      ),
      tabItem("HELP", 
              box("HELP box", 
                  textOutput("help"))
      ) 
    )
  )
)

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


  data <- reactive({

    print(input$SideBarMENU)

    if(input$SideBarMENU %in% names(iris)){
      iris[[input$SideBarMENU]]
    } else {
      rnorm(100, 1000, 10)
    }
  })


  output$results <- renderPlot({
    hist(data())
  })


  output$overview <- renderTable({
    head(iris)
  })



  output$help <- renderText({
    HTML("A wiki is a website on which users collaboratively.....")
  })



}

shinyApp(ui, server)

Answer 1

基本上，您需要两个组件：

1. 动态内容/情节

2. 动态仪表板主体

第一部分比较简单：

1.动态内容/情节

您可以按照其他一些 SO 帖子中的说明在循环中创建输出：

  lapply(nms, function(name){
    output[[name]] <- renderUI ({
      box("Results Box", plotOutput(paste0("plot_", name)))
    })

    output[[paste0("plot_", name)]] <- renderPlot({
      hist(iris[[input$SideBarMENU]], main = "")
    })
  })

2。动态仪表板主体

这部分比较复杂。您需要动态的tabitems()，并且它们必须与静态部分混合。为了将tabitem() 的列表移交给tabitems()，您可以使用do.call(tabItems, ..) 进行转换，请参阅下面的链接。要将它们与静态元素组合，请将静态元素转换为 list() 元素并将它们全部组合到 list() 中，然后再调用 do.call(tabItems, ..)。

  output$tabItms <- renderUI ({
    itemsDyn <- lapply(nms, function(name){
      tabItem(tabName = name, uiOutput(name))
    })

    items <- c(
      list(
        tabItem("OVERVIEW", 
              box("Overview box", 
                  tableOutput("overview"))
        )
      ),  
      itemsDyn,
      list(
        tabItem("HELP", 
                box("HELP box", 
                    textOutput("help"))
        )
      )
    )
    do.call(tabItems, items)
  })

可以在这里找到类似的组件：shinydashboard does not work with uiOutput 并在此处循环tabItems()：How to make a function in a for loop or lapply loop in a tabItem dashboard shiny。

注意：

我修改names(iris)：

nms <- gsub("[.]", "", names(iris))
names(iris) <- nms

因为 tabItem 名称不允许使用点。

可重现的例子：

library(shiny)
library(shinydashboard)

nms <- gsub("[.]", "", names(iris))
names(iris) <- nms


ui <- dashboardPage(
  dashboardHeader(), 
  dashboardSidebar(
    uiOutput("menu")
  ),
  dashboardBody(
    uiOutput("tabItms")
  )
)

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

  output$tabItms <- renderUI ({
    itemsDyn <- lapply(nms, function(name){
      tabItem(tabName = name, uiOutput(name))
    })

    items <- c(
      list(
        tabItem("OVERVIEW", 
              box("Overview box", 
                  tableOutput("overview"))
        )
      ),  
      itemsDyn,
      list(
        tabItem("HELP", 
                box("HELP box", 
                    textOutput("help"))
        )
      )
    )
    do.call(tabItems, items)
  })

  lapply(nms, function(name){
    output[[name]] <- renderUI ({
      box("Results Box", plotOutput(paste0("plot_", name)))
    })

    output[[paste0("plot_", name)]] <- renderPlot({
      hist(iris[[input$SideBarMENU]], main = "")
    })
  })



  output$menu <- renderUI({
    sidebarMenu(id = "SideBarMENU", 
                menuItem("Overview", tabName = "OVERVIEW", selected = TRUE),
                menuItem("Results", id = "resultChoice",  startExpanded = TRUE,
                         lapply(nms, function(name) {
                           menuSubItem(name, tabName = name)
                         })
                ), 
                menuItem("Help", tabName = "HELP")
    )
  })

  output$overview <- renderTable({
    head(iris)
  })

  output$help <- renderText({
    HTML("A wiki is a website on which users collaboratively.....")
  })

}

shinyApp(ui, server)