Practice with custom conditions in R

adv-R_custom-conditions.R

# practice with custom conditions
# https://adv-r.hadley.nz/conditions.html#custom-conditions
library(dplyr)
abort_bad_argument <- function(arg, must, not = NULL) {
    msg <- glue::glue("`{arg}` must {must}")
    if (!is.null(not)) {
        not <- typeof(not)
        msg <- glue::glue("{msg}; not {not}.")
    }

    rlang::abort("error_bad_argument",
          message = msg,
          arg = arg,
          must = must,
          not = not
    )
}
my_log <- function(x, base = exp(1)) {
    if (!is.numeric(x)) {
        abort_bad_argument("x", must = "be numeric", not = x)
    }
    if (!is.numeric(base)) {
        abort_bad_argument("base", must = "be numeric", not = base)
    }

    base::log(x, base = base)
}
my_log('a')
my_log(1:10, base = 'c')


bar <- function() deparse(sys.calls()[[sys.nframe()-1]])
foo <- function() bar()
foo()
(function() foo())
(function() bar())

baz <- function() sys.nframe()
baz()
bat <- function(arg) sys.call(-1)
bat(1)
bat2 <- function() bat(1)
bat2()



#' Check whether package(s) are installed
#'
#' @param ... names of packages to check
#' @return named vector with status of each packages; installed (`TRUE`) or not (`FALSE`)
#' @noRd
#' @author Kelly Sovacool \email{sovacool@@umich.edu}
#' @author Zena Lapp, \email{zenalapp@@umich.edu}
#'
#' @examples
#' check_packages_installed("base")
#' check_packages_installed("not-a-package-name")
#' all(check_packages_installed("parallel", "doFuture"))
check_packages_installed <- function(...) {
    return(sapply(c(...), requireNamespace, quietly = TRUE))
}

#' Throw error if required packages are not installed.
#'
#' Reports which packages need to be installed and the parent function name.
#' See \url{https://stackoverflow.com/questions/15595478/how-to-get-the-name-of-the-calling-function-inside-the-called-routine}
#'
#' @param package_status named vector with status of each package; installed (`TRUE`) or not (`FALSE`)
#' @noRd
#' @author Kelly Sovacool \email{sovacool@@umich.edu}
#'
#' @examples
#' abort_packages_not_installed(check_packages_installed("base"))
#' \dontrun{
#' abort_packages_not_installed(check_packages_installed(
#'   "not-a-package-name", 'caret', 'dplyr', 'non_package'))
#' }
abort_packages_not_installed <- function(package_status) {
    parent_fcn_name <- sub('\\(.*$', '\\(\\)', deparse(sys.calls()[[sys.nframe()-1]]))
    packages_not_installed <- Filter(isFALSE, package_status)
    if (length(packages_not_installed) > 0) {
        msg <- paste0('The following package(s) are required for `', parent_fcn_name,
                      '` but are not installed: \n  ',
                      paste0(names(packages_not_installed), collapse = ', '))
        stop(msg)
    }
}

#' Check that packages are installed and throw error if any are not installed
enforce1 <- function(...) {
    check_packages_installed(...) %>%
      abort_packages_not_installed()
}

#' Check that packages are installed and throw error if any are not installed
enforce2 <- function(...) {
    abort_packages_not_installed(check_packages_installed(...))
}

# the pipe counts as a function, can't use it
enforce1('asdf', 'not_a_package')

# this works
enforce2('asdf', 'not_a_package')
enforce2('caret', 'not_a_package', 'rlang')