URI routing for shinydashboard using shiny.router - r

Question

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?

Answer 1

Here is how to use the below approach with shiny's tabPanel() function.
Workarounds not using library(shiny.router):
Edit - Alternative using clientData$url_search and mode = "push" for updateQueryString to push a new history entry onto the browser's history stack:
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):
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
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$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:
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
newURL <- paste0(
session$clientData$url_protocol,
"//",
session$clientData$url_hostname,
":",
session$clientData$url_port,
session$clientData$url_pathname,
"?tab=",
input$sidebarID
)
updateQueryString(newURL, mode = "replace", 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:
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:
https://rstudio.github.io/shinydashboard/behavior.html#bookmarking
https://shiny.rstudio.com/reference/shiny/1.7.0/session.html
It is possible to restore a session, locally, in a Shiny app if the inputs have been previously written in a RDS file?
shinyjs - setBookmarkExclude for delay IDs
https://github.com/rstudio/shiny/issues/3546