Uri Routing for Shinydashboard Using Shiny.Router

URI routing for shinydashboard using shiny.router

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:

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
    
    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:

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
    
    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:

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:

  • 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

URI routing with shiny.router and navbarPage in a R shiny app

The following is a slightly modified version of my answer here, which avoids using library(shiny.router).

The difference is using shiny::updateNavbarPage instead of shinydashboard::updateTabItems:

# remotes::install_github("rstudio/shinythemes")

library(shiny)
library(shinythemes)

ui <- navbarPage(title = "Dashboard", id = "navbarID", theme = shinytheme("flatly"), 
                 tabPanel("Page 1", value = "page_1", "This is Page 1"),
                 tabPanel("Page 2", value = "page_2", "This is Page 2")
)

server <- function(input, output, session){
  observeEvent(input$navbarID, {
    # http://127.0.0.1:3252/#page_1
    # http://127.0.0.1:3252/#page_2
    
    newURL <- paste0(
      session$clientData$url_protocol,
      "//",
      session$clientData$url_hostname,
      ":",
      session$clientData$url_port,
      session$clientData$url_pathname,
      "#",
      input$navbarID
    )
    updateQueryString(newURL, mode = "replace", session)
  })
  
  observe({
    currentTab <- sub("#", "", session$clientData$url_hash) # might need to wrap this with `utils::URLdecode` if hash contains encoded characters (not the case here)
    if(!is.null(currentTab)){
      updateNavbarPage(session, "navbarID", selected = currentTab)
    }
  })
}

shinyApp(ui, server)

result

The above is using clientData$url_hash - the same could be done with clientData$url_search as shown in my earlier answer.

Edit: using mode = "push" in updateQueryString for browser navigation:

library(shiny)
library(shinythemes)

ui <- navbarPage(title = "Dashboard", id = "navbarID", theme = shinytheme("flatly"), 
                 tabPanel("Page 1", value = "page_1", "This is Page 1"),
                 tabPanel("Page 2", value = "page_2", "This is Page 2")
)

server <- function(input, output, session){
  observeEvent(session$clientData$url_hash, {
    currentHash <- sub("#", "", session$clientData$url_hash)
    if(is.null(input$navbarID) || !is.null(currentHash) && currentHash != input$navbarID){
      freezeReactiveValue(input, "navbarID")
      updateNavbarPage(session, "navbarID", selected = currentHash)
    }
  }, priority = 1)
  
  observeEvent(input$navbarID, {
    currentHash <- sub("#", "", session$clientData$url_hash) # might need to wrap this with `utils::URLdecode` if hash contains encoded characters (not the case here)
    pushQueryString <- paste0("#", input$navbarID)
    if(is.null(currentHash) || currentHash != input$navbarID){
      freezeReactiveValue(input, "navbarID")
      updateQueryString(pushQueryString, mode = "push", session)
    }
  }, priority = 0)
}

shinyApp(ui, server)

Alternative using clientData$url_search and mode = "push":

library(shiny)
library(shinythemes)

ui <- navbarPage(title = "Dashboard", id = "navbarID", theme = shinytheme("flatly"),
                 tabPanel("Page 1", value = "page_1", "This is Page 1"),
                 tabPanel("Page 2", value = "page_2", "This is Page 2")
)

server <- function(input, output, session){
  observeEvent(getQueryString(session)$page, {
    currentQueryString <- getQueryString(session)$page # alternative: parseQueryString(session$clientData$url_search)$page
    if(is.null(input$navbarID) || !is.null(currentQueryString) && currentQueryString != input$navbarID){
      freezeReactiveValue(input, "navbarID")
      updateNavbarPage(session, "navbarID", selected = currentQueryString)
    }
  }, priority = 1)

  observeEvent(input$navbarID, {
    currentQueryString <- getQueryString(session)$page # alternative: parseQueryString(session$clientData$url_search)$page
    pushQueryString <- paste0("?page=", input$navbarID)
    if(is.null(currentQueryString) || currentQueryString != input$navbarID){
      freezeReactiveValue(input, "navbarID")
      updateQueryString(pushQueryString, mode = "push", session)
    }
  }, priority = 0)
}

