UIOutput 在多个菜单项中的使用

Question

下面的 R 闪亮脚本在 subItem1 中显示“output$brand_selector”输出。我希望在 subItem2 和 subItem3 中显示相同的输出。另外，当我打开仪表板时，默认情况下会显示输出，我希望仅在单击子项时才显示输出。

candyData <- read.table(
text = "
Brand       Candy           value
Nestle      100Grand        Choc1
Netle       Butterfinger    Choc2
Nestle      Crunch          Choc2
Hershey's   KitKat          Choc4
Hershey's   Reeses          Choc3
Hershey's   Mounds          Choc2
Mars        Snickers        Choc5
Nestle      100Grand        Choc3
Nestle      Crunch          Choc4
Hershey's   KitKat          Choc5
Hershey's   Reeses          Choc2
Hershey's   Mounds          Choc1
Mars        Twix            Choc3
Mars        Vaid            Choc2",
header = TRUE,
stringsAsFactors = FALSE)
library(shiny)
library(shinydashboard)
ui <- dashboardPage(
dashboardHeader(),
dashboardSidebar(
sidebarMenu(
  
  id = "tabs",
  menuItem("Charts", icon = icon("bar-chart-o"),
           menuSubItem("Sub-item 1", tabName = "subitem1"),
           menuSubItem("Sub-item 2", tabName = "subitem2"),
           menuSubItem("Sub-item 3", tabName = "subitem3")
  ))),
dashboardBody(
tabItems(tabItem("subitem1", uiOutput("brand_selector")),
         tabItem("subitem2", 4),
         tabItem("subitem3", 7))
))
server <- function(input, output,session) {
observeEvent(input$Select1,{
updateSelectInput(session,'Select2',
               
choices=unique(candyData$Candy[candyData$Brand==input$Select1]))
}) 
observeEvent(input$Select2,{
updateSelectInput(session,'Select3',
                
choices=unique(candyData$value[candyData$Brand==input$Select1 & 
candyData$Candy==input$Select2]))
})
output$brand_selector <- renderUI({
box(title = "Data", status = "primary", solidHeader = T, width = 12,
    fluidPage(
      fluidRow(
        
        column(2,offset = 0, style='padding:1px;',  
 selectInput("Select1","select1",unique(candyData$Brand))),
        column(2,offset = 0, 
  style='padding:1px;',selectInput("Select2","select2",choices = NULL)),
        column(2, offset = 0, 
  style='padding:1px;',selectInput("Select3","select3",choices=NULL ))
      )))
  })}
  shinyApp(ui = ui, server = server)

Answer 1

您可以创建一个虚拟

tabItem

，即

hidden

并选择默认值。这会给人一种没有选择

tabItem

的错觉。要隐藏

tabItem

选项，您可以使用

hidden

包中的

shinyjs

函数。

以下是修改后的

ui

代码：

ui <- dashboardPage(
    dashboardHeader(),
    dashboardSidebar(
      sidebarMenu(
       shinyjs::useShinyjs(),
        id = "tabs",
        menuItem("Charts", icon = icon("bar-chart-o"),
                 shinyjs::hidden(menuSubItem("dummy", tabName = "dummy")),
                 menuSubItem("Sub-item 1", tabName = "subitem1"),
                 menuSubItem("Sub-item 2", tabName = "subitem2"),
                 menuSubItem("Sub-item 3", tabName = "subitem3")
        ))),
    dashboardBody(
      tabItems(tabItem("dummy"),
              tabItem("subitem1", uiOutput("brand_selector")),
               tabItem("subitem2", 4),
               tabItem("subitem3", 7))
    ))

编辑1： 根据乔here给出的答案中的评论和参考，您可以执行以下操作：

