#### 'matter_fct' class for file-based character vectors ####
## ----------------------------------------------------------
setClass("matter_fct",
slots = c(
levels = "ANY",
labels = "character"),
contains = "matter_vec",
validity = function(object) {
errors <- NULL
if ( !is.null(object@levels) ) {
if ( length(object@levels) != length(object@labels) )
errors <- c(errors, "'levels' and 'labels' must be the same length")
if ( typeof(object@levels) != object@type )
errors <- c(errors, "type of 'levels' must match object data type")
}
if ( is.null(errors) ) TRUE else errors
})
matter_fct <- function(data, levels, path = NULL,
length = NA_integer_, names = NULL, offset = 0, extent = NA_real_,
readonly = NA, append = FALSE, labels = as.character(levels), ...)
{
if ( !missing(data) && !is.null(data) ) {
if ( is.na(length) )
length <- length(data)
if ( is.null(names) )
names <- names(data)
if ( missing(levels) )
levels <- sort(unique(data))
data <- factor(data, levels=levels, labels=labels)
levels <- seq_len(nlevels(data))
labels <- levels(data)
}
x <- matter_vec(NULL, type=typeof(levels), path=path, length=length,
names=names, offset=offset, extent=extent,
readonly=readonly, append=append, rowMaj=FALSE, ...)
x <- as(x, "matter_fct")
x@levels <- levels
x@labels <- labels
if ( !missing(data) && !is.null(data) )
x[] <- data
if ( validObject(x) )
x
}
setMethod("as.factor", "matter_fct",
function(x) {
names(x) <- NULL
dimnames(x) <- NULL
if ( getOption("matter.coerce.altrep") ) {
as.altrep(x)
} else {
x[]
}
})
setMethod("describe_for_display", "matter_fct", function(x) {
desc1 <- paste0("<", length(x), " length> ", class(x))
desc2 <- paste0("out-of-memory factor")
paste0(desc1, " :: ", desc2)
})
setMethod("preview_for_display", "matter_fct", function(x) {
preview_vector(x)
cat("Levels(", nlevels(x), "): ", sep="")
cat(paste_head(x@labels), "\n")
})
get_matter_fct_elts <- function(x, i = NULL) {
y <- get_matter_arr_elts(x, i)
factor(y, levels=x@levels, labels=x@labels)
}
set_matter_fct_elts <- function(x, i = NULL, value = NULL) {
if ( is.factor(value) )
value <- x@labels[value]
value <- x@levels[match(value, x@labels)]
set_matter_arr_elts(x, i, value)
}
setMethod("[", c(x = "matter_fct"),
function(x, i, ..., drop = TRUE) {
i <- as_subscripts(i, x)
if ( is_null_or_na(drop) ) {
subset_matter_arr_elts(x, i)
} else {
get_matter_fct_elts(x, i)
}
})
setReplaceMethod("[", c(x = "matter_fct"),
function(x, i, ..., value) {
i <- as_subscripts(i, x)
set_matter_fct_elts(x, i, value)
})
setMethod("combine", "matter_fct",
function(x, y, ...) {
if ( any(x@levels != y@levels) )
matter_error("factor levels must match")
if ( any(x@labels != y@labels) )
matter_error("factor labels must match")
new("matter_fct", callNextMethod(),
levels=x@levels, labels=x@labels)
})
setMethod("levels", "matter_fct", function(x) x@labels)
setReplaceMethod("levels", "matter_fct",
function(x, value) {
if ( is.null(names(value)) ) {
x@labels <- value
} else {
x@levels <- as.vector(value)
x@labels <- names(value)
}
if ( validObject(x) )
x
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.