通过侧边栏菜单切换到闪亮的仪表板面板顶部

问题描述

考虑下面的闪亮仪表板示例（改编自https://rstudio.github.io/shinydashboard/get_started.html）。是否可以某种方式向下滚动到一个选项卡项目中，然后再通过单击位于新项目顶部的侧板而不是以前的高度来切换到另一个选项卡项目？

library(shiny)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard"),dashboardSidebar(
    sidebarMenu(
      style = "position: fixed; overflow: visible;",menuItem("Dashboard",tabName = "dashboard",icon = icon("dashboard")),menuItem("Widgets",tabName = "widgets",icon = icon("th"))
    )
  ),## Body content
  dashboardBody(
    tabItems(
      # First tab content
      tabItem(tabName = "dashboard",fluidRow(
                Box(plotOutput("plotA",height = 250)),Box(
                  title = "Controls",sliderInput("sliderA","Number of observations:",1,100,50)
                )
              ),fluidRow(
                Box(plotOutput("plotB",sliderInput("sliderB",fluidRow(
                Box(plotOutput("plotC",sliderInput("sliderC",fluidRow(
                Box(plotOutput("plotD",sliderInput("sliderD",fluidRow(
                Box(plotOutput("plotE",sliderInput("sliderE",fluidRow(
                Box(plotOutput("plotF",sliderInput("sliderF",50)
                )
              )
              
      ),# Second tab content
      tabItem(tabName = "widgets",h2("Widgets tab content"),fluidRow(
                Box(plotOutput("plot1",sliderInput("slider1",fluidRow(
                Box(plotOutput("plot2",sliderInput("slider2",fluidRow(
                Box(plotOutput("plot3",sliderInput("slider3",fluidRow(
                Box(plotOutput("plot4",sliderInput("slider4",fluidRow(
                Box(plotOutput("plot5",sliderInput("slider5",fluidRow(
                Box(plotOutput("plot6",sliderInput("slider6",50)
                )
              )
      )
    )
  )
)

server <- function(input,output) {
  set.seed(122)
  histdata <- rnorm(500)
  
  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider1)]
    hist(data)
  })
  
  output$plot2 <- renderPlot({
    data <- histdata[seq_len(input$slider2)]
    hist(data)
  })
  
  output$plot3 <- renderPlot({
    data <- histdata[seq_len(input$slider3)]
    hist(data)
  })
  
  output$plot4 <- renderPlot({
    data <- histdata[seq_len(input$slider4)]
    hist(data)
  })
  
  output$plot5 <- renderPlot({
    data <- histdata[seq_len(input$slider5)]
    hist(data)
  })
  
  output$plot6 <- renderPlot({
    data <- histdata[seq_len(input$slider6)]
    hist(data)
  })
  
  
  
  output$plotA <- renderPlot({
    data <- histdata[seq_len(input$sliderA)]
    hist(data)
  })
  
  output$plotB <- renderPlot({
    data <- histdata[seq_len(input$sliderB)]
    hist(data)
  })
  
  output$plotC <- renderPlot({
    data <- histdata[seq_len(input$sliderC)]
    hist(data)
  })
  
  output$plotD <- renderPlot({
    data <- histdata[seq_len(input$sliderD)]
    hist(data)
  })
  
  output$plotE <- renderPlot({
    data <- histdata[seq_len(input$sliderE)]
    hist(data)
  })
  
  output$plotF <- renderPlot({
    data <- histdata[seq_len(input$sliderF)]
    hist(data)
  })
}

shinyApp(ui,server)

解决方法

这是使用shinyjs的解决方案。每次单击侧边栏中的另一个项目时，都会执行一行JS。请参阅我添加的observeEvent：

library(shiny)
library(shinyjs)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "Basic dashboard"),dashboardSidebar(
    sidebarMenu(id = "sidebarID",style = "position: fixed; overflow: visible;",menuItem("Dashboard",tabName = "dashboard",icon = icon("dashboard")),menuItem("Widgets",tabName = "widgets",icon = icon("th"))
    )
  ),## Body content
  dashboardBody(
    useShinyjs(),extendShinyjs(text = 'shinyjs.scrolltop = function() {window.scrollTo(0,0)};'),tabItems(
      # First tab content
      tabItem(tabName = "dashboard",fluidRow(
                box(plotOutput("plotA",height = 250)),box(
                  title = "Controls",sliderInput("sliderA","Number of observations:",1,100,50)
                )
              ),fluidRow(
                box(plotOutput("plotB",sliderInput("sliderB",fluidRow(
                box(plotOutput("plotC",sliderInput("sliderC",fluidRow(
                box(plotOutput("plotD",sliderInput("sliderD",fluidRow(
                box(plotOutput("plotE",sliderInput("sliderE",fluidRow(
                box(plotOutput("plotF",sliderInput("sliderF",50)
                )
              )
              
      ),# Second tab content
      tabItem(tabName = "widgets",h2("Widgets tab content"),fluidRow(
                box(plotOutput("plot1",sliderInput("slider1",fluidRow(
                box(plotOutput("plot2",sliderInput("slider2",fluidRow(
                box(plotOutput("plot3",sliderInput("slider3",fluidRow(
                box(plotOutput("plot4",sliderInput("slider4",fluidRow(
                box(plotOutput("plot5",sliderInput("slider5",fluidRow(
                box(plotOutput("plot6",sliderInput("slider6",50)
                )
              )
      )
    )
  )
)

server <- function(input,output) {
  
  observeEvent(input$sidebarID,{
    js$scrolltop()
  })
  
  set.seed(122)
  histdata <- rnorm(500)
  
  output$plot1 <- renderPlot({
    data <- histdata[seq_len(input$slider1)]
    hist(data)
  })
  
  output$plot2 <- renderPlot({
    data <- histdata[seq_len(input$slider2)]
    hist(data)
  })
  
  output$plot3 <- renderPlot({
    data <- histdata[seq_len(input$slider3)]
    hist(data)
  })
  
  output$plot4 <- renderPlot({
    data <- histdata[seq_len(input$slider4)]
    hist(data)
  })
  
  output$plot5 <- renderPlot({
    data <- histdata[seq_len(input$slider5)]
    hist(data)
  })
  
  output$plot6 <- renderPlot({
    data <- histdata[seq_len(input$slider6)]
    hist(data)
  })
  
  
  
  output$plotA <- renderPlot({
    data <- histdata[seq_len(input$sliderA)]
    hist(data)
  })
  
  output$plotB <- renderPlot({
    data <- histdata[seq_len(input$sliderB)]
    hist(data)
  })
  
  output$plotC <- renderPlot({
    data <- histdata[seq_len(input$sliderC)]
    hist(data)
  })
  
  output$plotD <- renderPlot({
    data <- histdata[seq_len(input$sliderD)]
    hist(data)
  })
  
  output$plotE <- renderPlot({
    data <- histdata[seq_len(input$sliderE)]
    hist(data)
  })
  
  output$plotF <- renderPlot({
    data <- histdata[seq_len(input$sliderF)]
    hist(data)
  })
}

shinyApp(ui,server)