R/import-standalone-utils-assert.R

In orderly: Lightweight Reproducible Reporting

# Standalone file: do not edit by hand
# Source: https://github.com/reside-ic/reside.utils/blob/awkward-readme/R/standalone-utils-assert.R
# Generated by: usethis::use_standalone("reside-ic/reside.utils", "utils-assert", ref = "awkward-readme")
# ----------------------------------------------------------------------
#
# ---
# repo: reside/reside.utils
# file: standalone-utils-assert.R
# imports: cli
# ---
assert_scalar <- function(x, name = deparse(substitute(x)), arg = name,
                          call = parent.frame())  {
  if (length(x) != 1) {
    cli::cli_abort(
      c("'{name}' must be a scalar",
        i = "{name} has length {length(x)}"),
      call = call, arg = arg)
  }
  invisible(x)
}


assert_character <- function(x, name = deparse(substitute(x)),
                             arg = name, call = parent.frame()) {
  if (!is.character(x)) {
    cli::cli_abort("Expected '{name}' to be character", call = call, arg = arg)
  }
  invisible(x)
}


assert_numeric <- function(x, name = deparse(substitute(x)),
                           arg = name, call = parent.frame()) {
  if (!is.numeric(x)) {
    cli::cli_abort("Expected '{name}' to be numeric", call = call, arg = arg)
  }
  invisible(x)
}


assert_integer <- function(x, name = deparse(substitute(x)),
                           tolerance = NULL, arg = name,
                           call = parent.frame()) {
  if (is.numeric(x)) {
    rx <- round(x)
    if (is.null(tolerance)) {
      tolerance <- sqrt(.Machine$double.eps)
    }
    if (!isTRUE(all.equal(x, rx, tolerance = tolerance))) {
      cli::cli_abort(
        c("Expected '{name}' to be integer",
          i = paste("{cli::qty(length(x))}The provided",
                    "{?value was/values were} numeric, but not very close",
                    "to integer values")),
        arg = arg, call = call)
    }
    x <- as.integer(rx)
  } else {
    cli::cli_abort("Expected '{name}' to be integer", call = call, arg = arg)
  }
  invisible(x)
}


assert_logical <- function(x, name = deparse(substitute(x)),
                          arg = name, call = parent.frame()) {
  if (!is.logical(x)) {
    cli::cli_abort("Expected '{name}' to be logical", arg = arg, call = call)
  }
  invisible(x)
}


assert_nonmissing <- function(x, name = deparse(substitute(x)),
                              arg = name, call = parent.frame()) {
  if (anyNA(x)) {
    cli::cli_abort("Expected '{name}' to be non-NA", arg = arg, call = call)
  }
  invisible(x)
}


assert_scalar_character <- function(x, name = deparse(substitute(x)),
                                    allow_null = FALSE,
                                    arg = name, call = parent.frame()) {
  if (allow_null && is.null(x)) {
    return(invisible(x))
  }
  assert_scalar(x, name, arg = arg, call = call)
  assert_character(x, name, arg = arg, call = call)
  assert_nonmissing(x, name, arg = arg, call = call)
}


assert_scalar_numeric <- function(x, name = deparse(substitute(x)),
                                  allow_null = FALSE,
                                  arg = name, call = parent.frame()) {
  if (allow_null && is.null(x)) {
    return(invisible(x))
  }
  assert_scalar(x, name, arg = arg, call = call)
  assert_numeric(x, name, arg = arg, call = call)
  assert_nonmissing(x, name, arg = arg, call = call)
}


assert_scalar_integer <- function(x, name = deparse(substitute(x)),
                                  tolerance = NULL, allow_null = FALSE,
                                  arg = name, call = parent.frame()) {
  if (allow_null && is.null(x)) {
    return(invisible(x))
  }
  assert_scalar(x, name, arg = arg, call = call)
  assert_integer(x, name, tolerance = tolerance, arg = arg, call = call)
  assert_nonmissing(x, name, arg = arg, call = call)
}


assert_scalar_logical <- function(x, name = deparse(substitute(x)),
                                  allow_null = FALSE,
                                  arg = name, call = parent.frame()) {
  if (allow_null && is.null(x)) {
    return(invisible(x))
  }
  assert_scalar(x, name, arg = arg, call = call)
  assert_logical(x, name, arg = arg, call = call)
  assert_nonmissing(x, name, arg = arg, call = call)
}


