Nothing
## * Documentation
#' @name validFCTs
#' @aliases validClass
#' @aliases validDimension
#' @aliases validInteger
#' @aliases validLogical
#' @aliases validNames
#' @aliases validNumeric
#' @aliases validPath
#' @title Check Arguments of a function.
#'
#' @description Check the validity of the arguments in functions.
#'
#' @param value1 the value of the (first) argument to be checked
#' @param value2 the second value of a second argument whose dimensions should be consistent with the first one
#' @param name1 the name of the (first) argument.
#' @param name2 the name of the second argument.
#' @param validClass the acceptable classes(s) for the argument.
#' @param validDimension the acceptable dimension for the argument. If \code{NULL} then name2 is used as a reference.
#' @param valid.length the acceptable length(s) for the argument. If \code{NULL} no test is performed.
#' @param valid.values the acceptable value(s) for the argument. If \code{NULL} no test is performed. Can also be "character" or "character_or_logical".
#' @param refuse.NULL should an error be output if value is \code{NULL}.
#' @param refuse.NA should an error be output if value contains \code{NA}.
#' @param refuse.duplicates should an error be output if value contains duplicated values.
#' @param refuse.values values that must not appear in the argument
#' @param type For \code{validDimension}: the type of operator used to check the dimensions. For \code{validPath} either "dir" or "file" to check whether to path points to an existing directory or file.
#' @param required.values values that must appear in the argument
#' @param min the minimum acceptable value
#' @param max the maximum acceptable value
#' @param extension filter the files by the type of extension.
#' @param method the name of the function using the argument.
#' @param check.fsep display a warning when the separator is not correctly specified in
#' @param addPP add ": " after the name of the function in the error message.
#' @param unlist [logical] flatten argument before check.
#'
#' @return An invisible \code{TRUE} or an error message.
#'
#' @concept check
#' @keywords internal
## * validCharacter
#' @rdname validFCTs
validCharacter <- function(value1,
name1 = as.character(substitute(value1)),
valid.length,
valid.values = "character",
refuse.NULL = TRUE,
refuse.duplicates = FALSE,
method = NULL,
addPP = TRUE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
if(is.null(value1)){
if(refuse.NULL == TRUE){
stop(method, "\'", name1, "\' must not be NULL \n")
}
}else{
#### check size
n.value1 <- length(value1)
if(!is.null(valid.length) && n.value1 %in% valid.length == FALSE){
stop(method, "\'", name1, "\' must have length ", paste(valid.length, collapse = " or "), " \n",
"length(", name1, ") : ", n.value1, "\n")
}
#### check duplicates
if(refuse.duplicates == TRUE && any(duplicated(value1))){
stop(method, "\'", name1, "\' contains duplicated values: ", "\"",paste(unique(value1[duplicated(value1)]), collapse = "\" \""), "\" \n")
}
#### check values
if(identical(valid.values,"character")){
if(any(is.character(value1) == FALSE)){
stop(method, "\'", name1, "\' must be a ", if(n.value1 == 1){"character"}else{"vector of characters"}," \n",
"is(", name1, ") : ", paste(is(value1), collapse = " "), "\n")
}
} else if(identical(valid.values,"character_or_logical")){
if(any( (is.character(value1) == FALSE) * (is.logical(value1) == FALSE) > 0 )){
stop(method, "\'", name1, "\' must be a ", if(n.value1 == 1){"character or logical"}else{"vector of characters or logicals"}," \n",
"is(", name1, ") : ", paste(is(value1), collapse = " "), "\n")
}
} else if(!is.null(valid.values) && any(value1 %in% valid.values == FALSE)){
stop(method, "wrong specification of \'", name1, "\' \n",
"valid values for \'", name1, "\' : ", if(refuse.NULL == FALSE){"NULL"}, " \"", paste(valid.values, collapse = "\" \""), "\" \n",
"refused value",if(sum(value1 %in% valid.values == FALSE)>1){"s"}," for \'", name1, "\' : \"", paste(value1[value1 %in% valid.values == FALSE], collapse = "\" \""), "\"\n")
}
}
return(invisible(TRUE))
}
## * validClass
#' @rdname validFCTs
validClass <- function(value1,
name1 = as.character(substitute(value1)),
valid.class,
type = "inherits",
method = NULL,
addPP = TRUE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
if(type == "inherits"){
if(inherits(value1, valid.class) == FALSE){
stop(method, "class of \'", name1, "\' must inherit of \"", paste(valid.class,collapse="\" \""), "\" \n")
}
}else if(type == "is"){
if( all(is(value1) %in% validClass == FALSE) ){
stop(method, "class of \'", name1, "\' must be one of the following \"", paste(valid.class,collapse="\" \""), "\" \n",
"current superclass : \"", paste(is(value1),collapse="\" \""), "\" \n")
}
}else if(type == "class"){
if( class(value1) %in% validClass == FALSE){
stop(method, "class of \'", name1, "\' must be \"", paste(valid.class,collapse="\" \""),"\" \n",
"current class : ", class(value1)[[1]], "\n")
}
}
return(invisible(TRUE))
}
## * validDimension
#' @rdname validFCTs
validDimension <- function(value1,
value2 = NULL,
name1 = as.character(substitute(value1)),
name2 = as.character(substitute(value2)),
valid.dimension = NULL,
type = c("NROW","NCOL"),
method = NULL,
addPP = TRUE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
n.type <- length(type)
#### dimension 1
test.dimension <- sapply(1:n.type, function(x){
do.call(type[x], list(value1))
})
#### dimension 2
if(is.null(valid.dimension)){
valid.dimension <- sapply(1:n.type, function(x){
do.call(type[x], list(value2))
})
test.valid.dimension <- TRUE
}else if(is.null(name2)){
test.valid.dimension <- FALSE
}else{
test.valid.dimension <- TRUE
}
#### main
for(iType in 1:n.type){
if(test.dimension[iType] != valid.dimension[iType]){
if(test.valid.dimension){
stop(method, "dimension mismatch between argument \'", name1, "\' and argument \'", name2, "\' \n",
type[iType],"(", name1, ") = ", test.dimension[iType], " \n",
type[iType],"(", name2, ") = ", valid.dimension[iType], " \n")
}else{
stop(method, "dimension mismatch between argument \'", name1, "\' and argument \'", name2, "\' \n",
type[iType],"(", name1, ") = ", test.dimension[iType], " \n",
type[iType],"(", name2, ") = ", valid.dimension[iType], " \n")
}
}
}
return(invisible(TRUE))
}
## * validInteger
#' @rdname validFCTs
validInteger <- function(value1,
name1 = as.character(substitute(value1)),
valid.length,
min = NULL,
max = NULL,
refuse.NA = TRUE,
refuse.NULL = TRUE,
refuse.duplicates = FALSE,
method = NULL,
addPP = TRUE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
validNumeric(value1 = value1, name1 = name1, valid.length = valid.length, min = min, max = max,
refuse.NA = refuse.NA, refuse.NULL = refuse.NULL, refuse.duplicates = refuse.duplicates, method = method)
## check integer
if(!is.null(value1) && any(value1 %% 1 > 0)){
stop(method, "\'", name1, "\' must contain integers not doubles \n",
"invalid value(s) in ", name1, " : ", paste(value1[value1 %% 1 > 0], collapse = " "), "\n")
}
return(invisible(TRUE))
}
## * validLogical
#' @rdname validFCTs
validLogical <- function(value1,
name1 = as.character(substitute(value1)),
valid.length,
refuse.NULL = TRUE,
refuse.NA = TRUE,
method = NULL,
addPP = TRUE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
if(is.null(value1)){
#### NULL
if(refuse.NULL == TRUE){
stop(method, "\'", name1, "\' must be logical ",if(refuse.NA == FALSE){"or NA"}," and not NULL \n")
}
}else{
#### Size
if(!is.null(valid.length) && length(value1) %in% valid.length == FALSE){
stop(method, "\'", name1, "\' must have length ", paste(valid.length, collapse = " or "), " \n",
"length(", name1, ") : ", length(value1), "\n")
}
#### Type
if(any(is.logical(value1) == FALSE)){
stop(method, "\'", name1, "\' must be ", if(refuse.NULL == FALSE){"NULL or "}, if(refuse.NA == FALSE){"NA or "},"TRUE or FALSE \n",
"is(", name1, ") : ", paste(is(value1), collapse = " "), "\n")
}
if(refuse.NA == TRUE && any(is.na(value1)) ){
stop(method, "\'", name1, "\' must be logical ",if(refuse.NULL == FALSE){"or NULL"}," and not NA \n")
}
}
return(invisible(TRUE))
}
## * validNames
#' @rdname validFCTs
validNames <- function(value1,
name1 = as.character(substitute(value1)),
refuse.NULL = TRUE,
valid.length = NULL,
valid.values = NULL,
required.values = NULL,
refuse.values = NULL,
method = NULL,
addPP = TRUE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
## type
if(is.matrix(value1)){
value1 <- colnames(value1)
}
if(inherits(value1,"data.frame") || is.list(value1)){
value1 <- names(value1)
}
## tests
if(is.null(value1)){
if(refuse.NULL == TRUE){
stop(method, "names of \'", name1, "\' must not be NULL \n")
}
}else{
#### check size
n.value1 <- length(value1)
if(!is.null(valid.length) && n.value1 %in% valid.length == FALSE){
stop(method, "\'", name1, "\' must have ", paste(valid.length, collapse = " or ")," names \n",
"length(names(", name1, ")) : ", n.value1, "\n")
}
#### check content
if(!is.null(required.values) && any(required.values %in% value1 == FALSE)){
stop(method, "\'", name1, "\' must contain specific names \n",
"missing names : \"",paste(required.values[required.values %in% value1 == FALSE], collapse = "\" \""),"\" \n",
"possible names : \"", paste(value1, collapse = "\" \""), "\"\n")
}
if(!is.null(valid.values) && any(value1 %in% valid.values == FALSE)){
stop(method, "wrong specification of \'", name1, "\' \n",
"valid names for \'", name1, "\' : \"",paste(valid.values, collapse = "\" \""),"\" \n",
"refused names : \"", paste(value1[value1 %in% valid.values == FALSE], collapse = " "), "\"\n")
}
if(!is.null(refuse.values) && any(value1 %in% refuse.values)){
stop(method, "\'", name1, "\' contains forbidden names:", paste(value1[value1 %in% refuse.values], collapse = " "), "\"\n")
}
if(any(duplicated(value1))){
stop(method, "\'", name1, "\' must not contain duplicated names \n",
"duplicated names : \"", paste(value1[duplicated(value1)], collapse = " "), "\"\n")
}
}
return(invisible(TRUE))
}
## * validNumeric
#' @rdname validFCTs
validNumeric <- function(value1,
name1 = as.character(substitute(value1)),
valid.length,
valid.values = NULL ,
min = NULL,
max = NULL,
refuse.NA = TRUE,
refuse.NULL = TRUE,
refuse.duplicates = FALSE,
method = NULL,
addPP = TRUE,
unlist = FALSE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
if(is.null(value1)){
if(refuse.NULL == TRUE){
stop(method, "\'", name1, "\' must not be NULL \n")
}
}else{
#### check length
if(!is.null(valid.length) && length(value1) %in% valid.length == FALSE){
stop(method, "\'", name1, "\' must have length ", paste(valid.length, collapse = " or "), " \n",
"length(", name1, ") : ", length(value1), "\n")
}
#### check NA
if(unlist){
value1 <- unlist(value1)
}
if(refuse.NA == TRUE && any(is.na(value1))){
stop(method, "\'", name1, "\' must not contain any NA \n",
"index of NA values : ", paste(which(is.na(value1)), collapse = " "), "\n")
}
#### check numeric
if(any( (is.numeric(value1) == FALSE) * (is.na(value1) == FALSE) )){
stop(method, "\'", name1, "\' must be numeric \n",
"is(", name1, ") : ", paste(is(value1), collapse = " "), "\n")
}
#### check duplicates
if(refuse.duplicates == TRUE && any(duplicated(value1))){
stop(method, "\'", name1, "\' contains duplicated values: ", paste(unique(value1[duplicated(value1)]), collapse = " "), "\n")
}
#### check min value1
if(!is.null(min) && any(stats::na.omit(value1) < min)){
stop(method, "\'", name1, "\' must be bigger than ", min, " \n",
"invalid value(s): ", paste(value1[stats::na.omit(value1) < min], collapse = " "), "\n")
}
#### check max value1
if(!is.null(max) && any(stats::na.omit(value1) > max)){
stop(method, "\'", name1, "\' must be smaller than ", max, " \n",
"invalid value(s): ", paste(value1[stats::na.omit(value1) > max], collapse = " "), "\n")
}
#### check valid values
if(!is.null(valid.values) && any(stats::na.omit(value1) %in% valid.values == FALSE)){
stop(method, "\'", name1, "\' contains invalid values \n",
"valid values for \'", name1, "\' : ", if(refuse.NULL == FALSE){"NULL"}, " \"", paste(valid.values, collapse = "\" \""), "\" \n",
"refused value",if(sum(value1 %in% valid.values == FALSE)>1){"s"}," for \'", name1, "\' : \"", paste(value1[value1 %in% valid.values == FALSE], collapse = " "), "\"\n", sep = "")
}
}
return(invisible(TRUE))
}
## * validPath
#' @rdname validFCTs
validPath <- function(value1,
name1 = as.character(substitute(value1)),
type,
method = NULL,
addPP = TRUE,
extension = NULL,
check.fsep = FALSE){
if(!is.null(method) && addPP){
method <- paste0(method, ": ")
}
validCharacter(type, valid.length = 1, valid.values = c("file", "dir"))
try_path <- switch(type,
file = file.exists(value1),
dir = dir.exists(value1)
)
if(try_path == FALSE){
stop(method, "\'", name1, "\' does not lead to an existing ",switch(type,"file"="file","dir"="directory")," \n",
"current value: \"", value1, "\"\n",
"current path: ", getwd(), "\n")
}
if(type == "dir"){
if(check.fsep == TRUE && substr(value1, start = nchar(value1), stop = nchar(value1)) != "/"){
warning(method, "possible bad specification of \'", name1, "\' \n",
"it should end with a fsep (e.g. \"/\") \n")
}
}else if(type == "file" && !is.null(extension)){
fileExtension <- tools::file_ext(value1)
if(fileExtension %in% extension == FALSE){
stop(method, "\'", name1, "\' has not the expected extension \n",
"current extension: \"", fileExtension, "\" \n",
"expected extension: \"", paste(extension, collapse = "\" \""), "\"\n")
}
}
return(invisible(TRUE))
}
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.