R/chk-functions.R

In cobalt: Covariate Balance Tables and Plots

# Functions for clean argument checking. These are based on {chk} but
# with several modifications to ensure correct and clean printing. These revolve
# around pkg_caller_call(), which tells chk::err() which *user-facing* function
# the error occurred in.

# pkg_caller_call() searches along the call stack to find the function from this
# package that the user called. It gets a list of functions and methods exported
# by this package, moves along the call stack, and returns the call of the
# highest level function that is in this package.
pkg_caller_call <- function(start = 1) {
    package.funs <- c(getNamespaceExports(utils::packageName()),
                      .getNamespaceInfo(asNamespace(utils::packageName()), "S3methods")[, 3])
    e_max <- start
    
    for (k in start:length(sys.calls())) {
        e <- rlang::caller_call(k)
        if (!is.null(e) &&
            !is.null(n <- rlang::call_name(e)) &&
            n %in% package.funs) e_max <- k
    }
    rlang::caller_call(e_max)
}

# .err() is a version of chk::err() that uses pkg_caller_call() to get the correct function
# call since chk::err() has a default that doesn't always work. .wrn() and .msg()
# just call chk::wrn() and chk::msg() but make the syntax consistent.
.err <- function(...) {
    chk::err(..., call = pkg_caller_call(start = 2))
}
.wrn <- function(...) {
    chk::wrn(...)
}
.msg <- function(...) {
    chk::msg(...)
}

# Kind of insane loop to create (at build time) version of all .chk_*
# functions that use .err() instead of chk::abort_chk() internally. All
# .chk_* function now have a version like .chk_*, e.g., .chk_flag(),
# that can be used in package code instead of the chk version.
for (i in getNamespaceExports("chk")) {
    if (!startsWith(i, "chk_")) next
    assign(paste0(".", i), eval(str2expression(sprintf(
        "function(...) {
            tryCatch(chk::%s(...),
                     error = function(e) .err(conditionMessage(e)))
        }", i
    ))))
}

# Version of .chk_null_or() that isn't bugged.
.chk_null_or <- function(x, chk, ..., x_name = NULL) {
    if (is.null(x_name)) {
        x_name <- deparse1(substitute(x))
    }
    
    x_name <- add_quotes(x_name, "`")
    
    if (is.null(x)) {
        return(invisible(x))
    }
    
    tryCatch(chk(x, ..., x_name = x_name),
             error = function(e) {
                 msg <- sub("[.]$", " or `NULL`.",
                            conditionMessage(e))
                 .err(msg, .subclass = "chk_error")
             })
}

.chk_formula <- function(x, sides = NULL, x_name = NULL) {
    if (is.null(sides)) {
        if (rlang::is_formula(x)) {
            return(invisible(x))
        }
        if (is.null(x_name)) {
            x_name <- chk::deparse_backtick_chk(substitute(x))
        }
        .err(x_name, " must be a formula",
             x = x)
    }
    else if (sides == 1) {
        if (rlang::is_formula(x, lhs = FALSE)) {
            return(invisible(x))
        }
        if (is.null(x_name)) {
            x_name <- chk::deparse_backtick_chk(substitute(x))
        }
        .err(x_name, " must be a formula with no left-hand side",
             x = x)
    }
    else if (sides == 2) {
        if (rlang::is_formula(x, lhs = TRUE)) {
            return(invisible(x))
        }
        if (is.null(x_name)) {
            x_name <- chk::deparse_backtick_chk(substitute(x))
        }
        .err(x_name, " must be a formula with a left-hand side",
                       x = x)
    }
    else stop("`sides` must be NULL, 1, or 2")
}