div - ¿Cómo me aseguro de que una trama reactiva brillante solo cambie una vez que todos los demás reactivos terminen de cambiar?

tags$style shiny

Question

Tengo una aplicación brillante en la que el usuario selecciona un montón de entradas, como el rango x, el rango y, los tipos de escalado y la selección de un subconjunto particular del conjunto de datos a través de una lista desplegable.

Todo esto se hace mediante el uso de reactivos. Las entradas del control deslizante del rango X e Y reaccionan a los cambios en la selección del conjunto de datos porque el mínimo y el máximo deben encontrarse nuevamente. Esto puede tardar entre 1 y 2 segundos, mientras que la aplicación brillante está funcionando y el usuario elige una opción diferente en la lista desplegable. Durante esos 1-2 segundos, la gráfica cambia a la gráfica del nuevo subconjunto de datos seleccionado con el rango anterior de x e y antes de cambiar rápidamente a la gráfica correcta una vez que cambian los controles deslizantes de la gama x e y.

Una solución sería simplemente actualizar la trama en un botón aislando todo lo demás. Pero, ¿habría una manera de mantener la trama reactiva a los cambios, pero solo esperar hasta que todas las cosas dependientes hayan terminado de calcularse?

Gracias

Esta es la trama:

output$plot1 <- rCharts::renderChart2({
if(!is.null(input$date_of_interest) &&
!is.null(input$xrange) &&
!is.null(input$yrange) &&
!is.null(data()) &&
isolate(valid_date_of_interest())) {
filtered_data<- dplyr::filter(isolate(data()), id==input$choice)
p <- tryCatch(plot_high_chart(
data,
first_date_of_interest = input$date_of_interest,
ylim = input$yrange,
xlim = input$xrange),
error = function(e) e,
warning = function(w) w)
if(!inherits(p, "error") && !inherits(p, "warning")) {
return(p)
}
}
return(rCharts::Highcharts$new())
})

y x rango (y rango es similar):

output$xrange <- renderUI({
if(!is.null(input$date_of_interest) &&
!is.null(input$choice) &&
!is.null(valid_date_of_interest()) &&
isolate(valid_date_of_interest())) {
temp_data <- dplyr::filter(isolate(data()), date == input$date_of_interest)
temp <- data.table::data.table(temp_data, key = "child.id")
the_days <- as.double(as.Date(temp$last.tradeable.dt) - as.Date(temp$date))
min_days <- min(the_days,na.rm=TRUE)
max_days <- max(the_days,na.rm=TRUE)
sliderInput("xrange",
"Days Range (X Axis)",
step = 1,
min = 0,
max = max_days + 10,
value = c(min_days,max_days)
)
}
})

y la opción de entrada:

 output$choice<- renderUI({
selectInput("choice",
"Choose:",
unique(data$id),
selected = 1
)
})

Algunas orientaciones y sugerencias para implementar serían útiles. He pensado en tener variables globales como x_range_updated, y_range_updated, que están configuradas como falsas en el código para la opción de salida $ y luego configuradas como verdaderas en el código para la salida $ xrange, etc. . Se agradecerán otras sugerencias para abordar este problema.

Answer 1

Editar 2019-02-14

Desde Shiny 1.0.0 (publicado después de que escribí esta respuesta originalmente), ahora hay una función de debounce que agrega funcionalidad para ayudar con este tipo de tarea. En su mayor parte, esto evita la necesidad del código que escribí originalmente, aunque bajo el capó funciona de una manera similar. Sin embargo, por lo que puedo decir, el debounce no ofrece ninguna forma de cortocircuitar el retraso con un botón de acción de volver a dibujar en la línea de lo que he hecho aquí. Por lo tanto, he creado una versión modificada de debounce que ofrece esta funcionalidad:

