当 Shiny Dashboard 中存在 menuSubItems 时，显示 menuItem 的内容

Question

有没有一种方法可以在 Shiny Dashboard 的内容窗格中实际显示具有现有 menuSubItem 的 menuItem 的内容。在示例中：我尝试将“tabName = "charts"" 添加到 menuItem "Charts" 以显示 tabItem "charts" 的内容。但是，除了打开菜单并显示子菜单（内容窗格仍然显示上一次选择的“旧”内容）外，没有其他效果：

header <- dashboardHeader()
#> Error in dashboardHeader(): konnte Funktion "dashboardHeader" nicht finden

sidebar <- dashboardSidebar(
  sidebarUserPanel("User Name",
    subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"),
    # Image file should be in www/ subdir
    image = "userimage.png"
  ),
  sidebarSearchForm(label = "Enter a number", "searchText", "searchButton"),
  sidebarMenu(
    # Setting id makes input$tabs give the tabName of currently-selected tab
    id = "tabs",
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets", badgeLabel = "new",
             badgeColor = "green"),
    menuItem("Charts", icon = icon("bar-chart-o"),
      menuSubItem("Sub-item 1", tabName = "subitem1"),
      menuSubItem("Sub-item 2", tabName = "subitem2")
    )
  )
)
#> Error in dashboardSidebar(sidebarUserPanel("User Name", subtitle = a(href = "#", : konnte Funktion "dashboardSidebar" nicht finden

body <- dashboardBody(
  tabItems(
    tabItem("dashboard",
      div(p("Dashboard tab content"))
    ),
    tabItem("widgets",
      "Widgets tab content"
    ),
    tabItem("subitem1",
      "Sub-item 1 tab content"
    ),
    tabItem("subitem2",
      "Sub-item 2 tab content"
    )
  )
)
#> Error in dashboardBody(tabItems(tabItem("dashboard", div(p("Dashboard tab content"))), : konnte Funktion "dashboardBody" nicht finden

shinyApp(
  ui = dashboardPage(header, sidebar, body),
  server = function(input, output) { }
)
#> Error in shinyApp(ui = dashboardPage(header, sidebar, body), server = function(input, : konnte Funktion "shinyApp" nicht finden


devtools::session_info()
#> Session info -------------------------------------------------------------
#>  setting  value                       
#>  version  R version 3.4.0 (2017-04-21)
#>  system   x86_64, mingw32             
#>  ui       RTerm                       
#>  language (EN)                        
#>  collate  German_Germany.1252         
#>  tz       Europe/Berlin               
#>  date     2018-01-11
#> Packages -----------------------------------------------------------------
#>  package   * version    date       source                          
#>  backports   1.1.0      2017-05-22 CRAN (R 3.4.0)                  
#>  base      * 3.4.0      2017-04-21 local                           
#>  compiler    3.4.0      2017-04-21 local                           
#>  datasets  * 3.4.0      2017-04-21 local                           
#>  devtools    1.13.3     2017-08-02 CRAN (R 3.4.1)                  
#>  digest      0.6.13     2017-12-14 CRAN (R 3.4.3)                  
#>  evaluate    0.10.1     2017-06-24 CRAN (R 3.4.1)                  
#>  graphics  * 3.4.0      2017-04-21 local                           
#>  grDevices * 3.4.0      2017-04-21 local                           
#>  htmltools   0.3.6      2017-04-28 CRAN (R 3.4.0)                  
#>  knitr       1.17       2017-08-10 CRAN (R 3.4.1)                  
#>  magrittr    1.5        2014-11-22 CRAN (R 3.4.0)                  
#>  memoise     1.1.0      2017-04-21 CRAN (R 3.4.0)                  
#>  methods   * 3.4.0      2017-04-21 local                           
#>  Rcpp        0.12.14    2017-11-23 CRAN (R 3.4.3)                  
#>  rmarkdown   1.6        2017-06-15 CRAN (R 3.4.0)                  
#>  rprojroot   1.2        2017-01-16 CRAN (R 3.4.0)                  
#>  stats     * 3.4.0      2017-04-21 local                           
#>  stringi     1.1.5      2017-04-07 CRAN (R 3.4.0)                  
#>  stringr     1.2.0      2017-02-18 CRAN (R 3.4.0)                  
#>  tools       3.4.0      2017-04-21 local                           
#>  utils     * 3.4.0      2017-04-21 local                           
#>  withr       2.1.1.9000 2018-01-05 Github (jimhester/withr@df18523)
#>  yaml        2.1.14     2016-11-12 CRAN (R 3.4.0)

