Add debounce/throttle tests, priority arg

R/reactives.R

@@ -1736,6 +1736,10 @@ isNullEvent <- function(value) {
 #' @param millis The debounce/throttle time window. You may optionally pass a
 #'   no-arg function or reactive expression instead, e.g. to let the end-user
 #'   control the time window.
+#' @param priority Debounce/throttle is implemented under the hood using
+#'   \link[=observe]{observers}. Use this parameter to set the priority of
+#'   these observers. Generally, this should be higher than the priorities of
+#'   downstream observers and outputs (which default to zero).
 #' @param domain See \link{domains}.
 #'
 #' @examples
@@ -1779,7 +1783,7 @@ isNullEvent <- function(value) {
 #' }
 #'
 #' @export
-debounce <- function(r, millis, domain = getDefaultReactiveDomain()) {
+debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
 
   # TODO: make a nice label for the observer(s)
 
@@ -1810,7 +1814,7 @@ debounce <- function(r, millis, domain = getDefaultReactiveDomain()) {
 
     # The value (or possibly millis) changed. Start or reset the timer.
     v$when <- Sys.time() + millis()/1000
-  }, label = "debounce tracker", domain = domain)
+  }, label = "debounce tracker", domain = domain, priority = priority)
 
   # This observer is the timer. It rests until v$when elapses, then touches
   # v$trigger.
@@ -1826,18 +1830,28 @@ debounce <- function(r, millis, domain = getDefaultReactiveDomain()) {
     } else {
       invalidateLater((v$when - now) * 1000)
     }
-  }, label = "debounce timer", domain = domain)
+  }, label = "debounce timer", domain = domain, priority = priority)
 
   # This is the actual reactive that is returned to the user. It returns the
   # value of r(), but only invalidates/updates when v$trigger is touched.
-  eventReactive(v$trigger, {
+  er <- eventReactive(v$trigger, {
     r()
   }, label = "debounce result", ignoreNULL = FALSE, domain = domain)
+
+  # Force the value of er to be immediately cached upon creation. It's very hard
+  # to explain why this observer is needed, but if you want to understand, try
+  # commenting it out and studying the unit test failure that results.
+  primer <- observe({
+    primer$destroy()
+    er()
+  }, label = "debounce primer", domain = domain, priority = priority)
+
+  er
 }
 
 #' @rdname debounce
 #' @export
-throttle <- function(r, millis, domain = getDefaultReactiveDomain()) {
+throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
 
   # TODO: make a nice label for the observer(s)
 
@@ -1883,7 +1897,7 @@ throttle <- function(r, millis, domain = getDefaultReactiveDomain()) {
       # period.
       trigger()
     }
-  }, label = "throttle tracker", ignoreNULL = FALSE, domain = domain)
+  }, label = "throttle tracker", ignoreNULL = FALSE, priority = priority, domain = domain)
 
   observe({
     if (!v$pending) {
@@ -1896,7 +1910,7 @@ throttle <- function(r, millis, domain = getDefaultReactiveDomain()) {
     } else {
       trigger()
     }
-  }, domain = domain)
+  }, priority = priority, domain = domain)
 
   # This is the actual reactive that is returned to the user. It returns the
   # value of r(), but only invalidates/updates when v$trigger is touched.

man/debounce.Rd

@@ -5,9 +5,9 @@
 \alias{throttle}
 \title{Slow down a reactive expression with debounce/throttle}
 \usage{
-debounce(r, millis, domain = getDefaultReactiveDomain())
+debounce(r, millis, priority = 100, domain = getDefaultReactiveDomain())
 
-throttle(r, millis, domain = getDefaultReactiveDomain())
+throttle(r, millis, priority = 100, domain = getDefaultReactiveDomain())
 }
 \arguments{
 \item{r}{A reactive expression (that invalidates too often).}
@@ -16,6 +16,11 @@ throttle(r, millis, domain = getDefaultReactiveDomain())
 no-arg function or reactive expression instead, e.g. to let the end-user
 control the time window.}
 
+\item{priority}{Debounce/throttle is implemented under the hood using
+\link[=observe]{observers}. Use this parameter to set the priority of
+these observers. Generally, this should be higher than the priorities of
+downstream observers and outputs (which default to zero).}
+
 \item{domain}{See \link{domains}.}
 }
 \description{

tests/testthat/test-reactivity.r

@@ -976,3 +976,83 @@ test_that("event handling helpers take correct dependencies", {
   expect_equal(execCount(o1), 2)
   expect_equal(execCount(o2), 2)
 })
+
+run_debounce_throttle <- function(do_priming) {
+  # The changing of rv$a will be the (chatty) source of reactivity.
+  rv <- reactiveValues(a = 0)
+
+  # This observer will be what changes rv$a.
+  src <- observe({
+    invalidateLater(100)
+    rv$a <- isolate(rv$a) + 1
+  })
+  on.exit(src$destroy(), add = TRUE)
+
+  # Make a debounced reactive to test.
+  dr <- debounce(reactive(rv$a), 500)
+
+  # Make a throttled reactive to test.
+  tr <- throttle(reactive(rv$a), 500)
+
+  # Keep track of how often dr/tr are fired
+  dr_fired <- 0
+  dr_monitor <- observeEvent(dr(), {
+    dr_fired <<- dr_fired + 1
+  })
+  on.exit(dr_monitor$destroy(), add = TRUE)
+
+  tr_fired <- 0
+  tr_monitor <- observeEvent(tr(), {
+    tr_fired <<- tr_fired + 1
+  })
+  on.exit(tr_monitor$destroy(), add = TRUE)
+
+  # Starting values are both 0. Earlier I found that the tests behaved
+  # differently if I accessed the values of dr/tr before the first call to
+  # flushReact(). That bug was fixed, but to ensure that similar bugs don't
+  # appear undetected, we run this test with and without do_priming.
+  if (do_priming) {
+    expect_identical(isolate(dr()), 0)
+    expect_identical(isolate(tr()), 0)
+  }
+
+  # Pump timer and reactives for about 1.4 seconds
+  stopAt <- Sys.time() + 1.4
+  while (Sys.time() < stopAt) {
+    timerCallbacks$executeElapsed()
+    flushReact()
+    Sys.sleep(0.001)
+  }
+
+  # dr() should not have had time to fire, other than the initial run, since
+  # there haven't been long enough gaps between invalidations.
+  expect_identical(dr_fired, 1)
+  # The value of dr() should not have updated either.
+  expect_identical(isolate(dr()), 0)
+
+  # tr() however, has had time to fire multiple times and update its value.
+  expect_identical(tr_fired, 3)
+  expect_identical(isolate(tr()), 10)
+
+  # Now let some time pass without any more updates.
+  src$destroy() # No more updates
+  stopAt <- Sys.time() + 1
+  while (Sys.time() < stopAt) {
+    timerCallbacks$executeElapsed()
+    flushReact()
+    Sys.sleep(0.001)
+  }
+
+  # dr should've fired, and we should have converged on the right answer.
+  expect_identical(dr_fired, 2)
+  isolate(expect_identical(rv$a, dr()))
+  expect_identical(tr_fired, 4)
+  isolate(expect_identical(rv$a, tr()))
+}
+
+test_that("debounce/throttle work properly (with priming)", {
+  run_debounce_throttle(TRUE)
+})
+test_that("debounce/throttle work properly (without priming)", {
+  run_debounce_throttle(FALSE)
+})