Skip to content

Instantly share code, notes, and snippets.

@r2evans

r2evans/tryCatchPatterns.R

Last active Aug 15, 2019
Embed
What would you like to do?
exception handling by pattern (or sub-class)
#' 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)
}
@r2evans

This comment has been minimized.

Copy link
Owner Author

@r2evans r2evans commented Aug 15, 2019

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment