• context of evaluating expr: I believe quote(eval(expr, envir = parentenv)) is sufficient for ensuring no surprises with namespace and search path, am I missing something?

• context of the error: it would be ideal if traceback() of a not-caught error did not originate in myerror, is there a better way to re-throw the error with (or closer to) the original stack?

• similarly handle warnings: I have another version of this that adds warnings in the same way, so it uses withCallingHandlers and conditional use of invokeRestart("muffleWarning"). The premise is that some warnings I don't care about (I might otherwise use suppressWarnings), some I want to log, and some indicate problems (that could also turn into errors with options(warn=2)). In developing shiny apps, I often use something like this (with a logger::log_* call instead of cat):

  withCallingHandlers({
    warning("foo")
    99
  }, warning = function(w) {
    cat("caught:", conditionMessage(w), "\n")
    invokeRestart("muffleWarning")
  })
  # caught: foo 
  # [1] 99
  

  where it might be nice to "muffle" some warnings and not others. warning typically includes where the warning originated. Similar to the previous bullet, is there a way with warning to use the original context?

• assumptions: am I making an egregious false assumption in the code?

• context of evaluating expr: I believe quote(eval(expr, envir = parentenv)) is sufficient for ensuring no surprises with namespace and search path, am I missing something?

• context of the error: it would be ideal if traceback() of a not-caught error did not originate in myerror, is there a better way to re-throw the error with (or closer to) the original stack?

• similarly handle warnings: I have another version of this that adds warnings in the same way, so it uses withCallingHandlers and conditional use of invokeRestart("muffleWarning"). The premise is that some warnings I don't care about (I might otherwise use suppressWarnings), some I want to log, and some indicate problems (that could also turn into errors with options(warn=2)). In developing shiny apps, I often use something like this (with a logger::log_* call instead of cat):

  withCallingHandlers({
    warning("foo")
    99
  }, warning = function(w) {
    cat("caught:", conditionMessage(w), "\n")
    invokeRestart("muffleWarning")
  })
  # caught: foo 
  # [1] 99
  

  where it might be nice to "muffle" some warnings and not others. warning typically includes where the warning originated. Similar to the previous bullet, is there a way with warning to preserve (re-use) the original context?

• assumptions: am I making an egregious false assumption in the code?

#' Pattern-matching tryCatch
#'
#' Catch only specific types of errors at the appropriate level.
#' Supports nested use, where errors not matched by inner calls will
#' be passed to outer calls that may (or may not) catch them
#' separately. If no matches found, the error is re-thrown.
#'
#' @param expr expression to be evaluated
#' @param ... named functions, where the name is the regular
#'   expression to match the error against, and the function accepts a
#'   single argument, the error
#' @param finally expression to be evaluated before returning or
#'   exiting
#' @param perl logical, should Perl-compatible regexps be used?
#' @param fixed logical, if 'TRUE', the pattern (name of each handler
#'   argument) is a string to be matched as is
#' @return if no errors, the return value from 'expr'; if an error is
#'   matched by one of the handlers, the return value from that
#'   function; if no matches, the error is propogated up
#' @export
#' @examples
#' 
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("no-math-nearby, hello")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L })
#' # in inner
#' # [1] -1
#'
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("oops")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L })
#' # in outer
#' # [1] -2
#'
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("neither")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L })
#' # Error in eval(expr, envir = parentenv) : neither
#' 
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("neither")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L },
#'    "."    = function(e) { cat("in catch-all\n"); -3L })
#' # in catch-all
#' # [1] -3
#' 
tryCatchPatterns <- function(expr, ..., finally, perl = FALSE, fixed = FALSE) {
  parentenv <- parent.frame()
  handlers <- list(...)

  # ---------------------------------
  # check all handlers are correct
  if (length(handlers) > 0L &&
        (is.null(names(handlers)) || any(!nzchar(names(handlers)))))
    stop("all error handlers must be named")
  if (!all(sapply(handlers, is.function)))
    stop("all error handlers must be functions")

  # ---------------------------------
  # custom error-handler that references 'handlers'
  myerror <- function(e) {
    msg <- conditionMessage(e)
    handled <- FALSE
    for (hndlr in names(handlers)) {
      # can use ptn of "." for catch-all
      if (grepl(hndlr, msg, perl = perl, fixed = fixed)) {
        out <- handlers[[hndlr]](e)
        handled <- TRUE
        break
      }
    }
    if (handled) out else stop(e)
  }

  # ---------------------------------
  # quote some expressions to prevent too-early evaluation
  expr_q <- quote(eval(expr, envir = parentenv))
  finally_q <- if (!missing(finally)) quote(finally)
  tc_args <- list(error = myerror, finally = finally_q)

  # ---------------------------------
  # evaluate!
  do.call("tryCatch", c(list(expr_q), tc_args))
}

#' Pattern-matching tryCatch
#'
#' Catch only specific types of errors at the appropriate level.
#' Supports nested use, where errors not matched by inner calls will
#' be passed to outer calls that may (or may not) catch them
#' separately. If no matches found, the error is re-thrown.
#'
#' @param expr expression to be evaluated
#' @param ... named functions, where the name is the regular
#'   expression to match the error against, and the function accepts a
#'   single argument, the error
#' @param finally expression to be evaluated before returning or
#'   exiting
#' @param perl logical, should Perl-compatible regexps be used?
#' @param fixed logical, if 'TRUE', the pattern (name of each handler
#'   argument) is a string to be matched as is
#' @return if no errors, the return value from 'expr'; if an error is
#'   matched by one of the handlers, the return value from that
#'   function; if no matches, the error is propogated up
#' @export
#' @examples
#' 
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("no-math-nearby, hello")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L })
#' # in inner
#' # [1] -1
#'
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("oops")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L })
#' # in outer
#' # [1] -2
#'
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("neither")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L },
#'    "."    = function(e) { cat("in catch-all\n"); -3L })
#' # in catch-all
#' # [1] -3
#' 
#' \dontrun{
#' tryCatchPatterns({
#'   tryCatchPatterns({
#'     stop("neither")
#'     99
#'   }, "^no-math" = function(e) { cat("in inner\n"); -1L })
#' }, "oops" = function(e) { cat("in outer\n"); -2L })
#' # Error in eval(expr, envir = parentenv) : neither
#' }
#' 
tryCatchPatterns <- function(expr, ..., finally, perl = FALSE, fixed = FALSE) {
  parentenv <- parent.frame()
  handlers <- list(...)

  # ---------------------------------
  # check all handlers are correct
  if (length(handlers) > 0L &&
        (is.null(names(handlers)) || any(!nzchar(names(handlers)))))
    stop("all error handlers must be named")
  if (!all(sapply(handlers, is.function)))
    stop("all error handlers must be functions")

  # ---------------------------------
  # custom error-handler that references 'handlers'
  myerror <- function(e) {
    msg <- conditionMessage(e)
    handled <- FALSE
    for (hndlr in names(handlers)) {
      # can use ptn of "." for catch-all
      if (grepl(hndlr, msg, perl = perl, fixed = fixed)) {
        out <- handlers[[hndlr]](e)
        handled <- TRUE
        break
      }
    }
    if (handled) out else stop(e)
  }

  # ---------------------------------
  # quote some expressions to prevent too-early evaluation
  expr_q <- quote(eval(expr, envir = parentenv))
  finally_q <- if (!missing(finally)) quote(finally)
  tc_args <- list(error = myerror, finally = finally_q)

  # ---------------------------------
  # evaluate!
  do.call("tryCatch", c(list(expr_q), tc_args))
}