library(shiny)
library(magrittr)
# Redefined in global namespace since it''s not exported from shiny
`%OR%` <- shiny:::`%OR%`
debounce_sc <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain(), short_circuit = NULL)
{
force(r)
force(millis)
if (!is.function(millis)) {
origMillis <- millis
millis <- function() origMillis
}
v <- reactiveValues(trigger = NULL, when = NULL)
firstRun <- TRUE
observe({
r()
if (firstRun) {
firstRun <<- FALSE
return()
}
v$when <- Sys.time() + millis()/1000
}, label = "debounce tracker", domain = domain, priority = priority)
# New code here to short circuit the timer when the short_circuit reactive
# triggers
if (inherits(short_circuit, "reactive")) {
observe({
short_circuit()
v$when <- Sys.time()
}, label = "debounce short circuit", domain = domain, priority = priority)
}
# New code ends
observe({
if (is.null(v$when))
return()
now <- Sys.time()
if (now >= v$when) {
v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 +
1
v$when <- NULL
}
else {
invalidateLater((v$when - now) * 1000)
}
}, label = "debounce timer", domain = domain, priority = priority)
er <- eventReactive(v$trigger, {
r()
}, label = "debounce result", ignoreNULL = FALSE, domain = domain)
primer <- observe({
primer$destroy()
er()
}, label = "debounce primer", domain = domain, priority = priority)
er
}

Esto permite una aplicación brillante simplificada. He cambiado al modo de trabajo de un solo archivo, pero la interfaz de usuario sigue siendo la misma que la original.

ui <- fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectInput("column", "Column", colnames(faithful), selected = "waiting"),
actionButton("redraw", "Redraw")
),
mainPanel(
plotOutput("distPlot")
)
)
)
server <- function(input, output, session) {
reac <- reactive(list(bins = input$bins, column = input$column)) %>%
debounce_sc(5000, short_circuit = reactive(input$redraw))
# Only triggered by the debounced reactive
output$distPlot <- renderPlot({
x <- faithful[, reac()$column]
bins <- seq(min(x), max(x), length.out = reac()$bins + 1)
hist(x, breaks = bins, col = ''darkgray'', border = ''white'',
main = sprintf("Histogram of %s", reac()$column))
})
}
shinyApp(ui, server)

Versión original (pre Shiny 1.0.0)

No ha proporcionado un ejemplo reproducible, por lo que he optado por algo basado en el ejemplo fiel de Shiny que es el predeterminado en RStudio. La solución que tengo siempre tendrá un retraso de 5 segundos (configurable) entre un cambio de entrada y el gráfico que se está volviendo a dibujar. Cada cambio en la entrada restablece el temporizador. También hay un botón de redibujar para el impaciente que vuelve a dibujar el gráfico inmediatamente. Los valores del valor reactivo ''redibujado'' y las entradas se muestran en la consola cada vez que cambia una entrada o el temporizador marca. Esto debe ser eliminado para uso de producción. Esperemos que esto satisfaga sus necesidades!

library(shiny)
shinyUI(fluidPage(
titlePanel("Old Faithful Geyser Data"),
sidebarLayout(
sidebarPanel(
sliderInput("bins",
"Number of bins:",
min = 1,
max = 50,
value = 30),
selectInput("column", "Column", colnames(faithful), selected = "waiting"),
actionButton("redraw", "Redraw")
),
mainPanel(
plotOutput("distPlot")
)
)
))

servidor.R

library(shiny)
shinyServer(function(input, output, session) {
reac <- reactiveValues(redraw = TRUE, bins = isolate(input$bins), column = isolate(input$column))
# If any inputs are changed, set the redraw parameter to FALSE
observe({
input$bins
input$column
reac$redraw <- FALSE
})
# This event will also fire for any inputs, but will also fire for
# a timer and with the ''redraw now'' button.
# The net effect is that when an input is changed, a 5 second timer
# is started. This will be reset any time that a further input is
# changed. If it is allowed to lapse (or if the button is pressed)
# then the inputs are copied into the reactiveValues which in turn
# trigger the plot to be redrawn.
observe({
invalidateLater(5000, session)
input$bins
input$column
input$redraw
isolate(cat(reac$redraw, input$bins, input$column, "/n"))
if (isolate(reac$redraw)) {
reac$bins <- input$bins
reac$column <- input$column
} else {
isolate(reac$redraw <- TRUE)
}
})
# Only triggered when the copies of the inputs in reac are updated
# by the code above
output$distPlot <- renderPlot({
x <- faithful[, reac$column]
bins <- seq(min(x), max(x), length.out = reac$bins + 1)
hist(x, breaks = bins, col = ''darkgray'', border = ''white'',
main = sprintf("Histogram of %s", reac$column))
})
})