setOldClass('list')
#' Collection-class
#'
#' A container of S4 objects with a shared environment that may contain metadata.
#'
#' @seealso
#' \code{\link{makeCollectionClass}}, \code{\link{collectionConstructor}},
#' \code{\link{collectionValidator}}, \code{\link{collectionShower}}.rt
#' @name Collection-class
#' @rdname Collection-class
#' @keywords internal classes
new_Collection <- setClass(
Class='Collection',
contains = 'list',
slots = c(elementType = 'character', shared = 'environment'),
prototype = prototype(elementType = NA_character_,
shared = new.env(parent=emptyenv()))
)
#' Create a Collection Class Definition
#'
#' Create a subclass to \code{\linkS4class{Collection}} named
#' \code{<elementClass>List} and return a constructor function.
#'
#' The constructor function is generated by a call to
#' \code{\link{collectionConstructor}}, a simple validity-checking
#' method is supplied by a call to \code{\link{collectionConstructor}}.
#'
#' If a \code{show} method has been defined for the Collection elements,
#' a generic \code{show} method can be constructed by a call to
#' \code{\link{collectionShower}}.
#'
#' @param elementClass Class name of the elements.
#' @return A constructor function for \code{<elementClass>List}-Class.
#' @seealso
#' \code{\linkS4class{Collection}}, \code{\link{collectionConstructor}},
#' \code{\link{collectionValidator}}, \code{\link{collectionShower}}.
#' @keywords internal
makeCollectionClass <- function(elementClass) {
assert_that(isClass(elementClass))
listClass <- paste0(elementClass, 'List')
validator <- collectionValidator(eval(listClass))
setClass(listClass,
contains="Collection",
prototype = prototype(elementType = elementClass),
validity = validator,
where = topenv(parent.frame()))
collectionConstructor(eval(listClass))
}
#' @keywords internal
#' @docType methods
setGeneric("elementType", function(x, ...) standardGeneric("elementType"))
setMethod("elementType", "Collection", function(x) x@elementType)
setAs("Collection", "list", function(from) from@.Data)
## in order for lapply et al. to work with Collections it seems that
## "as.list" must be defined as an S4 method
#' @export
#' @docType methods
setMethod("as.list", "Collection", function(x, ...) {
as(x, "list")
})
#' @keywords internal
#' @docType methods
setGeneric('shared', function(x, i, ...) standardGeneric('shared'))
## `shared` without arguments returns the shared environment itself
setMethod("shared", c(x="Collection", i="missing"), function(x) x@shared)
## extract objects from the shared environment. The extracted object is
## NOT copied.
setMethod("shared", c(x="Collection", i="ANY"), function(x, i) {
tryCatch(get(i, x@shared, inherits=FALSE), error = function(e) NULL)
})
#' @keywords internal
#' @docType methods
setGeneric('shared<-', function(x, i, value, ...) standardGeneric('shared<-'))
setReplaceMethod("shared", c(x="Collection", i="ANY", value="ANY"),
function(x, i, value, ...) {
assert_that(length(i) == 1L)
assign(i, value, x@shared)
x
})
## Remove an object from a shared environment by setting it NULL
setReplaceMethod("shared", c(x="Collection", i="ANY", value="NULL"),
function(x, i, value, ...) {
assert_that(length(i) == 1L, nzchar(i))
rm(list=as.character(i), pos=x@shared)
x
})
#' @export
setMethod("[", "Collection", function(x, i, j, ..., drop) {
new(class(x), callNextMethod(), elementType = elementType(x),
shared = shared(x))
})
#' @export
setMethod("[[", "Collection", function(x, i, j, ...) {
callNextMethod()
})
#' Create a constructor function for a Collection class.
#'
#' @param Class Name of the collection class.
#' @keywords internal
collectionConstructor <- function(Class) {
assert_that(is.string(Class))
assert_that(extends(Class, "Collection"))
function(..., shared = new.env(parent=emptyenv())) {
listData <- list(...)
elementType <- elementType(new(Class))
if (length(listData) == 0L) {
new(Class, list(new(elementType)), elementType=elementType, shared=shared)
} else {
if (length(listData) == 1L && is.list(listData[[1L]]))
listData <- listData[[1L]]
if (!all(vapply(listData, is, elementType, FUN.VALUE=logical(1L))))
stop("All elements in '...' must be '", elementType,"' objects")
new(Class, .Data=listData, elementType=elementType, shared=shared)
}
}
}
#' Create a validity-checking method for a Collection class.
#'
#' @param Class Name of the collection class.
#' @keywords internal
collectionValidator <- function(Class) {
assert_that(is.string(Class))
function(object) {
errors <- character()
elementType <- elementType(object)
elem_of_class <- vapply(as(object, "list"), is, elementType, FUN.VALUE=logical(1L))
if (!all(elem_of_class)) {
msg <- paste0("All elements in a '", Class ,"' must be of type '", elementType, "'.")
errors <- c(errors, msg)
}
if (length(errors) == 0L) TRUE else errors
}
}
#' Create a show-method for a Collection class.
#'
#' @param showFun show function for Collection class elements.
#' @param numOfElements Number of elements to show as head and tail.
#' @param linesPerElement How many lines per element before the show-string
#' is elipsized.
#' @importFrom assertthat has_args
#' @keywords internal
collectionShower <- function(showFun, numOfElements = 6, linesPerElement = NULL) {
assert_that(is.function(showFun), has_args(showFun, c('x', 'width', 'ellipsis')))
assert_that(is.numeric(numOfElements), length(numOfElements) == 1)
showElements <- function(index, elems, lPerEl = NULL, ellipsis = ' ... ' ) {
index_string <- paste0('[[', index, ']] ')
if (is.null(lPerEl)) {
width <- Inf
} else {
indent <- nchar(index_string) + nchar(ellipsis) + 2L*lPerEl + 1L
width <- lPerEl*getOption("width") - indent
}
object_string <- unlist(Map(showFun, x=elems, width=width, ellipsis=ellipsis))
sprintf("%s%s", index_string, linebreak(object_string, indent = -nchar(index_string),
offset=1L, FORCE=TRUE))
}
##' @param x A Collection instance
##' @param nOfEl how many Collection elements do we show as head and tail.
##' @param lPerEl how many lines per collection element to we want to show
##' before we ellipsize.
function(x,
nOfEl = getOption('numOfElements') %||% numOfElements,
lPerEl = getOption('linesPerElement') %||% linesPerElement) {
data <- as.list(x)
ll <- length(data)
cat(sprintf("A %s instance of length %s\n", sQuote(class(x)), ll), sep="")
if (ll == 0L) {
showme <- ''
} else if (ll > 2*nOfEl) {
head_index <- seq_len(nOfEl)
head <- data[head_index]
showHead <- showElements(head_index, head, lPerEl)
tail_index <- seq.int(to=ll, length.out = min(nOfEl, ll))
tail <- data[tail_index]
showTail <- showElements(tail_index, tail, lPerEl)
showme <- c(showHead, '...', showTail)
} else {
showme <- showElements(seq_along(data), data, lPerEl)
}
cat(showme, sep="\n")
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.