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

icnyk63a  于 2022-12-25  发布在  其他
关注(0)|答案(2)|浏览(173)

我想使用shiny.router来创建一个使用navbarPagetabPanel的闪亮应用程序的标签的可共享链接。
下面是一个不起作用的可重复示例:

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

)

但是这并没有给我留下一个看起来合适的导航栏。有没有可能用navbarPagetabPanel结构搭配shiny.router

hc2pp10m

hc2pp10m1#

下面是我的答案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,如我前面的答案所示。

**编辑:**在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) # 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)

备选使用clientData$url_searchmode = "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
PPS:这里可以找到关于使用辅助导航的navbarPage的相关问题。

xdnvmnnf

xdnvmnnf2#

作为一种变通方法,我从shinytheme(“flatly”)源代码中提取了class标签,并将它们分别应用于ul()和a()。

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)

相关问题