在 R shiny 应用程序中使用 shiny.router 和 navbarPage 进行 URI 路由

Question

I would like to use shiny.router to create shareable links to tabs of a shiny app that uses navbarPage and tabPanel .

Here is reproducible example that does not work:

library(shiny)
library(shiny.router)

page_1 <- tabPanel("Page 1", value = "page_1",
                   "This is Page 1")

page_2 <- tabPanel("Page 2", value = "page_2",
                   "This is Page 2")

router <- make_router(
  route("/", page_1),
  route("page2", page_2)
)

#+++++++++++++
# ui
#+++++++++++++

ui <- navbarPage("Dashboard", theme = shinytheme("flatly"), 

      router$ui
)

#+++++++++++++
# server
#+++++++++++++

server <- function(input, output, session)
{
  router$server(input, output, session)
}

shinyApp(ui, server)

It kind of works if I use for the ui part this code:

#+++++++++++++
# ui
#+++++++++++++

ui <- navbarPage("Dashboard", theme = shinytheme("flatly"),

  tabPanel(
    tags$ul(
      tags$li(a(href = route_link("/"), "Page 1")),
      tags$li(a(href = route_link("page2"), "Page 2"))
    ),
  router$ui
  )

)

But that does not leave me with a proper looking navbar. Is ist possible to use a navbarPage and tabPanel structure with shiny.router ?

Answer 1

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)

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)

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.

Answer 2

As a workaround I took class tags from shinytheme("flatly") source code and applied them individually to ul() and a(). I'd rather use navbarPage() if possible.

library(shiny)
library(shiny.router)


home_page <- div(
  titlePanel("Dashboard"),
  p("This is a dashboard page")
)

settings_page <- div(
  titlePanel("Settings"),
  p("This is a settings page")
)

contact_page <- div(
  titlePanel("Contact"),
  p("This is a contact page")
)


router <- make_router(
  route("/", home_page),
  route("settings", settings_page),
  route("contact", contact_page)
)


ui <- fluidPage(theme = shinytheme("flatly"),


tags$ul(class="navbar navbar-expand-lg navbar-dark bg-primary",
        a(class="navbar-brand", href = route_link("/"), "Dashboard"),
        a(class="navbar-brand", href = route_link("settings"), "Settings"),
        a(class="navbar-brand", href = route_link("contact"), "Contact")
        ),
router$ui
)

server <- function(input, output, session) {
router$server(input, output, session)
}

shinyApp(ui, server)