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

Question

我想使用 shiny.router 创建可共享的链接，指向使用 navbarPage 和 tabPanel 的 Shiny 应用的选项卡。

这里是一个不工作的可重现的例子:

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)

如果我将这段代码用于 ui 部分，它会起作用:

#+++++++++++++
# 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
  )

)

但这并没有给我留下一个合适的导航栏。是否可以将 navbarPage 和 tabPanel 结构与 shiny.router 一起使用？

Answer 1

以下是我的回答的略微修改版本 here ，这避免了使用 library(shiny.router)。

不同之处在于使用 shiny::updateNavbarPage 而不是 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)
    if(!is.null(currentTab)){
      updateNavbarPage(session, "navbarID", selected = currentTab)
    }
  })
}

shinyApp(ui, server)

上面使用的是 clientData$url_hash - 同样可以用 clientData$url_search 完成，如我之前的回答所示。

---

编辑:使用 updateQueryString 中的 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(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)
    pushQueryString <- paste0("#", input$navbarID)
    if(is.null(currentHash) || currentHash != input$navbarID){
      freezeReactiveValue(input, "navbarID")
      updateQueryString(pushQueryString, mode = "push", session)
    }
  }, priority = 0)
}

shinyApp(ui, server)

---

替代方案使用clientData$url_search 和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:使用 shiny 的 bookmarking capabilities 也可以恢复选定的选项卡。 ，只要为 navbarPage 提供 id。