In Shiny apps for R, how do I delay the firing of a reactive?
You should debounce the reactive.
There is an R implementation here:
https://gist.github.com/jcheng5/6141ea7066e62cafb31c
# Returns a reactive that debounces the given expression by the given time in
# milliseconds.
#
# This is not a true debounce in that it will not prevent \code{expr} from being
# called many times (in fact it may be called more times than usual), but
# rather, the reactive invalidation signal that is produced by expr is debounced
# instead. This means that this function should be used when \code{expr} is
# cheap but the things it will trigger (outputs and reactives that use
# \code{expr}) are expensive.
debounce <- function(expr, millis, env = parent.frame(), quoted = FALSE,
domain = getDefaultReactiveDomain()) {
force(millis)
f <- exprToFunction(expr, env, quoted)
label <- sprintf("debounce(%s)", paste(deparse(body(f)), collapse = "\n"))
v <- reactiveValues(
trigger = NULL,
when = NULL # the deadline for the timer to fire; NULL if not scheduled
)
# Responsible for tracking when f() changes.
observeEvent(f(), {
# The value changed. Start or reset the timer.
v$when <- Sys.time() + millis/1000
}, ignoreNULL = FALSE)
# This observer is the timer. It rests until v$when elapses, then touches
# v$trigger.
observe({
if (is.null(v$when))
return()
now <- Sys.time()
if (now >= v$when) {
v$trigger <- runif(1)
v$when <- NULL
} else {
invalidateLater((v$when - now) * 1000, domain)
}
})
# This is the actual reactive that is returned to the user. It returns the
# value of f(), but only invalidates/updates when v$trigger is touched.
eventReactive(v$trigger, {
f()
}, ignoreNULL = FALSE)
}
#' @examples
#' library(shiny)
#'
#' ui <- fluidPage(
#' numericInput("val", "Change this rapidly, then pause", 5),
#' textOutput("out")
#' )
#'
#' server <- function(input, output, session) {
#' debounced <- debounce(input$val, 1000)
#' output$out <- renderText(
#' debounced()
#' )
#' }
#'
#' shinyApp(ui, server)
How do I make sure that a shiny reactive plot only changes once all other reactives finish changing?
Edit 2019-02-14
Since Shiny 1.0.0 (released after I originally wrote this answer), there is now a debounce function which adds functionality to help with this kind of task. For the most part, this avoids the need for the code I originally wrote, although under the hood it works in a similar manner. However, as far as I can tell, debounce doesn't offer any way of short-circuiting the delay with a redraw action button along the lines of what I'd done here. I've therefore created a modified version of debounce that offers this functionality:
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
}
This then permits a simplified shiny application. I've switched to the single file mode of working, but the UI remains the same as the original one.
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)
Original version (pre Shiny 1.0.0)
You haven't provided a reproducible example, so I've gone with something based on the Shiny faithful example that is the default in RStudio. The solution I've got will always have a (configurable) 5 second delay between an input changing and the graph being redrawn. Each change in input resets the timer. There's also a redraw button for the impatient which redraws the graph immediately. The values of the reactive value 'redraw' and the inputs are shown in the console every time an input changes or the timer ticks. This should be removed for production use. Hopefully this meets your needs!
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")
)
)
))
server.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))
})
})
Reactive variable triggered too soon (on app start up) in Shiny Dashboard
Your example isn't reproducible because there's no code that loads your data (likely to be outside the ui and server parts). However, I think one issue is that there is no code that updates the selection input object. "renderUI" has ui elements that are typically rendered when certain conditions are met; the code in your example has no conditions attached.
Try something like the below instead of the renderUI function:
updateSelectInput(session, "camp",
choices = schoolchoices(),
selected = input$camp)
Also, if updates to your map are still happening too fast then consider use of the isolate() function within the school_choices reactive expression. You could even isolate all reactives other than an action button.
# From https://shiny.rstudio.com/articles/isolation.html
# The plot render function changes only when the "goButton" button changes, rather than every time the input slider "obs" changes
server <- function(input, output) {
output$distPlot <- renderPlot({
# Take a dependency on input$goButton
input$goButton
# Use isolate() to avoid dependency on input$obs
dist <- isolate(rnorm(input$obs))
hist(dist)
})
}
How to wait for two blocks of code to run in R Shiny
I have accomplished this before by eventObserving or eventReacting to the reactive objects or reactiveValues generated by 'code-block-a' or 'code-block-b'. I have attached 3 small shiny app examples to give insight into this approach using different methods (hopefully these will help answer the original question - or at least give some ideas).
This app will create a table in 'code-block-a' with as many rows as the sliderInput has selected. Once this 'event_a()' reactive is updated 'code-block-b' subsets one row. Once 'code-block-b' updates its object 'event_b()' a modal is displayed showing the selected row in a table.
library(shiny)
library(tidyverse)
ui <- fluidPage(
sliderInput("slide", "slide", value = 5, min = 1, max = 10),
actionButton("go", "go"),
)
server <- function(input, output, session) {
rv <- reactiveValues(tr1 = 0, el = 0)
final <- reactiveValues()
#CODE BLOCK A#
#takes slider input and makes a table with that many rows
event_a <- eventReactive(input$go,{
nums <- seq(1, input$slide, by = 1)
l <- 1:length(nums)
tibble(Letter = letters[l],
Value = nums)
})
#trigger next series of events in response to event_a()
#observeEvent(event_a(),{
# rv$el <- rv$el + 1
# })
##CODE BLOCK B##
# this will subset a row of data based on the value of the reactive
event_b <- eventReactive(event_a(), {
row <- sample(1:nrow(event_a()), 1)
event_a()[row,]
})
#look for changes in event_b() to trigger event C
#the loading of event_b will trigger the modal via rv$tr1
# observeEvent(event_b(), {
# rv$tr1 <- rv$tr1 + 1
# })
#side effect make a table from event_b() to be shown in modal
output$modal_plot <- renderTable({
event_b()
})
##CODE BLOCK C##
#launch modal showing table
observeEvent(event_b(), {
showModal(modalDialog(title = "Table",
"This is a table",
tableOutput("modal_plot"),
inline = T))
})
}
shinyApp(ui, server)
Or if all your 'code-block' are observers you can use reactive values that are updated inside of an observer. I have found this flexible if multiple things need to happen to trigger something downstream:
library(shiny)
library(tidyverse)
ui <- fluidPage(
sliderInput("slide", "slide", value = 5, min = 1, max = 10),
actionButton("go", "go"),
)
server <- function(input, output, session) {
rv <- reactiveValues(tr1 = 0, el = 0)
final <- reactiveValues()
#CODE BLOCK A#
#takes slider input and makes a table with that many rows
event_a <- eventReactive(input$go,{
nums <- seq(1, input$slide, by = 1)
l <- 1:length(nums)
tibble(Letter = letters[l],
Value = nums)
})
#trigger next series of events in response to event_a()
observeEvent(event_a(),{
rv$el <- rv$el + 1
})
##CODE BLOCK B##
# this will subset a row of data based on the value of the reactive
event_b <- eventReactive(rv$el, ignoreInit = T, {
row <- sample(1:nrow(event_a()), 1)
event_a()[row,]
})
#look for changes in event_b() to trigger event C
#the loading of event_b will trigger the modal via rv$tr1
observeEvent(event_b(), {
rv$tr1 <- rv$tr1 + 1
})
#side effect make a table from event_b() to be shown in modal
output$modal_plot <- renderTable({
event_b()
})
##CODE BLOCK C##
#launch modal showing table
observeEvent(rv$tr1, ignoreInit = T, {
showModal(modalDialog(title = "Table",
"This is a table",
tableOutput("modal_plot"),
inline = T))
})
}
shinyApp(ui, server)
Furthermore, if you are wanting something that iterates like a loop here is an example that describes the above process, but plots each row of data in a modal one row at a time and asking for user input each time:
library(shiny)
library(tidyverse)
ui <- fluidPage(
sliderInput("slide", "slide", value = 5, min = 1, max = 10),
actionButton("go", "go"),
tableOutput("df"),
tableOutput("user_choices_table")
)
server <- function(input, output, session) {
rv <- reactiveValues(tr1 = 0, el = 0)
final <- reactiveValues()
#STEP 1
#some function/series of events that gives us a some data
data1 <- eventReactive(input$go,{
c <- seq(1, input$slide, by = 1)
l <- 1:length(c)
out_table <- tibble(Letter = letters[l],
Value = c)
return(out_table)
})
#side effect - return data1 to UI
output$df <- renderTable({
data1()
})
#number of max iterations we will go though (dependent number of rows in data1)
num_iterations <- reactive({
nrow(data1())
})
#trigger next series of events in response to data1()
#this will get us from 0 to 1 and another observer will be used to add
#all the way up to the max_iterations
observeEvent(data1(),{
rv$el <- rv$el + 1
})
#this ^ observer is like entering the loop on the first iteration
##STEP 2##
##start/continue the "disjointed-loop".
#Subset data1 into smaller piece we want based on rv$el
#this will be our 'i' equivalent in for(i in ...)
#data subset
data2 <- eventReactive(rv$el, ignoreInit = TRUE, {
data2 <- data1()[rv$el,]
return(data2)
})
#side effect make a plot based on data2 to be shown in modal
output$modal_plot <- renderPlot({
d <- data2()
ggplot()+
geom_col(data = d, aes(x = Letter, y = Value, fill = Letter))+
theme_linedraw()
})
#once we get our data2 subset ask the user via modal if this is what they want
#the loading of data2 will trigger the modal via rv$tr1
observeEvent(data2(), {
rv$tr1 <- rv$tr1 + 1
})
##STEP 3##
#launch modal showing plot and ask for user input
observeEvent(rv$tr1, ignoreInit = TRUE, {
showModal(modalDialog(title = "Make a Choice!",
"Is this a good selection?",
plotOutput("modal_plot"),
checkboxGroupInput("check", "Choose:",
choices = c("Yes" = "yes",
"No" = "no"),
inline = T),
footer = actionButton("modal_submit", "Submit")))
})
#when user closes modal the response is saveed to final[[character representing number of iteration]]
observeEvent(input$modal_submit, {
final[[as.character(rv$el)]] <- input$check
if(rv$el < num_iterations()){
rv$el <- rv$el + 1 #this retriggers step2 to go again
} else {
rv$done <- rv$done + 1
} #breaks the disjointed loop and trigger start of next reactions
})
#and the modal is closed
observeEvent(input$modal_submit, {
removeModal()
})
final_choice <- eventReactive(rv$done, ignoreInit = TRUE,{
enframe(isolate(reactiveValuesToList(final))) %>%
mutate(name = as.numeric(name),
value = unlist(value)) %>%
arrange(name)
})
output$user_choices_table <- renderTable({
final_choice()
})
}
shinyApp(ui, server)
Delay on sliderinput
You can use invalidateLater. It can be done in a naive but concise way:
library(shiny)
shinyApp(
server = function(input, output, session) {
values <- reactiveValues(mean=0)
observe({
invalidateLater(3000, session)
isolate(values$mean <- input$mean)
})
output$plot <- renderPlot({
x <- rnorm(n=1000, mean=values$mean, sd=1)
plot(density(x))
})
},
ui = fluidPage(
sliderInput("mean", "Mean:", min = -5, max = 5, value = 0, step= 0.1),
plotOutput("plot")
)
)
Problem with this approach is that you can still trigger execution when changing slider input and invalidate event is fired. If thats the problem you try a little bit more complex approach where you check if values changed and how many time value has been seen.
library(shiny)
library(logging)
basicConfig()
shinyApp(
server = function(input, output, session) {
n <- 2 # How many times you have to see the value to change
interval <- 3000 # Set interval, make it large so we can see what is going on
# We need reactive only for current but it is easier to keep
# all values in one place
values <- reactiveValues(current=0, pending=0, times=0)
observe({
# Invalidate
invalidateLater(interval, session)
# Isolate so we don't trigger execution
# by changing reactive values
isolate({
m <- input$mean
# Slider value is pending and not current
if(m == values$pending && values$current != values$pending) {
# Increment counter
values$times <- values$times + 1
loginfo(paste(values$pending, "has been seen", values$times, "times"))
# We've seen value enough number of times to plot
if(values$times == n) {
loginfo(paste(values$pending, "has been seen", n, "times. Replacing current"))
values$current <- values$pending
}
} else if(m != values$pending) { # We got new pending
values$pending <- m
values$times <- 0
loginfo(paste("New pending", values$pending))
}
})
})
output$plot <- renderPlot({
x <- rnorm(n=1000, mean=values$current, sd=1)
plot(density(x))
})
},
ui = fluidPage(
sliderInput("mean", "Mean:", min = -5, max = 5, value = 0, step= 0.1),
plotOutput("plot")
)
)
Related Topics
How to Overlay an Image on to a Ggplot
Changing Styles When Selecting and Deselecting Multiple Polygons with Leaflet/Shiny
Fixing Variance Values in Lme4
How to Create a Histogram from Aggregated Data in R
How to Combine Multiple .CSV Files in R
How to Rename Element's List Indexed by a Loop in R
How to Show Every Second R Ggplot2 X-Axis Label Value
Str_Extract_All: Return All Patterns Found in String Concatenated as Vector
How to Transpose a Tibble() in R
Rbindlist Two Data.Tables Where One Has Factor and Other Has Character Type for a Column
Downloading Files from Ftp with R
Passing Arguments into Multiple Match_Fun Functions in R Fuzzyjoin::Fuzzy_Join
R Histogram with Multiple Populations
In Shiny Apps for R, How to Delay the Firing of a Reactive
Page Refresh Button in R Shiny
Fill in Na Based on the Last Non-Na Value for Each Group in R