implements custom R conditions (like errors, warnings, messages) as found in 1st Edition of Hadley's Advanced R book

conditions.R

# DOCUMENTATION
#
# Sources: http://adv-r.had.co.nz/Exceptions-Debugging.html & https://adv-r.hadley.nz/conditions.html
#
# - all conditions inherit from abstract class 'condition'
# - conditions are being signalled from functions
# - R conditions system was inpsired by Common Lisp
#
#
# Ressources:
#
# - 'A Prototype of a Condition System for R' by Robert Gentleman and Luke Tierney 
# - @ http://homepage.stat.uiowa.edu/~luke/R/exceptions/simpcond.html
# Early version of the R conditions system, shows the big picture
# 
# - '19. Beyond Exception Handling: Conditions and Restarts' 
# @ https://gigamonkeys.com/book/beyond-exception-handling-conditions-and-restarts.html
# - Lisp Exceptions handlich which is very similar to R


#' condition
#'
#' @description
#' condition constructor as in http://adv-r.had.co.nz/Exceptions-Debugging.html
#'
#' @param subclass
#' @param message
#' @param call
#' @param ...
#'
#' @return new condition of its own type
#'
#' @examples
#'
#' # simple usage
#' e <- condition(c("my_error", "error"), "This is an error")
#' signalCondition(e)
#' # NULL
#' stop(e)
#' # Error: This is an error
#' w <- condition(c("my_warning", "warning"), "This is a warning")
#' warning(w)
#' # Warning message: This is a warning
#' m <- condition(c("my_message", "message"), "This is a message")
#' message(m)
#' # This is a message
#'
#' # Usage with 'tryCatch()'
#' custom_stop <- function(subclass, message, call = sys.call(-1), ...) {
#'   c <- condition(c(subclass, "error"), message, call = call, ...)
#'   stop(c)
#' }
#' my_log <- function(x) {
#'   if (!is.numeric(x)) {
#'     custom_stop("invalid_class", "my_log() needs numeric input")
#'   }
#'   if (any(x < 0)) {
#'     custom_stop("invalid_value", "my_log() needs positive inputs")
#'   }
#'   log(x)
#' }
#' tryCatch(
#'   my_log("a"),
#'   invalid_class = function(c) "class",
#'   invalid_value = function(c) "value"
#' )
#' #> [1] "class"
#'
condition <- function(subclass, message, call = sys.call(-1), ...) {
  structure(
    class = c(subclass, "condition"),
    list(message = message, call = call),
    ...
  )
}

#' is.condition
#'
#' @description
#' check if is of the abstract class condition
#'
#' @param x
#'
#' @return bool
#'
is.condition <- function(x) inherits(x, "condition")

#' custom_stop
#'
#' @param subclass 
#' @param message 
#' @param call 
#' @param ... 
#'
#' @return
#' @export
#'
#' @examples
#' custom_stop("invalid_class", "my_log() needs numeric input")
#' 
custom_stop <- function(subclass, message, call = sys.call(-1), ...) {
  c <- condition(c(subclass, "error"), message, call = call, ...)
  stop(c)
}