渲染新的输出元素时，R shinydashboard 自动滚动到底部

Question

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

我正在寻找的解决方案是，每次在 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", label = "Histogram - iris, Sepal.Width"),
              conditionalPanel(condition = "input.sepalWdt",
                               plotOutput(outputId = "histSepalWdt", height = "500px")
              ),
              checkboxInput(inputId = "petalLng", label = "Histogram - iris, Petal.Length"),
              conditionalPanel(condition = "input.petalLng",
                               plotOutput(outputId = "histPetalLng", height = "500px")
              ),
              checkboxInput(inputId = "petalWdt", label = "Histogram - iris, 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", height = "500px")
              ),
              checkboxInput(inputId = "drat", label = "Histogram - mtcars, drat"),
              conditionalPanel(condition = "input.drat",
                               plotOutput(outputId = "histDrat", height = "500px")
              ),
              checkboxInput(inputId = "wt", label = "Histogram - mtcars, wt"),
              conditionalPanel(condition = "input.wt",
                               plotOutput(outputId = "histWt", height = "500px")
              ),
              checkboxInput(inputId = "qsec", label = "Histogram - mtcars, 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)

有人可以帮忙吗？

Answer 1

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

1. 你需要为menuItem添加sidebarMenu()包装，否则，它是丑陋的要点，当你点击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', function(){
                  setTimeout(function() {
                    window.scrollTo(0,document.body.scrollHeight);
                }, 200)
               })
             })"
        ),
        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", label = "Histogram - iris, Sepal.Width"),
                    conditionalPanel(condition = "input.sepalWdt",
                                     plotOutput(outputId = "histSepalWdt", height = "500px")
                    ),
                    checkboxInput(inputId = "petalLng", label = "Histogram - iris, Petal.Length"),
                    conditionalPanel(condition = "input.petalLng",
                                     plotOutput(outputId = "histPetalLng", height = "500px")
                    ),
                    checkboxInput(inputId = "petalWdt", label = "Histogram - iris, 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", height = "500px")
                    ),
                    checkboxInput(inputId = "drat", label = "Histogram - mtcars, drat"),
                    conditionalPanel(condition = "input.drat",
                                     plotOutput(outputId = "histDrat", height = "500px")
                    ),
                    checkboxInput(inputId = "wt", label = "Histogram - mtcars, wt"),
                    conditionalPanel(condition = "input.wt",
                                     plotOutput(outputId = "histWt", height = "500px")
                    ),
                    checkboxInput(inputId = "qsec", label = "Histogram - mtcars, qsec"),
                    conditionalPanel(condition = "input.qsec",
                                     plotOutput(outputId = "histQsec", height = "500px")
                    )
            )
        )
    )
)

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

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

1. 在renderPlot function处添加JS脚本，当render函数触发时，你就滚动，但是你需要为每个render函数都做，所以会有很多重复的代码，不理想。这个可以通过shinyjs 包。
2. 我的解决方案只需要在前端脚本上工作，没有后端通信。所以另一种选择是添加闪亮的服务器通信来告诉 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 将我的& 更改为“&”，必须改用HTML。