I had a similar problem as OP. I was writing a package that contained a function (tryCapture(what, args, quote)) that should wrap any other function (what), pass args to what, and capture either the result of what or any error. In either case, any warnings should also be captured. The kicker, tho, was making sure any error and warnings reported a full stack trace.
@Martin Morgan's answer proved to be what I needed to solve the problem.
Those familiar with do.call() (which wraps a function and passes a list of arguments) will note that I borrowed the parameter semantics -- i.e., what is the function to be wrapped, args is a named list of arguments, and quote determines if the arguments are quoted.
The motivation was to place tryCapture() in a script (say, foo.R) that could be called from the command line using Rscript. This way, any function would be passed to what could be executed in a non-interactive production environment knowing that all errors and warnings would be trapped in a way that the error and/or warnings and their stack traces could written to a log file or reported to a webhook or database.
Within tryCapture(what, args, quote), my approach was to wrap do.call(what, args, quote) within withCallingHandlers(). This way, the associated warning handler can add the stack trace to the $message member of any warning, save the modified warning, and resume processing. The associated error handler can add the stack trace to the $message member of any error and then throw the modified error.
By wrapping the withCallingHandlers() in a tryCatch() any error from what (now including the stack trace in the $message member of the error) can be captured and returned. Thus, the tryCatch() will return either the result of what (if there is no error) or the error generated by what, (modified to include the stack trace in the associated error message).
Finally, the result from the tryCatch() can be combined in a list with the stored warnings and the list is returned from tryCapture()
Here is the code:
tryCapture <- function(what, args = list, quote = FALSE) {
warning_list <- list()
store_warning_with_trace <- function(w) {
# the `head()` call removes four calls that represent error handling, so that
# the call list ends with the call that created the warning
calls <- head(sys.calls(), -4)
w$message <- makeConditionMessage(w$message, calls)
warning_list <<- c(warning_list, list(w))
invokeRestart("muffleWarning")
}
throw_error_with_trace <- function(e) {
# the `head()` call removes a call that represent error handling, so that
# the call list ends with the call that created the warning
calls <- head(sys.calls(), -1)
e$message <- makeConditionMessage(e$message, calls)
# raise the modified error to call the `error =` function in tryCatch()
stop(e)
}
echo_error <- function(e) e
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
list(result = result, warnings = warning_list)
}
To test the approach, we can imagine a set of dependent functions that would create a stack trace similar to OP's that might look like this:
x <- function(characters, numeric) {
y(characters, numeric)
}
y <- function(chars, nums) {
z(chars, nums)
}
z <- function(cs, n) {
as.numeric(cs) + n
}
If we call x(c("0", "1"), 2), z() should return c(2,3) with no warnings or errors.
If we call x(c("a", "1"), 2), z() should return c(NA, 3), but with a warning because as.numeric(v) will return c(NA, 1) with a warning about NA's resulting from coercion to a numeric.
If we call x(c("a", "1", "text"), z() should return first the warning regarding NA's resulting from coercion to a numeric, followed by an error because "text" can't be added to c(NA, 1)
Here is tryCapture() in action, with the three test cases described above:
> tryCapture(x, list(characters = c("0", "1"), numeric = 2))
$result
[1] 2 3
$warnings
list()
> tryCapture(x, list(characters = c("a", "1"), numeric = 2))
$result
[1] NA 3
$warnings
$warnings[[1]]
<simpleWarning in z(chars, nums): NAs introduced by coercion
Stack trace:
tryCapture(x, list(characters = c("a", "1"), numeric = 2))
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
tryCatchList(expr, classes, parentenv, handlers)
tryCatchOne(expr, names, parentenv, handlers[[1L]])
doTryCatch(return(expr), name, parentenv, handler)
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
do.call(what, args, quote)
(function(characters, numeric) {y(characters, numeric)})(characters = c("a",
"1"), numeric = 2)
y(characters, numeric)
z(chars, nums)
as.numeric(cs) + n>
> tryCapture(x, list(characters = c("a", "1"), numeric = "a"))
$result
<simpleError in as.numeric(cs) + n: non-numeric argument to binary operator
Stack trace:
tryCapture(x, list(characters = c("a", "1"), numeric = "a"))
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
tryCatchList(expr, classes, parentenv, handlers)
tryCatchOne(expr, names, parentenv, handlers[[1L]])
doTryCatch(return(expr), name, parentenv, handler)
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
do.call(what, args, quote)
(function(characters, numeric) {y(characters, numeric)})(characters = c("a",
"1"), numeric = "a")
y(characters, numeric)
z(chars, nums)
as.numeric(cs) + n>
$warnings
$warnings[[1]]
<simpleWarning in z(chars, nums): NAs introduced by coercion
Stack trace:
tryCapture(x, list(characters = c("a", "1"), numeric = "a"))
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
tryCatchList(expr, classes, parentenv, handlers)
tryCatchOne(expr, names, parentenv, handlers[[1L]])
doTryCatch(return(expr), name, parentenv, handler)
result <-
tryCatch (
withCallingHandlers(
{
do.call(what, args, quote)
},
error = throw_error_with_trace,
warning = store_warning_with_trace
),
error = echo_error
)
do.call(what, args, quote)
(function(characters, numeric) {y(characters, numeric)})(characters = c("a",
"1"), numeric = "a")
y(characters, numeric)
z(chars, nums)
as.numeric(cs) + n>
