How do I access/print/track the current tab selection in a Shiny app? How do I access/print/track the current tab selection in a Shiny app? r r

How do I access/print/track the current tab selection in a Shiny app?


Since you haven't provided a minimal reproducible example, I have to make some guesses to produce an appropriate example - but it's fine :) It seems that you're using shinydashboard and in the app you have a sidebarMenu with at least two tabs.

I want to be able to access information on the current tab a user is on in a session.

You can give sidebarMenu an ID, say, tabs and then you can access the information on the current tab via input$tabs.


Let's take a look at an example below which highlights these two aspects

First, we "award" sidebarMenu with an unique ID

sidebarMenu(id = "tabs",       menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),      menuItem("Help", tabName = "help", icon = icon("h-square"))    )

and then spy on it on the server side with

observe({    print(input$tabs)  })

Full example:

library(shiny)library(shinydashboard)ui <- dashboardPage(  dashboardHeader(title = "Example"),  dashboardSidebar(    sidebarMenu(id = "tabs", # note the id      menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),      menuItem("Help", tabName = "help", icon = icon("h-square"))    ),    br(),    # Teleporting button    actionButton("teleportation", "Teleport to HELP", icon = icon("h-square"))  ),  dashboardBody(    tabItems(      tabItem(tabName = "dashboard",              h2("Dashboard tab content")      ),      tabItem(tabName = "help",              h2("Help tab content")      )    )  ))server <- function(input, output, session) {  # prints acutall tab  observe({    print(input$tabs)  })  observeEvent(input$teleportation, {    # if (USER$Logged == TRUE) {    if (input$tabs != "help") {       # it requires an ID of sidebarMenu (in this case)      updateTabItems(session, inputId = "tabs", selected = "help")     }    #}  })}shinyApp(ui, server)


Is that what you expected?

library(shiny)library(shinyWidgets)library(shinydashboard)library(kableExtra)sidebar <- dashboardSidebar(  sidebarMenu(id = "tab",              menuItem("1", tabName = "1"),              menuItem("2", tabName = "2"),              menuItem("3", tabName = "3"),              menuItem("4", tabName = "4")  ))body <-   ## Body content  dashboardBody(box(width = 12,fluidRow(    column(      width = 3,      # pickerInput(      #   inputId = "metric",      #   label = h4("Metric Name"),      #   choices = c(      #     "alpha",      #     "beta"      #   ),      #         #   width = "100%"      # )      uiOutput("metric")      , actionButton("show", "Help")    )  )))ui <-   dashboardPage(dashboardHeader(title = "Scorecard"),                      sidebar,                      body)# Define the server codeserver <- function(input, output,session) {  # observeEvent(input$metric, {  #   if (input$tab == "1"){  #     choices <- c(  #       "alpha",  #       "beta"  #     )  #   }  #   else if (input$tab == "2") {  #     choices <- c(  #       "apple",  #       "orange"  #     )  #   }  #   else {  #     choices <- c(  #       "foo",  #       "zoo",  #       "boo"  #     )  #   }  #   updatePickerInput(session,  #                     inputId = "metric",  #                     choices = choices)  # })  output$metric<-renderUI({    if (input$tab == "1"){      choices <- c(        "alpha",        "beta"      )    }    else if (input$tab == "2") {      choices <- c(        "apple",        "orange"      )    }    else {      choices <- c(        "foo",        "zoo",        "boo"      )    }    pickerInput(      inputId = "metric",      label = h4("Metric Name"),      choices = choices,      width = "100%"    )  })  faq1 <- data.frame(    Findings = c(      "lorem ipsum"    ))  faq2 <- data.frame(    Findings = c(      "lorem ipsum bacon"    ))  faq3 <- data.frame(    Findings = c(      "lorem ipsum bacon bacon"    ))  observeEvent(input$show, {    showModal(modalDialog(      title = "Guildlines",        tableOutput("kable_table"),      easyClose = TRUE    ))  })  faqtext<-reactive({    if (input$tab == "1"){      return(faq1)    }    else if (input$tab == "2") {      return(faq2)    }    else if (input$tab == "3") {      return(faq3)    }    else {      return(benchmark_faq)    }  })  output$kable_table<-function(){    kable(faqtext()) %>%      kable_styling("striped", full_width = F) %>%      column_spec(1, bold = T, border_right = T)%>%HTML  }}shinyApp(ui = ui, server = server)