R閃亮儀表板標題中的“主頁”按鈕

Question

我正在嘗試在Shiny應用程序的標題中添加主頁按鈕，以便每當有人從任何選項卡單擊它時，它將重定向到第一頁。 目前，我在每個帶有obtainEvent的選項卡中使用一個actionButton返回第一頁。

我無法在Shiny應用程序的標題部分添加任何actionButton。 這個功能有什么辦法嗎？

它是這樣的： 樣本閃亮外觀

可復制代碼：

library(shiny)
library(shinydashboard)
library(shinyjs)
options(shiny.maxRequestSize=1000*1024^2)

app <- shinyApp(
  a <- dashboardPage(
    dashboardHeader(title = "Sample Shiny", titleWidth=1450),
    dashboardSidebar(sidebarMenu(id='tabs',
                                 menuItem("Welcome", tabName = "welcome"),
                                 menuItem("Tab1", tabName = "tab1"),
                                 menuItem("Tab2",
                                      menuSubItem("Tab2_1", tabName = "tab2_1"),
                                      menuSubItem("Tab2_2", tabName = "tab2_2"))
    )
    ),
    dashboardBody(  shinyjs::useShinyjs(),
                    tabItems(
                      tabItem(tabName="welcome", tabPanel(title = "Score",fluidRow(valueBoxOutput("box_01"),valueBoxOutput("box_02")))),
                      # First tab content
                      tabItem(tabName = "tab1",actionButton("homeButton1", "Home")),
                      # Second tab content
                      tabItem(tabName = "tab2_1",tabsetPanel(id = "test",tabPanel(title = "tab2_1",actionButton("homeButton2", "Home"),actionButton("NextButton2", "Tab3")))),
                      tabItem(tabName = "tab2_2",tabsetPanel(id = "outputTabset",tabPanel(title = "Tab 3",actionButton("homeButton3", "Home"))))         
    )
  )),

  b<-shinyServer(function(input, output, session) {

    ##########Links from first page
    output$box_01 <- renderValueBox({
      box1<-valueBox(value=01,
                 icon = icon("database",lib="font-awesome")
                 ,width=NULL
                 ,color = "blue"
                 ,href="#"
                 ,subtitle=HTML("<b>Tab 1</b>")
      )
      box1$children[[1]]$attribs$class<-"action-button"
      box1$children[[1]]$attribs$id<-"button_box_01"
      return(box1)

    })

    output$box_02 <- renderValueBox({
      box2<-valueBox(value=02,
                 icon = icon("user-secret",lib="font-awesome")
                 ,width=NULL
                 ,color = "yellow"
                 ,href="#"
                 ,subtitle=HTML("<b>Tab 2</b>")
      )
      box2$children[[1]]$attribs$class<-"action-button"
      box2$children[[1]]$attribs$id<-"button_box_02"
      return(box2)

    })

    observeEvent(input$button_box_01,{
      if(input$button_box_01[1]>0){
        newtab <- switch(input$tabs,
                     "welcome" = "tab1",
                     "tab1" = "welcome"
        )
        updateTabItems(session, "tabs", newtab)
      }  })

    observeEvent(input$button_box_02,{
      if(input$button_box_02[1]>0){
        newtab <- switch(input$tabs,
                     "welcome" = "tab2_1",
                     "tab2_1" = "welcome"
    )
    updateTabItems(session, "tabs", newtab)
  }  })


### HomeButtons

observeEvent(input$homeButton1,{
  newtab <- switch(input$tabs,
                   "welcome" = "tab1",
                   "tab1" = "welcome"
  )
  updateTabItems(session, "tabs", newtab)
})
observeEvent(input$homeButton2,{
  newtab <- switch(input$tabs,
                   "welcome" = "tab2_1",
                   "tab2_1" = "welcome"
  )
  updateTabItems(session, "tabs", newtab)
    })

    observeEvent(input$NextButton2,{
      newtab <- switch(input$tabs,
                   "tab2_2" = "tab2_1",
                   "tab2_1" = "tab2_2"
      )
      updateTabItems(session, "tabs", newtab)
    })

    observeEvent(input$homeButton3,{
      newtab <- switch(input$tabs,
                   "welcome" = "tab2_2",
                   "tab2_2" = "welcome"
      )
      updateTabItems(session, "tabs", newtab)
    })


#######SideBar Disable

    addClass(selector = "body", class = "sidebar-collapse")


    })
        )

shiny::runApp(app,launch.browser=TRUE,host="0.0.0.0",port=6105)

Answer 1

請參閱以下解決方案。 您仍然需要使用CSS設置位置樣式。 關鍵是將actionButton放入帶有tags$li(class = "dropdown", ...)的標題中，否則dashboardHeader將不接受它：

ui <- dashboardPage(
  dashboardHeader(title = "Demo", tags$li(class = "dropdown", actionButton("home", "Home"))),
  dashboardSidebar(sidebarMenu(id = "sidebar", # id important for updateTabItems
    menuItem("Home", tabName = "home", icon = icon("house")),
    menuItem("Tab1", tabName = "tab1", icon = icon("table")),
    menuItem("Tab2", tabName = "tab2", icon = icon("line-chart")),
    menuItem("Tab3", tabName = "tab3", icon = icon("line-chart")))
  ),

  dashboardBody(
    tabItems(
      tabItem("home", "This is the home tab"),
      tabItem("tab1", "This is Tab1"),
      tabItem("tab2", "This is Tab2"),
      tabItem("tab3", "This is Tab3")
  ))
)
server = function(input, output, session){
 observeEvent(input$home, {
   updateTabItems(session, "sidebar", "home")
 })
}
shinyApp(ui, server)

Answer 2

這是一個使用javascript和一個很適合標題的主頁圖標的選​​項：

dashboardHeader(title = "Your Title",
               tags$li(a(onclick = "openTab('home')",
                        href = NULL,
                        icon("home"),
                        title = "Homepage",
                        style = "cursor: pointer;"),
                      class = "dropdown",
                      tags$script(HTML("
                                       var openTab = function(tabName){
                                       $('a', $('.sidebar')).each(function() {
                                       if(this.getAttribute('data-value') == tabName) {
                                       this.click()
                                       };
                                       });
                                       }")))
)

更改home中openTab('home')部分無論你的主頁選項卡被調用，點擊時會切換到該標簽。