R/assert.R

In NorwegianVeterinaryInstitute/NVIcheckmate: Extension of checkmate with argument checking adapted for NVIverse

# BSD 3-Clause License
#
# Copyright (c) 2019, Michel Lang
# Copyright (c) 2020, Dénes Tóth
# All rights reserved.
#
# The file has been imported from https://gihub.com/mllg/checkmate/R/
# Modifications
# - Square brackets in help text are escaped
#
#' Combine multiple checks into one assertion
#'
#' @description You can call this function with an arbitrary number of of
#'     \code{check*} functions, i.e. functions provided by the packages
#'     \code{checkmate}, \code{NVIcheckmate} or your own functions which
#'     return \code{TRUE} on success and the error message as
#'     \code{character(1)} otherwise.
#'
#' @details The resulting assertion is successful, if \code{combine} is
#'     \dQuote{or} (default) and at least one check evaluates to \code{TRUE}
#'     or \code{combine} is \dQuote{and} and all checks evaluate to \code{TRUE}.
#'     Otherwise, \code{assert} throws an informative error message.
#'
#' @param ... \[any\]\cr
#'  List of calls to check functions.
#' @param combine \[\code{character(1)}\]\cr
#'  \dQuote{or} or \dQuote{and} to combine the check functions with an OR
#'  or AND, respectively.
#' @template assert
#' @return Throws an error (or pushes the error message to an
#'   \code{\link{AssertCollection}} if \code{add} is not \code{NULL})
#'   if the checks fail and invisibly returns \code{TRUE} otherwise.
#' @export
#' @examples
#' x = 1:10
#' assert(checkmate::checkNull(x), checkmate::checkInteger(x, any.missing = FALSE))
#' collection <- checkmate::makeAssertCollection()
#' assert(checkmate::checkChoice(x, c("a", "b")), checkmate::checkDataFrame(x), add = collection)
#' collection$getMessages()
assert = function(..., combine = "or", .var.name = NULL, comment = NULL, add = NULL) {
  checkmate::assertChoice(x = combine, choices = c("or", "and"))
  checkmate::assertClass(x = add, classes = "AssertCollection", .var.name = "add", null.ok = TRUE)
  dots = match.call(expand.dots = FALSE)$...
  checkmate::assertCharacter(x = .var.name, null.ok = TRUE, min.len = 1L, max.len = length(dots))
  env = parent.frame()
  if (combine == "or") {
    msgs = character(length(dots))
    for (i in seq_along(dots)) {
      val = eval(dots[[i]], envir = env)
      if (isTRUE(val))
        return(invisible(TRUE))
      msgs[i] = as.character(val)
    }
    if (is.null(.var.name))
      .var.name = vapply(dots, function(x) as.character(x)[2L], FUN.VALUE = NA_character_)
    if (length(msgs) > 1L) {
      msgs = sprintf("%s(%s): %s", vapply(dots, function(x) as.character(x)[1L], FUN.VALUE = NA_character_), .var.name, msgs)
      msgs = paste0(c("One of the following must apply:", strwrap(msgs, prefix = " * ")), collapse = "\n")
    }
    if (!is.null(comment)) {msgs = paste(paste0(msgs, '.'), comment, sep = "\n")}
    mstopOrPush(res = msgs, v_name = .var.name, collection = add)
  } else {
    for (i in seq_along(dots)) {
      val = eval(dots[[i]], envir = env)
      if (!isTRUE(val)) {
        if (is.null(.var.name))
          .var.name = as.character(dots[[i]])[2L]
        if (!is.null(comment)) {val = paste0(val, '. ', comment)}
        mstopOrPush(res = val, v_name = .var.name, collection = add)
      }
    }
  }
  invisible(TRUE)
}

# Error handling in assert()
#
# Internal helper function to handle errors in assert().
# @param res [character(1)}]\cr
#   error message
# @param v_name [\code{character}]\cr
#   Name(s) of the variable(s) whose assertion failed.
# @param collection [\code{AssertCollection} | \code{NULL}]\cr
#   See AssertCollection.
# @return mstopOrPush() throws an exception by calling
#   mstop() if 'collection' is NULL, or
#   pushes the error message to the collection otherwise.
# @keywords internal
mstopOrPush = function(res, v_name, collection = NULL) {
  if (!is.null(collection)) {
    v_name = sort(unique(v_name))
    prefix =
      if (length(v_name) > 1L) {
        sprintf(
          "Variables %s",
          paste0(shQuote(v_name), collapse = ", ")
        )
      } else {
        sprintf("Variable '%s'", v_name)
      }
    collection$push(sprintf("%s: %s.", prefix, res))
  } else if (length(v_name) > 1L) {
    mstop("Assertion failed. %s", res)
  } else {
    mstop("Assertion on '%s' failed: %s.", v_name, res)
  }
}