Automatic scrolling based on recent output in Shiny - r

Question

This question builds on this previous question R Shiny: keep old output.
I would like to view the output at the top of the page. How to automatically scroll the output to the top of the page?
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 added based on Waldi's answer:
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);
}
});
View Video Screenshot Gif

Answer 1

As mentionned in the comments, you can set a javascript trigger on model_record tag:
create the js script under 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);
}
});
include the script in the UI:
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)
Now the scrollbar moves down after each model update... but you have to scroll up to find the fit model button : this can be changed by using a fixed sidebar css.
Finally, to show only the last model on top, building on #Tonio Liebrand suggestion, you can add a div with 90% of viewport height so that it automatically adapts to screen size.

Answer 2

Thanks for clarifying concerning my question in the comments. I think now i understand what you are attempting to achieve.
I think one challenge you might face is that the sidebar wont scroll down as well. I am not sure that it is desired.
Potential solution:
You could add a placeholder that ensures that your latest modell output will be on top if you scroll down. It could be just an empty div:
div(style="height: 850px;")
This is more of a draft as we should ensure first that the spec is fully understood. Enhancements would be to scale this div to the size of the users screen.
Reproducible example:
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)