R/class_schema_methods.R

In jeanmathieupotvin/cargo: Data containers, schemas and prototypes

# class_schema_methods.R


#' @include internals.R


#' @rdname class_schema_methods
#' @template class_schema_methods
#' @aliases as.data.table,Schema-method
#' @export
as.data.table.Schema <- function(x, ...)
{
    if (!isTRUE(errs <- valid_schema(x))) {
        stop("'x' is not a valid Schema object:\n",
             .collapse(" > ", errs), call. = FALSE)
    }

    is    <- x@inputs
    archs <- lapply(prototypes(x), methods::slot, name = "archetype")
    dt    <- data.table::data.table()

    if (.is_not_unique(larchs <- lengths(archs))) {
        archs <- lapply(archs, rep_len, length.out = max(larchs))
    }
    for (j in seq_along(is)) {
        data.table::set(dt, NULL, is[[j]], archs[[j]])
    }

    return(dt)
}


#' @rdname class_schema_methods
#' @export
format.Schema <- function(x, ...)
{
    methods::validObject(x)

    tags   <- .strpad(c("tags", names(x@inputs)))
    inputs <- .strpad(c("fields", x@inputs))
    ptypes <- c("prototypes", .vapply1c(x@prototypes, format))

    if (length(x)) {
        return(
            c(sprintf("  %s  %s  %s\n", tags[1L], inputs[1L], ptypes[1L]),
              sprintf("> %s  %s  %s\n", tags[-1L], inputs[-1L], ptypes[-1L]))
        )
    } else {
        ""
    }
}


#' @rdname class_schema_methods
#' @export
methods::setMethod("length",
    signature  = signature(x = "Schema"),
    definition = function(x)
{
    return(length(x@inputs))
})


#' @rdname class_schema_methods
#' @export
methods::setMethod("names",
    signature  = signature(x = "Schema"),
    definition = function(x)
{
    return(names(x@inputs))
})