Last active
March 10, 2023 07:15
-
-
Save Patrikios/f0dc79f11d9543e107d44f524f5de8a2 to your computer and use it in GitHub Desktop.
implements custom R conditions (like errors, warnings, messages) as found in 1st Edition of Hadley's Advanced R book
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
# 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) | |
} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment