rshinyshinydashboard

URI routing for shinydashboard using shiny.router

Suppose you have a simple shinydashboard which contains links created with menuItem and pages created with tabItems:

library(shiny)
library(shinydashboard)

skin <- Sys.getenv("DASHBOARD_SKIN")
skin <- tolower(skin)
skin <- "blue"

## ui.R ##
sidebar <- dashboardSidebar(
  sidebarMenu(
    menuItem("Dashboard", tabName = "dashboard", icon = icon("dashboard")),
    menuItem("Widgets", icon = icon("th"), tabName = "widgets",
             badgeLabel = "new", badgeColor = "green")
  )
)

body <- dashboardBody(
  tabItems(
    tabItem(tabName = "dashboard",
            h2("Dashboard tab content")
    ),
    
    tabItem(tabName = "widgets",
            h2("Widgets tab content")
    )
  )
)

# Put them together into a dashboardPage
ui<-dashboardPage(
  dashboardHeader(title = "Simple tabs"),
  sidebar,
  body
)


server <- function(input, output) {
  
}

shinyApp(ui, server)

Is it possible to create permalinks for the pages? e.g. the home page (tabName == "dashboard") has a URL of 127.0.0.1:1234/home and the widgets page is at 127.0.0.1:1234/widgets?

It seems that shiny doesn't have URL routing out of the box. shiny.router seems to be a possible alternative but I've found no easy ways to do this with shinydashboard i.e. with the use of menuItem and tabItem. I'm trying to avoid rewriting the app's UI to use something which is more tightly integrated with shiny.router (e.g. shiny.semantic)

Is it possible to keep the above shinydashboard code while implementing permalinks to the various different pages?

Solution

  • Here is how to use the below approach with shiny's tabPanel() function.

    Here is how to use the below approach with a hidden tabsetPanel.

    Workarounds not using library(shiny.router):

    Edit - Alternative using getQueryString and updateQueryString with mode = "push" activated to push a new history entry onto the browser's history stack:

    result

    library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {
  # http://127.0.0.1:6172/?tab=dashboard
  # http://127.0.0.1:6172/?tab=widgets
  
  observeEvent(getQueryString(session)$tab, {
    currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    if(is.null(input$sidebarID) || !is.null(currentQueryString) && currentQueryString != input$sidebarID){
      freezeReactiveValue(input, "sidebarID")
      updateTabItems(session, "sidebarID", selected = currentQueryString)
    }
  }, priority = 1)
  
  observeEvent(input$sidebarID, {
    currentQueryString <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    pushQueryString <- paste0("?tab=", input$sidebarID)
    if(is.null(currentQueryString) || currentQueryString != input$sidebarID){
      freezeReactiveValue(input, "sidebarID")
      updateQueryString(pushQueryString, mode = "push", session)
    }
  }, priority = 0)
  
}

shinyApp(ui, server, enableBookmarking = "disable")

    Another Edit - using url_hash (uri fragments):

    result_fragments

    library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {
  observeEvent(input$sidebarID, {
    # http://127.0.0.1:6172/#dashboard
    # http://127.0.0.1:6172/#widgets
    clientData <- reactiveValuesToList(session$clientData)
    newURL <- with(clientData, paste0(url_protocol, "//", url_hostname, ":", url_port, url_pathname, "#", input$sidebarID))
    updateQueryString(newURL, mode = "replace", session)
  })
  
  observe({
    currentTab <- sub("#", "", session$clientData$url_hash)
    if(!is.null(currentTab)){
      updateTabItems(session, "sidebarID", selected = currentTab)
    }
  })
}

shinyApp(ui, server, enableBookmarking = "disable")

    Edit - using url_search: Actually we can do the same without bookmarking using getQueryString and updateTabItems:

    result_without_bookmarking

    library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}

server <- function(input, output, session) {

  observeEvent(input$sidebarID, {
    # http://127.0.0.1:6172/?tab=dashboard
    # http://127.0.0.1:6172/?tab=widgets
    clientData <- reactiveValuesToList(session$clientData)
    newURL <- with(clientData, paste0(url_protocol, "//", url_hostname, ":", url_port, url_pathname, "?tab=", input$sidebarID))
    updateQueryString(newURL, mode = "replace", session)
    # updateQueryString(newURL, mode = "push", session)
  })

  observe({
    currentTab <- getQueryString(session)$tab # alternative: parseQueryString(session$clientData$url_search)$tab
    if(!is.null(currentTab)){
      updateTabItems(session, "sidebarID", selected = currentTab)
    }
  })

}

shinyApp(ui, server, enableBookmarking = "disable")

    Using bookmarks:

    Not sure if you are interested in a workaround like this, but you could use shiny's bookmarking and updateQueryString to achive a similar behaviour:

    result

    library(shiny)
library(shinydashboard)

ui <- function(request) {
  dashboardPage(
    header = dashboardHeader(title = "Simple tabs"),
    sidebar = dashboardSidebar(
      sidebarMenu(
        id = "sidebarID",
        menuItem(
          "Dashboard",
          tabName = "dashboard",
          icon = icon("tachometer-alt")
        ),
        menuItem(
          "Widgets",
          icon = icon("th"),
          tabName = "widgets",
          badgeLabel = "new",
          badgeColor = "green"
        )
      )
    ),
    body = dashboardBody(tabItems(
      tabItem(tabName = "dashboard",
              h2("Dashboard tab content")),
      tabItem(tabName = "widgets",
              h2("Widgets tab content"))
    ))
  )
}


server <- function(input, output, session) {
  bookmarkingWhitelist <- c("sidebarID")
  
  observe({
    setBookmarkExclude(setdiff(names(input), bookmarkingWhitelist))
  })
  
  observeEvent(input$sidebarID, {
    # http://127.0.0.1:6172/?_inputs_&sidebarID=%22dashboard%22
    # http://127.0.0.1:6172/?_inputs_&sidebarID=%22widgets%22
    
    newURL <- paste0(
        session$clientData$url_protocol,
        "//",
        session$clientData$url_hostname,
        ":",
        session$clientData$url_port,
        session$clientData$url_pathname,
        "?_inputs_&sidebarID=%22",
        input$sidebarID,
        "%22"
      )
    
    updateQueryString(newURL,
                      mode = "replace",
                      session)
  })
}

shinyApp(ui, server, enableBookmarking = "url")

    Some related links: