R/class_schema.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# class_schema.R


#' @include globals.R
#' @include internals.R
#' @include class_prototype.R


# Definition -------------------------------------------------------------------


#' @rdname class_schema
#' @template class_schema
#' @template class_schema_slots
methods::setClass("Schema",
    slots = c(
        inputs     = "character",
        prototypes = "list"
    ),
    prototype = list(
        inputs     = character(),
        prototypes = list()
    )
)


# Constructors -----------------------------------------------------------------


#' @rdname class_schema
#' @template class_schema_constructor
#' @aliases Schema
#' @export
methods::setGeneric("Schema", function(inputs, prototypes, ...)
{
    standardGeneric("Schema")
})


#' @rdname class_schema
#' @export
methods::setMethod("Schema",
    signature  = signature(
        inputs     = "missing",
        prototypes = "missing"
    ),
    definition = function(inputs, prototypes)
{
    return(.new_schema(character(), list()))
})


#' @rdname class_schema
#' @export
methods::setMethod("Schema",
    signature  = signature(
        inputs     = "character",
        prototypes = "list"
    ),
    definition = function(inputs = character(), prototypes = list())
{
    if (!identical(length(inputs), length(prototypes))) {
        stop("@inputs and @prototypes lengths do not match.",
             call. = FALSE)
    }

    return(.new_schema(inputs, prototypes))
})


.new_schema <- function(inputs, prototypes)
{
    if (length(inputs)) {
        ni <- names(inputs)
        np <- names(prototypes)

        if (is.null(ni) && !is.null(np)) {
            names(inputs) <- np
        } else if (!is.null(ni) && is.null(np)) {
            names(prototypes) <- ni
        } else if (is.null(ni) && is.null(np)) {
            nd <- paste0("col", seq_len(length(inputs)))
            names(inputs)     <- nd
            names(prototypes) <- nd
        }
    }

    return(
        methods::new("Schema",
            inputs     = inputs,
            prototypes = prototypes
        )
    )
}


# Validators -------------------------------------------------------------------


#' @rdname class_schema_validators
#' @template class_schema_validators
#' @aliases valid_schema
#' @export
valid_schema <- function(x)
{
    if (!is_schema(x)) {
        stop("'x' is not a Schema object.", call. = FALSE)
    }
    return(methods::validObject(x))
}


#' @rdname class_schema_validators
#' @export
.valid_schema <- function(object)
{
    ni <- names(object@inputs)
    np <- names(object@prototypes)

    txt1 <- if (!identical(length(ni), length(np))) {
        "@inputs and @prototypes lengths do not match."
    }
    txt2 <- if (!setequal(ni, np)) {
        "@inputs and @prototypes tags do not match."
    }
    txt3 <- if (any(!.vapply1b(object@prototypes, is_prototype))) {
        "@prototypes must only contain objects of class Prototype."
    }

    return(
        c(txt1, txt2, txt3,
          .valid_names(ni, "inputs"),
          .valid_names(np, "prototypes"))
    )
}


.valid_names <- function(x, s)
{
    txt1 <- if (any(!nzchar(x))) {
        sprintf("@%s contains unnamed components.", s)
    }
    txt2 <- if (anyDuplicated(x)) {
        sprintf("@%s has non-unique tags.", s)
    }

    return(c(txt1, txt2))
}


methods::setValidity("Schema", method = function(object)
{
    txt <- .valid_schema(object)
    return(if (is.null(txt)) TRUE else txt)
})


# Accessors --------------------------------------------------------------------


#' @rdname class_schema_accessors
#' @template class_schema_accessors
#' @aliases inputs
#' @export
methods::setGeneric("inputs", function(x)
{
    standardGeneric("inputs")
})


#' @rdname class_schema_accessors
#' @export
methods::setGeneric("prototypes", function(x)
{
    standardGeneric("prototypes")
})


#' @rdname class_schema_accessors
#' @export
methods::setGeneric("inputs<-", function(x, value)
{
    standardGeneric("inputs<-")
})


#' @rdname class_schema_accessors
#' @export
methods::setGeneric("prototypes<-", function(x, value)
{
    standardGeneric("prototypes<-")
})


#' @rdname class_schema_accessors
#' @export
methods::setMethod("inputs",
    signature  = signature(x = "Schema"),
    definition = function(x) x@inputs
)


#' @rdname class_schema_accessors
#' @export
methods::setMethod("prototypes",
    signature  = signature(x = "Schema"),
    definition = function(x) x@prototypes
)


#' @rdname class_schema_accessors
#' @export
methods::setMethod("inputs<-",
    signature  = signature(x = "Schema"),
    definition = function(x, value)
{
    if (!is.character(value)) {
        stop("'value' must be a character.", call. = FALSE)
    }
    if (!identical(length(x), length(value))) {
        stop("'value' length must be equal to the length of 'x'.")
    }
    if (is.null(names(value))) {
        names(value) <- names(x)
    }

    x@inputs <- value
    methods::validObject(x)

    return(invisible(x))
})