candyData <- read.table(
    text = "
    Brand       Candy           value
    Nestle      100Grand        Choc1
    Netle       Butterfinger    Choc2
    Nestle      Crunch          Choc2
    Hershey's   KitKat          Choc4
    Hershey's   Reeses          Choc3
    Hershey's   Mounds          Choc2
    Mars        Snickers        Choc5
    Nestle      100Grand        Choc3
    Nestle      Crunch          Choc4
    Hershey's   KitKat          Choc5
    Hershey's   Reeses          Choc2
    Hershey's   Mounds          Choc1
    Mars        Twix            Choc3
    Mars        Vaid            Choc2",
    header = TRUE,
    stringsAsFactors = FALSE)
  library(shiny)
  library(shinydashboard)
  ui <- dashboardPage(
    dashboardHeader(),
    dashboardSidebar(
      sidebarMenu(
       shinyjs::useShinyjs(),
        id = "tabs",
        menuItem("Charts", icon = icon("bar-chart-o"),
                 shinyjs::hidden(menuSubItem("dummy", tabName = "dummy")),
                 menuSubItem("Sub-item 1", tabName = "subitem1"),
                 menuSubItem("Sub-item 2", tabName = "subitem2"),
                 menuSubItem("Sub-item 3", tabName = "subitem3")
        ))),
    dashboardBody(
      tabItems(tabItem("dummy"),
              tabItem("subitem1", uiOutput("brand_selector")),
               tabItem("subitem2", uiOutput("brand_selector1")),
               tabItem("subitem3", uiOutput("brand_selector2")))
    ))
  server <- function(input, output,session) {
    
    
    observeEvent(input$Select1,{
      updateSelectInput(session,'Select2',
                        
                        choices=unique(candyData$Candy[candyData$Brand==input$Select1]))
    }) 
    observeEvent(input$Select2,{
      updateSelectInput(session,'Select3',
                        
                        choices=unique(candyData$value[candyData$Brand==input$Select1 & 
                                                         candyData$Candy==input$Select2]))
    })
    output$brand_selector1 <-  output$brand_selector2 <-  output$brand_selector <- renderUI({
      box(title = "Data", status = "primary", solidHeader = T, width = 12,
          fluidPage(
            fluidRow(
              
              column(2,offset = 0, style='padding:1px;',  
                     selectInput("Select1","select1",unique(candyData$Brand))),
              column(2,offset = 0, 
                     style='padding:1px;',selectInput("Select2","select2",choices = NULL)),
              column(2, offset = 0, 
                     style='padding:1px;',selectInput("Select3","select3",choices=NULL ))
            )))
    })}
  shinyApp(ui = ui, server = server)

编辑2：

这是一种稍微不同的方法，不使用

renderUI

和使用

shinyModule

:

candyData <- read.table(
  text = "
  Brand       Candy           value
  Nestle      100Grand        Choc1
  Netle       Butterfinger    Choc2
  Nestle      Crunch          Choc2
  Hershey's   KitKat          Choc4
  Hershey's   Reeses          Choc3
  Hershey's   Mounds          Choc2
  Mars        Snickers        Choc5
  Nestle      100Grand        Choc3
  Nestle      Crunch          Choc4
  Hershey's   KitKat          Choc5
  Hershey's   Reeses          Choc2
  Hershey's   Mounds          Choc1
  Mars        Twix            Choc3
  Mars        Vaid            Choc2",
  header = TRUE,
  stringsAsFactors = FALSE)
library(shiny)
library(shinydashboard)

submenuUI <- function(id) {
  ns <- NS(id)
  tagList(
    box(title = "Data", status = "primary", solidHeader = T, width = 12,
              fluidPage(
                fluidRow(

                  column(2,offset = 0, style='padding:1px;',
                         selectInput(ns("Select1"),"select1",unique(candyData$Brand))),
                  column(2,offset = 0,
                         style='padding:1px;',selectInput(ns("Select2"),"select2",choices = NULL)),
                  column(2, offset = 0,
                         style='padding:1px;',selectInput(ns("Select3"),"select3",choices=NULL ))
                )))
        )
  
}

# submenu <- function(input,output,session){}
submenuServ <- function(input, output, session){

  observeEvent(input$Select1,{
    updateSelectInput(session,'Select2',

                      choices=unique(candyData$Candy[candyData$Brand==input$Select1]))
  })
  observeEvent(input$Select2,{
    updateSelectInput(session,'Select3',

                      choices=unique(candyData$value[candyData$Brand==input$Select1 &
                                                       candyData$Candy==input$Select2]))
  })
  
}




ui <- dashboardPage(
  dashboardHeader(),
  dashboardSidebar(
    sidebarMenu(
      shinyjs::useShinyjs(),
      id = "tabs",
      menuItem("Charts", icon = icon("bar-chart-o"),
               shinyjs::hidden(menuSubItem("dummy", tabName = "dummy")),
               menuSubItem("Sub-item 1", tabName = "subitem1"),
               menuSubItem("Sub-item 2", tabName = "subitem2"),
               menuSubItem("Sub-item 3", tabName = "subitem3")
      ))),
  dashboardBody(
    tabItems(tabItem("dummy"),
             tabItem("subitem1", submenuUI('submenu1')),
             tabItem("subitem2", submenuUI('submenu2')),
             tabItem("subitem3", submenuUI('submenu3'))
             )
  ))
server <- function(input, output,session) {
  
  callModule(submenuServ,"submenu1")
  callModule(submenuServ,"submenu2")
  callModule(submenuServ,"submenu3")
  
}
shinyApp(ui = ui, server = server)