Last active
October 20, 2021 04:54
-
-
Save jcheng5/6141ea7066e62cafb31c to your computer and use it in GitHub Desktop.
reactive debounce for Shiny
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment