Example functions to check inputs to a parent function, using {cli} for better messaging and {rlang} for dot collection and to prevent an 'error handling eclipse'

input-checks-rlang-cli.R

#' Check Class of Argument Inputs
#' @param ... Objects to be checked for class.
#' @param .expected_class Character. The name of the class against which objects
#' @param .call Environment. The environment in which this function is called.
#'     will be checked.
#' @noRd
check_class <- function(
    ...,
    .expected_class = c("numeric", "character"),
    .call = rlang::caller_env()
) {

  .expected_class <- match.arg(.expected_class)

  args <- rlang::dots_list(..., .named = TRUE)

  args_are_class <- lapply(
    args,
    function(arg) {
      switch(
        .expected_class,
        numeric   = is.numeric(arg),
        character = is.character(arg),
      )
    }
  )

  fails_names <- names(Filter(isFALSE, args_are_class))

  if (length(fails_names) > 0) {

    fails <- args[names(args) %in% fails_names]
    fails_classes <- sapply(fails, class)

    fails_bullets <- setNames(
      paste0(
        "{.var ", names(fails_classes), "} with class {.cls ",
        fails_classes, "}"
      ),
      rep("*", length(fails_classes))
    )

    cli::cli_abort(
      message = c(
        "{.var {fails_names}} must be of class {.cls {(.expected_class)}}",
        x = "You provided:",
        fails_bullets
      ),
      call = .call
    )
  }

}

#' Check if Vector Length is a Multiple of a Shorter Vector
#' @param ... Vectors to be compared for length.
#' @param .call Environment. The environment in which this function is called.
#' @noRd
check_lengths <- function(..., .call = rlang::caller_env()) {

  args <- rlang::dots_list(..., .named = TRUE)
  args_lengths <- lapply(args, length)

  pairs <- combn(args_lengths, 2, simplify = FALSE)

  fails <- lapply(pairs, function(x) max(unlist(x)) %% min(unlist(x)) != 0)

  if (any(unlist(fails))) {

    fails_i <- which(unlist(fails))
    fails_pairs <- lapply(pairs[fails_i], unlist)

    fails_bullets <- lapply(
      fails_pairs,
      function(x) {
        x <- sort(x, decreasing = TRUE)
        paste0(
          "{.var ", names(x[1]), "} has length ", x[1],
          " but ",
          "{.var ", names(x[2]), "} has length ", x[2]
        )
      }
    )

    names(fails_bullets) <- rep("*", length(fails_bullets))

    cli::cli_warn(
      c(
        i = "Longer object length is not a multiple of shorter object length.",
        i = "Vectors were recycled with some values left over.",
        i = "This occurred because:",
        unlist(fails_bullets)
      ),
      call = .call
    )

  }

}