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)