exception handling by pattern (or sub-class)

tryCatchPatterns.R

#' 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.
#'
#' @details
#'
#' Exception handling with a little finer control over *where* a
#' particular error is caught and handled.
#'
#' Special patterns exist to solicit specific behavior. Because
#' patterns are regexes, some specials are otherwise impossible
#' patterns, ending with the literal '^', ensuring they should never
#' conflict with actual patterns.
#'
#' Specials for 'warning':
#'
#' - 'always^' will always fire; it does *not* trigger the '.warning1'
#'   break, so is useful for one handler that must always be done
#'   (such as logging);
#'
#' - '.*' will match everything (even the empty string), intended if
#'   a literal catch-all is needed.
#'
#' - '$subclass' matches sub-classes of errors
#'
#' Specials in 'error':
#'
#' - 'always^' will always fire; it does *not* preclude testing
#'   remaining error handlers (the default behavior is to exit after
#'   the first match), so is useful for one handler that must always
#'   be done (such as logging);
#' 
#' - '.*' will match everything (event the empty string), intended if
#'   a literal catch-all is needed.
#'
#' - '$subclass' matches sub-classes of errors
#' 
#' Sub-classed conditions, while rare, might originate from something
#' like:
#'
#' ```r
#' os_error = function (message, call = NULL) {
#'   class = c('os_error', 'simpleError', 'error', 'condition')
#'   stop(structure(list(message = message, call = call), class = class))
#' }
#' os_error("did not find it")
#' ```
#'
#' While this is mostly a proof-of-concept, classes of errors such as
#' this can be caught much more simply by an additional special class,
#' the class name preceded by a '$', such as:
#'
#' ```r
#' tryCatch(
#'   { expr; },
#'   errors = list( "$os_error" = function(e) NULL )
#' )
#' ```
#'
#' @section Order of Handlers:
#'
#' The order of handlers is neither checked nor adjusted, so it is
#' feasible to have handlers that may never fire. This is the case
#' either for progressive regexp patterns (e.g., '.*' and then
#' '^something') as well as for specials (e.g., 'always^' after
#' something else). The only time having 'always^' *after* others
#' guarantees firing is when '.warning1' is false, thereby ensuring
#' all warning handlers are checked.
#'
#' With this, it would seem logical to put 'always^' (if included) as
#' the first handler, or the first handler after *filtering* handlers
#' (that you want muffled with no effect).
#'
#' When both generic handlers (within '...') and specific handlers
#' (with 'warnings' and/or 'errors') are provided, the generic
#' handlers are *appended* to the list of specific handlers, but this
#' can be controlled: if there is a singleton 'NA' in the specific
#' list, the generic handlers will be placed at that position within
#' the specific list.
#'
#' For example:
#'
#' ```r
#' tryCatchPatterns(
#'   { expr; },
#'   "^ptn1" = function(z) {},
#'   "^ptn2" = functino(z) {},
#'   warnings = list(
#'     "always^" = function(z) logger::log_warn(z),
#'     NA,
#'     "^ptn3" = function(z) {}
#'   )
#' )
#' ```
#'
#' will result in warning handlers of: 'always^', '^ptn1', '^ptn2',
#' and '^ptn3' (in that order). One can easily force prepending with
#' 'warnings=list(NA,...)'. (Similarly for 'errors'.)
#' 
#' @section Nesting:
#'
#' This function works just as well when nested within itself. For
#' example, one layer might handle one type of error and, given an
#' error it does not know about, "punt" the error up the call stack.
#' If there is an instance of this function higher in the stack that
#' is prepared to catch this other type of error, it will get the
#' chance. If no instance of 'tryCatchPatterns' catches the particular
#' error, then the 'stop' terminates the running code.
#'
#' @section Usage-Patterns:
#'
#' It might be suggested that types (and order) of handlers can
#' solicit specific behavior.
#'
#' In this example, the first warnings handler using a
#' "special pattern" will always initiate some form of logging ('cat'
#' here), and then the follow-on match does nothing (ignores/muffles
#' the warning). In this model, the usage-pattern is to log-first
#' ("always^"), ignore known warnings with empty functions, everything
#' else propogates.
#'
#' ```
#' tryCatchPatterns(
#'   { warning("ptn2"); 1;  },
#'   warnings = list(
#'     'always^' = function(w) { cat("found some warning:", sQuote(w), "\n") },
#'     '^ptn1' = function(w) { cat("ptn1\n") },
#'     '^ptn2' = function(w) { }
#'   )
#' )
#' ```
#'
#' Other usage-patterns will be added as they come to light :-)
#' 
#' @param expr expression to be evaluated in the
#'   warning/error-catching context
#' @param ... zero or more named handlers to apply to *both* warnings
#'   and errors; the name is a regex pattern to match against the
#'   warning or error text; any return value from these handlers is
#'   returned by errors and ignored by warnings
#' @param warnings named list of handlers to be applied only to
#'   warnings; if 'NULL', then warnings will not be caught/muffled
#' @param errors named list of handlers to be applied only to errors;
#'   if 'NULL', then errors will not be caught
#' @param finally expression to be executed at the end of the
#'   'tryCatch' execution
#' @param .warning1 logical, whether to check all warning handlers or
#'   stop on the first match (note: the special pattern 'always^' will
#'   not preclude checking follow-on handlers)
#' @param perl logical, passed to 'grepl' for pattern matching
#' @param fixed logical, passed to 'grepl' for pattern matching
#' @return
#' @export
#' @md
#' @examples
#'
#' ### 'always^' is not reached because '.warning1' is true and '^f'
#' ### is found first
#' tryCatchPatterns({
#'   stop("foo")
#'   99
#' },
#'   "^f"      = function(e) { cat("in '^f'\n"); -1L  },
#'   "o$"      = function(e) { cat("in 'o$'\n"); -2L  },
#'   warnings  = list('always^' = function(w) { cat("in warning\n");   })
#' )
#' # in '^f'
#' # [1] -1
#'
#' ### 'always^' is first, then '^f', nothing more because '.warning1'
#' ### is true
#' tryCatchPatterns({
#'   warning("foo")
#'   99
#' },
#'   warnings  = list(
#'     'always^' = function(w) { cat("in warning\n"); },
#'     "^f"      = function(e) { cat("in '^f'\n"); -1L  },
#'     "o$"      = function(e) { cat("in 'o$'\n"); -2L  }
#'   )
#' )
#' # in warning
#' # in '^f'
#' # [1] 99
#'
#' ### similar, but now we see 'o$' because of '.warning1' being false
#' tryCatchPatterns({
#'   warning("foo")
#'   99
#' },
#'   warnings  = list(
#'     'always^' = function(w) { cat("in warning\n"); },
#'     "^f"      = function(e) { cat("in '^f'\n"); -1L  },
#'     "o$"      = function(e) { cat("in 'o$'\n"); -2L  }
#'   ),
#'   .warning1 = FALSE
#' )
#' # in warning
#' # in '^f'
#' # in 'o$'
#' # [1] 99
#'
#'
#' \dontrun{
#' 
#'   # skip/ignore "foo" completely, log some others (including "bar"),
#'   # but do not muffle the warning "bar"
#'   tryCatchPatterns(
#'     { warning("foo"); warning("bar"); 99; },
#'     warnings = list(
#'       "^foo"    = function(z) {},
#'       "always^" = function(z) { cat("logging:", z, "\n"); },
#'       "o$" = function(z) { cat("do something\n"); }
#'     )
#'   )
#'   # logging: bar 
#'   # Warning in withCallingHandlers(expr = { : bar
#'   # [1] 99
#'
#' }
#' 
#' # this demonstrates that with errors, 'always^' does not stop
#' # checking handlers
#' tryCatchPatterns(
#'   { stop("foo"); 99 },
#'   errors = list(
#'     'always^' = function(e) { cat("in always\n"); -1L },
#'     'bar'     = function(e) { cat("in bar\n")   ; -2L },
#'     'foo'     = function(e) { cat("in foo\n")   ; -3L },
#'     'quux'    = function(e) { cat("in quux\n")  ; -4L }
#'   )
#' )
#' # in always
#' # in foo
#' # [1] -3
#'
#' \dontrun{
#' 
#'   # this demonstrates that with errors, 'always^' does not stop
#'   # checking handlers, and if nothing matches, the error will
#'   # propogate up and out of the call stack
#'   tryCatchPatterns(
#'     { stop("foo") },
#'     errors = list(
#'       'always^' = function(e) { cat("in always\n"); -1L },
#'       'bar'     = function(e) { cat("in bar\n")   ; -2L },
#'       'quux'    = function(e) { cat("in quux\n")  ; -3L }
#'     )
#'   )
#'   # in always
#'   # Error in doTryCatch(return(expr), name, parentenv, handler) : foo
#'
#' }
#'
#' ###
#' ### NESTING error-matching in tryCatchPatterns:
#' ### the appropriate layer will catch its own error(s)
#' ###
#'
#' # caught by the inner
#' tryCatchPatterns({
#'   tryCatchPatterns(
#'     { stop("hello; no-math-around"); 99 },
#'     errors = list(
#'       "no-math" = function(e) { cat("in inner\n"); -1L }
#'     )
#'   )},
#'   errors = list(
#'     "oops" = function(e) { cat("in outer\n"); -2L }
#'   )
#' )
#' # in inner
#' # [1] -1
#' 
#' # caught by the outer
#' tryCatchPatterns({
#'   tryCatchPatterns(
#'     { stop("oops"); 99 },
#'     errors = list(
#'       "no-math" = function(e) { cat("in inner\n"); -1L }
#'     )
#'   )},
#'   errors = list(
#'     "oops" = function(e) { cat("in outer\n"); -2L }
#'     )
#'   )
#' # in outer
#' # [1] -2
#' 
#' # caught by the "catch-all" outer
#' tryCatchPatterns({
#'   tryCatchPatterns(
#'     { stop("neither"); 99 },
#'     errors = list(
#'       "^no-math" = function(e) { cat("in inner\n"); -1L })
#'     )
#' },
#'   errors = list(
#'     "oops" = function(e) { cat("in outer\n"); -2L },
#'     "."    = function(e) { cat("in catch-all\n"); -3L }
#'   )
#' )
#' # in catch-all
#' # [1] -3
#' 
#'
#' \dontrun{
#'
#'   # the inner does not catch it, the outer does not catch it, so the
#'   # error propogates out
#'   tryCatchPatterns({
#'     tryCatchPatterns(
#'       { stop("neither"); 99 },
#'       errors = list(
#'         "^no-math" = function(e) { cat("in inner\n"); -1L }
#'       )
#'     )},
#'     errors = list(
#'       "oops" = function(e) { cat("in outer\n"); -2L }
#'     )
#'   )
#'   # Error in doTryCatch(return(expr), name, parentenv, handler) : neither
#' 
#' }
#'
#' tryCatchPatterns({
#'   os_error = function (message, call = NULL) {
#'     class = c('os_error', 'simpleError', 'error', 'condition')
#'     stop(structure(list(message = message, call = call), class = class))
#'   }
#'   os_error("foo")
#'   }, errors = list(
#'     "foo" = function(e) { cat("in 'foo'\n"); -1L; }
#'   )
#' )
#' # in 'foo'
#' # [1] -1
#' 
#' tryCatchPatterns({
#'   os_error = function (message, call = NULL) {
#'     class = c('os_error', 'simpleError', 'error', 'condition')
#'     stop(structure(list(message = message, call = call), class = class))
#'   }
#'   os_error("foo")
#'   }, errors = list(
#'     "$os_error" = function(e) { cat("in 'os_error'\n"); -1L; }
#'   )
#' )
#' # in 'os_error'
#' # [1] -1
#' 
#' 
tryCatchPatterns <- function(expr, ..., warnings = list(NA), errors = list(NA), finally,
                             .warning1 = TRUE, perl = FALSE, fixed = FALSE) {
  parentenv <- parent.frame()
  handlers <- list(...)

  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")

  buildlist <- function(L, H) {
    if (is.null(L) || length(L) == 0L) return(list())
    isna <- !sapply(L, is.function)
    isna[isna] <- c(sapply(L[isna], is.na), logical(0))
    isna <- unlist(isna)
    if (any(isna)) {
      isna <- which(isna)[1]
      len <- length(L)
      L <- c(L[ seq_len(isna - 1) ],
             H, L[ isna + seq_len(len - isna) ])
    } else L <- c(L, H)
    return(L)
  }
  warnings <- buildlist(warnings, handlers)
  errors   <- buildlist(errors, handlers)
  
  # ---------------------------------
  # internal functions
  mywarning <- function(w) {
    msg <- conditionMessage(w)
    handled <- FALSE
    for (hndlr in names(warnings)) {
      if (hndlr == "always^" ||
            (grepl("^\\$", hndlr) && inherits(e, gsub("^\\$", "", hndlr))) ||
            grepl(hndlr, msg, perl = perl, fixed = fixed)) {
        .ign <- warnings[[hndlr]](msg)
        if (hndlr != "always^") {
          handled <- TRUE
          if (.warning1) break
        }
      }
    }
    if (handled) invokeRestart("muffleWarning")
  }

  myerror <- function(e) {
    msg <- conditionMessage(e)
    handled <- FALSE
    for (hndlr in names(errors)) {
      if (hndlr == "always^" ||
            (grepl("^\\$", hndlr) && inherits(e, gsub("^\\$", "", hndlr))) ||
            grepl(hndlr, msg, perl = perl, fixed = fixed)) {
        out <- errors[[hndlr]](e)
        if (hndlr != "always^") {
          handled <- TRUE
          break
        }
      }
    }
    if (handled) out else stop(e)
  }

  # ---------------------------------
  # record the calling expression
  call <- match.call(expand.dots = FALSE)

  # ---------------------------------
  # set up evaluation with in tryCatch(withCallingHandlers(...)) or
  # just tryCatch(...)
  if (length(warnings) > 0L) {
    wch_call <- call("withCallingHandlers", expr = call$expr, warning = mywarning)
    tc_call <- call("tryCatch", expr = wch_call, error = myerror, finally = call$finally)
  } else {
    tc_call <- call("tryCatch", expr = call$expr, error = myerror, finally = call$finally)
  }

  # ---------------------------------
  # evaluate!
  eval.parent(tc_call)
}

### variant posted on CodeReview
### https://codereview.stackexchange.com/questions/225419/error-specific-trycatch/
#' 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_CR({
#'   tryCatchPatterns_CR({
#'     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_CR({
#'   tryCatchPatterns_CR({
#'     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_CR({
#'   tryCatchPatterns_CR({
#'     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_CR({
#'     tryCatchPatterns_CR({
#'       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_CR <- 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)
  }

  # ---------------------------------
  # record the calling expression
  call <- match.call(expand.dots = FALSE)

  # ---------------------------------
  # set up evaluation with tryCatch(...)
  tc_call <- call("tryCatch", expr = call$expr, error = myerror, finally = call$finally)

  # ---------------------------------
  # evaluate!
  eval.parent(tc_call)
}

Recent edits suggested by @klmr (https://codereview.stackexchange.com/questions/225419/error-specific-trycatch/226198#226198), thanks!