Nothing
#' Assert that an input is a vector/list with desired properties
#'
#' @param x A vector/list. The input to be analysed.
#' @param class A string. The class that this input should inherit from.
#' @param len An integer. The length of the vector. If `NULL`, length is not
#' checked.
#' @param null_ok A logical. Whether the input could also be `NULL`.
#' @param var_name A string. The name of the variable in the informative
#' message. If `NULL`, the name is guessed from the function call.
#' @param subset_of A character vector. If `x` is a character vector, specifies
#' which values it can take. If `NULL`, values are not checked.
#' @param named A logical. Whether the input should be a named vector/list. If
#' `FALSE` this check is not enforced (i.e. the input object can be named even
#' if named is `FALSE`).
#' @param n_call A negative integer. The number of frames to go back to find the
#' call to associate the error generated by the function with. Defaults to the
#' parent frame (-1). This argument is only relevant to other assertion
#' functions that build on top of this one.
#'
#' @return `TRUE` if the check is successful. Throws an error describing the
#' issue with the input otherwise.
#'
#' @family input assertion
#'
#' @keywords internal
assert_vector <- function(x,
class,
len = NULL,
null_ok = FALSE,
var_name = NULL,
subset_of = NULL,
named = FALSE,
n_call = -1L) {
# basic input checking
if (!(is.character(class) && length(class) == 1)) {
error_bad_class_argument()
}
if (!is.null(len) && !(is.integer(len) && length(len) == 1)) {
error_bad_len_argument()
}
if (!(is.logical(null_ok) && length(null_ok) == 1)) {
error_bad_null_ok_argument()
}
if (!is.null(var_name) && !(is.character(var_name) && length(var_name) == 1))
error_bad_var_name_argument()
if (!is.null(subset_of) && !is.character(subset_of)) {
error_bad_subset_of_argument()
}
if (!(is.logical(named) && length(named) == 1)) {
error_bad_named_argument()
}
if (!(is.integer(n_call) && length(n_call) == 1 && n_call < 0)) {
error_bad_n_call_argument()
}
# construct input_name either from 'var_name' or from function call
current_call <- sys.call(0)
input_name <- as.character(current_call[[2]])
if (!is.null(var_name)) input_name <- var_name
# objects to create the gtfsio_error
error_call <- sys.call(n_call)
input_error_class <- paste0("bad_", input_name, "_argument")
input_name <- paste0("'", input_name, "'")
vector_name <- ifelse(
class == "list",
"a list.",
paste0("a(n) ", class, " vector.")
)
# check against desired properties
# the complicated logical condition below checks for the possibility of 'x'
# being NULL if null_ok is TRUE.
# also, it always consider NAs not ok, even when looking at logical vectors
if ((!inherits(x, class) && null_ok && !is.null(x))
|| (!inherits(x, class) && !null_ok)
|| (is.logical(x) && any(is.na(x)))) {
error_x_wrong_class(input_name, vector_name, input_error_class, error_call)
}
if (!is.null(len) && len != length(x)) {
error_x_wrong_length(input_name, len, input_error_class, error_call)
}
if (!is.null(subset_of) && (is.character(x) && any(! x %in% subset_of))) {
error_x_wrong_value(input_name, subset_of, input_error_class, error_call)
}
vector_name2 <- ifelse(class == "list", "list.", paste0(class, " vector."))
if (named && is.null(names(x)) && !is.null(x)) {
error_x_not_named(input_name, vector_name2, input_error_class, error_call)
}
non_empty_names <- names(x)[! names(x) %chin% ""]
if (named && (!is.null(names(x)) && length(non_empty_names) != length(x))) {
error_x_not_fully_named(input_name, input_error_class, error_call)
}
invisible(TRUE)
}
#' @rdname assert_vector
#' @family input assertion
#' @keywords internal
assert_list <- function(x, len = NULL, null_ok = FALSE, named = FALSE) {
# input checks are all conducted inside assert_vector()
call <- sys.call(0)
var_name <- as.character(call[[2]])
assert_vector(
x,
"list",
len = len,
null_ok = null_ok,
var_name = var_name,
named = named,
n_call = -2L
)
}
#' @rdname assert_vector
#' @family input assertion
#' @keywords internal
assert_class <- function(x, class, n_call = -1) {
assert_vector(class, "character")
# construct input_name from function call
current_call <- sys.call(0)
input_name <- as.character(current_call[[2]])
# objects to create the gtfsio_error
error_call <- sys.call(n_call)
input_error_class <- paste0("bad_", input_name, "_argument")
input_name <- paste0("'", input_name, "'")
# check against desired properties
if (!(all(inherits(x, class, which = TRUE)))) {
error_x_wrong_inheritance(input_name, class, input_error_class, error_call)
}
invisible(TRUE)
}
# errors ------------------------------------------------------------------
#' @include gtfsio_error.R
error_bad_class_argument <- parent_function_error(
"'class' must be a string.",
subclass = "bad_class_argument"
)
error_bad_len_argument <- parent_function_error(
"'length' must be an integer vector with length 1.",
subclass = "bad_len_argument"
)
error_bad_null_ok_argument <- parent_function_error(
"'null_ok' must be a logical vector with length 1.",
subclass = "bad_null_ok_argument"
)
error_bad_var_name_argument <- parent_function_error(
"'var_name' must be a string.",
subclass = "bad_var_name_argument"
)
error_bad_subset_of_argument <- parent_function_error(
"'subset_of' must be a character vector.",
subclass = "bad_subset_of_argument"
)
error_bad_named_argument <- parent_function_error(
"'named' must be a logical vector with length 1.",
subclass = "bad_named_argument"
)
error_bad_n_call_argument <- parent_function_error(
"'n_call' must be a negative integer.",
subclass = "bad_n_call_argument"
)
error_x_wrong_class <- function(input_name,
vector_name,
input_error_class,
error_call) {
gtfsio_error(
paste0(input_name, " must be ", vector_name),
input_error_class,
error_call
)
}
error_x_wrong_length <- function(input_name,
len,
input_error_class,
error_call) {
gtfsio_error(
paste0(input_name, " must have length ", len, "."),
input_error_class,
error_call
)
}
error_x_wrong_value <- function(input_name,
subset_of,
input_error_class,
error_call) {
gtfsio_error(
paste0(
input_name,
" must be a subset of [",
paste(paste0("'", subset_of, "'"), collapse = ", "),
"]."
),
input_error_class,
error_call
)
}
error_x_not_named <- function(input_name,
vector_name2,
input_error_class,
error_call) {
gtfsio_error(
paste0(input_name, " must be a named ", vector_name2),
input_error_class,
error_call
)
}
error_x_not_fully_named <- function(input_name, input_error_class, error_call) {
gtfsio_error(
paste0("Every element in ", input_name, " must be named."),
input_error_class,
error_call
)
}
error_x_wrong_inheritance <- function(input_name,
class,
input_error_class,
error_call) {
gtfsio_error(
paste0(
input_name, " must inherit from the ",
paste0("'", class, "'", collapse = ", "),
" class."
),
input_error_class,
error_call
)
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.