From 9a35b01e23fe9e95e69aeb3624554b58c7a2b74f Mon Sep 17 00:00:00 2001
From: Joe Cheng <joe@posit.co>
Date: Mon, 9 Dec 2024 20:50:53 -0800
Subject: [PATCH] Fix observeEvent stack trace stripping (#4163)

* Fix observeEvent stack trace stripping

* Add unit test

* Add deep stack version of unit test
---
 NEWS.md                      |  2 ++
 R/reactives.R                |  2 +-
 tests/testthat/test-stacks.R | 51 ++++++++++++++++++++++++++++++++++++
 3 files changed, 54 insertions(+), 1 deletion(-)

diff --git a/NEWS.md b/NEWS.md
index fad3261d8..93bab763a 100644
--- a/NEWS.md
+++ b/NEWS.md
@@ -26,6 +26,8 @@
 
 * Updating the choices of a `selectizeInput()` via `updateSelectizeInput()` with `server = TRUE` no longer retains the selected choice as a deselected option if the current value is not part of the new choices. (@dvg-p4 #4142)
 
+* Fixed a bug where stack traces from `observeEvent` were being stripped of stack frames too aggressively.
+
 # shiny 1.9.1
 
 ## Bug fixes
diff --git a/R/reactives.R b/R/reactives.R
index 6342ba957..a5f7772b6 100644
--- a/R/reactives.R
+++ b/R/reactives.R
@@ -2304,7 +2304,7 @@ observeEvent <- function(eventExpr, handlerExpr,
     priority = priority,
     domain = domain,
     autoDestroy = TRUE,
-    ..stacktraceon = FALSE # TODO: Does this go in the bindEvent?
+    ..stacktraceon = TRUE
   ))
 
   o <- inject(bindEvent(
diff --git a/tests/testthat/test-stacks.R b/tests/testthat/test-stacks.R
index 4e77bbec3..c3adc4779 100644
--- a/tests/testthat/test-stacks.R
+++ b/tests/testthat/test-stacks.R
@@ -206,6 +206,57 @@ test_that("validation error logging", {
   captureErrorLog(validate("boom"))
   expect_null(caught)
 
+  caught <- NULL
   captureErrorLog(stop("boom"))
   expect_true(!is.null(caught))
 })
+
+test_that("observeEvent is not overly stripped (#4162)", {
+  caught <- NULL
+  ..stacktraceoff..(
+    ..stacktracefloor..({
+      observeEvent(1, {
+        tryCatch(
+          captureStackTraces(stop("boom")),
+          error = function(cond) {
+            caught <<- cond
+          }
+        )
+      })
+      flushReact()
+    })
+  )
+  st_str <- capture.output(printStackTrace(caught), type = "message")
+  expect_true(any(grepl("observeEvent\\(1\\)", st_str)))
+
+  # Now same thing, but deep stack trace version
+
+  A__ <- function() {
+    promises::then(promises::promise_resolve(TRUE), ~{
+      stop("boom")
+    })
+  }
+
+  B__ <- function() {
+    promises::then(promises::promise_resolve(TRUE), ~{
+      A__()
+    })
+  }
+
+  caught <- NULL
+  ..stacktraceoff..(
+    ..stacktracefloor..({
+      observeEvent(1, {
+        captureStackTraces(promises::catch(B__(), ~{
+          caught <<- .
+        }))
+      })
+      flushReact()
+      wait_for_it()
+    })
+  )
+  st_str <- capture.output(printStackTrace(caught), type = "message")
+  # cat(st_str, sep = "\n")
+  expect_true(any(grepl("A__", st_str)))
+  expect_true(any(grepl("B__", st_str)))
+})