#' Checking an input vector
#'
#' An input vector (of length one unless okSeveral is TRUE) is checked.
#'
#' @param x Input vector to be checked
#' @param alt NULL or vector of allowed values
#' @param min NULL or minimum value (when type is numeric or integer)
#' @param max NULL or maximum value (when type is numeric or integer)
#' @param type One of: "character", "numeric", "integer", "logical", "varName", "varNr", "varNrName".
#' numeric/integer is not checked against exact class, but whether the value fit into the class.
#' Also see data below.
#' @param data A data frame or matrix. When above type is varNames x is checked against colnames(data).
#' When type is varNr x is checked against column numbers.
#' When type is varNrName x can be either column numbers or column names.
#' @param okSeveral When TRUE length(x)>1 is allowed
#' @param okNULL When TRUE NULL is allowed
#' @param okNA When TRUE NA is allowed
#' @param okDuplicates When TRUE duplicated values are allowed.
#' Default is TRUE if alt is NULL and if type does not refer to column(s) of data.
#'
#' @details x is checked according to the other input parameters.
#' When x is wrong an error is produced with appropriate text.
#'
#' @return NULL
#'
#' @author Øyvind Langsrud
#'
#' @export
#'
#' @examples
#'a <- c("no", "yes")
#'b <- c(3.14, 4, 5)
#'z <- data.frame(A = a, B = b[1:2], C = TRUE)
#'
#'# Lines causing error are embedded in 'try'
#'
#'try(CheckInput(a, type = "character"))
#'CheckInput(a, type = "character", alt = c("no", "yes", "dontknow"), okSeveral = TRUE)
#'try(CheckInput("yesno", type = "character", alt = c("no", "yes", "dontknow")))
#'CheckInput(a[1], type = "character", alt = c("no", "yes", "dontknow"))
#'
#'try(CheckInput(b, type = "integer", max = 100, okSeveral = TRUE))
#'try(CheckInput(b, type = "numeric", min = 4, okSeveral = TRUE))
#'CheckInput(b, type = "numeric", max = 100, okSeveral = TRUE)
#'try(CheckInput(b, type = "numeric", alt = 1:10, okSeveral = TRUE))
#'CheckInput(b[2], type = "numeric", alt = 1:10)
#'
#'try(CheckInput("TRUE", type = "logical"))
#'CheckInput(TRUE, type = "logical")
#'
#'try(CheckInput("A", type = "varName"))
#'CheckInput("A", type = "varName", data = z)
#'CheckInput(c("A", "B"), type = "varNrName", data = z, okSeveral = TRUE)
#'try(CheckInput("ABC", type = "varNrName", data = z))
#'try(CheckInput(5, type = "varNrName", data = z))
#'CheckInput(3, type = "varNr", data = z)
#'CheckInput(2:3, type = "varNr", data = z, okSeveral = TRUE)
CheckInput <- function(x, alt = NULL, min = NULL, max = NULL, type = "character", data = NULL,
okSeveral = FALSE, okNULL = FALSE, okNA = FALSE,
okDuplicates = is.null(alt) & !(type %in% c("varName", "varNr", "varNrName"))){
types <- c("character", "numeric", "integer", "logical", "varName", "varNr", "varNrName")
xInput <- get_args()$x
xInput <- deparse(xInput) # These two lines cannot be written as one
if(is.null(x)){
if(okNULL) return()
else stop(paste(xInput, ": NULL input not not allowed"))
}
if (type %in% c("varName", "varNr", "varNrName")){
if (is.null(data))
stop(paste(xInput, ": data missing"))
if(is.list(x)) return() # No further checking here if complicated list input
}
if (!okSeveral & length(x) > 1)
stop(paste(xInput, ": Input must be of length 1"))
if (length(x) == 0)
stop(paste(xInput, ": Input is of length 0"))
if (any(is.na(x)))
if(!okNA) stop(paste(xInput, ": NA input"))
if(!okDuplicates & any(duplicated(x)))
stop(paste(xInput, ": Duplicates not allowed"))
if (!(type %in% types))
stop(paste(xInput, ": Type must be in:", paste(types, collapse = ", ")))
if (type == "varNrName") {
if (is.character(x))
type <- "varName" else type <- "varNr"
}
if (type == "varName") {
type <- "character"
alt <- colnames(data)
if (is.null(alt))
stop(paste(xInput, ": No colnames in data"))
}
if (type == "varNr") {
type <- "integer"
min <- 1
max <- NCOL(data)
}
if (type == "integer") {
if (!suppressWarnings(identical(as.numeric(as.integer(x)), as.numeric(x))))
stop(paste(xInput, ": Input is not in accordance with integer"))
type <- "numeric"
}
if (any(c(!is.null(min), !is.null(max)))) {
if (type == "numeric") {
if (!is.null(alt))
warning(paste(xInput, ": alt not used when min/max is input"))
if (is.null(min))
min <- -Inf
if (is.null(max))
max <- Inf
if (any(x < min, na.rm = TRUE) | any(x > max, na.rm = TRUE))
stop(paste(xInput, ": Input must be within the interval [", min, ",", max, "]"))
return()
} else warning(paste(xInput, ": min/max not used"))
}
if (any(!is.na(x))){ # No check if only NA
if (type == "numeric" & !is.numeric(x))
stop(paste(xInput, ": Input must be numeric or integer"))
if (type == "character" & !is.character(x))
stop(paste(xInput, ": Input must be character"))
if (type == "logical" & !is.logical(x))
stop(paste(xInput, ": Input must be logical"))
}
if (!is.null(alt))
if (any(!(x %in% alt)))
stop(paste(xInput, ": Input must be in:", paste(HeadEnd(alt, n = 8), collapse = ", ")))
return()
}
# Based on the discussion at http://stackoverflow.com/questions/17256834/getting-the-arguments-of-a-parent-function-in-r-with-names
get_args <- function() {
cl <- sys.call(-1)
# f <- get(as.character(cl[[1]]), mode='function', sys.frame(-2))
f <- eval(cl[[1]], parent.frame())
cl <- match.call(definition = f, call = cl)
as.list(cl)[-1]
}
# HeadEnd(1:1000) '1' '2' '3' '4' '...' '1000'
HeadEnd <- function(x, n = 4L) {
x <- as.character(x)
if (length(x) > (n + 2))
x <- c(head(x, n = n), "...", tail(x, n = 1))
x
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.