Merge branch 'main' into rc-v1.7.2

Author: cpsievert

NEWS.md

@@ -23,6 +23,10 @@ shiny 1.7.2
 
 ### Bug fixes
 
+* Closed #3250:`{rlang}`/`{tidyeval}` conditions (i.e., warnings and errors) are no longer filtered from stack traces. (#3602)
+
+* Closed #3581: Errors in throttled/debounced reactive expressions no longer cause the session to exit. (#3624)
+
 * The auto-reload feature (`options(shiny.autoreload=TRUE)`) was not being activated by `devmode(TRUE)`, despite a console message asserting that it was. (#3620)
 
 * Closed #2297: If an error occurred in parsing a value in a bookmark query string, an error would be thrown and nothing would be restored. Now a message is displayed and that value is ignored. (Thanks to @daattali, #3385)
@@ -43,7 +47,6 @@ shiny 1.7.2
 
 * HTML dependencies that are sent to dynamic UI now have better type checking, and no longer require a `dep.src.href` field. (#3537)
 
-
 shiny 1.7.1
 ===========
 

R/conditions.R

@@ -421,8 +421,17 @@ pruneStackTrace <- function(parents) {
   # Loop over the parent indices. Anything that is not parented by current_node
   # (a.k.a. last-known-good node), or is a dupe, can be discarded. Anything that
   # is kept becomes the new current_node.
+  #
+  # jcheng 2022-03-18: Two more reasons a node can be kept:
+  #   1. parent is 0
+  #   2. parent is i
+  # Not sure why either of these situations happen, but they're common when
+  # interacting with rlang/dplyr errors. See issue rstudio/shiny#3250 for repro
+  # cases.
   include <- vapply(seq_along(parents), function(i) {
-    if (!is_dupe[[i]] && parents[[i]] == current_node) {
+    if ((!is_dupe[[i]] && parents[[i]] == current_node) ||
+        parents[[i]] == 0 ||
+        parents[[i]] == i) {
       current_node <<- i
       TRUE
     } else {

R/reactives.R

@@ -2472,11 +2472,11 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
 
       # Ensure r() is called only after setting firstRun to FALSE since r()
       # may throw an error
-      r()
+      try(r(), silent = TRUE)
       return()
     }
     # This ensures r() is still tracked after firstRun
-    r()
+    try(r(), silent = TRUE)
 
     # The value (or possibly millis) changed. Start or reset the timer.
     v$when <- getDomainTimeMs(domain) + millis()
@@ -2509,7 +2509,7 @@ debounce <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
   # commenting it out and studying the unit test failure that results.
   primer <- observe({
     primer$destroy()
-    er()
+    try(er(), silent = TRUE)
   }, label = "debounce primer", domain = domain, priority = priority)
 
   er
@@ -2551,7 +2551,7 @@ throttle <- function(r, millis, priority = 100, domain = getDefaultReactiveDomai
   }
 
   # Responsible for tracking when f() changes.
-  observeEvent(r(), {
+  observeEvent(try(r(), silent = TRUE), {
     if (v$pending) {
       # In a blackout period and someone already scheduled; do nothing
     } else if (blackoutMillisLeft() > 0) {

tests/testthat/test-reactives.R

@@ -13,3 +13,28 @@ test_that("can access reactive values directly", {
   y <- reactive(x1() + x2$a)
   expect_equal(y(), 4)
 })
+
+test_that("errors in throttled/debounced reactives are catchable", {
+  reactiveConsole(TRUE)
+  on.exit(reactiveConsole(FALSE))
+
+  # In Shiny 1.7 and earlier, if a throttled/debounced reactive threw an error,
+  # it would cause internal observers used by the implementations of
+  # debounce/throttle to error, which would kill the session. The correct
+  # behavior is to only expose the error to consumers of the throttled/debounced
+  # reactive.
+
+  r <- reactive({
+    stop("boom")
+  })
+
+  rd <- r %>% debounce(1000)
+  rt <- r %>% throttle(1000)
+
+  observe({
+    try(rd(), silent = TRUE)
+    try(rt(), silent = TRUE)
+  })
+
+  expect_silent(flushReact())
+})

tests/testthat/test-stacks-pruning.R

@@ -1,30 +1,33 @@
-capture <- function() {
-  list(
-    calls = sys.calls(),
-    parents = sys.parents()
-  )
-}
+foo <- function() {
+  capture <- function() {
+    list(
+      calls = sys.calls(),
+      parents = sys.parents()
+    )
+  }
 
-capture_1 <- function() {
-  capture()
-}
+  capture_1 <- function() {
+    capture()
+  }
 
-capture_2 <- function() {
-  capture_1()
-}
+  capture_2 <- function() {
+    capture_1()
+  }
 
-res <- do.call(
-  identity,
-  list(
-    identity(capture_2())
+  do.call(
+    identity,
+    list(
+      identity(capture_2())
+    )
   )
-)
-res$calls <- tail(res$calls, 5)
-res$parents <- tail(res$parents - (length(res$parents) - 5), 5)
+}
+res <- foo()
+res$calls <- tail(res$calls, 6)
+res$parents <- tail(res$parents - (length(res$parents) - 6), 6)
 
 describe("stack pruning", {
   it("passes basic example", {
-    expect_equal(pruneStackTrace(res$parents), c(F, F, T, T, T))
-    expect_equal(lapply(list(res$parents), pruneStackTrace), list(c(F, F, T, T, T)))
+    expect_equal(pruneStackTrace(res$parents), c(T, F, F, T, T, T))
+    expect_equal(lapply(list(res$parents), pruneStackTrace), list(c(T, F, F, T, T, T)))
   })
 })