R/standalone-assertions_handlers.R

In prioritizr: Systematic Conservation Prioritization in R

# ---
# repo: prioritizr/prioritizr
# file: standalone-assertions_handlers.R
# imports: [assertthat (>= 0.2.0), cli (>= 3.6.0), rlang (>= 1.1.0)]
# ---

#' Assert that a condition is met
#'
#' Assert if an assertion is met and throw a [base::warning()] if it
#' is not. This function is equivalent to [assertthat::assert_that()]
#' except that it uses [rlang::abort()].
#'
#' @param x `logical` condition.
#'
#' @param env `environment` passed to [assertthat::validate_that].
#'   Defaults to [parent.frame()].
#'
#' @param call `environment` for call. Defaults to `fn_caller_env()`.
#'
#' @param .internal `logical` passed to [cli::cli_abort].
#'
#' @details
#' The function will throw warnings if any of the conditions are not met.
#'
#' @return A `logical` value.
#'
#' @noRd
assert <- function(..., env = parent.frame(), call = fn_caller_env(),
                   .internal = FALSE) {
  # check if assertions met
  res <- assertthat::validate_that(..., env = env)
  # if res is TRUE, then return success
  if (isTRUE(res)) return(TRUE)
  # if not TRUE, then res should be a character vector with the error message,
  # so now we will format it following tidyverse style guide
  res <- format_assertthat_msg(res)
  # throw error
  cli::cli_abort(res, call = call, .envir = env, .internal = .internal)
}

#' Verify if a condition is met
#'
#' Verify if an condition is met and throw a [base::warning()] if it
#' is not. This function is equivalent to [assertthat::assert_that()]
#' except that it uses [rlang::warn()].
#'
#' @param x `logical` condition.
#'
#' @param env `environment` passed to [assertthat::validate_that].
#'   Defaults to [parent.frame()].
#'
#' @param call `environment` for call. Defaults to `fn_caller_env()`.
#'
#' @details
#' The function will throw warnings if any of the conditions are not met.
#'
#' @return A `logical` value.
#'
#' @noRd
verify <- function(..., env = parent.frame(), call = fn_caller_env()) {
  # check if assertions met
  res <- assertthat::validate_that(..., env = env)
  # if res is TRUE, then return success
  if (isTRUE(res)) return(invisible(TRUE))
  # if not TRUE, then res should be a character vector with the error message,
  # so now we will format it following tidyverse style guide
  res <- format_assertthat_msg(res)
  # replace "must" with descriptions,
  # because verify() is used to indicate valid -- but likely mistaken -- inputs
  res <- gsub("must not have", "has", res, fixed = TRUE)
  res <- gsub("must have", "does not have", res, fixed = TRUE)
  # if first warning message does not have a symbol,
  # then give it one by default
  if (is.null(names(res)) || !nzchar(names(res)[[1]])) {
    names(res)[[1]] <- ">"
  }
  # throw warning
  rlang::warn(
    cli::format_warning(res, .envir = call),
    call = call
  )
  # return result
  invisible(FALSE)
}

#' Format error message from \pkg{assertthat} package
#'
#' Format an error message generated by the \pkg{assertthat} package.
#'
#' @param x `character` vector.
#'
#' @details
#' The primary usage for this function is to standardize
#' messages displayed by `assert()` and `verify()`.
#'
#' @return A `character` vector.
#'
#' @noRd
format_assertthat_msg <- function(x) {
  # add a full stop to end of message if needed
  idx <-
    !endsWith(x, ".") &
    (nchar(x) > 0) &
    !endsWith(x, "\n") &
    !endsWith(x, "\f") &
    !endsWith(x, "?") &
    !endsWith(x, "!") &
    !endsWith(x, ":")
  if (any(idx)) {
    x[idx] <- paste0(x[idx], ".")
  }
  # format the arguments for cli
  if (
    !isTRUE(grepl("{", x, fixed = TRUE)) &&
    (
      isTRUE(grepl(" is not a ", x, TRUE)) ||
      isTRUE(grepl(" does not have ", x, TRUE))
    )
  ) {
    x <- paste0("{.arg ", sub(" ", "} ", x, fixed = TRUE))
  }
  # return result
  x
}

#' Error prefix handler
#'
#' Wrap an error message.
#'
#' @param expr Expression.
#'
#' @param prefix `character` vector with error prefix.
#'
#' @inheritParams assert
#'
#' @return An invisible `logical` value.
#'
#' @noRd
error_prefix_handler <- function(expr, prefix, call = fn_caller_env()) {
  # try to evaluate expression
  x <- rlang::try_fetch(expr, error = function(cnd) cnd)
  # if success, then return result
  if (!inherits(x, "error")) return(x)
  # otherwise, extract the error message
  x <- x$message
  # add in bullet point formatting to error message
  if (is.null(names(x))) {
    names(x) <- rep("x", length(x))
  }
  # nocov start
  if (anyNA(names(x))) {
    names(x)[is.na(x)] <- "x"
  }
  # nocov end
  # throw error message
  cli::cli_abort(c(prefix, x), call = call)
}

#' Get properties of the calling environment
#'
#' This is a wrapper for [rlang::caller_env()] that is designed to
#' skip local environments to provide meaningful information in error
#' messages.
#'
#' @param n `integer` value. Defaults to 1.
#'
#' @return An `environment` object.
#'
#' @noRd
fn_caller_env <- function(n = 1) {
  call <- parent.frame(n + 1)
  nm <- as.character(rlang::frame_call(call))
  if (
    (length(nm) > 0) &&
    identical(nm[[1]], ".local")
  ) {
    call <- parent.frame(n = n + 2)
  }
  call
}

#' Get properties of the current environment
#'
#' This is a wrapper for [rlang::current_env()] that is designed to
#' skip local environments to provide meaningful information in error
#' messages.
#'
#' @param n `integer` value. Defaults to 1.
#'
#' @return An `environment` object.
#'
#' @noRd
fn_current_env <- function() {
  call <- parent.frame()
  nm <- as.character(rlang::frame_call(call))
  if (
    (length(nm) > 0) &&
    identical(nm[[1]], ".local")
  ) {
    call <- parent.frame(n = 2)
  }
  call
}