#### HELPER FUNCTIONS ####################################################################
#------------------------------------------------
# for single value, return value as string. For vector of values return string
# of comma-separated values enclosed in curly brackets
#' @noRd
nice_format <- function(x) {
if (is.null(x)) {
return("")
}
if (length(x)==1) {
ret <- as.character(x)
} else {
ret <- paste0("{", paste(x, collapse = ", "), "}")
}
return(ret)
}
#### BASIC OBJECT TYPES ####################################################################
# messages should be NULL with the default speficied within function
#------------------------------------------------
# x is NULL
#' @noRd
assert_null <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be null", name)
}
if (!is.null(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is not NULL
#' @noRd
assert_non_null <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s cannot be null", name)
}
if (is.null(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is NA
#' @noRd
assert_NA <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be NA", name)
}
assert_non_null(x, name = name, message = message)
if (!all(is.na(x))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is not NA
#' @noRd
assert_non_NA <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s cannot be NA", name)
}
if (any(is.na(x))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is atomic
#' @noRd
assert_atomic <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be atomic (see ?is.atomic)", name)
}
if (!is.atomic(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is character string
#' @noRd
assert_string <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a character string", name)
}
if (!is.character(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is logical
#' @noRd
assert_logical <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be logical", name)
}
if (!is.logical(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is numeric
#' @noRd
assert_numeric <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be numeric", name)
}
if (!is.numeric(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is integer
#' @noRd
assert_int <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be integer valued", name)
}
assert_numeric(x, name = name, message = message)
if (!isTRUE(all.equal(x, round(x), check.attributes = FALSE))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is integer and within C++ int limits
#' @noRd
assert_cpp_int <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be integer valued and within C++ integer limits (-2147483649 > x < 2147483648)", name)
}
assert_int(x, name = name, message = message)
assert_gr(x, -2147483649, name_x = name, message = message)
assert_le(x, 2147483648, name_x = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is positive (with or without zero allowed)
#' @noRd
assert_pos <- function(x, zero_allowed = TRUE, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be greater than or equal to zero", name)
} else {
message <- sprintf("%s must be greater than zero", name)
}
}
assert_numeric(x, name = name, message = message)
if (zero_allowed) {
if (!all(x >= 0)) {
stop(message, call. = FALSE)
}
} else {
if (!all(x > 0)) {
stop(message, call. = FALSE)
}
}
return(TRUE)
}
#------------------------------------------------
# x is a vector (and is not a list or another recursive type)
#' @noRd
assert_vector <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a non-recursive vector", name)
}
if (!is.vector(x) || is.recursive(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is a matrix
#' @noRd
assert_matrix <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a matrix", name)
}
if (!is.matrix(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is a list
assert_list <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a list", name)
}
if (!is.list(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is named
assert_named <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be named", name)
}
if (is.null(names(x))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is a data frame
assert_dataframe <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a data frame", name)
}
if (!is.data.frame(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x inherits from class c
assert_class <- function(x, c, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must inherit from class '%s'", name, c)
}
if (!inherits(x, c)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#### COMPOUND OBJECT TYPES ####################################################################
# messages should be NULL, allowing them to be propagated through to more
# elementary levels
#------------------------------------------------
# x is atomic and single valued (has length 1)
#' @noRd
assert_single <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single value (atomic and of length 1)", name)
}
assert_non_null(x, name = name, message = message)
assert_atomic(x, name = name, message = message)
assert_length(x, 1, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single character string
#' @noRd
assert_single_string <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single character string", name)
}
assert_length(x, n = 1, name = name, message = message)
assert_string(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single logical
#' @noRd
assert_single_logical <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single logical value", name)
}
assert_length(x, n = 1, name = name, message = message)
assert_logical(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single numeric
#' @noRd
assert_single_numeric <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single numeric value", name)
}
assert_length(x, n = 1, name = name, message = message)
assert_numeric(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single integer
#' @noRd
assert_single_int <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single integer", name)
}
assert_length(x, n = 1, name = name, message = message)
assert_int(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single integer and within C++ int limits
#' @noRd
assert_single_cpp_int <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single integer and within C++ integer limits (-2147483649 > x < 2147483648)", name)
}
assert_single_int(x, name = name, message = message)
assert_gr(x, -2147483649, name_x = name, message = message)
assert_le(x, 2147483648, name_x = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single positive (with or without zero allowed)
#' @noRd
assert_single_pos <- function(x, zero_allowed = TRUE, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a single positive value or zero", name)
} else {
message <- sprintf("%s must be a single positive value", name)
}
}
assert_length(x, n = 1, name = name, message = message)
assert_pos(x, zero_allowed = zero_allowed, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is positive integer (with or without zero allowed)
#' @noRd
assert_pos_int <- function(x, zero_allowed = TRUE, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a positive integer or zero", name)
} else {
message <- sprintf("%s must be a positive integer", name)
}
}
assert_int(x, name = name, message = message)
assert_pos(x, zero_allowed = zero_allowed, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is positive integer (with or without zero allowed) and within C++ int limits
#' @noRd
assert_pos_cpp_int <- function(x, zero_allowed = TRUE, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a positive integer or zero and within C++ integer limits (< 2147483648)", name)
} else {
message <- sprintf("%s must be a positive integer and within C++ integer limits (< 2147483648)", name)
}
}
assert_pos_int(x, zero_allowed = zero_allowed, name = name, message = message)
assert_le(x, 2147483648, name_x = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single positive integer (with or without zero allowed)
#' @noRd
assert_single_pos_int <- function(x, zero_allowed = TRUE, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a single positive integer or zero", name)
} else {
message <- sprintf("%s must be a single positive integer", name)
}
}
assert_length(x, n = 1, name = name, message = message)
assert_pos_int(x, zero_allowed = zero_allowed, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single positive integer (with or without zero allowed) and within C++ int limits
#' @noRd
assert_single_pos_cpp_int <- function(x, zero_allowed = TRUE, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a single positive integer or zeroand within C++ integer limits (< 2147483648)", name)
} else {
message <- sprintf("%s must be a single positive integer and within C++ integer limits (< 2147483648)", name)
}
}
assert_single_pos_int(x, zero_allowed = zero_allowed, name = name, message = message)
assert_le(x, 2147483648, name_x = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is single value bounded between limits
#' @noRd
assert_single_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a single value bounded between %s and %s", name, left, right)
}
assert_length(x, n = 1, name = name, message = message)
assert_bounded(x, left = left, right = right,
inclusive_left = inclusive_left, inclusive_right = inclusive_right,
message = message,
name = name)
return(TRUE)
}
#------------------------------------------------
# x is a logical (boolean) vector
#' @noRd
assert_vector_logical <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a boolean vector", name)
}
assert_logical(x, name = name, message = message)
assert_vector(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a numeric vector
#' @noRd
assert_vector_numeric <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a numeric vector", name)
}
assert_numeric(x, name = name, message = message)
assert_vector(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a vector of integers
#' @noRd
assert_vector_int <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a vector of integers", name)
}
assert_int(x, name = name, message = message)
assert_vector(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a vector of positive values
#' @noRd
assert_vector_pos <- function(x, zero_allowed = TRUE,
message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a vector of positive values or zero", name)
} else {
message <- sprintf("%s must be a vector of positive values", name)
}
}
assert_pos(x, zero_allowed = zero_allowed, name = name, message = message)
assert_vector(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a vector of positive integers
#' @noRd
assert_vector_pos_int <- function(x, zero_allowed = TRUE,
message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
if (zero_allowed) {
message <- sprintf("%s must be a vector of positive integers or zero", name)
} else {
message <- sprintf("%s must be a vector of positive integers", name)
}
}
assert_pos(x, zero_allowed = zero_allowed, name = name, message = message)
assert_vector(x, name = name, message = message)
assert_int(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a vector of bounded values
#' @noRd
assert_vector_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a vector of values bounded between %s and %s", name, left, right)
}
assert_vector(x, name = name, message = message)
assert_bounded(x, left = left, right = right,
inclusive_left = inclusive_left, inclusive_right = inclusive_right,
message = message,
name = name)
return(TRUE)
}
#------------------------------------------------
# x is a vector of strings
#' @noRd
assert_vector_string <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a vector of character strings", name)
}
assert_vector(x, name = name, message = message)
assert_string(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a matrix of numeric values
#' @noRd
assert_matrix_numeric <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a matrix of numeric values", name)
}
assert_matrix(x, name = name, message = message)
assert_numeric(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a named list
assert_list_named <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a named list", name)
}
assert_named(x, name = name, message = message)
assert_list(x, name = name, message = message)
return(TRUE)
}
#------------------------------------------------
# x is a plotting limit, i.e. contains two increasing values
assert_limit <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be vector of two increasing values", name)
}
assert_vector(x, name = name, message = message)
assert_length(x, 2, name = name, message = message)
assert_numeric(x, name = name, message = message)
assert_increasing(x, name = name, message = message)
return(TRUE)
}
#### VALUE COMPARISONS ####################################################################
#------------------------------------------------
# x and y are equal in all matched comparisons. x and y can be any type
#' @noRd
assert_eq <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("%s must equal %s", name_x, name_y)
}
assert_non_null(x, name = name_x, message = message)
assert_non_null(y, name = name_y, message = message)
assert_same_length(x, y, name_x = name_x, name_y = name_y, message = message)
if (!isTRUE(all.equal(x, y, check.attributes = FALSE))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x and y are unequal in all matched comparisons. x and y can be any type
#' @noRd
assert_neq <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("%s cannot equal %s", name_x, name_y)
}
assert_non_null(x, name = name_x, message = message)
assert_non_null(y, name = name_y, message = message)
assert_same_length(x, y, name_x = name_x, name_y = name_y, message = message)
if (any(x == y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is greater than y in all matched comparisons
#' @noRd
assert_gr <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""),
name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be greater than %s", name_x, name_y)
}
assert_numeric(x, name = name_x, message = message)
assert_numeric(y, name = name_y, message = message)
assert_in(length(y), c(1, length(x)), message = message)
if (!all(x > y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is greater than or equal to y in all matched comparisons
#' @noRd
assert_greq <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""),
name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be greater than or equal to %s", name_x, name_y)
}
assert_numeric(x, name = name_x, message = message)
assert_numeric(y, name = name_y, message = message)
assert_in(length(y), c(1, length(x)), message = message)
if (!all(x >= y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is less than y in all matched comparisons
#' @noRd
assert_le <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""),
name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be less than %s", name_x, name_y)
}
assert_numeric(x, name = name_x, message = message)
assert_numeric(y, name = name_y, message = message)
assert_in(length(y), c(1, length(x)), message = message)
if (!all(x < y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is less than or equal to y in all matched comparisons
#' @noRd
assert_leq <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""),
name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be less than or equal to %s", name_x, name_y)
}
assert_numeric(x, name = name_x, message = message)
assert_numeric(y, name = name_y, message = message)
assert_in(length(y), c(1, length(x)), message = message)
if (!all(x <= y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is between bounds (inclusive or exclusive)
#' @noRd
assert_bounded <- function(x, left = 0, right = 1, inclusive_left = TRUE, inclusive_right = TRUE,
message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
if (inclusive_left) {
assert_greq(x, left, name_x = name, message = message)
} else {
assert_gr(x, left, name_x = name, message = message)
}
if (inclusive_right) {
assert_leq(x, right, name_x = name, message = message)
} else {
assert_le(x, right, name_x = name, message = message)
}
return(TRUE)
}
#------------------------------------------------
# all x are in y
#' @noRd
assert_in <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("all %s must be in %s", name_x, name_y)
}
assert_non_null(x, name = name_x, message = message)
assert_non_null(y, name = name_y, message = message)
if (!all(x %in% y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# none of x are in y
#' @noRd
assert_not_in <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""), name_y = nice_format(y)) {
# default message
if (is.null(message)) {
message <- sprintf("none of %s can be in %s", name_x, name_y)
}
assert_non_null(x, name = name_x, message = message)
assert_non_null(y, name = name_y, message = message)
if (any(x %in% y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#### DIMENSIONS ####################################################################
#------------------------------------------------
# length(x) equals n
#' @noRd
assert_length <- function(x, n, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be of length %s", name, n)
}
assert_pos_int(n, name = name, message = message)
if (length(x) != n[1]) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x and y are same length
#' @noRd
assert_same_length <- function(x, y, message = NULL,
name_x = paste(deparse(substitute(x)), collapse = ""),
name_y = paste(deparse(substitute(y)))) {
# default message
if (is.null(message)) {
message <- sprintf("%s and %s must be the same length", name_x, name_y)
}
if (length(x) != length(y)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# multiple objects all same length
#' @noRd
assert_same_length_multiple <- function(...) {
l <- mapply(length, list(...))
if (length(unique(l)) != 1) {
l_names <- sapply(match.call(expand.dots = FALSE)$..., deparse)
stop(sprintf("variables %s must be the same length", nice_format(l_names)), call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is two-dimensional
#' @noRd
assert_2d <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be two-dimensional", name)
}
is_2d <- FALSE
if (!is.null(dim(x))) {
is_2d <- (length(dim(x)) == 2)
}
if (!is_2d) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# nrow(x) equals n
#' @noRd
assert_nrow <- function(x, n, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must have %s rows", name, n)
}
assert_2d(x, name = name, message = message)
if (nrow(x) != n) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# ncol(x) equals n
#' @noRd
assert_ncol <- function(x, n, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must have %s cols", name, n)
}
assert_2d(x, name = name, message = message)
if (ncol(x) != n) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# dim(x) equals y
#' @noRd
assert_dim <- function(x, y, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must have %s rows and %s columns", name, y[1], y[2])
}
assert_2d(x, name = name, message = message)
assert_pos_int(y, name = name, message = message)
assert_length(y, 2, name = name, message = message)
if (nrow(x) != y[1] | ncol(x) != y[2]) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is square matrix
#' @noRd
assert_square_matrix <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a square matrix", name)
}
assert_matrix(x, name = name, message = message)
if (nrow(x) != ncol(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# is symmetric matrix
#' @noRd
assert_symmetric_matrix <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a symmetric matrix", name)
}
assert_square_matrix(x, name = name, message = message)
if (!isSymmetric(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#### MISC ####################################################################
#------------------------------------------------
# x contains no duplicates
#' @noRd
assert_noduplicates <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must contain no duplicates", name)
}
if (any(duplicated(x))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# file exists at chosen path
#' @noRd
assert_file_exists <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be a string defining a file that exists at that path", name)
}
assert_single_string(x, name = name, message = message)
if (!file.exists(x)) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is increasing
#' @noRd
assert_increasing <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be increasing", name)
}
assert_non_null(x, name = name, message = message)
assert_numeric(x, name = name, message = message)
if (!isTRUE(all.equal(x, sort(x)))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
#------------------------------------------------
# x is decreasing
#' @noRd
assert_decreasing <- function(x, message = NULL,
name = paste(deparse(substitute(x)), collapse = "")) {
# default message
if (is.null(message)) {
message <- sprintf("%s must be decreasing", name)
}
assert_non_null(x, name = name, message = message)
assert_numeric(x, name = name, message = message)
if (!isTRUE(all.equal(x, sort(x, decreasing = TRUE)))) {
stop(message, call. = FALSE)
}
return(TRUE)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.