assert_scalar_size <- function(x, allow_zero = TRUE, allow_null = FALSE,
                               name = deparse(substitute(x)),
                               arg = name, call = parent.frame()) {
  if (allow_null && is.null(x)) {
    return(invisible(x))
  }
  assert_scalar_integer(x, name = name, arg = arg, call = call)
  assert_nonmissing(x, name, arg = arg, call = call)
  min <- if (allow_zero) 0 else 1
  if (x < min) {
    cli::cli_abort("'{name}' must be at least {min}", arg = arg, call = call)
  }
  invisible(x)
}


assert_length <- function(x, len, name = deparse(substitute(x)), arg = name,
                          call = parent.frame()) {
  if (length(x) != len) {
    cli::cli_abort(
      "Expected '{name}' to have length {len}, but was length {length(x)}",
      arg = arg, call = call)
  }
  invisible(x)
}


assert_is <- function(x, what, name = deparse(substitute(x)), arg = name,
                      call = parent.frame()) {
  if (!inherits(x, what)) {
    cli::cli_abort("Expected '{name}' to be a '{what}' object",
                   arg = arg, call = call)
  }
  invisible(x)
}


assert_list <- function(x, name = deparse(substitute(x)), arg = name,
                        call = parent.frame()) {
  if (!is.list(x)) {
    cli::cli_abort("Expected '{name}' to be a list",
                   arg = arg, call = call)
  }
  invisible(x)
}


assert_scalar_positive_numeric <- function(x, allow_zero = TRUE,
                                           name = deparse(substitute(x)),
                                           arg = name, call = parent.frame()) {
  assert_scalar_numeric(x, name = name, call = call)
  if (allow_zero) {
    if (x < 0) {
      cli::cli_abort("'{name}' must be at least 0", arg = arg, call = call)
    }
  } else {
    if (x <= 0) {
      cli::cli_abort("'{name}' must be greater than 0", arg = arg, call = call)
    }
  }
  invisible(x)
}


assert_scalar_positive_integer <- function(x, allow_zero = TRUE,
                                           name = deparse(substitute(x)),
                                           tolerance = NULL, arg = name,
                                           call = parent.frame()) {
  assert_scalar_integer(x, name, tolerance = tolerance, arg = arg, call = call)
  min <- if (allow_zero) 0 else 1
  if (x < min) {
    cli::cli_abort("'{name}' must be at least {min}", arg = arg, call = call)
  }
  invisible(x)
}


assert_raw <- function(x, len = NULL, name = deparse(substitute(x)),
                       arg = name, call = parent.frame()) {
  if (!is.raw(x)) {
    cli::cli_abort("'{name}' must be a raw vector", arg = arg, call = call)
  }
  if (!is.null(len)) {
    assert_length(x, len, name = name, call = call)
  }
  invisible(x)
}


assert_named <- function(x, unique = FALSE, name = deparse(substitute(x)),
                         arg = name, call = parent.frame()) {
  nms <- names(x)
  if (is.null(nms)) {
    cli::cli_abort("'{name}' must be named", call = call, arg = arg)
  }
  if (anyNA(nms) || any(nms == "")) {
    cli::cli_abort("All elements of '{name}' must be named",
                   call = call, arg = arg)
  }
  if (unique && anyDuplicated(names(x))) {
    dups <- sprintf("'%s'", unique(names(x)[duplicated(names(x))]))
    cli::cli_abort(
      c("'{name}' must have unique names",
        i = "Found {length(dups)} duplicate{?s}: {dups}"),
      call = call, arg = arg)
  }
  invisible(x)
}


match_value <- function(x, choices, name = deparse(substitute(x)), arg = name,
                        call = parent.frame()) {
  assert_scalar_character(x, call = call, name = name, arg = arg)
  if (!(x %in% choices)) {
    choices_str <- paste(sprintf("'%s'", choices), collapse = ", ")
    cli::cli_abort(c("'{name}' must be one of {choices_str}",
                     i = "Instead we were given '{x}'"), call = call,
                   arg = arg)
  }
  x
}