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

Question

I am working within a shiny app and I want to be able to access information on the current tab a user is on in a session.

I have a observe event that listens for a parti

Answer 1

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)

Answer 2

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 code
server <- 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)