#' A function for input validation
#'
#' @param obj The object that undergoes validation
#' @param argument_name A string indicating the name of the object
#' This name is used when an error is thrown so the user
#' is informed on the cause of the error.
#' @param class_string A character vector of legal classes. If
#' \code{class_string} is "numeric", it will be expanded to
#' c("numeric", "integer", "double"). The class is tested via the
#' function \code{class}. This means that if \code{obj} is a matrix,
#' it is necessary to pass \code{class_string = "matrix"}; you cannot
#' refer to the "mode" of the matrix. A special case is the
#' \code{class_string} "groupvar" that is expanded to
#' c("factor", "character", "numeric", "integer", "double").
#' @param len Optional numeric vector for objects having a length
#' (mostly for vectors).
#' @param gt0 Optional logical vector indicating if numeric input has
#' to be greater than 0.
#' @param must_be_integer Optional logical vector indicating if numeric
#' input has to be integer.
#' @param groupsize Optional argument how many groups a grouping variable
#' consist of.
#' @param input_set Optional argument specifying a set of values an
#' argument can take.
#'
#' @return NULL
#'
#' @noRd
validate_input <- function(obj, argument_name, class_string = NULL, len = NULL,
gt0 = FALSE, must_be_integer = FALSE, groupsize = NULL,
input_set = NULL) {
self_validation(argument_name, class_string, len, gt0,
must_be_integer, groupsize, input_set)
## - Check class of object
if (argument_exists(class_string)) {
# Allow for all numeric types:
if ("numeric" %in% class_string) {
class_string <- c(class_string, "integer", "double")
}
# Case - grouping variable: Allow for numeric, character or factor
if ("groupvariable" %in% class_string) {
class_string <- setdiff(c(class_string, "factor", "ordered", "character",
"numeric", "integer", "double", "logical"),
"groupvariable")
}
correct_class <- class(obj)[1] %in% class_string
if (!correct_class) {
stop(argument_name, " must be of class '",
paste(class_string, collapse = "' or '"), "'")
}
}
## - Check length of input
if (argument_exists(len)) {
if (length(obj) != len) {
stop(argument_name, " must have length ", len)
}
}
## - Check if input has to be greater than 0
if (gt0 == TRUE && any(obj <= 0)) {
stop(argument_name, " must be greater than 0")
}
## - Check if input has to be integer
if (must_be_integer == TRUE && any(obj %% 1 != 0)) {
stop(argument_name, " must be integer")
}
## - Check if correct number of groups is provided
if (argument_exists(groupsize)) {
if (length(table(obj)[table(obj) != 0]) != groupsize) {
stop(argument_name, " must consist of exactly ", groupsize,
" groups with more than 0 observations.")
}
}
## - Check if argument matches a predefined input set
if (argument_exists(input_set)) {
if (!obj %in% input_set) {
stop(argument_name, " can either be set to '",
paste(input_set, collapse = "' or '"), "'")
}
}
return(invisible(NULL))
}
## Validate input for the `validate_input` function (these errors are
## not for users, but only for developers)
self_validation <- function(argument_name, class_string, len, gt0,
must_be_integer, groupsize,
input_set) {
if (argument_exists(class_string)) {
stopifnot(class(class_string) == "character")
stopifnot(class(argument_name) == "character")
}
if (argument_exists(len)) {
stopifnot(class(len) %in% c("numeric", "integer"))
stopifnot(length(len) == 1)
stopifnot(len >= 0)
stopifnot(len %% 1 == 0)
}
stopifnot(class(gt0) == "logical")
stopifnot(length(gt0) == 1)
stopifnot(class(must_be_integer) == "logical")
stopifnot(length(must_be_integer) == 1)
if (argument_exists(groupsize)) {
stopifnot(mode(groupsize) == "numeric")
stopifnot(length(groupsize) == 1)
}
if (argument_exists(input_set) && len != 1) {
stop("If an input set is passed, argument len must be 1 ",
"(this message should not be seen by users of the package prmisc).")
}
return(invisible(NULL))
}
argument_exists <- function(arg) {
!is.null(arg)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.