我想使用
shiny.router
创建指向使用 navbarPage
和 tabPanel
的闪亮应用程序选项卡的可共享链接。
这是不起作用的可重现示例:
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
?
以下是我的答案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) # 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)
上面使用的是
clientData$url_hash
- 同样可以使用 clientData$url_search
来完成,如我之前的答案所示。
编辑: 使用
mode = "push"
中的 updateQueryString
进行浏览器导航:
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)
替代使用
getQueryString
和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的书签功能也可以恢复选定的选项卡,只要
navbarPage
带有id
。
PPS:这里可以找到关于使用辅助导航的
navbarPage
的相关问题。
作为一种解决方法,我从shinytheme(“flatly”)源代码中获取了类标签,并将它们单独应用于ul()和a()。 如果可能的话,我宁愿使用 navbarPage() 。
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)