使用shiny.router为shinydashboard进行URI路由

Question

假设您有一个简单的shinydashboard包含使用创建的链接menuItem和使用创建的页面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)

是否可以为页面创建永久链接？例如，主页（tabName==“仪表板”）的 URL 为 127.0.0.1:1234/home，小部件页面位于 127.0.0.1:1234/widgets？

似乎shiny没有开箱即用的 URL 路由。shiny.router似乎是一个可能的替代方案，但我发现没有简单的方法可以shinydashboard使用 iemenuItem和来做到这一点tabItem。我试图避免重写应用程序的 UI 以使用与shiny.router（例如shiny.semantic）更紧密集成的东西

是否可以保留上述shinydashboard代码，同时实现到各个不同页面的永久链接？

Answer 1

以下是如何将以下方法与闪亮的tabPanel()功能一起使用。

不使用的解决方法library(shiny.router)：

编辑- 替代使用clientData$url_search和mode = "push"forupdateQueryString将新的历史记录条目推送到浏览器的历史记录堆栈上：

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")

另一个编辑 - 使用 url_hash （uri 片段）：

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")

编辑 - 使用 url_search：实际上我们可以在不使用书签的情况下执行相同的操作getQueryString和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
    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")

使用书签：

不确定您是否对这样的解决方法感兴趣，但您可以使用闪亮的书签并updateQueryString实现类似的行为：

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")

一些相关链接：

• https://rstudio.github.io/shinydashboard/behavior.html#bookmarking
• https://shiny.rstudio.com/reference/shiny/1.7.0/session.html
• 如果输入之前已写入 RDS 文件，是否可以在 Shiny 应用程序中本地恢复会话？
• shinyjs - setBookmarkExclude 用于延迟 ID
• https://github.com/rstudio/shiny/issues/3546