R/class_container.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# class_container.R


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


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


#' @rdname class_container
#' @template class_container
#' @template class_container_slots
methods::setClass("Container",
    slots = c(
        table  = "data.table",
        schema = "Schema"
    ),
    prototype = list(
        table  = data.table::data.table(),
        schema = Schema()
    )
)


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


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


#' @rdname class_container
#' @export
methods::setMethod("Container",
    signature  = signature(x = "missing"),
    definition = function(x, schema = Schema(), ...)
{
    return(.new_container(data.table::data.table(), schema))
})


#' @rdname class_container
#' @export
methods::setMethod("Container",
    signature  = signature(x = "character"),
    definition = function(x, schema = Schema(), ...)
{
    return(.new_container(safe_read_csv(x, ...), schema))
})


#' @rdname class_container
#' @export
methods::setMethod("Container",
    signature  = signature(x = "data.frame"),
    definition = function(x, schema = Schema(), ...)
{
    return(.new_container(data.table::as.data.table(x, ...), schema))
})


#' @rdname class_container
#' @export
methods::setMethod("Container",
    signature  = signature(x = "data.table"),
    definition = function(x, schema = Schema(), ...)
{
    return(.new_container(x, schema))
})


#' @rdname class_container
#' @export
methods::setMethod("Container",
    signature  = signature(x = "Schema"),
    definition = function(x, ...)
{
    if (!missing(schema)) {
        warning("Schema objects passed to both 'x' and 'schema'.",
                " The latter was ignored.", call. = FALSE)
    }

    return(.new_container(data.table::as.data.table(x, ...), x))
})


.new_container <- function(table, schema)
{
    return(methods::new("Container", table = table, schema = schema))
}


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


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


#' @rdname class_container_validators
#' @export
.valid_container <- function(object)
{
    txt1 <- if (length(sdiff(object@table, object@schema, "inputs"))) {
         "@schema inputs does not reconcile with @table fields."
    }
    txt2 <- if (length(sdiff(object@table, object@schema, "types"))) {
        "@schema prototypes does not reconcile with @table types."
    }

    return(c(txt1, txt2))
}


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


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


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


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


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


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


#' @rdname class_container_accessors
#' @export
methods::setMethod("table",
    signature  = "Container",
    definition = function(x) return(x@table)
)


#' @rdname class_container_accessors
#' @export
methods::setMethod("schema",
    signature  = signature(x = "Container"),
    definition = function(x) x@schema
)


#' @rdname class_container_accessors
#' @export
methods::setMethod("table<-",
    signature  = signature(x = "Container"),
    definition = function(x, value)
{
    if (!data.table::is.data.table(value)) {
        stop("'value' must be a data.table.",call. = FALSE)
    }

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

    return(invisible(x))
})


#' @rdname class_container_accessors
#' @export
methods::setMethod("schema<-",
    signature  = signature(x = "Container"),
    definition = function(x, value)
{
    if (!is_schema(value)) {
        stop("'value' must be an object of class Schema.", call. = FALSE)
    }

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

    return(invisible(x))
})


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


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


#' @rdname class_container_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Container",
        i    = "expression",
        j    = "expression",
        drop = "missing"),
    definition = function(x, i, j, ...)
{
    return(x@table[eval(i, envir = x@table),
                   eval(j, envir = x@table), ...])
})


#' @rdname class_container_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Container",
        i    = "expression",
        j    = "missing",
        drop = "missing"),
    definition = function(x, i, j, ...)
{
    return(x@table[eval(i, envir = x@table), ...])
})


#' @rdname class_container_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Container",
        i    = "missing",
        j    = "expression",
        drop = "missing"),
    definition = function(x, i, j, ...)
{
    return(x@table[, eval(j, envir = x@table), ...])
})


#' @rdname class_container_extractors
#' @export
methods::setMethod("[",
    signature = signature(
        x    = "Container",
        i    = "ANY",
        j    = "ANY",
        drop = "ANY"),
    definition = function(x, i, j, ...)
{
    return(base::`[.data.frame`(x@table, i, j))
})


#' @rdname class_container_extractors
#' @export
methods::setMethod("[[",
    signature = signature(
        x    = "Container",
        i    = "ANY",
        j    = "missing"),
    definition = function(x, i, j, ...)
{
    return(x@table[[i]])
})


#' @rdname class_container_extractors
#' @export
methods::setMethod("[[",
    signature = signature(
        x    = "Container",
        i    = "ANY",
        j    = "ANY"),
    definition = function(x, i, j, ...)
{
    return(x@table[[i, j]])
})


#' @rdname class_container_extractors
#' @export
methods::setMethod("$",
    signature  = signature(x = "Container"),
    definition = function(x, name)
{
    return(x@table[[name]])
})


#' @rdname class_container_extractors
#' @usage
#' ## Convenient wrapper for expressions
#' e(expr)
#'
#' @export
e <- function(expr) return(as.expression(substitute(expr)))


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


#' @rdname class_container_is
#' @template class_container_is
#' @export
is_container <- function(x)
{
    return(methods::is(x, "Container"))
}


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


#' @rdname class_container
#' @template class_container_show
#' @aliases show,Container-method
#' @export
methods::setMethod("show",
    signature  = signature(object = "Container"),
    definition = function(object)
{
    cat(sprintf("An object of S4 class %s.\n", class(object)[[1L]]),
        "--- Schema -------------------\n", format(object@schema),
        "--- Table (head only) --------\n", sep = "")
    print(utils::head(object@table),
          class      = TRUE,
          row.names  = FALSE,
          col.names  = "top",
          print.keys = FALSE)

    return(invisible())
})