Автоматическая c прокрутка на основе недавнего вывода в Shiny - PullRequest
Новая
       48

Автоматическая c прокрутка на основе недавнего вывода в Shiny

0 голосов
/ 13 июля 2020

Этот вопрос основан на предыдущем вопросе R Shiny: сохранить старый вывод .

Я хотел бы просмотреть вывод в верхней части страницы. Как автоматически прокручивать вывод в верхнюю часть страницы? 

library(shiny)
library(broom)
library(dplyr)
library(shinyjs)
library(shinydashboard)

header <- dashboardHeader(title = "My Dashboard")

sidebar <-  dashboardSidebar(
    sidebarMenu(
          checkboxGroupInput(inputId = "indep",
                             label = "Independent Variables",
                             choices = names(mtcars)[-1],
                             selected = NULL),
          actionButton(inputId = "fit_model",
                       label = "Fit Model"),
          numericInput(inputId = "model_to_show",
                       label = "Show N most recent models",
                       value = 20)
      )
)
  
body <- dashboardBody(
  includeScript("www/scrolldown.js"),
  tags$head(includeCSS('www/style.css')),
       
          htmlOutput("model_record")
)

ui <- dashboardPage(header, sidebar, body)

server <-  
  shinyServer(function(input, output, session){
    Model <- reactiveValues(
      Record = list()
    )
    
    observeEvent(
      input[["fit_model"]],
      {
        fit <- 
          lm(mpg ~ ., 
             data = mtcars[c("mpg", input[["indep"]])])
        
        #Model$Record <- c(Model$Record, list(fit))
        #Last result up
        Model$Record <- c(list(fit),Model$Record)
      }
    )
    
    output$model_record <- 
      renderText({
        tail(Model$Record, input[["model_to_show"]]) %>%
          lapply(tidy) %>%
          lapply(knitr::kable,
                 format = "html") %>%
          lapply(as.character) %>%
          unlist() %>%
          paste0(collapse = "<br/><br/>")
      })
    
  })


shinyApp(ui, server)

style. css file: 

.sidebar {
    color: #FFF;
    position: fixed;
    width: 220px;
    white-space: nowrap;
    overflow: visible;
  }
  
  .main-header {
    position: fixed;
    width:100%;
  }

  .content {
    padding-top: 60px;
  }

EDIT: Javascript добавлено на основе ответа Вальди:

прокрутка вниз. js

$(document).on('shiny:value', function(event) {
  // Scroll down after model update
  if (event.target.id === 'model_record') {
    window.scrollTo(0,document.body.scrollHeight);
  }
});

Просмотр видео Скриншот Gif

Ответы [ 2 ]

2 голосов
/ 16 июля 2020

Спасибо, что разъяснили мой вопрос в комментариях. Думаю, теперь я понимаю, чего вы пытаетесь достичь.

Я думаю, что одна проблема, с которой вы можете столкнуться, заключается в том, что боковая панель также не будет прокручиваться вниз. Я не уверен, что это желательно.

Возможное решение:

Вы можете добавить заполнитель, который гарантирует, что ваш последний вывод модели будет наверху, если вы прокрутите вниз . Это может быть просто пустой div: 

div(style="height: 850px;")

Это скорее черновик, так как мы должны сначала убедиться, что spe c полностью понят. Усовершенствования заключаются в том, чтобы масштабировать этот div до размера экрана пользователя.

Воспроизводимый пример: 

library(shiny)
library(broom)
library(dplyr)
library(shinyjs)
library(shinydashboard)

header <- dashboardHeader(title = "My Dashboard")

js_code <- "$(document).on('shiny:value', function(event) {
  // Scroll down after model update
  if (event.target.id === 'model_record') {
    window.scrollTo(0,document.body.scrollHeight);
  }
});"

sidebar <-  dashboardSidebar(
  
  sidebarMenu(
    
    checkboxGroupInput(inputId = "indep",
                       label = "Independent Variables",
                       choices = names(mtcars)[-1],
                       selected = NULL),
    
    actionButton(inputId = "fit_model",
                 label = "Fit Model"),
    
    numericInput(inputId = "model_to_show",
                 label = "Show N most recent models",
                 value = 20)
  )
)

body <- dashboardBody(
  tags$script(js_code),
  htmlOutput("model_record"),
  div(style="height: 850px;")
)

ui <- dashboardPage(header, sidebar, body)

server <-  
  shinyServer(function(input, output, session){
    Model <- reactiveValues(
      Record = list()
    )
    
    observeEvent(
      input[["fit_model"]],
      {
        fit <- 
          lm(mpg ~ ., 
             data = mtcars[c("mpg", input[["indep"]])])
        
        Model$Record <- c(Model$Record, list(fit))
      }
    )
    
    output$model_record <- 
      renderText({
        tail(Model$Record, input[["model_to_show"]]) %>%
          lapply(tidy) %>%
          lapply(knitr::kable,
                 format = "html") %>%
          lapply(as.character) %>%
          unlist() %>%
          paste0(collapse = "<br/><br/>")
      })
    
  })


shinyApp(ui, server)
1 голос
/ 16 июля 2020

Как упоминалось в комментариях, вы можете установить триггер javascript для тега model_record:

  1. создать сценарий js под www/scrolldown.js: 
$(document).on('shiny:value', function(event) {
  // Scroll down after model update
  if (event.target.id === 'model_record') {
    window.scrollTo(0,document.body.scrollHeight);
  }
});
включить сценарий в пользовательский интерфейс: 
library(shiny)
library(broom)
library(dplyr)
library(shinyjs)
library(shinydashboard)

header <- dashboardHeader(title = "My Dashboard")

sidebar <-  dashboardSidebar(
  sidebarMenu(
    checkboxGroupInput(inputId = "indep",
                       label = "Independent Variables",
                       choices = names(mtcars)[-1],
                       selected = NULL),
    actionButton(inputId = "fit_model",
                 label = "Fit Model"),
    numericInput(inputId = "model_to_show",
                 label = "Show N most recent models",
                 value = 20)
  )
)

body <- dashboardBody(
  includeScript("www/scrolldown.js"),
  tags$head(includeCSS('www/style.css')),
  
  htmlOutput("model_record"),
  div(style="height: 90vh;")
)

ui <- dashboardPage(header, sidebar, body)

server <-  
  shinyServer(function(input, output, session){
    Model <- reactiveValues(
      Record = list()
    )
    
    observeEvent(
      input[["fit_model"]],
      {
        fit <- 
          lm(mpg ~ ., 
             data = mtcars[c("mpg", input[["indep"]])])
        
        Model$Record <- c(Model$Record, list(fit))
      }
    )
    
    output$model_record <- 
      renderText({
        tail(Model$Record, input[["model_to_show"]]) %>%
          lapply(tidy) %>%
          lapply(knitr::kable,
                 format = "html") %>%
          lapply(as.character) %>%
          unlist() %>%
          paste0(collapse = "<br/><br/>")
      })
    
  })


shinyApp(ui, server)

Теперь полоса прокрутки перемещается вниз после каждого обновления модели ... но вам нужно прокрутить вверх, чтобы найти кнопку fit model: это может можно изменить с помощью фиксированной боковой панели css.

Наконец, чтобы отображать только последнюю модель сверху, основываясь на предложении @Tonio Liebrand, вы можете добавить div с 90% высота области просмотра , чтобы оно автоматически адаптировалось к размеру экрана.

...