is.AbstractCategories <- function(x) inherits(x, "AbstractCategories")
setMethod("initialize", "AbstractCategories", function(.Object, ...) {
# list of object constructors to use (based on the class being initialized)
# for Categories, use Category
# for Insertions use Insertion
Constructor <- list(
AbstractCategories = AbstractCategory,
Categories = Category,
Insertions = Insertion,
Subtotals = Subtotal,
Headings = Heading
)[[class(.Object)]]
stopifnot(is.function(Constructor))
.Object@.Data <- lapply(..1, function(x) {
# only reconstruct if we don't have an AbstractCategory already
# this allows for Insertions to inclue elements of class: Insertion,
# Subtotal, and Heading
if (!is.AbstractCategory(x)) {
x <- try(Constructor(data = x), silent = TRUE)
}
return(x)
})
validObject(.Object)
return(.Object)
})
###############################################################
## Abstract Categories manipulation and subsetting methods
###############################################################
setMethod("lapply", "AbstractCategories", function(X, FUN, ...) {
X@.Data <- lapply(X@.Data, FUN, ...)
return(X)
})
#' @rdname crunch-extract
#' @export
setMethod("[", c("AbstractCategories", "ANY"), function(x, i, ...) {
x@.Data <- x@.Data[i]
return(x)
})
#' @rdname crunch-extract
#' @export
setMethod("[", c("AbstractCategories", "character"), function(x, i, ...) {
indices <- match(i, names(x))
if (any(is.na(indices))) {
halt("subscript out of bounds: ", serialPaste(i[is.na(indices)]))
}
callNextMethod(x, i = indices)
})
#' @rdname crunch-extract
#' @export
setMethod("[", c("AbstractCategories", "numeric"), function(x, i, ...) {
invalid.indices <- setdiff(abs(i), seq_along(x@.Data))
if (length(invalid.indices)) {
halt("subscript out of bounds: ", serialPaste(invalid.indices))
}
x@.Data <- x@.Data[i]
return(x)
})
#' @rdname crunch-extract
#' @export
setMethod("[<-", c("AbstractCategories", "character"), function(x, i, ..., value) {
indices <- match(i, names(x))
if (any(is.na(indices))) {
# if there are no matches, add it on to the end
indices <- i
}
x@.Data[indices] <- value
return(x)
})
#' @rdname crunch-extract
#' @export
setMethod("[[", c("AbstractCategories", "character"), function(x, i, ...) {
indices <- match(i, names(x))
if (any(is.na(indices))) {
halt("subscript out of bounds: ", serialPaste(i[is.na(indices)]))
}
callNextMethod(x, i = indices)
})
#' @rdname crunch-extract
#' @export
setMethod("[[<-", c("AbstractCategories", "character"), function(x, i, ..., value) {
indices <- match(i, names(x))
if (any(is.na(indices))) {
# if there are no matches, add it on to the end
x@.Data[[i]] <- value
return(x)
}
callNextMethod(x, i = indices, value)
})
# a version of modifyList that doesn't recurse into the AbstractCategories themselves
modifyCats <- function(x, val) {
stopifnot(is.AbstractCategories(x), is.AbstractCategories(val))
vnames <- names(val)
vnames <- vnames[nzchar(vnames)]
for (v in vnames) {
x[[v]] <- val[[v]]
}
return(x)
}
###############################################################
## Abstract Categories named get/set methods
###############################################################
#' @rdname describe-catalog
#' @export
setMethod("names", "AbstractCategories", function(x) {
n <- vapply(x, name, character(1))
return(n)
})
#' @rdname describe-catalog
#' @export
setMethod("names<-", "AbstractCategories", function(x, value) {
if (is.null(value) || !is.character(value)) {
halt('Names must be of class "character"')
}
if (!identical(length(x), length(value))) {
halt(
"Invalid names: supplied ", length(value), " names for ",
length(x), " categories"
)
}
if (any(is.na(value))) {
halt("Category names must be non-missing")
}
x[] <- mapply(setAbstractCategoryName, x, value = value, SIMPLIFY = FALSE)
return(x)
})
#' @rdname describe-catalog
#' @export
setMethod("ids", "AbstractCategories", function(x) vapply(x, id, integer(1)))
# TODO: concatenateAbstractCategories
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.