R shinydashboard: Сочетание динамических и статических вкладок для различных пунктов меню.

Question

Я создаю приложение с тремя сегментами:

1. Обзор
2. Подробные результаты
3. Помощь

В подробном разделе результатов должны отображаться результаты множества подпунктов, по одному за раз.

Мне интересно, чтобы раздел «Результат» представлял собой одну вкладку, потому что я не хочу писать код каждой вкладке для каждого подпункта. Каждый подпункт имеет идентичные, в примере гистограмму.

Когда я запускаю пример, я теряю идентификатор подэлементов. Можно ли иметь подобный макет, но сохранить идентификаторы всех пунктов меню и пунктов меню?

Рад взглянуть на альтернативные подходы.

Ниже приведен пример, иллюстрирующий проблему. Решение покажет таблицу в обзоре, гистограмму результатов для любого из подпунктов и вывод 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 не работает с uiOutput и для зацикливания tabItems() здесь: Как сделать функцию в цикле for или в цикле lapply на панели инструментов tabItem блестящей .

Примечание:

Я изменяю 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)