R/stopperr.R
In j-martineau/uj: Utilities by JAM
Defines functions
bankerrs
bankerr
checkerr
banked_errs
err
errs
errs_if_pop
err_if_pop
errs_if_nots
errs_ifs
err_if_not
err_if
purgerr
getterr
stopperr
Documented in
banked_errs
bankerr
bankerrs
checkerr
err
err_if
err_if_not
err_if_pop
errs
errs_if_nots
errs_if_pop
errs_ifs
getterr
purgerr
stopperr
#' @encoding UTF-8
#' @family Errs
#' @title Error Checking, Banking, and Processing
#' @description Bank error messages in the immediate environment of a function to allow for exhaustive error checking before throwing an exception. Results in a possibly multiple-error, accumulated message to be processed upon completion of error checking.
#' @details **Primary stopping functions**
#' \tabular{ll}{ `stopperr` or `stopper` \tab Stops execution by: \cr
#' \tab \enumerate{
#' \item Posting an \code{\link{alert}} header the console with the following components: an error `'ERROR'` title and a subheader identifying the function Where the error originated (from `FUN`).
#' \item Posting one or more error message to the console following the header, each preceded by a bullet, Where each element of each `...` arg is a separate error message.
#' \item Creating a \code{\link[base]{simpleError}} object with an error message consisting of an \link[=lineage]{abbreviated function call lineage} given as a vector in `stack`.
#' \item Attaching the function identity, package identity, and associated message(s) to the `simpleError` object as attributes.
#' \item Archiving the `simpleError` object in the global variable `.ppp_LAST_ERR_ppp.` (which can be retrieved by calling `getter()` and can be purged by calling `purger()`). Allows for error tracing in the circumstance that R purges the last error in final error processing.
#' \item Calling `stop` with the `simpleError` object as the argument. } \cr \tab \cr
#' `checkerr` or `checker` \tab Calls `stopper` with any error messages banked by the functions described in sections *error banking* *utilities functions* and *condition-based error-checking functions*. If none are banked, does nothing. \cr \tab \cr
#' `purgerr` or `purger` \tab Purges the most recent \code{\link[base]{simpleError}} object generated by this family of functions. \cr \tab \cr
#' `getterr` or `getter` \tab Gets the most recent `simpleError` object generated by this family of functions. }
#' \cr Both `stopperr / stopper` and `checkerr / checker` can identify error-generating functions further up the call Stack than the function in which they are called:
#' \itemize{\item `stopperr / stopper` uses args `fun`, and `stack` to identify the error-generating function.
#' \item `checkerr / checker` uses arg `gens` to identify the error-generating function.}
#' \cr\cr **Secondary stopping functions**
#' \cr\cr These functions are designed to be called directly from the function Where an error is generated. It gathers the name of the function generating the error rather than requiring the user to provide the function name. These functions operate as follows:
#' \tabular{ll}{ `Errs` \tab Calls `stopperr` treating each element of each `...` arg as a separate error message, allowing for compiling multiple error message before processing. \cr \tab \cr
#' `err` \tab Calls `stopperr` with a single error message constructed by \link[=collapse_dots]{collapsing} all elements of all `...` args into a character scalar error message before processing. }
#' \cr\cr **Multiple-error conditional stopping functions**
#' \cr\cr These functions conditionally compile multiple errors, and if any are compiled, they notify the user and stop execution.
#' \tabular{ll}{ `errs_if_nots` \tab Conditionally compiles errors, treating each odd-numbered `...` arg as a test and each even-numbered `...` arg as the corresponding error message if the test is `FALSE`, and calls `stopperr` if any are compiled. \cr \tab \cr
#' `errs_if_pop` \tab Calls `stopperr` if there are any `...` args, treating each `...` arg as a separate error message. \cr \tab \cr
#' `errs_ifs` \tab Conditionally compiles errors, treating each odd-numbered `...` arg as a test and each even-numbered `...` arg as the corresponding error message if the test is `TRUE`, and calls `stopperr` if any are compiled. }
#' \cr\cr **Single-error conditional stopping functions**
#' \cr\cr These functions conditionally construct a single error, and if one is constructed, they notify the user and stop execution.
#' \tabular{ll}{ `err_if_pop` \tab If there are any `...` args, collapsing them into a character scalar error message, and calls `stopperr`. \cr \tab \cr
#' `err_if_not` \tab If `TEST = FALSE`, collapses `...` args to a character scalar error message and calls `stopperr`. \cr \tab \cr
#' `err_if` \tab If `TEST = TRUE`, collapses `...` args to a character scalar error message and calls `stopperr`. }
#' \cr\cr **Utility functions**
#' \cr\cr These functions purge and retrieve the most recent error generated by this family of functions.
#' \cr\cr **Primary error banking functions**
#' \cr\cr Error banking utility functions: These functions are utilities for banking user-defined error messages within a function to allow for checking for multiple errors in separate statements and banking those error messages as they are checked, waiting to process banked error messages until an error checking block is completed. These functions also allow for generating and checking for error messages further up the call Stack than the function in which the error banking/processing occurs by specifying the number of generations back in the call Stack Where error banking/processing occurs in `gens`:
#' \tabular{ll}{ `banked_errs` \tab Retrieves the bank of error message stored in the environment of the function `gens` generations back in the call Stack. \cr \tab \cr
#' `bankerrs` \tab Banks each element of \link[=cmp_chr_vec]{complete character vec} as an individual error message. \cr \tab \cr
#' `bankerr` \tab Banks an arbitrary error message (built by \link[=collapse_dots]{collapsing} `...` args) in the environment of the function `gens` generations back in the call Stack. }
#' All functions in family \code{\link{check_xxx}} also check for specific types of errors and incrementally bank errors if any are found.
#' \cr\cr **Error checking / conditional error banking functions**
#' \cr\cr **`checkerr`** checks for any banked error messages. If there are any, processes them and stops execution. Otherwise, does nothing.
#' @param ... **Unnamed** arguments.
#' @param d A non-`NA` character scalar delimiter for collapsing `...` into a an error message.
#' @param fun A character scalar naming the function generating an error or errors.
#' @param gens A \link[=cmp_nnw_scl]{complete non-negative whole-number scalar} indicating the number of generations back in the call stack in which to bank and/or check for error messages.
#' @param funs A \link[=cmp_chr_vec]{complete character vec} containing `1` or more \link[=prop_funs]{property function} names.
#' @param stack An optional character vector naming the lineage of the function generating the error. If `NULL`, retrieves the stack under the assumption that the immediate calling function is Where the error is generated.
#' @param test A non-`NA` logical scalar.
#' @return **A **\code{\link[base]{simpleError}} **object** \cr\cr `getterr`
#' \cr\cr **A character vector** \cr\cr `banked_Errs`
#' \cr\cr All others are called for their side effects.
#' @examples
#' egStopper <- function() {stopperr('stopper demo')}
#' egErrs <- function() {Errs('Errs demo1', 'Errs demo2')}
#' egErr <- function() {err('err', 'demo')}
#' egErrors <- function(..., tf = NA, lgl = 42, not = FALSE, pop = NULL,
#' fail = simpleError('error'), funs = 2:4, spec = 42,
#' vals = 42, class = 42, nas.or = NULL, nll.or = NA,
#' chars = '5', when.a = "error.a", when.b = "error.b") {
#' bankerr(...elt(1))
#' bankErrs(...elt(2), ...elt(3))
#' check_tf(tf = tf)
#' check_lgl(lgl = lgl)
#' check_t(not = not)
#' check_pop(pop = pop)
#' check_fail(fail = fail)
#' check_funs(c('cmp_ch1_vec', 'cmp_ngw_vec'), funs = funs)
#' check_spec('cmp_ch1_vec|nll|nas', spec = spec)
#' check_vals(letters, vals = vals)
#' check_cls('data.frame', class)
#' check_nas_or(c('cmp_ch1_vec', 'cmp_ngw_vec'), nas.or = nas.or)
#' check_nll_or(c('cmp_ch1_vec', 'cmp_ngw_vec'), nll.or = nll.or)
#' check_chars(letters, chars = chars)
#' check_when(when.a = when.a, when.b = when.b, c('error.a', ''), c('error.b', ''))
#' checkerr()
#' }
#' \dontrun{
#' egstopperr()
#' getterr()
#' purgerr()
#' getter()
#' egErrs()
#' egErrs()
#' egErrors()
#' }
#' @export
stopperr <- function(..., fun = "", stack = "") {
.rwb <- function(X) {crayon::bgRed(crayon::white(crayon::bold(X)))}
.bwp <- function(X) {crayon::bgBlack(crayon::white(X))}
.byi <- function(X) {crayon::bgBlack(crayon::yellow(crayon::italic(X)))}
if (uj::is_err(fun)) {fun <- ""} else if (!base::is.character(fun) | base::length(fun) != 1) {fun <- ""} else if (base::is.na(fun)) {fun <- ""}
if (uj::is_err(stack)) {stack <- ""} else if (!base::is.character(stack) | base::length(stack) == 0) {stack <- ""} else if (base::any(base::is.na(stack))) {stack <- ""}
errs <- base::as.character(uj::av(uj::failsafe(base::list(...))))
errs[base::trimws(errs, which = "both", whitespace = "[ \t\r]") == ""] <- "[unknown.error]"
errs <- base::unique(errs)
if (fun == "") {fun <- uj::caller()}
if (base::length(stack) == 1) {if (stack == "") {stack <- uj::callers()}}
fun <- uj::stack2funs(fun)
stack <- uj::stack2funs(stack)
errLab <- " ERROR IN "
funLab <- " function: "
funLen <- base::nchar(fun)
padLen <- base::nchar(fun)
spaces <- base::paste0(base::rep.int(" ", 101), collapse = "")
errPad <- base::substr(spaces, 1, padLen)
funPad <- base::substr(spaces, 1, padLen - funLen)
suff <- base::ifelse(base::length(errs) > 1, "S", "")
mssg <- base::paste0(base::paste0(base::paste0("\n \u2022 ", errs), collapse = ""), "\n\n")
base::cat("\n"); base::cat(base::gsub(" ", " ", base::paste0(.rwb(errLab), .rwb(errPad))))
base::cat("\n"); base::cat(base::gsub(" ", " ", base::paste0(.byi(funLab), .bwp(base::paste0(fun, funPad)))))
base::cat("\n")
stack <- base::paste0(base::paste0("\n \u2022 ", stack), collapse = "")
errObj <- base::paste0("\nFUNCTION\n \u2022 ", fun, "\n\nCALL STACK ", stack, "\n\nERROR MESSAGE", suff, mssg)
errObj <- base::simpleError(errObj)
base::assign(".ppp_LAST_ERR_ppp.", errObj, envir = .GlobalEnv)
stop(mssg)
}
#' @rdname stopperr
#' @export
getterr <- function() {if (base::exists(".ppp_LAST_ERR_ppp.", envir = base::.GlobalEnv)) {base::get(".ppp_LAST_ERR_ppp.", envir = .GlobalEnv)} else {NULL}}
#' @rdname stopperr
#' @export
purgerr <- function() {if (base::exists(".ppp_LAST_ERR_ppp.", envir = .GlobalEnv)) {base::rm(".ppp_LAST_ERR_ppp.", envir = .GlobalEnv)}}
#' @rdname stopperr
#' @export
stopper <- stopperr
#' @rdname stopperr
#' @export
getter <- getterr
#' @rdname stopperr
#' @export
purger <- purgerr
#' @rdname stopperr
#' @export
err_if <- function(test, ..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
if (base::isTRUE(test)) {
err <- base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d)
if (err == "") {err <- "[unknown.error]"}
uj::stopperr(err, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
err_if_not <- function(test, ..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
if (!base::isTRUE(uj::failsafe(test))) {
err <- base::trimws(base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d), which = "both", whitespace = "[ \t\r]")
if (err == "") {err <- "[unknown.error]"}
uj::stopperr(err, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
errs_ifs <- function(..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
n <- base::...length()
if (n / 2 == base::round(n / 2)) {
errs <- NULL
for (i in 1:(n - 1)) {
test <- uj::failsafe(base::...elt(i))
if (base::isTRUE(test)) {
err <- base::paste0(uj::av(uj::failsafe(base::...elt(i + 1))), collapse = d)
if (err == "") {err <- "[unknown.error]"}
errs <- base::c(errs, err)
}
}
if (!base::is.null(errs)) {
errs <- base::unique(errs)
uj::stopperr(errs, fun = fun, stack = stack)
}
} else {uj::stopperr("There must be an even number of [...] args.")}
}
#' @rdname stopperr
#' @export
errs_if_nots <- function(..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
n <- base::...length()
if (n / 2 == base::round(n / 2)) {
errs <- NULL
for (i in 1:(n - 1)) {
test <- uj::failsafe(base::...elt(i))
if (!base::isTRUE(test)) {
err <- base::paste0(uj::av(uj::failsafe(base::...elt(i + 1))), collapse = d)
if (err == "") {err <- "[unknown.error]"}
errs <- base::c(errs, err)
}
}
if (!base::is.null(errs)) {
errs <- base::unique(errs)
uj::stopperr(errs, fun = fun, stack = stack)
}
} else {uj::stopperr("There must be an even number of [...] args.")}
}
#' @rdname stopperr
#' @export
err_if_pop <- function(..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
if (base::...length() > 0) {
errs <- NULL
for (i in 1:base::...length()) {
piece <- uj::failsafe(base::...elt(i))
if (!base::is.null(piece)) {
if (!uj::is_err(piece)) {errs <- base::c(errs, base::as.character(piece))}
else {errs <- base::c(errs, "")}
}
}
if (base::length(errs) > 0) {
errs <- base::paste0(errs, collapse = d)
if (errs == "") {errs <- "[unknown.error]"}
uj::stopperr(errs, fun = fun, stack = stack)
}
}
}
#' @rdname stopperr
#' @export
errs_if_pop <- function(..., fun = "", stack = "") {
if (uj::is_err(fun )) {fun <- ""} else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- ""} else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- ""} else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- ""} else if (base::any(base::is.na(stack))) {stack <- ""}
errs <- uj::failsafe(base::list(...))
errs <- base::as.character(uj::av(errs))
errs[base::is.na(errs)] <- "[unknown.error]"
if (base::length(errs) == 1) {if (errs == "") {errs <- NULL}}
if (base::length(errs) > 0) {
errs[errs == ""] <- "[unknown.error]"
errs <- base::unique(errs)
uj::stopperr(errs, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
errs <- function(errs, stack = "") {
if (uj::is_err(stack)) {stack <- ""} else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- ""} else if (base::any(base::is.na(stack))) {stack <- ""}
errs <- base::as.character(uj::failsafe(errs))
errs <- base::trimws(base::as.character(uj::av(errs)), which = "both")
errs[base::is.na(errs)] <- "[unknown.error]"
errs[errs == ""] <- "[unknown.error]"
errs <- base::unique(errs)
fun <- uj::caller()
uj::stopperr(errs, fun = fun, stack = stack)
}
#' @rdname stopperr
#' @export
err <- function(..., stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if (base::is.na(d) ) {d <- " "}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
err <- base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d)
err <- base::trimws(err, which = "both")
if (base::is.na(err)) {err <- "[unknown.error]"}
if (err != "" ) {err <- "[unknown.error]"}
fun <- uj::caller()
uj::stopperr(err, fun = fun, stack = stack)
}
#' @rdname stopperr
#' @export
banked_errs <- function(gens = 0) {
if ( uj::is_err(gens) ) {gens <- 0}
if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
gens <- gens + 1
if (base::exists(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)) {base::get(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)} else {NULL}
}
#' @rdname stopperr
#' @export
checkerr <- function(gens = 0) {
if (uj::is_err(gens)) {gens <- 0} else if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
gens <- gens + 1
stack <- uj::callers()
stack <- stack[gens:base::length(stack)]
if (base::exists(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)) {
fun <- uj::callerN(gens + 1)
errs <- base::get(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)
base::rm(list = ".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F);
uj::stopperr(errs, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
checker <- checkerr
#' @rdname stopperr
#' @export
bankerr <- function(..., gens = 0, d = "") {
if (uj::is_err(gens)) {gens <- 0 } else if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d) | base::length(d) != 1) {d <- " "} else if (base::is.na(d)) {d <- " "}
gens <- gens + 1
err <- base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d)
err <- base::trimws(err, which = "both")
if (base::is.na(err)) {err <- "[unknown.error]"}
if (err == "") {err <- "[unknown.error]"}
errs <- base::c(uj::banked_errs(gens), errs)
base::assign(".ppp_ERR_BANK_ppp.", errs, envir = base::parent.frame(gens))
}
#' @rdname stopperr
#' @export
bankerrs <- function(..., gens = 0) {
if (uj::is_err(gens)) {gens <- 0} else if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
gens <- gens + 1
if (base::...length() > 0) {
errs <- NULL
for (i in 1:base::...length()) {
err <- base::paste0(base::as.character(uj::av(uj::failsafe(base::...elt(i)))), collapse = "")
err <- base::trimws(err, which = "both")
if (base::is.na(err)) {err <- "[unknown.error]"}
if (err == "" ) {err <- "[unknown.error]"}
errs <- base::c(errs, err)
}
} else {errs <- "{ unknown error } "}
errs <- base::unique(base::c(uj::banked_errs(gens), errs))
base::assign(".ppp_ERR_BANK_ppp.", errs, envir = base::parent.frame(gens))
}
j-martineau/uj documentation built on Sept. 14, 2024, 4:40 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions bankerrs bankerr checkerr banked_errs err errs errs_if_pop err_if_pop errs_if_nots errs_ifs err_if_not err_if purgerr getterr stopperr
Documented in banked_errs bankerr bankerrs checkerr err err_if err_if_not err_if_pop errs errs_if_nots errs_if_pop errs_ifs getterr purgerr stopperr
#' @encoding UTF-8
#' @family Errs
#' @title Error Checking, Banking, and Processing
#' @description Bank error messages in the immediate environment of a function to allow for exhaustive error checking before throwing an exception. Results in a possibly multiple-error, accumulated message to be processed upon completion of error checking.
#' @details **Primary stopping functions**
#' \tabular{ll}{ `stopperr` or `stopper` \tab Stops execution by: \cr
#' \tab \enumerate{
#' \item Posting an \code{\link{alert}} header the console with the following components: an error `'ERROR'` title and a subheader identifying the function Where the error originated (from `FUN`).
#' \item Posting one or more error message to the console following the header, each preceded by a bullet, Where each element of each `...` arg is a separate error message.
#' \item Creating a \code{\link[base]{simpleError}} object with an error message consisting of an \link[=lineage]{abbreviated function call lineage} given as a vector in `stack`.
#' \item Attaching the function identity, package identity, and associated message(s) to the `simpleError` object as attributes.
#' \item Archiving the `simpleError` object in the global variable `.ppp_LAST_ERR_ppp.` (which can be retrieved by calling `getter()` and can be purged by calling `purger()`). Allows for error tracing in the circumstance that R purges the last error in final error processing.
#' \item Calling `stop` with the `simpleError` object as the argument. } \cr \tab \cr
#' `checkerr` or `checker` \tab Calls `stopper` with any error messages banked by the functions described in sections *error banking* *utilities functions* and *condition-based error-checking functions*. If none are banked, does nothing. \cr \tab \cr
#' `purgerr` or `purger` \tab Purges the most recent \code{\link[base]{simpleError}} object generated by this family of functions. \cr \tab \cr
#' `getterr` or `getter` \tab Gets the most recent `simpleError` object generated by this family of functions. }
#' \cr Both `stopperr / stopper` and `checkerr / checker` can identify error-generating functions further up the call Stack than the function in which they are called:
#' \itemize{\item `stopperr / stopper` uses args `fun`, and `stack` to identify the error-generating function.
#' \item `checkerr / checker` uses arg `gens` to identify the error-generating function.}
#' \cr\cr **Secondary stopping functions**
#' \cr\cr These functions are designed to be called directly from the function Where an error is generated. It gathers the name of the function generating the error rather than requiring the user to provide the function name. These functions operate as follows:
#' \tabular{ll}{ `Errs` \tab Calls `stopperr` treating each element of each `...` arg as a separate error message, allowing for compiling multiple error message before processing. \cr \tab \cr
#' `err` \tab Calls `stopperr` with a single error message constructed by \link[=collapse_dots]{collapsing} all elements of all `...` args into a character scalar error message before processing. }
#' \cr\cr **Multiple-error conditional stopping functions**
#' \cr\cr These functions conditionally compile multiple errors, and if any are compiled, they notify the user and stop execution.
#' \tabular{ll}{ `errs_if_nots` \tab Conditionally compiles errors, treating each odd-numbered `...` arg as a test and each even-numbered `...` arg as the corresponding error message if the test is `FALSE`, and calls `stopperr` if any are compiled. \cr \tab \cr
#' `errs_if_pop` \tab Calls `stopperr` if there are any `...` args, treating each `...` arg as a separate error message. \cr \tab \cr
#' `errs_ifs` \tab Conditionally compiles errors, treating each odd-numbered `...` arg as a test and each even-numbered `...` arg as the corresponding error message if the test is `TRUE`, and calls `stopperr` if any are compiled. }
#' \cr\cr **Single-error conditional stopping functions**
#' \cr\cr These functions conditionally construct a single error, and if one is constructed, they notify the user and stop execution.
#' \tabular{ll}{ `err_if_pop` \tab If there are any `...` args, collapsing them into a character scalar error message, and calls `stopperr`. \cr \tab \cr
#' `err_if_not` \tab If `TEST = FALSE`, collapses `...` args to a character scalar error message and calls `stopperr`. \cr \tab \cr
#' `err_if` \tab If `TEST = TRUE`, collapses `...` args to a character scalar error message and calls `stopperr`. }
#' \cr\cr **Utility functions**
#' \cr\cr These functions purge and retrieve the most recent error generated by this family of functions.
#' \cr\cr **Primary error banking functions**
#' \cr\cr Error banking utility functions: These functions are utilities for banking user-defined error messages within a function to allow for checking for multiple errors in separate statements and banking those error messages as they are checked, waiting to process banked error messages until an error checking block is completed. These functions also allow for generating and checking for error messages further up the call Stack than the function in which the error banking/processing occurs by specifying the number of generations back in the call Stack Where error banking/processing occurs in `gens`:
#' \tabular{ll}{ `banked_errs` \tab Retrieves the bank of error message stored in the environment of the function `gens` generations back in the call Stack. \cr \tab \cr
#' `bankerrs` \tab Banks each element of \link[=cmp_chr_vec]{complete character vec} as an individual error message. \cr \tab \cr
#' `bankerr` \tab Banks an arbitrary error message (built by \link[=collapse_dots]{collapsing} `...` args) in the environment of the function `gens` generations back in the call Stack. }
#' All functions in family \code{\link{check_xxx}} also check for specific types of errors and incrementally bank errors if any are found.
#' \cr\cr **Error checking / conditional error banking functions**
#' \cr\cr **`checkerr`** checks for any banked error messages. If there are any, processes them and stops execution. Otherwise, does nothing.
#' @param ... **Unnamed** arguments.
#' @param d A non-`NA` character scalar delimiter for collapsing `...` into a an error message.
#' @param fun A character scalar naming the function generating an error or errors.
#' @param gens A \link[=cmp_nnw_scl]{complete non-negative whole-number scalar} indicating the number of generations back in the call stack in which to bank and/or check for error messages.
#' @param funs A \link[=cmp_chr_vec]{complete character vec} containing `1` or more \link[=prop_funs]{property function} names.
#' @param stack An optional character vector naming the lineage of the function generating the error. If `NULL`, retrieves the stack under the assumption that the immediate calling function is Where the error is generated.
#' @param test A non-`NA` logical scalar.
#' @return **A **\code{\link[base]{simpleError}} **object** \cr\cr `getterr`
#' \cr\cr **A character vector** \cr\cr `banked_Errs`
#' \cr\cr All others are called for their side effects.
#' @examples
#' egStopper <- function() {stopperr('stopper demo')}
#' egErrs <- function() {Errs('Errs demo1', 'Errs demo2')}
#' egErr <- function() {err('err', 'demo')}
#' egErrors <- function(..., tf = NA, lgl = 42, not = FALSE, pop = NULL,
#' fail = simpleError('error'), funs = 2:4, spec = 42,
#' vals = 42, class = 42, nas.or = NULL, nll.or = NA,
#' chars = '5', when.a = "error.a", when.b = "error.b") {
#' bankerr(...elt(1))
#' bankErrs(...elt(2), ...elt(3))
#' check_tf(tf = tf)
#' check_lgl(lgl = lgl)
#' check_t(not = not)
#' check_pop(pop = pop)
#' check_fail(fail = fail)
#' check_funs(c('cmp_ch1_vec', 'cmp_ngw_vec'), funs = funs)
#' check_spec('cmp_ch1_vec|nll|nas', spec = spec)
#' check_vals(letters, vals = vals)
#' check_cls('data.frame', class)
#' check_nas_or(c('cmp_ch1_vec', 'cmp_ngw_vec'), nas.or = nas.or)
#' check_nll_or(c('cmp_ch1_vec', 'cmp_ngw_vec'), nll.or = nll.or)
#' check_chars(letters, chars = chars)
#' check_when(when.a = when.a, when.b = when.b, c('error.a', ''), c('error.b', ''))
#' checkerr()
#' }
#' \dontrun{
#' egstopperr()
#' getterr()
#' purgerr()
#' getter()
#' egErrs()
#' egErrs()
#' egErrors()
#' }
#' @export
stopperr <- function(..., fun = "", stack = "") {
.rwb <- function(X) {crayon::bgRed(crayon::white(crayon::bold(X)))}
.bwp <- function(X) {crayon::bgBlack(crayon::white(X))}
.byi <- function(X) {crayon::bgBlack(crayon::yellow(crayon::italic(X)))}
if (uj::is_err(fun)) {fun <- ""} else if (!base::is.character(fun) | base::length(fun) != 1) {fun <- ""} else if (base::is.na(fun)) {fun <- ""}
if (uj::is_err(stack)) {stack <- ""} else if (!base::is.character(stack) | base::length(stack) == 0) {stack <- ""} else if (base::any(base::is.na(stack))) {stack <- ""}
errs <- base::as.character(uj::av(uj::failsafe(base::list(...))))
errs[base::trimws(errs, which = "both", whitespace = "[ \t\r]") == ""] <- "[unknown.error]"
errs <- base::unique(errs)
if (fun == "") {fun <- uj::caller()}
if (base::length(stack) == 1) {if (stack == "") {stack <- uj::callers()}}
fun <- uj::stack2funs(fun)
stack <- uj::stack2funs(stack)
errLab <- " ERROR IN "
funLab <- " function: "
funLen <- base::nchar(fun)
padLen <- base::nchar(fun)
spaces <- base::paste0(base::rep.int(" ", 101), collapse = "")
errPad <- base::substr(spaces, 1, padLen)
funPad <- base::substr(spaces, 1, padLen - funLen)
suff <- base::ifelse(base::length(errs) > 1, "S", "")
mssg <- base::paste0(base::paste0(base::paste0("\n \u2022 ", errs), collapse = ""), "\n\n")
base::cat("\n"); base::cat(base::gsub(" ", " ", base::paste0(.rwb(errLab), .rwb(errPad))))
base::cat("\n"); base::cat(base::gsub(" ", " ", base::paste0(.byi(funLab), .bwp(base::paste0(fun, funPad)))))
base::cat("\n")
stack <- base::paste0(base::paste0("\n \u2022 ", stack), collapse = "")
errObj <- base::paste0("\nFUNCTION\n \u2022 ", fun, "\n\nCALL STACK ", stack, "\n\nERROR MESSAGE", suff, mssg)
errObj <- base::simpleError(errObj)
base::assign(".ppp_LAST_ERR_ppp.", errObj, envir = .GlobalEnv)
stop(mssg)
}
#' @rdname stopperr
#' @export
getterr <- function() {if (base::exists(".ppp_LAST_ERR_ppp.", envir = base::.GlobalEnv)) {base::get(".ppp_LAST_ERR_ppp.", envir = .GlobalEnv)} else {NULL}}
#' @rdname stopperr
#' @export
purgerr <- function() {if (base::exists(".ppp_LAST_ERR_ppp.", envir = .GlobalEnv)) {base::rm(".ppp_LAST_ERR_ppp.", envir = .GlobalEnv)}}
#' @rdname stopperr
#' @export
stopper <- stopperr
#' @rdname stopperr
#' @export
getter <- getterr
#' @rdname stopperr
#' @export
purger <- purgerr
#' @rdname stopperr
#' @export
err_if <- function(test, ..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
if (base::isTRUE(test)) {
err <- base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d)
if (err == "") {err <- "[unknown.error]"}
uj::stopperr(err, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
err_if_not <- function(test, ..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
if (!base::isTRUE(uj::failsafe(test))) {
err <- base::trimws(base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d), which = "both", whitespace = "[ \t\r]")
if (err == "") {err <- "[unknown.error]"}
uj::stopperr(err, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
errs_ifs <- function(..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
n <- base::...length()
if (n / 2 == base::round(n / 2)) {
errs <- NULL
for (i in 1:(n - 1)) {
test <- uj::failsafe(base::...elt(i))
if (base::isTRUE(test)) {
err <- base::paste0(uj::av(uj::failsafe(base::...elt(i + 1))), collapse = d)
if (err == "") {err <- "[unknown.error]"}
errs <- base::c(errs, err)
}
}
if (!base::is.null(errs)) {
errs <- base::unique(errs)
uj::stopperr(errs, fun = fun, stack = stack)
}
} else {uj::stopperr("There must be an even number of [...] args.")}
}
#' @rdname stopperr
#' @export
errs_if_nots <- function(..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
n <- base::...length()
if (n / 2 == base::round(n / 2)) {
errs <- NULL
for (i in 1:(n - 1)) {
test <- uj::failsafe(base::...elt(i))
if (!base::isTRUE(test)) {
err <- base::paste0(uj::av(uj::failsafe(base::...elt(i + 1))), collapse = d)
if (err == "") {err <- "[unknown.error]"}
errs <- base::c(errs, err)
}
}
if (!base::is.null(errs)) {
errs <- base::unique(errs)
uj::stopperr(errs, fun = fun, stack = stack)
}
} else {uj::stopperr("There must be an even number of [...] args.")}
}
#' @rdname stopperr
#' @export
err_if_pop <- function(..., fun = "", stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if ( base::is.na(d ) ) {d <- " "}
if (uj::is_err(fun )) {fun <- "" } else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- "" } else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
if (base::...length() > 0) {
errs <- NULL
for (i in 1:base::...length()) {
piece <- uj::failsafe(base::...elt(i))
if (!base::is.null(piece)) {
if (!uj::is_err(piece)) {errs <- base::c(errs, base::as.character(piece))}
else {errs <- base::c(errs, "")}
}
}
if (base::length(errs) > 0) {
errs <- base::paste0(errs, collapse = d)
if (errs == "") {errs <- "[unknown.error]"}
uj::stopperr(errs, fun = fun, stack = stack)
}
}
}
#' @rdname stopperr
#' @export
errs_if_pop <- function(..., fun = "", stack = "") {
if (uj::is_err(fun )) {fun <- ""} else if (!base::is.character(fun ) | base::length(fun ) != 1) {fun <- ""} else if ( base::is.na(fun ) ) {fun <- ""}
if (uj::is_err(stack)) {stack <- ""} else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- ""} else if (base::any(base::is.na(stack))) {stack <- ""}
errs <- uj::failsafe(base::list(...))
errs <- base::as.character(uj::av(errs))
errs[base::is.na(errs)] <- "[unknown.error]"
if (base::length(errs) == 1) {if (errs == "") {errs <- NULL}}
if (base::length(errs) > 0) {
errs[errs == ""] <- "[unknown.error]"
errs <- base::unique(errs)
uj::stopperr(errs, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
errs <- function(errs, stack = "") {
if (uj::is_err(stack)) {stack <- ""} else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- ""} else if (base::any(base::is.na(stack))) {stack <- ""}
errs <- base::as.character(uj::failsafe(errs))
errs <- base::trimws(base::as.character(uj::av(errs)), which = "both")
errs[base::is.na(errs)] <- "[unknown.error]"
errs[errs == ""] <- "[unknown.error]"
errs <- base::unique(errs)
fun <- uj::caller()
uj::stopperr(errs, fun = fun, stack = stack)
}
#' @rdname stopperr
#' @export
err <- function(..., stack = "", d = " ") {
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d ) | base::length(d ) != 1) {d <- " "} else if (base::is.na(d) ) {d <- " "}
if (uj::is_err(stack)) {stack <- "" } else if (!base::is.character(stack) | base::length(stack) != 1) {stack <- "" } else if (base::any(base::is.na(stack))) {stack <- ""}
err <- base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d)
err <- base::trimws(err, which = "both")
if (base::is.na(err)) {err <- "[unknown.error]"}
if (err != "" ) {err <- "[unknown.error]"}
fun <- uj::caller()
uj::stopperr(err, fun = fun, stack = stack)
}
#' @rdname stopperr
#' @export
banked_errs <- function(gens = 0) {
if ( uj::is_err(gens) ) {gens <- 0}
if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
gens <- gens + 1
if (base::exists(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)) {base::get(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)} else {NULL}
}
#' @rdname stopperr
#' @export
checkerr <- function(gens = 0) {
if (uj::is_err(gens)) {gens <- 0} else if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
gens <- gens + 1
stack <- uj::callers()
stack <- stack[gens:base::length(stack)]
if (base::exists(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)) {
fun <- uj::callerN(gens + 1)
errs <- base::get(".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F)
base::rm(list = ".ppp_ERR_BANK_ppp.", envir = base::parent.frame(gens), inherits = F);
uj::stopperr(errs, fun = fun, stack = stack)
}
}
#' @rdname stopperr
#' @export
checker <- checkerr
#' @rdname stopperr
#' @export
bankerr <- function(..., gens = 0, d = "") {
if (uj::is_err(gens)) {gens <- 0 } else if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
if (uj::is_err(d )) {d <- " "} else if (!base::is.character(d) | base::length(d) != 1) {d <- " "} else if (base::is.na(d)) {d <- " "}
gens <- gens + 1
err <- base::paste0(uj::av(uj::failsafe(base::list(...))), collapse = d)
err <- base::trimws(err, which = "both")
if (base::is.na(err)) {err <- "[unknown.error]"}
if (err == "") {err <- "[unknown.error]"}
errs <- base::c(uj::banked_errs(gens), errs)
base::assign(".ppp_ERR_BANK_ppp.", errs, envir = base::parent.frame(gens))
}
#' @rdname stopperr
#' @export
bankerrs <- function(..., gens = 0) {
if (uj::is_err(gens)) {gens <- 0} else if (!uj::.cmp_psw_scl(gens)) {gens <- 0}
gens <- gens + 1
if (base::...length() > 0) {
errs <- NULL
for (i in 1:base::...length()) {
err <- base::paste0(base::as.character(uj::av(uj::failsafe(base::...elt(i)))), collapse = "")
err <- base::trimws(err, which = "both")
if (base::is.na(err)) {err <- "[unknown.error]"}
if (err == "" ) {err <- "[unknown.error]"}
errs <- base::c(errs, err)
}
} else {errs <- "{ unknown error } "}
errs <- base::unique(base::c(uj::banked_errs(gens), errs))
base::assign(".ppp_ERR_BANK_ppp.", errs, envir = base::parent.frame(gens))
}
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.