Shiny Dashboard 在頁面頂部加載新標簽

Question

我已經按照這個線程在窗口頂部凍結了 Shiny Dashboard 的標題，這很方便，因為我的儀表板上會有很多長標簽。 但是，每當我切換選項卡時，新選項卡都不會在選項卡頂部與我一起加載 - 無論我在新選項卡上有多遠，我在切換時都在舊選項卡上。 有沒有辦法改變這種情況？ 這是一些播放代碼：

library(shiny)          # shiny application
library(shinydashboard) # shiny dashboard toolkit
library(shinyjs)        # allows use of Javascript--used for sidebar closing ability

# ------------------------------------------------------------------------------
# BUILD UI
# ------------------------------------------------------------------------------

# Box height
boxHeight = "30em"

# Header content
header <- dashboardHeader(
  title = span("Jim's Dashboard", 
               style = "color: white; font-size: 28px"), 
  titleWidth = 260
)

# Sidebar content
sidebar <- dashboardSidebar(
  width = 260,
  collapsed = TRUE,
  sidebarMenu(
    id = "mysidebar",
    menuItem("Dashboard 1", tabName = "tab1", icon = icon("tachometer-alt")),
    menuItem("Dashboard 2", tabName = "tab2", icon = icon("chart-pie"))
  )
)

# Body content
body <- dashboardBody(

  # Keep header/sidebar frozen at top, per https://stackoverflow.com/questions/45706670/shiny-dashboadpage-lock-dashboardheader-on-top
  tags$script(HTML("$('body').addClass('fixed');")), 
  
  # This line allows us to use Javascript; so far, it's only used to make the
  # sidebar go away once we've changed pages, per https://stackoverflow.com/questions/47830553/r-shiny-automatically-hide-the-sidebar-when-you-navigate-into-tab-items
  useShinyjs(),
  
  tabItems(
    # 1ST TAB
    tabItem(tabName = "tab1",
      fluidRow(
        column(width=10, offset=1,
          fluidRow(
            box(height = boxHeight),
            box(height = boxHeight),
            box(height = boxHeight),
            box(height = boxHeight),
            box(height = boxHeight,width = 12),
            box(height = boxHeight),
            box(height = boxHeight),
            box(height = boxHeight,width = 12)
    )))),
    # 2ND TAB
    tabItem(tabName = "tab2",
      fluidRow(
        column(width=10, offset=1,
        fluidRow(
          box(height = boxHeight,width = 12),
          box(height = boxHeight),
          box(height = boxHeight),
          box(height = boxHeight),
          box(height = boxHeight),
          box(height = boxHeight,width = 12),
          box(height = boxHeight,width = 12),
          box(height = boxHeight,width = 12)
    ))))
  )
)

server <- function(input,output,session){
  
  # Adding these lines makes the sidebar go away once we've loaded a new page,
  # per https://stackoverflow.com/questions/47830553/r-shiny-automatically-hide-the-sidebar-when-you-navigate-into-tab-items
  observeEvent(input$mysidebar,
               {
                 # for desktop browsers
                 addClass(selector = "body", class = "sidebar-collapse")
                 # for mobile browsers
                 removeClass(selector = "body", class = "sidebar-open")
               }
  )
}

#Dashboard page
dashboard <- dashboardPage(header, sidebar, body, tags$head(tags$style(HTML('* {font-family: "Lucida Sans"}!important;'))))

shinyApp(dashboard, server)

Answer 1

在身體的任何地方添加這個

tags$script('$(".sidebar-menu a[data-toggle=\'tab\']").click(function(){window.scrollTo({top: 0});})')

像這樣

library(shiny)          # shiny application
library(shinydashboard) # shiny dashboard toolkit
library(shinyjs)        # allows use of Javascript--used for sidebar closing ability

# ------------------------------------------------------------------------------
# BUILD UI
# ------------------------------------------------------------------------------

# Box height
boxHeight = "30em"

# Header content
header <- dashboardHeader(
  title = span("Jim's Dashboard", 
               style = "color: white; font-size: 28px"), 
  titleWidth = 260
)

# Sidebar content
sidebar <- dashboardSidebar(
  width = 260,
  collapsed = TRUE,
  sidebarMenu(
    id = "mysidebar",
    menuItem("Dashboard 1", tabName = "tab1", icon = icon("tachometer-alt")),
    menuItem("Dashboard 2", tabName = "tab2", icon = icon("chart-pie"))
  )
)

# Body content
body <- dashboardBody(
  tags$script('$(".sidebar-menu a[data-toggle=\'tab\']").click(function(){window.scrollTo({top: 0});})'),
  # Keep header/sidebar frozen at top, per https://stackoverflow.com/questions/45706670/shiny-dashboadpage-lock-dashboardheader-on-top
  tags$script(HTML("$('body').addClass('fixed');")), 
  
  # This line allows us to use Javascript; so far, it's only used to make the
  # sidebar go away once we've changed pages, per https://stackoverflow.com/questions/47830553/r-shiny-automatically-hide-the-sidebar-when-you-navigate-into-tab-items
  useShinyjs(),
  
  tabItems(
    # 1ST TAB
    tabItem(tabName = "tab1",
            fluidRow(
              column(width=10, offset=1,
                     fluidRow(
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight,width = 12),
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight,width = 12)
                     )))),
    # 2ND TAB
    tabItem(tabName = "tab2",
            fluidRow(
              column(width=10, offset=1,
                     fluidRow(
                       box(height = boxHeight,width = 12),
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight),
                       box(height = boxHeight,width = 12),
                       box(height = boxHeight,width = 12),
                       box(height = boxHeight,width = 12)
                     ))))
  )
)

server <- function(input,output,session){
  
  # Adding these lines makes the sidebar go away once we've loaded a new page,
  # per https://stackoverflow.com/questions/47830553/r-shiny-automatically-hide-the-sidebar-when-you-navigate-into-tab-items
  observeEvent(input$mysidebar,
               {
                 # for desktop browsers
                 addClass(selector = "body", class = "sidebar-collapse")
                 # for mobile browsers
                 removeClass(selector = "body", class = "sidebar-open")
               }
  )
}

#Dashboard page
dashboard <- dashboardPage(header, sidebar, body, tags$head(tags$style(HTML('* {font-family: "Lucida Sans"}!important;'))))

shinyApp(dashboard, server)