shinyApp(ui, server)

result

PS: restoring a selected tab is also possible using shiny's bookmarking capabilities, as long as the navbarPage is provided with an id.

PPS: Here a related question on a navbarPage using secondary navigation can be found.

Shiny Router appending routes

The reason this is happening is because the route_link acts like a hash router and therefore the solution would be just to paste the actual string as a path instead of using the route_link solution

tags$li(a(class = "item", href = route_link("/sample-apps/shiny-router/#!/home"), "Home page"))

#instead use
tags$li(a(class = "item", href = "/sample-apps/shiny-router/#!/home", "Home page"))

How do you pass parameters to a shiny app via URL

You'd have to update the input yourself when the app initializes based on the URL. You would use the session$clientData$url_search variable to get the query parameters. Here's an example, you can easily expand this into your needs

library(shiny)

shinyApp(
  ui = fluidPage(
    textInput("text", "Text", "")
  ),
  server = function(input, output, session) {
    observe({
      query <- parseQueryString(session$clientData$url_search)
      if (!is.null(query[['text']])) {
        updateTextInput(session, "text", value = query[['text']])
      }
    })
  }
)

How to programmatically filter contents of a second shiny app displayed via iframe

The following script creates two shiny apps:
The child_app is running in a seperate background R process (depending on how you deploy your app this might not be needed), which can be controlled (filtered) via query strings.

The parent_app displays the child_app in an iframe and changes the query string (iframe's src) depending on the user accessing the app (permission level):

library(shiny)
library(shinymanager)
library(callr)
library(datasets)
library(DT)

# create child_app --------------------------------------------------------
# which will be shown in an iframe of the parent_app and can be controlled by passing query strings
ui <- fluidPage(
  DT::DTOutput("filteredTable")
)

server <- function(input, output, session) {
  permission <- reactive({shiny::getQueryString(session)$permission})
  
  # req: if child_app is accessed without providing a permission query string nothing is shown
  # "virginica" is default (unknown permission level - query string other than "advanced" / "basic")
  # http://127.0.0.1:3838/?permission=unknown
  output$filteredTable <- DT::renderDT({
    permissionFilter <- switch(req(permission()),
                               "advanced" = "setosa",
                               "basic" = "versicolor",
                               "virginica")
    if(!is.null(permissionFilter) && permissionFilter %in% unique(iris$Species)){
      datasets::iris[datasets::iris$Species == permissionFilter,]
    } else {
      datasets::iris
    }
  })
}

child_app <- shinyApp(ui, server)

# run child_app in a background R process - not needed when e.g. hosted on shinyapps.io
child_app_process <- callr::r_bg(
  func = function(app) {
    shiny::runApp(
      appDir = app,
      port = 3838L,
      launch.browser = FALSE,
      host = "127.0.0.1" # child_app is accessible only locally (or via the iframe)
    )
  },
  args = list(child_app),
  supervise = TRUE
)
# child_app_process$is_alive()

# create parent app -------------------------------------------------------
credentials <- data.frame(
  user = c("admin", "user1", "user2"),
  password = c("admin", "user1", "user2"),
  admin = c(TRUE, FALSE, FALSE),
  permission = c("advanced", "basic", "basic"),
  job = c("CEO", "CTO", "DRH"),
  stringsAsFactors = FALSE)

ui <- fluidPage(
  fluidRow(tags$h2("My secure application"),
  verbatimTextOutput("auth_output"),
  uiOutput("child_app_iframe"))
)

ui <- secure_app(ui)

server <- function(input, output, session) {
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  
  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })
  
  output$child_app_iframe <- renderUI({
    tags$iframe(
      src = sprintf("http://127.0.0.1:3838/?permission=%s", res_auth$permission),
      style = "border: none;
               overflow: hidden;
               height: 65vh;
               width : 100%;
               position: relative;
               top:15px;
               padding:0;"
      # position: absolute;
    )
    })
}

