R/ArgValidation.R

In DSkrzypiec/oRtrack: Object References Tracker

# ---------------------------------------------------------------
#
#    Author     : Damian Skrzypiec <damian.j.skrzypiec@gmail.com>
#
#    Date       : 2017-12-29 14:44:21
#
#    Description: Functions for argument validation.
#
# ---------------------------------------------------------------



getArgumentStringName <- function(object)
{
    return(deparse(substitute(object, env = parent.frame())))
}


print.msgError <- function(obj)
{
    stopifnot(is.character(obj))
    msgLines <- strsplit(x = obj, split = "\n", fixed = TRUE)[[1]]

    for (msg in msgLines)
    {
        message(msg)
    }
}


isNumeric <- function(object)
{
    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Given argument <", argumentName, "> is invalid. \n",
                           "Numeric value was expected. Object of class {",
                           class(object), "} was provided.")
    class(msg)   <- "msgError"

    if (!is.numeric(object))
    {
        stop(msg)
    }
}


isInRange <- function(object, min, max)
{
    isNumeric(object)
    isNumeric(min)
    isNumeric(max)

    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Argument <", argumentName, "> with value of (", object,
                           ") is out of expected range [", min, ", ", max, "].")
    class(msg)   <- "msgError"

    if (object < min || object > max)
    {
        stop(msg)
    }
}


isCharacter <- function(object)
{
    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Given argument <", argumentName, "> is invalid. \n",
                           "Character value was expected. Object of class {",
                           class(object), "} was provided.")
    class(msg)   <- "msgError"

    if (!is.character(object))
    {
        stop(msg)
    }
}


isLogical <- function(object)
{
    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Given argument <", argumentName, "> is invalid. \n",
                           "Logical value was expected. Object of class {",
                           class(object), "} was provided.")
    class(msg)   <- "msgError"

    if (!is.logical(object))
    {
        stop(msg)
    }
}


isList <- function(object)
{
    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Given argument <", argumentName, "> is invalid. \n",
                           "List was expected. Object of class {",
                           class(object), "} was provided.")
    class(msg)   <- "msgError"

    if (!is.list(object))
    {
        stop(msg)
    }
}


isDataframe <- function(object)
{
    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Given argument <", argumentName, "> is invalid. \n",
                           "Data.frame was expected. Object of class {",
                           class(object), "} was provided.")
    class(msg)   <- "msgError"

    if (!is.data.frame(object))
    {
        stop(msg)
    }
}


isOfClass <- function(object, requiredClassName)
{
    isCharacter(requiredClassName)

    argumentName <- getArgumentStringName(object)
    msg          <- paste0("Given argument <", argumentName, "> has incorrect type. \n",
                           "Expected object of class {", requiredClassName,
                           "}. Provided argument is of class {", class(object), "}.")
    class(msg)   <- "msgError"

    if (!any(class(object) == requiredClassName))
    {
        stop(msg)
    }
}


isVectorsTheSame <- function(vector1, vector2)
{
    if (length(vector1) != length(vector2))
        return(FALSE)

    return(all(vector1 == vector2))
}


hasTheSameLength <- function(vector1, vector2)
{
    v1Name <- getArgumentStringName(vector1)
    v2Name <- getArgumentStringName(vector2)
    msg    <- paste0("Given vectors has different lengths - ",
                     "(", length(vector1), " vs ", length(vector2), ")")

    if (length(vector1) != length(vector2))
    {
        stop(msg)
    }

}


isValidPath <- function(path)
{
    isCharacter(path)
    msg <- paste0("Given path = [", path, "] is incorrect.")

    if (!file.exists(path))
    {
        stop(msg)
    }
}


isWindowsOS <- function()
{
    return(grepl(pattern = "Windows", x = Sys.info()[["sysname"]]))
}


isLinuxOS <- function()
{
    return(grepl(pattern = "Linux", x = Sys.info()[["sysname"]]))
}


isSingleCharacters <- function(object)
{
    isCharacter(object)
    argumentName <- getArgumentStringName(object)
    msg          <- "Expected vector of single characters."
    class(msg)   <- "msgError"
    singles      <- all(sapply(object, nchar) == 1)

    if (!singles)
    {
        stop(msg)
    }
}


isRScriptChars <- function(object)
{
	isOfClass(object, "RScriptChars")
}