Add traceback support in log_errors

* Add traceback support in log_errors
* add news bullet
* avoid formatting traceback calls
* Add coverage of adding srcref info to traceback
* lint break long line

---------

Co-authored-by: Gergely Daroczi (@daroczig) <daroczig@rapporter.net>

Author: thomasp85

NEWS.md

@@ -16,6 +16,7 @@ improved documentations, modernized tests, performance speedups.
 * `log_appender()`, `log_layout()` and `log_formatter()` now check that you are calling them with a function, and return the previously set value (#170, @hadley)
 * new function to return number of log indices (#194, @WurmPeter)
 * `appender_async` is now using `mirai` instead of a custom background process and queue system (#214, @hadley @shikokuchuo)
+* `log_errors()` gains a `traceback` argument that toggles whether the error traceback should be logged along with the message (#86, @thomasp85)
 
 ## Fixes
 

R/hooks.R

@@ -58,19 +58,20 @@ log_warnings <- function(muffle = getOption("logger_muffle_warnings", FALSE)) {
   }
 }
 
-
 #' Injects a logger call to standard errors
 #'
 #' This function uses [trace()] to add a [log_error()] function call when
 #' [stop()] is called to log the error messages with the `logger` layout
 #' and appender.
 #' @param muffle if TRUE, the error is not thrown after being logged
+#' @param traceback if TRUE the error traceback is logged along with the error
+#' message
 #' @export
 #' @examples \dontrun{
 #' log_errors()
 #' stop("foobar")
 #' }
-log_errors <- function(muffle = getOption("logger_muffle_errors", FALSE)) {
+log_errors <- function(muffle = getOption("logger_muffle_errors", FALSE), traceback = FALSE) {
   if (any(sapply(
     globalCallingHandlers()[names(globalCallingHandlers()) == "error"],
     attr,
@@ -81,6 +82,21 @@ log_errors <- function(muffle = getOption("logger_muffle_errors", FALSE)) {
     globalCallingHandlers(
       error = structure(function(m) {
         logger::log_level(logger::ERROR, m$message, .topcall = m$call)
+        if (traceback) {
+          bt <- .traceback(3L)
+          logger::log_level(logger::ERROR, "Traceback:", .topcall = m$call)
+          for (i in seq_along(bt)) {
+            msg <- paste0(length(bt) - i + 1L, ": ", bt[[i]])
+            ref <- attr(bt[[i]], "srcref")
+            file <- attr(ref, "srcfile")
+            if (inherits(file, "srcfile")) {
+              file <- basename(file$filename)
+              line <- paste(unique(c(ref[1L], ref[3L])), collapse = "-")
+              msg <- paste0(msg, " at ", file, " #", line)
+            }
+            logger::log_level(logger::ERROR, skip_formatter(msg), .topcall = m$call)
+          }
+        }
         if (isTRUE(muffle)) {
           invokeRestart("abort")
         }

man/log_errors.Rd

@@ -27,6 +27,14 @@
       writeLines(eval_outside("log_errors()", "f<-function(x) {42 * \"foobar\"}; f()"))
     Output
       ERROR non-numeric argument to binary operator
+    Code
+      writeLines(eval_outside("log_errors(traceback = TRUE)",
+        "source(\"helper.R\", keep.source = TRUE)", "function_that_fails()"))
+    Output
+      ERROR I'm failing
+      ERROR Traceback:
+      ERROR 2: stop("I'm failing") at helper.R #46
+      ERROR 1: function_that_fails()
 
 # shiny input initialization is detected
 

tests/testthat/_snaps/hooks.md

@@ -40,3 +40,8 @@ eval_outside <- function(...) {
   suppressWarnings(system2(path, input, stdout = TRUE, stderr = TRUE))
   readLines(output)
 }
+
+# This function is needed to test traceback logging
+function_that_fails <- function() {
+  stop("I'm failing")
+}

tests/testthat/helper.R

@@ -15,6 +15,9 @@ test_that("log_errors", {
     writeLines(eval_outside("log_errors()", "stop(42)"))
     writeLines(eval_outside("log_errors()", "foobar"))
     writeLines(eval_outside("log_errors()", 'f<-function(x) {42 * "foobar"}; f()'))
+    writeLines(eval_outside("log_errors(traceback = TRUE)",
+                            'source("helper.R", keep.source = TRUE)',
+                            "function_that_fails()"))
   })
 })