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 particular button to be clicked. In simple, I would like to store/print the current tab the user is on when they click this button. After they click this button the tab is changed to 'help' with the updateTabItems which takes the session, inputId and selected values as parameters.

# Observe event when someone clicks a button
observeEvent(input$help, {
  # if they are logged in
  if(USER$Logged == TRUE) {

     # current_tab <- ???
     shiny_session <<- session
    updateTabItems(session, "sidebar", selected = "help")
  }
})

Since the session holds some value I tried to explore it.

> class(shiny_session)
[1] "ShinySession" "R6"

> names(shiny_session)
 [1] ".__enclos_env__"     "session"            
 [3] "groups"              "user"               
 [5] "singletons"          "request"            
 [7] "closed"              "downloads"          
 [9] "files"               "token"              
[11] "clientData"          "output"             
[13] "input"               "progressStack"      
[15] "clone"               "decrementBusyCount" 
[17] "incrementBusyCount"  "outputOptions"      
[19] "manageInputs"        "manageHiddenOutputs"
[21] "registerDataObj"     "registerDownload"   
[23] "fileUrl"             "saveFileUrl"        
[25] "handleRequest"       "@uploadEnd"         
[27] "@uploadInit"         "@uploadieFinish"    
[29] "reload"              "reactlog"           
[31] "onFlushed"           "onFlush"            
[33] "sendInputMessage"    "sendCustomMessage"  
[35] "dispatch"            "sendProgress"       
[37] "showProgress"        "flushOutput"        
[39] "defineOutput"        "setShowcase"        
[41] "isEnded"             "isClosed"           
[43] "wsClosed"            "close"              
[45] "unhandledError"      "onInputReceived"    
[47] "onEnded"             "onSessionEnded"     
[49] "ns"                  "makeScope"          
[51] "initialize"

I tried to explore these elements of the shiny session and they are mostly structured as functions and could not find anything on the current tab.

UpdateTabItems seems to take values and sends them to sendInputMessage.

> updateTabItems
function (session, inputId, selected = NULL) 
{
    message <- dropNulls(list(value = selected))
    session$sendInputMessage(inputId, message)
}

This appears to be some sort of stack of commands that gets executed in the shiny app so I stopped exploring it.

> shiny_session$sendInputMessage
function (inputId, message) 
{
    data <- list(id = inputId, message = message)
    private$inputMessageQueue[[length(private$inputMessageQueue) + 
        1]] <- data
}

Any suggestions on how I could access the current tab information in a variable at a given point in time?

Thanks.

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)