Conditional Debounce - Githubissues

Hey,

I was about to submit a pull request on this, however I wasn't able to get Rtools running so I couldn't check for any new messages, warnings and errors as requested in CONTRIBUTING.md. Furthermore I do not know how to properly execute a unit test as I have never done something similar. Instead I'll just post my problem and the solution I came up with here and let you decided whether this might be a valuable addition for Shiny.

Problem: In the most simple configuration the app may consist of two sliders:

An independent slider which can only be changed by the user directly and is always debounced
Another slider which can be changed either by the user directly or due to a call of updateSliderInput()

The second slider however should only be debounced if the change is triggered by the user directly, hence the name conditional debounce On the other hand a change due to a call of updateSliderInput() should not be debounced to prevent the app from debouncing twice.

Solution: To achieve the intended behavior I introduced a global logical variable updated_by_user and altered the already existing debounce() function leading to a new function debounce_if(). The code block below highlights the changes of debounce_if() relative to debounce().

- debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomain()) {
+ debounce_if <- function (r, test, millis_TRUE, millis_FALSE = 0, priority = 100, domain = getDefaultReactiveDomain()) {

  # TODO: make a nice label for the observer(s)

  force(r)
-  force(millis)
+  force(millis_TRUE)
+  force(millis_FALSE)
+  force(test)

-  if (!is.function(millis)) {
-    origMillis <- millis
-    millis <- function() origMillis
+  # Get the name of `test` as from the caller's perspective as a string.
+  # (The formal parameter `test` bound by `environment()` will be substituted by the actual parameter.)
+  testVarName <- deparse(substitute(test, environment()))
+
+  # Check whether the actual parameter of `test` is defined in the global envirmen. If not, do so.
+  if (!(testVarName %in% ls(.GlobalEnv))) {
+    assign(testVarName, test, envir = .GlobalEnv)
+  }
+
+  # Make sure that `millis_TRUE` is of type function.
+  if (!is.function(millis_TRUE)) {
+    origMillis1 <- millis_TRUE
+    millis_TRUE <- function() origMillis1
+  }
+
+  # Make sure that `millis_FALSE` is of type function.
+  if (!is.function(millis_FALSE)) {
+    origMillis2 <- millis_FALSE
+    millis_FALSE <- function() origMillis2
  }

  v <- reactiveValues(
    trigger = NULL,
    when = NULL # the deadline for the timer to fire; NULL if not scheduled
  )
  # Responsible for tracking when r() changes.
  firstRun <- TRUE
  observe({
    if (firstRun) {
      # During the first run we don't want to set v$when, as this will kick off
      # the timer. We only want to do that when we see r() change.
      firstRun <<- FALSE
      # Ensure r() is called only after setting firstRun to FALSE since r()
      # may throw an error
      r()
      return()
    }
    # This ensures r() is still tracked after firstRun
    r()

+    # Make sure to get the latest value set for the actual parameter for `test`.
+    # This can be considered as an update of `test` on an invalidation of the reactive `r`.
+    assign("test", get(testVarName), envir = parent.env(environment()))
+
    # The value (or possibly millis) changed. Start or reset the timer.
-    v$when <- getDomainTimeMs(domain) + millis()
+    if (test) {
+      v$when <- getDomainTimeMs(domain) + millis_TRUE()
+    }
+    else {
+      v$when <- getDomainTimeMs(domain) + millis_FALSE()
+    }
  }, label = "debounce tracker", domain = domain, priority = priority)

  # This observer is the timer. It rests until v$when elapses, then touches
  # v$trigger.
  observe({
    if (is.null(v$when))
      return()

    now <- getDomainTimeMs(domain)
    if (now >= v$when) {
      # Mod by 999999999 to get predictable overflow behavior
      v$trigger <- isolate(v$trigger %OR% 0) %% 999999999 + 1
      v$when <- NULL
    } else {
      invalidateLater(v$when - now)
    }
  }, 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.
  er <- eventReactive(v$trigger, {
+    assign(testVarName, TRUE, envir = .GlobalEnv)
+    assign("test", get(testVarName), envir = parent.env(environment()))
    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

Note that in the current configuration the global logical variable updated_by_user is changed to TRUE within debounce_if().

This diagram displays the intended behavior of the sliders (the yellow cursor marks direct user actions) alt text

Following the diagram I use the debounce_if() function as follows within the server() function:

server <- function(input, output, session) {
    assign("update_by_user", FALSE, envir = .GlobalEnv)
    slider1 <- eventReactive(input$bins, {

        update_necc <- ...

        if (update_necc) {
            assign("update_by_user", FALSE, envir = .GlobalEnv)
            updateSliderInput(session, inputId = "number",
                              value =  sample(1:50, 1))
        }
        input$bins
    }) %>% debounce(2000)

    slider2 <- eventReactive(input$number, {
        input$number
    }) %>% debounce_if(update_by_user, 2000, 0)

    ...

}

I highly appreciate any comment on this issue and the solution I came up with.

Best regards

rstudio / shiny

Conditional Debounce #3013