#' @rdname class_schema_accessors
#' @export
methods::setMethod("prototypes<-",
    signature  = signature(x = "Schema"),
    definition = function(x, value)
{
    if (inherits(value, "list", TRUE) != 1L) {
        stop("'value' must be a list.", call. = FALSE)
    }
    if (!identical(length(x), length(value))) {
        stop("'value' length must be equal to the length of 'x'.")
    }
    if (is.null(names(value))) {
        names(value) <- names(x)
    }

    x@prototypes <- value
    methods::validObject(x)

    return(invisible(x))
})


# Extractors -------------------------------------------------------------------


#' @rdname class_schema_extractors
#' @template class_schema_extractors
#' @aliases [,Schema,missing,missing,missing-method
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Schema",
        i    = "missing",
        j    = "missing",
        drop = "missing"),
    definition = function(x, i)
{
    return(x)
})


#' @rdname class_schema_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x = "Schema",
        i = "logical",
        j = "missing",
        drop = "missing"),
    definition = function(x, i)
{
    if (length(i) > length(x)) i <- i[seq_along(x)]
    return(.new_schema(x@inputs[i], x@prototypes[i]))
})


#' @rdname class_schema_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Schema",
        i    = "numeric",
        j    = "missing",
        drop = "missing"),
    definition = function(x, i)
{
    if (length(i <- i[i <= length(x) & is.finite(i)])) {
        return(.new_schema(x@inputs[i], x@prototypes[i]))
    } else {
        return(.new_schema(character(), list()))
    }
})


#' @rdname class_schema_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Schema",
        i    = "character",
        j    = "missing",
        drop = "missing"),
    definition = function(x, i)
{
    i <- data.table::chmatch(i, names(x), 0L)
    return(.new_schema(x@inputs[i], x@prototypes[i]))
})


#' @rdname class_schema_extractors
#' @export
methods::setMethod("[[",
    signature = signature(
        x    = "Schema",
        i    = "numeric",
        j    = "missing"),
    definition = function(x, i)
{
    return(x[i[[1L]]])
})


#' @rdname class_schema_extractors
#' @export
methods::setMethod("[[",
    signature = signature(
        x    = "Schema",
        i    = "character",
        j    = "missing"),
    definition = function(x, i)
{
    return(x[i[[1L]]])
})


#' @rdname class_schema_extractors
#' @export
methods::setMethod("$",
    signature  = signature(x = "Schema"),
    definition = function(x, name)
{
    ans <- x[[substitute(name)]]
    return(if (length(ans)) ans else NULL)
})


# Introspector -----------------------------------------------------------------


#' @rdname class_schema_is
#' @template class_schema_is
#' @export
is_schema <- function(x)
{
    return(methods::is(x, "Schema"))
}


# Coercion methods -------------------------------------------------------------


#' @rdname class_schema_as
#' @template class_schema_as
#' @aliases as_schema
#' @export
methods::setGeneric("as_schema", function(x, ...)
{
    standardGeneric("as_schema")
})


#' @rdname class_schema_as
#' @export
methods::setMethod("as_schema",
    signature  = signature(x = "Schema"),
    definition = function(x, ...)
{
    return(x)
})


#' @rdname class_schema_as
#' @export
methods::setMethod("as_schema",
    signature  = signature(x = "data.table"),
    definition = function(x, ...)
{
    f <- methods::selectMethod("as_schema", methods::signature(x = "list"))
    return(f(as.list(x), ...))
})


#' @rdname class_schema_as
#' @export
methods::setMethod("as_schema",
    signature  = signature(x = "data.frame"),
    definition = function(x, ...)
{
    f <- methods::selectMethod("as_schema", methods::signature(x = "list"))
    return(f(as.list(x), ...))
})


#' @rdname class_schema_as
#' @export
methods::setMethod("as_schema",
    signature  = signature(x = "list"),
    definition = function(x, ...)
{
    for (j in seq_along(x)) {
        if (length(x[[j]])) x[[j]] <- x[[j]][[1L]]
    }
    return(Schema(names(x), lapply(x, Prototype)))
})


# Show -------------------------------------------------------------------------


#' @rdname class_schema
#' @template class_schema_show
#' @aliases show,Schema-method
#' @export
methods::setMethod("show",
    signature  = signature(object = "Schema"),
    definition = function(object)
{
    cat(sprintf("An object of S4 class %s.\n", class(object)[[1L]]))

    if (length(object)) {
        cat(format(object), sep = "")
    } else {
        cat("> Empty.")
    }

    return(invisible())
})