Better handling for user-defined error conditions in debug mode

R/utils.R

@@ -743,9 +743,20 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
       error = function(e) {
         if (is.null(attr(e, "stack.trace", exact = TRUE))) {
           calls <- sys.calls()
+          reverseStack <- rev(calls)
           attr(e, "stack.trace") <- calls
-          errorCall <- e$call[[1]]
-
+
+          if (!is.null(e$call[[1]]))
+            errorCall <- e$call[[1]]
+          else {
+            # attempt to capture the error or warning if thrown by
+            # simpleError or simpleWarning (which may arise for user-defined errors)
+            #
+            # the first matching call in the reversed stack will always be
+            # getStackTrace, so we select the second match instead
+            errorCall <- reverseStack[grepl(x=reverseStack, "simpleError|simpleWarning")][[2]]
+          }
+
           functionsAsList <- lapply(calls, function(completeCall) {
             currentCall <- completeCall[[1]]
 
@@ -760,8 +771,6 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
 
           })
 
-          reverseStack <- rev(calls)
-
           if (prune_errors) {
             # this line should match the last occurrence of the function
             # which raised the error within the call stack; prune here
@@ -779,14 +788,18 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
               # to stop at the correct position.
               if (is.function(currentCall[[1]])) {
                 identical(deparse(errorCall), deparse(currentCall[[1]]))
-              } else {
+              } else if (currentCall[[1]] == "stop") {
+                # handle case where function developer deliberately invokes a stop
+                # condition and halts function execution
+                identical(deparse(errorCall), deparse(currentCall))
+                }
+              else {
                 FALSE
               }
 
               }
               )
             )
-
             # the position to stop at is one less than the difference
             # between the total number of calls and the index of the
             # call throwing the error
@@ -797,12 +810,14 @@ getStackTrace <- function(expr, debug = FALSE, prune_errors = TRUE) {
             functionsAsList <- removeHandlers(functionsAsList)
           }
 
+          # use deparse in case the call throwing the error is a symbol,
+          # since this cannot be "printed" without deparsing the call
           warning(call. = FALSE, immediate. = TRUE, sprintf("Execution error in %s: %s", 
-                                                            functionsAsList[[length(functionsAsList)]], 
+                                                            deparse(functionsAsList[[length(functionsAsList)]]), 
                                                             conditionMessage(e)))
 
           stack_message <- stackTraceToHTML(functionsAsList,
-                                            functionsAsList[[length(functionsAsList)]],
+                                            deparse(functionsAsList[[length(functionsAsList)]]),
                                             conditionMessage(e))
 
           assign("stack_message", value=stack_message, 

tests/integration/callbacks/test_handle_stop.py

@@ -0,0 +1,46 @@
+from selenium.webdriver.support.select import Select
+
+app = """
+library(dash)
+library(dashHtmlComponents)
+library(dashCoreComponents)
+
+app <- Dash$new()
+
+app$layout(
+  htmlDiv(
+    list(
+      dccDropdown(options = list(
+        list(label = "Red", value = "#FF0000"),
+        list(label = "Throw error", value = "error")
+      ),
+      id = "input-choice",
+      value = "error"),
+      htmlDiv(id="div-choice")
+    )
+  )
+)
+
+app$callback(output(id = 'div-choice', property = 'children'),
+             list(input(id = 'input-choice', property = 'value')),
+             function(choice) {
+               if (choice == "error") {
+                 stop(simpleError("Throwing an error by request"))
+                 }
+               if (!is.null(unlist(choice))) {
+                 return(sprintf("Choice was %s", choice))
+                 } else {
+                   return(sprintf("Make a choice"))
+                   }
+               })
+
+app$run_server(debug=TRUE)
+"""
+
+
+def test_rshs001_handle_stop(dashr):
+    dashr.start_server(app)
+    dashr.wait_for_text_to_equal(
+        ".dash-fe-error__title",
+        "Callback error updating div-choice.children"
+    )