menuSubItem in sidebar not activated in ShinyDashboard when opened using a direct link from a different tab

Question

In the code below, I am not able to activate the menuSubitem when opening it using the 'Computation completed' link in the first tab. The link opens the correct tab but fails to automatically activate/open the associated submenu in the sidebar.

Code is modified from the example here, 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

Welcome to stackoverflow!

You could provide your menuItem "Results" with an id and change it's display style dynamically.

Please check my approach using 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)

Furthermore please see this related article .