Answer 1

这个问题React to menuItem() tab selection 非常感谢。唯一烦人的是你必须再次点击Charts 标签，但我认为应该没问题

library(shiny)
library(shinydashboard)

convertMenuItem <- function(mi,tabName) {
  mi$children[[1]]$attribs['data-toggle']="tab"
  mi$children[[1]]$attribs['data-value'] = tabName
  if(length(mi$attribs$class)>0 && mi$attribs$class=="treeview"){
    mi$attribs$class=NULL
  }
  mi
}

header <- dashboardHeader()

sidebar <- dashboardSidebar(
  sidebarUserPanel("Pork Chop",
                   subtitle = a(href = "#", icon("circle", class = "text-success"), "Online"),
                   # Image file should be in www/ subdir
                   image = "https://vignette.wikia.nocookie.net/fanfictiondisney/images/9/9e/Pumba_3.jpg/revision/latest?cb=20120708163413"
  ),
  sidebarSearchForm(label = "Enter a number", "searchText", "searchButton"),
  sidebarMenu(
    # Setting id makes input$tabs give the tabName of currently-selected tab
    id = "tabs",
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets", badgeLabel = "new", badgeColor = "green"),
    convertMenuItem(menuItem("Charts", tabName = "charts",icon = icon("bar-chart-o"),selected=T,
             menuSubItem("Sub-item 1", tabName = "subitem1"),
             menuSubItem("Sub-item 2", tabName = "subitem2")),"charts")
  )
)

body <- dashboardBody(
  tabItems(
    tabItem("dashboard",div(p("Dashboard tab content"))),
    tabItem("widgets","Widgets tab content"),
    tabItem("charts","Charts Tab"),
    tabItem("subitem1","Sub-item 1 tab content"),
    tabItem("subitem2","Sub-item 2 tab content")
  )
)

shinyApp(
  ui = dashboardPage(header, sidebar, body),
  server = function(input, output) { }
)

Answer 2

来自here。这是一种替代方法，一旦展开子 menuItem，就会显示与 tabItem 相关联的隐藏 childless menuItem。

与@PorkChop 的当前解决方案相比，有两个优点，即input$sidebarItemExpanded 保持功能（使用convertMenuItem 时不会更新）并且无需再次单击即可展开菜单。

library(shiny)
library(shinydashboard)
library(shinyjs)

ui <- dashboardPage(
  dashboardHeader(), 
  dashboardSidebar(
    sidebarMenu(
      id = "sidebarID",
      menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
      menuItem("Widgets", icon = icon("th"), tabName = "widgets"),
      menuItem("Charts", id = "chartsID", tabName = "charts", icon = icon("bar-chart-o"), expandedName = "CHARTS",
                               menuSubItem("Sub-item 1", tabName = "subitem1"),
                               menuSubItem("Sub-item 2", tabName = "subitem2")
      ),
      hidden(menuItem("hiddenCharts", tabName = "hiddenCharts"))
    )
  ),
  dashboardBody(
    useShinyjs(),
    tabItems(
      tabItem("dashboard", "Dashboard tab content"),
      tabItem("widgets", "Widgets tab content"),
      tabItem("hiddenCharts", "Charts Tab"),
      tabItem("subitem1", "Sub-item 1 tab content"),
      tabItem("subitem2", "Sub-item 2 tab content") 
    )
  )
)

server <- function(input, output, session) {
  observeEvent(input$sidebarItemExpanded, {
    if(input$sidebarItemExpanded == "CHARTS"){
      updateTabItems(session, "sidebarID", selected = "hiddenCharts")
    }
  })
}

shinyApp(ui, server)