Блог

Рассмотрим приведенный ниже код. Он создает блестящую панель мониторинга с двумя пунктами меню, где каждый раз, когда пользователь устанавливает флажок на любой вкладке, отображается гистограмма. Однако, после определенного момента (после отображения второй гистограммы на каждой вкладке), каждый раз, когда отображается гистограмма нового элемента, пользователь должен прокручивать вниз вручную.

То, что я ищу, — это решение, при котором каждый раз, когда новый элемент отображается дальше вниз на вкладке блестящей панели мониторинга, вкладка немедленно прокручивается вниз до самого низа, чтобы новый элемент был полностью виден и чтобы он применялся ко всем вкладкам панели мониторинга. В этом примере используются графики (гистограммы), но это может быть любой вид вывода.

 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)
  

Кто-нибудь может помочь?

Приведенный ниже код — это то, что вам нужно. Но сначала вам нужно обратить внимание на некоторые мелкие детали:

1. вам нужно добавить sidebarMenu() оболочку для menuItem , иначе это будет некрасивый маркер, и когда вы нажмете tab1 и tab2, вы не сможете нажать tab1, чтобы вернуться к tab1. Я не знаю, какую версию dashboard вы используете, по крайней мере, на мой взгляд, это так.

 # 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. Вы можете использовать shinyjs package для запуска JS, если предпочитаете более R-способ. Это сложнее, чем я думал.

По сути, что я делаю, так это всякий раз, когда вы устанавливаете флажок под содержимым вкладки (не имеет значения, какой именно или на какой вкладке), он автоматически прокручивает ваше окно. Однако график отображается после нажатия кнопки. Если я прокручиваю во время щелчка, высота окна остается неизменной до тех пор, пока график не будет отправлен с сервера во внешний интерфейс. Итак, я добавил задержку на 200 мс, вы можете увидеть 200 в скрипте. Если для рендеринга вашего графика требуется более 200 мс, вам необходимо изменить это время задержки на более длительное. Если вы говорите, что хотите автоматически определять время задержки:

1. добавьте JS script в renderPlot function , когда функция рендеринга запускается, тогда вы прокручиваете, но вам нужно делать это для каждой функции рендеринга, поэтому будет много повторяющегося кода, который не идеален.Это может быть сделано с помощью shinyjs пакета.
2. Мое решение должно работать только на интерфейсном скрипте, нет обратной связи. Итак, другой вариант — добавить связь shiny-server, чтобы сообщить 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' amp;amp; is_checked === true){
                  setTimeout(function() {
                    window.scrollTo(0,document.body.scrollHeight);
                  }, 200)
                }
              })
           })
        </script>"
        ),
  

tags$script измените мой amp; на «amp;amp;», придется использовать HTML вместо этого.