cargo: Data containers, schemas and prototypes

Documented in is_prototype .valid_prototype valid_prototype

# class_prototype.R


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


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


#' @rdname class_prototype
#' @template class_prototype
#' @template class_prototype_slots
methods::setClass("Prototype",
    slots = c(
        archetype   = "ANY",
        enclosure   = "NullEnv",
        constructor = "NullCall"
    ),
    prototype = list(
        archetype   = NULL,
        enclosure   = NULL,
        constructor = NULL
    )
)


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


#' @rdname class_prototype
#' @template class_prototype_constructor
#' @aliases Prototype
#' @export
methods::setGeneric("Prototype", function(archetype, enclosure, constructor, ...)
{
    standardGeneric("Prototype")
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "missing",
        enclosure   = "missing",
        constructor = "missing"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(.new_prototype(NULL, NULL, NULL))
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "missing",
        constructor = "missing"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(.new_prototype(archetype, NULL, NULL))
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "character",
        constructor = "missing"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(.new_prototype(archetype, .chr_to_ns(enclosure[[1L]]), NULL))
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "environment",
        constructor = "missing"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    if (...length()) {
        warning("Further arguments passed to ... were ignored.",
                call. = FALSE)
    }
    return(.new_prototype(archetype, enclosure, NULL))
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "character",
        constructor = "character"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    enclosure <- .chr_to_ns(enclosure[[1L]])
    return(
        .new_prototype(
            archetype, enclosure, .as_ptype_call(enclosure, constructor, ...)
        )
    )
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "environment",
        constructor = "character"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(
        .new_prototype(
            archetype, enclosure, .as_ptype_call(enclosure, constructor, ...)
        )
    )
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "missing",
        constructor = "call"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(.new_prototype(archetype, NULL, constructor))
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "character",
        constructor = "call"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(.new_prototype(archetype, .chr_to_ns(enclosure[[1L]]), constructor))
})


#' @rdname class_prototype
#' @export
methods::setMethod("Prototype",
    signature  = signature(
        archetype   = "ANY",
        enclosure   = "environment",
        constructor = "call"
    ),
    definition = function(archetype, enclosure, constructor, ...)
{
    return(.new_prototype(archetype, enclosure, constructor))
})


.new_prototype <- function(archetype, enclosure, constructor)
{
    return(
        methods::new("Prototype",
            archetype   = archetype,
            enclosure   = enclosure,
            constructor = constructor
        )
    )
}


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


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


#' @rdname class_prototype_validators
#' @export
.valid_prototype <- function(object)
{
    is_same_class <- identical(
        class(object@archetype),
        class(eval(object@constructor, parent.frame()))
    )

    if (is.null(object@constructor) || is_same_class) {
        return(NULL)
    } else {
        return("@constructor does not return an object of the same class as @archetype.")
    }
}


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


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


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


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


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



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


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


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


#' @rdname class_prototype_accessors
#' @export
methods::setMethod("archetype",
    signature  = signature(x = "Prototype"),
    definition = function(x) x@archetype
)


#' @rdname class_prototype_accessors
#' @export
methods::setMethod("enclosure",
    signature  = signature(x = "Prototype"),
    definition = function(x) x@enclosure
)


#' @rdname class_prototype_accessors
#' @export
methods::setMethod("constructor",
    signature  = signature(x = "Prototype"),
    definition = function(x) x@constructor
)


#' @rdname class_prototype_accessors
#' @export
methods::setMethod("archetype<-",
    signature  = signature(x = "Prototype"),
    definition = function(x, value)
{
    x@archetype <- value
    methods::validObject(x)

    return(invisible(x))
})


#' @rdname class_prototype_accessors
#' @export
methods::setMethod("enclosure<-",
    signature  = signature(x = "Prototype"),
    definition = function(x, value)
{
    if (!methods::is(value, "NullEnv")) {
        stop("value must be an environment or NULL.", call. = FALSE)
    }

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

    return(invisible(x))
})


#' @rdname class_prototype_accessors
#' @export
methods::setMethod("constructor<-",
    signature  = signature(x = "Prototype"),
    definition = function(x, value)
{
    if (!methods::is(value, "NullCall")) {
        stop("value must be a call or NULL.", call. = FALSE)
    }

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

    return(invisible(x))
})


# Instrospector ----------------------------------------------------------------


#' @rdname class_prototype_is
#' @template class_prototype_is
#' @export
is_prototype <- function(x)
{
    return(methods::is(x, "Prototype"))
}


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


#' @rdname class_prototype
#' @template class_prototype_show
#' @aliases show,Prototype-method
#' @export
methods::setMethod("show",
    signature  = signature(object = "Prototype"),
    definition = function(object)
{
    scls <- if (length(cls <- class(object@archetype)) > 1L) {
        .collapse(cls[-1L], collapse = ", ")
    } else {
        "none"
    }

    cat("An object of S4 class Prototype.\n")
    cat(sprintf(" > Class       : %s\n", cls[[1L]]))
    cat(sprintf(" > Subclasses  : %s\n", scls))
    cat(sprintf(" > Enclosure   : %s\n", format(object@enclosure)))
    cat(sprintf(" > Constructor : %s\n", deparse(object@constructor)))
    cat(" > Archetype   : see below\n-------------\n")
    print(object@archetype)

    return(invisible())
})