parent_app <- shinyApp(ui, server, onStart = function() {
  cat("Doing application setup\n")
  onStop(function() {
    cat("Doing application cleanup\n")
    child_app_process$kill() # kill child_app if parent_app is exited - not needed when hosted separately
  })
})

# run parent_app
runApp(appDir = parent_app,
       port = 3939L,
       launch.browser = TRUE,
       host = "0.0.0.0")

Please note the Species column:

result

Edit: Here is a clean multi-file approach avoiding nested render-functions (This needs to be adapted when used with shiny-server - please see my comments):

child_app.R:

library(shiny)
library(shinymanager)
library(datasets)
library(DT)

ui <- fluidPage(
  DT::DTOutput("filteredTable")
  )

server <- function(input, output, session) {
  permission <- reactive({shiny::getQueryString(session)$permission})
  
  table_data <- reactive({
    permissionFilter <- switch(req(permission()),
                               "advanced" = "setosa",
                               "basic" = "versicolor",
                               "virginica")
    if(!is.null(permissionFilter) && permissionFilter %in% unique(iris$Species)){
      datasets::iris[datasets::iris$Species == permissionFilter,]
    } else {
      NULL # don't show something without permission
    }
  })
  
  output$filteredTable <- DT::renderDT({
    table_data()
  })
    
}

child_app <- shinyApp(ui, server)

# run parent_app (local deployment)
runApp(
  appDir = child_app,
  port = 3838L,
  launch.browser = FALSE,
  host = "127.0.0.1" # child_app is accessible only locally (or via the iframe)
)

parent_app.R:

library(shiny)
library(shinymanager)
library(datasets)
library(DT)

credentials <- data.frame(
  user = c("admin", "user1", "user2"),
  password = c("admin", "user1", "user2"),
  permission = c("advanced", "basic", "basic"),
  stringsAsFactors = FALSE)

ui <- fluidPage(
  fluidRow(tags$h2("My secure application"),
           verbatimTextOutput("auth_output"),
           uiOutput("child_app_iframe"))
)

ui <- secure_app(ui)

server <- function(input, output, session) {
  res_auth <- secure_server(
    check_credentials = check_credentials(credentials)
  )
  
  output$auth_output <- renderPrint({
    reactiveValuesToList(res_auth)
  })
  
  output$child_app_iframe <- renderUI({
    tags$iframe(
      # src = sprintf("child_app_link/child_app/?permission=%s", res_auth$permission), # shiny-server
      src = sprintf("http://127.0.0.1:3838/?permission=%s", res_auth$permission), # local deployment
      style = "border: none;
               overflow: hidden;
               height: 500px;
               width : 95%;
               # position: relative;
               # top:15px;
               # padding:0;
      "
    )
  })
}

parent_app <- shinyApp(ui, server)

# run parent_app (local deployment)
runApp(appDir = parent_app,
       port = 3939L,
       launch.browser = TRUE,
       host = "0.0.0.0")

Related Topics

R Table Function - How to Remove 0 Counts

Why "Character Is Often Preferred to Factor" in Data.Table for Key

How to Find Correct Executable with Sys.Which on Windows

Programmatically Create Tab and Plot in Markdown

How to Store Filter Expressions as Strings

Reshape Data for Values in One Column

Updating Filters in Shiny App

Ggplot2: Have Common Facet Bar in Outer Facet Panel in 3-Way Plot

How to Get Mean of Every N Rows and Keep the Date Index

R: Removing Duplicate Elements in a Vector

Error in Install.Packages:Type =="Both" Cannot Be Used with 'Repos =Null'

R Change Na Values

Conditional Mean Statement

Find Closest Points (Lat/Lon) from One Data Set to a Second Data Set

Map Array of Strings to an Array of Integers

Remove a List of Whole Words That May Contain Special Chars from a Character Vector Without Matching Parts of Words

R Shiny - Checkboxes and Action Button Combination Issue

R - Calculate Test Mse Given a Trained Model from a Training Set and a Test Set


Leave a reply



Submit