R Shinydashboard：各种菜单子项的动态和静态 tabItems 的混合

Question

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

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

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

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

但是，当我运行该示例时，我丢失了子项的 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, ..)进行转换，请参阅下面的链接。 要将它们与静态元素组合，请在调用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 不适用于uiOutput和 for looping 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)