使用来自不同选项卡的直接链接打开时，侧边栏中的 menuSubItem 未在 ShinyDashboard 中激活

Question

在下面的代码中，使用第一个选项卡中的“计算完成”链接打开 menuSubitem 时，我无法激活它。该链接会打开正确的选项卡，但无法自动激活/打开侧边栏中的相关子菜单。

代码根据此处的示例修改，Direct link to tabItem with R shiny dashboard。

library(shiny)
library(shinydashboard)

ui <- shinyUI(
  dashboardPage(
    dashboardHeader(title = "Some Header"),
    dashboardSidebar(
      sidebarMenu(
        menuItem("Computations", tabName = "tabItem1", icon = icon("dashboard")),
        menuItem("Results", tabName = "tabItem2", icon = icon("th"),
                 menuSubItem("Test", tabName = "subitem2"))
      )
    ),
    
    dashboardBody(
      tags$script(HTML("
        var openTab = function(tabName){
          $('a', $('.sidebar')).each(function() {
            if(this.getAttribute('data-value') == tabName) {
              this.click()
            };
          });
        }
      ")),
      tabItems(
        tabItem(tabName = "tabItem1",
                fluidRow(
                  box(plotOutput("plot1", height = 250)),
                  
                  box(
                    title = "Controls",
                    sliderInput("slider", "Number of observations:", 1, 100, 50)
                  )
                ),
                infoBoxOutput("out1")
        ),
        
        tabItem(tabName = "subitem2",
                h2("Widgets tab content")
        )
      )
    )
  )
)

server <- function(input, output){
  histdata <- rnorm(500)
  
  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider)]
    hist(data)
  })
  
  output$out1 <- renderInfoBox({
    infoBox("Completed",  
            a("Computation Completed", onclick = "openTab('subitem2')", href="#"),
            icon = icon("thumbs-o-up"), color = "green"
    )
  })
}

shinyApp(ui, server)

Answer 1

欢迎使用 stackoverflow！

您可以为您的menuItem“结果”提供id，并动态更改其显示样式。

请使用library(shinyjs)检查我的方法：

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

jsCode <- 'shinyjs.hidemenuItem = function(targetid) {var x = document.getElementById(targetid); x.style.display = "none"; x.classList.remove("menu-open");};
shinyjs.showmenuItem = function(targetid) {var x = document.getElementById(targetid); x.style.display = "block"; x.classList.add("menu-open");};'

ui <- shinyUI(
  dashboardPage(
    dashboardHeader(title = "Some Header"),
    dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem("Computations", tabName = "tabItem1", icon = icon("dashboard")),
        menuItem(text = "Results", id = "resultsID", tabName = "tabItem2", icon = icon("th"),
                 menuSubItem("Test", tabName = "subitem2"))
      )
    ),
    
    dashboardBody(
      useShinyjs(),
      extendShinyjs(text = jsCode),
      tabItems(
        tabItem(tabName = "tabItem1",
                fluidRow(
                  box(plotOutput("plot1", height = 250)),
                  
                  box(
                    title = "Controls",
                    sliderInput("slider", "Number of observations:", 1, 100, 50)
                  )
                ),
                infoBoxOutput("out1")
        ),
        
        tabItem(tabName = "subitem2",
                h2("Widgets tab content")
        )
      )
    )
  )
)

server <- function(input, output, session){
  histdata <- rnorm(500)
  
  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider)]
    hist(data)
  })
  
  output$out1 <- renderInfoBox({
    infoBox("Completed",  
            actionLink(inputId = "completed", label = "Computation Completed"),
            icon = icon("thumbs-o-up"), color = "green"
    )
  })
  
  observeEvent(input$completed, {
    js$showmenuItem("resultsID")
    updateTabItems(session, inputId="sidebarID", selected = "subitem2")
  })
  
  observeEvent(input$sidebarID, {
    if(input$sidebarID != "subitem2"){
      js$hidemenuItem("resultsID")
    }
  })
  
}

shinyApp(ui, server)

此外，请参阅related article。