呈现新的输出元素时，R Shinydashboard自动滚动到底部

问题描述

请考虑以下代码。它产生带有两个菜单项的Shiny仪表板，每当用户在任一选项卡上选中一个框时，都会显示一个直方图。但是，在某个点之后（在每个选项卡上显示第二个直方图之后），每次绘制新的元素直方图时，用户都必须手动向下滚动。

我正在寻找的解决方案是，每次在Shiny仪表板的选项卡上将新元素向下进一步渲染时，该选项卡都会立即向下滚动到底部，因此可以完全看到新元素，并且适用于仪表板的所有选项卡。该示例带有曲线图（直方图），但可以是任何类型的输出。

library(shiny)
library(shinydashboard)

ui <- dashboardPage(
  dashboardHeader(title = "My dashboard"),dashboardSidebar(
    menuItem(text = "Tab 1",tabName = "tab1"),menuItem(text = "Tab 2",tabName = "tab2")
    
  ),dashboardBody(
    tabItems(
      tabItem(tabName = "tab1",h1(textoutput(outputId = "header1")),checkBoxInput(inputId = "sepalLng",label = "Histogram - iris,Sepal.Length"),conditionalPanel(condition = "input.sepalLng",plotOutput(outputId = "histSepalLng",height = "500px")
              ),checkBoxInput(inputId = "sepalWdt",Sepal.Width"),conditionalPanel(condition = "input.sepalWdt",plotOutput(outputId = "histSepalWdt",checkBoxInput(inputId = "petalLng",Petal.Length"),conditionalPanel(condition = "input.petalLng",plotOutput(outputId = "histPetalLng",checkBoxInput(inputId = "petalWdt",Petal.Width"),conditionalPanel(condition = "input.petalWdt",plotOutput(outputId = "histPetalWdt",height = "500px")
              )
      ),tabItem(tabName = "tab2",h1(textoutput(outputId = "header2")),checkBoxInput(inputId = "mpg",label = "Histogram - mtcars,mpg"),conditionalPanel(condition = "input.mpg",plotOutput(outputId = "histMpg",checkBoxInput(inputId = "drat",drat"),conditionalPanel(condition = "input.drat",plotOutput(outputId = "histdrat",checkBoxInput(inputId = "wt",wt"),conditionalPanel(condition = "input.wt",plotOutput(outputId = "histWt",checkBoxInput(inputId = "qsec",qsec"),conditionalPanel(condition = "input.qsec",plotOutput(outputId = "histQsec",height = "500px")
              )
      )
    )
  )
)

server <- function(input,output) {
  
  output$header1 <- renderText({"Tab 1 - iris data"})
  output$histSepalLng <- renderPlot(hist(iris$Sepal.Length))
  output$histSepalWdt <- renderPlot(hist(iris$Sepal.Width))
  output$histPetalLng <- renderPlot(hist(iris$Petal.Length))
  output$histPetalWdt <- renderPlot(hist(iris$Petal.Width))
  
  output$header2 <- renderText({"Tab 2 - mtcars data"})
  output$histMpg <- renderPlot(hist(mtcars$mpg))
  output$histdrat <- renderPlot(hist(mtcars$drat))
  output$histWt <- renderPlot(hist(mtcars$wt))
  output$histQsec <- renderPlot(hist(mtcars$qsec))
}

shinyApp(ui,server)

有人可以帮忙吗？

解决方法

下面的代码是您想要的。但首先，您需要注意一些小细节：

您需要为sidebarMenu()添加menuItem包装器，否则，这是难看的要点，并且当您单击tab1和tab2时，您不能单击tab1返回到tab1。我不知道您使用的是什么版本的仪表板，至少在我看来是这样。

# just add this to your dash body
    dashboardBody(
        tags$script(
            "$( document ).ready(function() {
               $(\".tab-content [type='checkbox']\").on('click',function(){
                  setTimeout(function() {
                    window.scrollTo(0,document.body.scrollHeight);
                },200)
               })
             })"
        ),...
    )

看起来像这样：

ui <- dashboardPage(
    dashboardHeader(title = "My dashboard"),dashboardSidebar(
        sidebarMenu(
            menuItem(text = "Tab 1",tabName = "tab1"),menuItem(text = "Tab 2",tabName = "tab2")
        )
    ),dashboardBody(
        tags$script(
            "$( document ).ready(function() {
               $(\".tab-content [type='checkbox']\").on('click',tabItems(
            tabItem(tabName = "tab1",h1(textOutput(outputId = "header1")),checkboxInput(inputId = "sepalLng",label = "Histogram - iris,Sepal.Length"),conditionalPanel(condition = "input.sepalLng",plotOutput(outputId = "histSepalLng",height = "500px")
                    ),checkboxInput(inputId = "sepalWdt",Sepal.Width"),conditionalPanel(condition = "input.sepalWdt",plotOutput(outputId = "histSepalWdt",checkboxInput(inputId = "petalLng",Petal.Length"),conditionalPanel(condition = "input.petalLng",plotOutput(outputId = "histPetalLng",checkboxInput(inputId = "petalWdt",Petal.Width"),conditionalPanel(condition = "input.petalWdt",plotOutput(outputId = "histPetalWdt",height = "500px")
                    )
            ),tabItem(tabName = "tab2",h1(textOutput(outputId = "header2")),checkboxInput(inputId = "mpg",label = "Histogram - mtcars,mpg"),conditionalPanel(condition = "input.mpg",plotOutput(outputId = "histMpg",checkboxInput(inputId = "drat",drat"),conditionalPanel(condition = "input.drat",plotOutput(outputId = "histDrat",checkboxInput(inputId = "wt",wt"),conditionalPanel(condition = "input.wt",plotOutput(outputId = "histWt",checkboxInput(inputId = "qsec",qsec"),conditionalPanel(condition = "input.qsec",plotOutput(outputId = "histQsec",height = "500px")
                    )
            )
        )
    )
)

我使用了一些Jquery和JS函数。如果您更喜欢R方式，则可以使用shinyjs包运行JS。比我想的还要棘手。

基本上，我要做的是，只要单击选项卡内容下的复选框（与哪个或哪个选项卡无关），它就会自动滚动窗口。但是，单击按钮后将绘制图。如果在单击时滚动，则窗口高度将保持不变，直到将图从服务器发送到前端为止。因此，我添加了200ms的延迟，您可以在脚本中看到200。如果绘图需要200毫秒以上的渲染时间，则需要将此延迟时间更改为更长的时间。如果您说要自动确定延迟时间：

在renderPlot function上添加JS脚本，当渲染功能触发时，您可以滚动，但是您需要为每个渲染功能执行此操作，因此会有很多重复的代码不理想。由shinyjs包完成。
我的解决方案只需要在前端脚本上工作，就没有后端通信。因此，另一种选择是添加闪亮的服务器通信以告知JS触发时间。 sendCustomMessage可以完成此操作，但需要花费很多时间来学习。我不建议您是初学者。

也许只是估计时间，大多数情节应该花不到1秒的时间渲染。

编辑：

上面的脚本同时滚动选中/取消选中该框，但我认为您只希望选中该框：

        HTML(
        "<script>
           $( document ).ready(function() {
              $(\".tab-content [type='checkbox']\").on('click',function(){
                var is_checked = this.checked;
                if(typeof is_checked === 'boolean' && is_checked === true){
                  setTimeout(function() {
                    window.scrollTo(0,document.body.scrollHeight);
                  },200)
                }
              })
           })
        </script>"
        ),

tags$script将我的&更改为“＆amp;”，而必须使用HTML。

autoscroll r r shiny shinydashboard