R/DemographicArray-methods.R
In StatisticsNZ/dembase: Analysing Cross-Classified Data about Populations
Defines functions
t.DemographicArray
median.DemographicArray
mean.DemographicArray
mad.DemographicArray
as.matrix.DemographicArray
as.array.DemographicArray
aperm.DemographicArray
`[.DemographicArray`
## HAS_TESTS
#' @export
setAs(from = "DemographicArray", to = "Counts",
function(from) {
.Data <- from@.Data
metadata <- metadata(from)
methods::new("Counts", .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @export
setAs(from = "DemographicArray", to = "Values",
function(from) {
.Data <- from@.Data
metadata <- metadata(from)
methods::new("Values", .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @export
setAs(from = "DemographicArray",
to = "matrix",
def = function(from) {
if (!identical(length(dim(from)), 2L))
stop("object does not have two dimensions")
ans <- from@.Data
dimnames(ans) <- dimnames(from)
ans
},
replace = function(from, value) {
from@.Data <- value
from
})
## HAS_TESTS
#' @export
`[.DemographicArray` <- function(x, i, j, ..., drop = TRUE) {
nargs <- nargs() - methods::hasArg(drop)
if (nargs == 1L)
return(x)
else if (nargs == 2L)
.Data <- methods::callGeneric(x = x@.Data, i = i, drop = FALSE)
else
.Data <- methods::callGeneric(x = x@.Data, i = i, j = j, ..., drop = FALSE)
dimnames.without.drop <- dimnames(.Data)
if (drop)
.Data <- drop(.Data)
dim.after <- dim(.Data)
if (is.null(dim.after))
return(.Data)
dim.before <- dim(x)
dims <- match(names(x), names(dimnames(.Data)), nomatch = 0L)
indices <- mapply(match,
x = dimnames(x),
table = dimnames.without.drop,
nomatch = 0L,
USE.NAMES = FALSE,
SIMPLIFY = FALSE)
transform <- methods::new("CollapseTransform",
dims = dims,
indices = indices,
dimBefore = dim.before,
dimAfter = dim.after)
metadata <- collapse(metadata(x), transform = transform)
.Data <- array(.Data, dim = dim(metadata), dimnames = dimnames(metadata))
methods::new(class(x), .Data = .Data, metadata = metadata)
}
#' @rdname internal-methods
#' @export
setMethod("[",
signature(x = "DemographicArray"),
`[.DemographicArray`)
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("Summary",
signature = "DemographicArrayOrNumeric",
function(x, ..., na.rm = FALSE) {
dots <- list(...)
n.dots <- length(dots)
## if ((length(x) == 0L) && (n.dots > 0L) && (.Generic != "range"))
## return(callGeneric(..., na.rm = na.rm))
if (methods::is(x, "DemographicArray")) {
.Data.x <- x@.Data
names.x <- names(x)
metadata.x <- metadata(x)
dimtypes.x <- dimtypes(metadata.x, use.names = FALSE)
DimScales.x <- DimScales(metadata.x, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes.x
if (has.quantile)
stop(gettextf("dimension with dimtype \"%s\"",
"quantile"))
i.iter.x <- match("iteration", dimtypes.x, nomatch = 0L)
has.iter.x <- i.iter.x > 0L
if (has.iter.x) {
n.iter.x <- dim(x)[i.iter.x]
if (.Generic == "range") {
name.iter.x <- names.x[i.iter.x]
nms <- c("range", name.iter.x)
nms <- make.unique(nms)
ds.range <- new("Categories", dimvalues = c("min", "max"))
ds.iter <- DimScales.x[[i.iter.x]]
metadata.ans.x <- new("MetaData",
nms = nms,
dimtypes = c("state", "iteration"),
DimScales = list(ds.range, ds.iter))
.Data.ans.x <- matrix(nrow = 2L, ncol = n.iter.x)
}
else {
metadata.ans.x <- metadata.x[i.iter.x]
if (is.integer(x))
.Data.ans.x <- integer(length = n.iter.x)
else
.Data.ans.x <- numeric(length = n.iter.x)
}
if ((length(.Data.x) == 0L) && (.Generic %in% c("min", "max", "range"))) {
if (.Generic == "min")
.Data.ans.x <- rep(Inf, times = n.iter.x)
else if (.Generic == "max")
.Data.ans.x <- rep(-Inf, times = n.iter.x)
else
.Data.ans.x <- rep(c(Inf, -Inf), times = n.iter.x)
}
else {
index <- slice.index(.Data.x, MARGIN = i.iter.x)
if (.Generic == "range") {
for (i in seq_len(n.iter.x))
.Data.ans.x[,i] <- callGeneric(.Data.x[index == i], na.rm = na.rm)
}
else {
for (i in seq_len(n.iter.x))
.Data.ans.x[i] <- callGeneric(.Data.x[index == i], na.rm = na.rm)
}
}
.Data.ans.x <- array(.Data.ans.x,
dim = dim(metadata.ans.x),
dimnames = dimnames(metadata.ans.x))
class.x <- if(methods::is(x, "Counts")) "Counts" else "Values"
ans.x <- methods::new(class.x,
.Data = .Data.ans.x,
metadata = metadata.ans.x)
}
else {
if ((length(.Data.x) == 0L) && (.Generic %in% c("min", "max", "range"))) {
if (.Generic == "min")
ans.x <- Inf
else if (.Generic == "max")
ans.x <- -Inf
else
ans.x <- c(Inf, -Inf)
}
else
ans.x <- methods::callGeneric(.Data.x, na.rm = na.rm)
.Data.ans.x <- ans.x
}
}
else {
has.iter.x <- FALSE
if ((length(x) == 0L) && (.Generic %in% c("min", "max", "range"))) {
if (.Generic == "min")
ans.x <- Inf
else if (.Generic == "max")
ans.x <- -Inf
else
ans.x <- c(Inf, -Inf)
}
else
ans.x <- methods::callNextMethod(x, na.rm = TRUE)
.Data.ans.x <- ans.x
}
if (n.dots == 0L)
return(ans.x)
checkIterationDimvalues(x, dots)
if ((n.dots == 1L) && (length(dots[[1L]]) == 0L))
return(ans.x)
ans.dots <- methods::callGeneric(..., na.rm = na.rm)
if (methods::is(ans.dots, "DemographicArray")) {
dimtypes.dots <- dimtypes(ans.dots, use.names = FALSE)
i.iter.dots <- match("iteration", dimtypes.dots, nomatch = 0L)
has.iter.dots <- i.iter.dots > 0L
.Data.ans.dots <- ans.dots@.Data
}
else {
has.iter.dots <- FALSE
.Data.ans.dots <- ans.dots
}
if (has.iter.x || has.iter.dots) {
if (has.iter.x && has.iter.dots) {
class <- class(ans.x)
metadata.ans <- metadata.ans.x
.Data.ans <- .Data.ans.x
if (.Generic == "range") {
for (i in seq_len(n.iter.x)) {
.Data.ans[1L,i] <- min(.Data.ans.x[1L,i],
.Data.ans.dots[1L,i],
na.rm = na.rm)
.Data.ans[2L,i] <- max(.Data.ans.x[2L,i],
.Data.ans.dots[2L,i],
na.rm = na.rm)
}
}
else {
for (i in seq_len(n.iter.x))
.Data.ans[i] <- methods::callGeneric(.Data.ans.x[i],
.Data.ans.dots[i],
na.rm = na.rm)
}
}
else if (has.iter.x && !has.iter.dots) {
class <- class(ans.x)
metadata.ans <- metadata.ans.x
.Data.ans <- .Data.ans.x
if (.Generic == "range") {
for (i in seq_len(n.iter.x)) {
.Data.ans[1L,i] <- min(.Data.ans.x[1L,i],
.Data.ans.dots[1L],
na.rm = na.rm)
.Data.ans[2L,i] <- max(.Data.ans.x[2L,i],
.Data.ans.dots[2L],
na.rm = na.rm)
}
}
else {
for (i in seq_len(n.iter.x))
.Data.ans[i] <- methods::callGeneric(.Data.ans.x[i],
.Data.ans.dots,
na.rm = na.rm)
}
}
else {
class <- class(ans.dots)
.Data.ans <- .Data.ans.dots
metadata.ans.dots <- metadata(ans.dots)
metadata.ans <- metadata.ans.dots
n.iter.dots <- dim(ans.dots)[i.iter.dots]
if (.Generic == "range") {
for (i in seq_len(n.iter.dots)) {
.Data.ans[1L,i] <- min(.Data.ans.x[1L],
.Data.ans.dots[1L,i],
na.rm = na.rm)
.Data.ans[2L,i] <- max(.Data.ans.x[2L],
.Data.ans.dots[2L,i],
na.rm = na.rm)
}
}
else {
for (i in seq_len(n.iter.dots))
.Data.ans[i] <- methods::callGeneric(.Data.ans.x,
.Data.ans.dots[i],
na.rm = na.rm)
}
}
methods::new(class, .Data = .Data.ans, metadata = metadata.ans)
}
else {
if (.Generic == "range")
c(min(ans.x[1L], ans.dots[1L], na.rm = na.rm),
max(ans.x[2L], ans.dots[2L], na.rm = na.rm))
else
methods::callGeneric(ans.x, ans.dots, na.rm = na.rm)
}
})
## HAS_TESTS
#' @rdname exported-not-api
#' @export
setMethod("DimScales",
signature(object = "DemographicArray"),
function(object, use.names = TRUE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname addDimension
#' @export
setMethod("addDimension",
signature(object = "DemographicArray"),
function(object, name, labels, after = length(dim(object)),
dimtype = NULL, dimscale = NULL, scale = 1L) {
class <- if (methods::is(object, "Counts")) "Counts" else "Values"
n.name <- length(name)
n.dim <- length(dim(object))
if (is.list(labels)) {
if (length(labels) > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"labels", "name"))
}
else
labels <- list(labels)
labels <- rep(labels, length.out = n.name)
labels <- lapply(labels, as.character)
if (!identical(length(after), 1L))
stop(gettextf("'%s' does not have length %d", "after", 1L))
if (is.character(after))
after <- match(after, names(object), nomatch = -1L)
if (!(after %in% seq.int(from = 0, to = n.dim)))
stop(gettextf("'%s' outside valid range", "after"))
if (is.list(scale)) {
if (length(scale) > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"scale", "name"))
}
else
scale <- list(scale)
scale <- rep(scale, length.out = n.name)
for (i in seq_len(n.name)) {
n.scale <- length(scale[[i]])
n.labels <- length(labels[[i]])
if (n.scale < n.labels)
scale[[i]] <- rep(scale[[i]], length.out = n.labels)
else if (n.scale > n.labels)
stop(gettextf("'%s' has more elements than '%s'",
"scale", "labels"))
}
if (is.null(dimtype))
dimtype <- inferDimtypes(name)
else {
n.dimtype <- length(dimtype)
if (n.dimtype < n.name)
dimtype <- rep(dimtype, length.out = n.name)
else if (n.dimtype > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"dimtype", "name"))
}
if (is.null(dimscale))
dimscale <- list(NULL)
else {
n.dimscale <- length(dimscale)
if (n.dimscale < n.name)
dimscale <- rep(dimscale, length.out = n.name)
else if (n.dimscale > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"dimscale", "name"))
}
DimScale <- mapply(inferDimScale,
dimtype = dimtype,
dimscale = dimscale,
labels = labels,
name = name,
SIMPLIFY = FALSE,
USE.NAMES = FALSE)
nms <- c(names(object), name)
dimtypes <- c(dimtypes(object, use.names = FALSE), unlist(dimtype))
DimScales <- c(DimScales(object, use.names = FALSE), DimScale)
metadata <- methods::new("MetaData",
nms = nms,
dimtypes = dimtypes,
DimScales = DimScales)
.Data <- c(object@.Data)
all.integer <- all(sapply(scale, is.integer))
scale <- Reduce("%o%", scale)
if (all.integer)
scale <- as.integer(scale)
scale <- rep(scale, each = length(.Data))
.Data <- scale * .Data
.Data <- array(.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
permute <- !identical(after, n.dim)
if (permute) {
old <- seq_len(n.dim)
new <- seq.int(from = n.dim + 1L, length.out = length(name))
perm <- append(old, values = new, after = after)
.Data <- aperm(.Data, perm = perm)
metadata <- metadata[perm]
}
methods::new(class,
.Data = .Data,
metadata = metadata)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("ageMax",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
ageMinMax(object = object,
min = FALSE)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setReplaceMethod("ageMax",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = FALSE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("ageMin",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
ageMinMax(object = object,
min = TRUE)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setReplaceMethod("ageMin",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = TRUE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname ageTimeStep
#' @export
setMethod("ageTimeStep",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname alignPair
#' @export
setMethod("alignPair",
signature(object = "DemographicArray"),
function(object, base = NULL, omitted = ifelse(methods::is(object, "Counts"), 0L, NA)) {
names <- names(object)
dimtypes <- dimtypes(object, use.names = FALSE)
dimtypes.with.pairs <- getDimtypesWithPairs(firstElementOnly = TRUE)
names.first <- names[dimtypes %in% dimtypes.with.pairs]
if (!is.null(base)) {
## base may legitimately match more than one pair
base.names.first <- removeSuffixes(names.first)
base.found <- base %in% base.names.first
if (any(!base.found))
stop(gettextf("\"%s\" is not a valid base name", base[!base.found][1L]))
names.first <- names.first[base.names.first %in% base]
}
indices.first <- match(names.first, names, nomatch = 0L)
for (i in seq_along(indices.first)) {
## object potentially changed at each iteration
name.first <- names.first[i]
index.first <- indices.first[i]
name.second <- getNamesPairs(name.first)
index.second <- match(name.second, names)
dv.first <- dimvalues(DimScales(object)[[index.first]])
dv.second <- dimvalues(DimScales(object)[[index.second]])
if (!identical(dv.first, dv.second)) {
dv.combined <- union(dv.first, dv.second) ## dv.first comes first
i.second <- match(dv.combined, dv.second, nomatch = 0L)
DimScale.combined <- methods::new("Categories", dimvalues = dv.combined)
DimScales.new <- replace(DimScales(object, use.names = FALSE),
list = c(index.first, index.second),
values = list(DimScale.combined))
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales.new)
.Data <- array(omitted,
dim = dim(metadata),
dimnames = dimnames(metadata))
is.old <- ((slice.index(.Data, MARGIN = index.first) <= length(dv.first)) &
(slice.index(.Data, MARGIN = index.second) %in% which(i.second > 0L)))
.Data.old <- slab(object,
dimension = index.second,
elements = i.second[i.second > 0L])
.Data[is.old] <- .Data.old
object <- methods::new(class(object), .Data = .Data, metadata = metadata)
}
}
object
})
## HAS_TESTS
#' @method aperm DemographicArray
#' @export
aperm.DemographicArray <- function(a, perm, resize = TRUE, keep.class = TRUE, ...) {
if (missing(perm) || is.null(perm))
perm <- seq_along(dim(a))
if (!isTRUE(resize) || !isTRUE(keep.class))
methods::callGeneric(a = a@.Data, perm = perm, resize = resize,
keep.class = keep.class, ...)
else {
.Data.new <- methods::callGeneric(a = a@.Data, perm = perm)
metadata.new <- metadata(a)[perm]
methods::new(class(a), .Data = .Data.new, metadata = metadata.new)
}
}
#' @rdname internal-methods
#' @export
setMethod("aperm",
signature(a = "DemographicArray"),
aperm.DemographicArray)
## ## NO_TESTS
## setMethod("apply",
## signature(X = "DemographicArray"),
## function(X, MARGIN, FUN, ...) {
## kSimpleFun <- c(mean, median, mode, max, min, sum, sd, var)
## FUN <- match.fun(FUN)
## MARGIN <- tidySubscript(MARGIN, nDim = length(dim(X)), names = names(X))
## matchesFUN <- function(f) identical(f, FUN)
## if (any(sapply(kSimpleFun, matchesFUN)))
## applySimple(X = X, MARGIN = MARGIN, FUN = FUN, ...)
## else
## applyComplicated(X = X, MARGIN = MARGIN, FUN = FUN, ...)
## })
## HAS_TESTS
#' @method as.array DemographicArray
#' @export
as.array.DemographicArray <- function(x, ...) {
x@.Data
}
#' @rdname internal-methods
#' @export
setMethod("as.array",
signature(x = "DemographicArray"),
as.array.DemographicArray)
## HAS_TESTS
#' @method as.matrix DemographicArray
#' @export
as.matrix.DemographicArray <- function(x, ...) {
as.matrix(x@.Data)
}
#' @rdname internal-methods
#' @export
setMethod("as.matrix",
signature(x = "DemographicArray"),
as.matrix.DemographicArray)
## HAS_TESTS
#' @rdname collapseIterations
#' @export
setMethod("collapseIterations",
signature(object = "DemographicArray"),
function(object, FUN = quantile, ...) {
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
if (identical(i.iter, 0L))
return(object)
if (length(object) == 0L)
stop(gettextf("'%s' has length %d",
"object", 0L))
name <- make.names(deparse(substitute(FUN)))
FUN <- match.fun(FUN)
n.dim <- length(dim(object))
if (n.dim == 1L) {
.Data <- FUN(object@.Data, ...)
if (is.list(.Data))
return(.Data)
return.value.length.1 <- length(.Data) == 1L
if (return.value.length.1)
return(.Data)
else
.Data <- array(.Data,
dim = length(.Data),
dimnames = list(names(.Data)))
}
else {
MARGIN <- seq_len(n.dim)[-i.iter]
.Data <- apply(object@.Data, MARGIN = MARGIN, FUN = FUN, ...)
if (is.list(.Data))
return(.Data)
if (is.null(dim(.Data)))
.Data <- array(.Data,
dim = length(.Data),
dimnames = dimnames(object)[-i.iter])
return.value.length.1 <- identical(dim(.Data), dim(object)[-i.iter])
}
if (return.value.length.1)
metadata <- metadata(object)[-i.iter]
else {
labels <- dimnames(.Data)[[1L]]
if (is.null(labels))
stop(gettextf("return values of '%s' do not have names", "FUN"))
if (any(is.na(labels)) || !all(nzchar(labels)))
stop(gettextf("return values of '%s' do not have valid names", "FUN"))
if (any(duplicated(labels)))
stop(gettextf("return values of '%s' have duplicated names [%s]",
"FUN", paste(dQuote(labels[duplicated(labels)]), collapse = ", ")))
dimvalues <- inferDimvalues(methods::new("Quantiles"), labels = labels)
looks.like.quantile <- !is.null(dimvalues)
if (looks.like.quantile) {
DimScale <- methods::new("Quantiles", dimvalues = dimvalues)
dimtype <- "quantile"
}
else {
DimScale <- methods::new("Categories", dimvalues = labels)
dimtype <- "state"
}
names <- replace(names(object), list = i.iter, values = name)
dimtypes <- replace(dimtypes(object, use.names = FALSE),
list = i.iter,
values = dimtype)
DimScales <- replace(DimScales(object, use.names = FALSE),
list = i.iter,
values = list(DimScale))
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
if (length(names) > 1L) {
perm <- append(seq.int(from = 2L, to = length(names)),
values = 1L,
after = i.iter - 1L)
.Data <- aperm(.Data, perm = perm)
}
dimnames(.Data) <- dimnames(metadata)
}
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## NO_TESTS
#' @rdname credibleInterval
#' @export
setMethod("credibleInterval",
signature(object = "DemographicArray"),
function(object, width = 95, na.rm = FALSE,
adjust = c("search", "expand", "none")) {
dim <- dim(object)
.Data <- object@.Data
dimtypes.obj <- dimtypes(object, use.names = FALSE)
i.iter <- match("iteration", dimtypes.obj, nomatch = 0L)
has.iter <- i.iter > 0L
if (!has.iter)
stop(gettextf("'%s' does not have a dimension with %s \"%s\"",
"object", "dimtype", "iteration"))
n.iter <- dim[i.iter]
width <- checkAndTidyPercentage(width)
if (isTRUE(all.equal(width, 0)))
stop(gettextf("'%s' equals %d",
"width", 0L))
checkLogicalFlag(value = na.rm,
name = "na.rm")
adjust <- match.arg(adjust)
q <- 1 - width / 100
prob <- c(q/2, 1 - q/2)
if (na.rm) {
quantile <- stats::quantile
ans <- collapseIterations(object,
FUN = quantile,
prob = prob,
na.rm = na.rm)
}
else {
names <- paste0(prob * 100, "%")
quantile <- function(x) {
if (any(is.na(x)))
structure(.Data = c(NA, NA), names = names)
else
stats::quantile(x, prob = prob)
}
ans <- collapseIterations(object,
FUN = quantile)
}
if (all(is.na(ans)))
return(ans)
if (identical(adjust, "none"))
return(ans)
.Data.obs <- !is.na(.Data)
.Data.whole.num <- (is.integer(.Data)
|| (all(.Data[.Data.obs] == as.integer(.Data[.Data.obs]))))
if (!.Data.whole.num)
return(ans)
dimtypes.ans <- dimtypes(ans, use.names = FALSE)
i.quantile <- match("quantile", dimtypes.ans)
lower <- slab(ans,
dimension = i.quantile,
elements = 1L,
drop = "dimension")
upper <- slab(ans,
dimension = i.quantile,
elements = 2L,
drop = "dimension")
floor.lower <- floor(lower)
ceiling.upper <- ceiling(upper)
if (identical(adjust, "search")) {
ceiling.lower <- ceiling(lower)
floor.upper <- floor(upper)
width.floor.floor <- floor.upper@.Data - floor.lower@.Data
width.ceiling.floor <- floor.upper@.Data - ceiling.lower@.Data
width.floor.ceiling <- ceiling.upper@.Data - floor.lower@.Data
width.ceiling.ceiling <- ceiling.upper@.Data - ceiling.lower@.Data
width.all <- matrix(c(width.floor.floor,
width.ceiling.floor,
width.floor.ceiling,
width.ceiling.ceiling),
nrow = length(width.floor.floor),
ncol = 4L)
if (length(lower) > 1L)
x <- as(lower, "Values")
else
x <- lower
transform.extend <- makeTransform(x = x,
y = object)
x <- as(object, "Counts")
dimtypes(x)[i.iter] <- "state"
transform.collapse <- makeTransform(x = x,
y = lower)
floor.lower.ext <- extend(floor.lower@.Data,
transform = transform.extend)
ceiling.lower.ext <- extend(ceiling.lower@.Data,
transform = transform.extend)
floor.upper.ext <- extend(floor.upper@.Data,
transform = transform.extend)
ceiling.upper.ext <- extend(ceiling.upper@.Data,
transform = transform.extend)
inside.floor.floor <- 1L * ((.Data.obs & (floor.lower.ext <= .Data))
& (.Data.obs & (.Data <= floor.upper.ext)))
inside.ceiling.floor <- 1L * ((.Data.obs & (ceiling.lower.ext <= .Data))
& (.Data.obs & (.Data <= floor.upper.ext)))
inside.floor.ceiling <- 1L * ((.Data.obs & (floor.lower.ext <= .Data))
& (.Data.obs & (.Data <= ceiling.upper.ext)))
inside.ceiling.ceiling <- 1L * ((.Data.obs & (ceiling.lower.ext <= .Data))
& (.Data.obs & (.Data <= ceiling.upper.ext)))
sum.floor.floor <- collapse(inside.floor.floor,
transform = transform.collapse)
sum.ceiling.floor <- collapse(inside.ceiling.floor,
transform = transform.collapse)
sum.floor.ceiling <- collapse(inside.floor.ceiling,
transform = transform.collapse)
sum.ceiling.ceiling <- collapse(inside.ceiling.ceiling,
transform = transform.collapse)
sum.obs <- collapse(1L * .Data.obs,
transform = transform.collapse)
cover.floor.floor <- sum.floor.floor / sum.obs
cover.ceiling.floor <- sum.ceiling.floor / sum.obs
cover.floor.ceiling <- sum.floor.ceiling / sum.obs
cover.ceiling.ceiling <- sum.ceiling.ceiling / sum.obs
cover.all <- matrix(c(cover.floor.floor,
cover.ceiling.floor,
cover.floor.ceiling,
cover.ceiling.ceiling),
nrow = length(cover.floor.floor),
ncol = 4L)
width.all[is.na(cover.all) | (cover.all < (width / 100))] <- Inf
best.combination <- apply(width.all, 1, which.min)
lower.all <- matrix(c(floor.lower,
ceiling.lower,
floor.lower,
ceiling.lower),
nrow = length(floor.lower),
ncol = 4L)
upper.all <- matrix(c(floor.upper,
floor.upper,
ceiling.upper,
ceiling.upper),
nrow = length(floor.upper),
ncol = 4L)
index.best <- cbind(seq_along(best.combination),
best.combination)
lower <- lower.all[index.best]
upper <- upper.all[index.best]
}
else if (identical(adjust, "expand")) {
lower <- floor.lower
upper <- ceiling.upper
}
else
stop(gettextf("invalid value for '%s' : \"%s\"",
"adjust", adjust))
slab(ans,
dimension = i.quantile,
elements = 1L) <- lower
slab(ans,
dimension = i.quantile,
elements = 2L) <- upper
ans <- toInteger(ans)
ans
})
## diff.DemographicArray <- function(x, lag = 1L, difference = 1L, dimension) {
## if ("quantile" %in% dimtypes(x))
## stop(gettext("'%s' has dimtype \"%s\"", "x", "quantile"))
## if (methods::hasArg(dimension)) {
## dimension <- tidySubscript(dimension, nDim = length(dim(x)), names = names(x))
## if (!identical(length(dimension), 1L))
## stop(gettext("more than one dimension selected"))
## }
## else {
## i.time <- match("time", dimtypes(x), nomatch = 0L)
## if (i > 0L)
## dimension <- i.time
## else
## stop(gettextf("'%s' not supplied, and '%s' does not have dimtype \"%s\", so no default",
## "dimension", "x", "time"))
## }
## margin <- invertSubscript(dimension, nDim = length(dim(x)))
## .Data <- apply(x@.Data, MARGIN = margin, FUN = diff, lag = lag, difference = difference)
## DimScale.new <- diff(DimScales(x)[[dimension]], lag = lag, difference = difference)
## ## TODO - FINISH
## }
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dim",
signature(x = "DemographicArray"),
function(x) {
x <- metadata(x)
methods::callGeneric(x)
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dim",
signature(x = "DemographicArray"),
function(x, value)
stop(sprintf("%s of object of class \"%s\" cannot be modified directly",
"dimensions", class(x))))
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dimnames",
signature(x = "DemographicArray"),
function(x) {
x <- metadata(x)
methods::callGeneric(x)
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dimnames",
signature(x = "DemographicArray"),
function(x, value)
stop(sprintf("%s of object of class \"%s\" cannot be modified directly",
"dimnames", class(x))))
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dimscales",
signature(object = "DemographicArray"),
function(object, use.names = TRUE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dimscales",
signature(object = "DemographicArray"),
function(object, value) {
object@metadata <- methods::callGeneric(object = metadata(object),
value = value)
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dimtypes",
signature(object = "DemographicArray"),
function(object, use.names = TRUE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dimtypes",
signature(object = "DemographicArray"),
function(object, value) {
object@metadata <- methods::callGeneric(object = metadata(object),
value = value)
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("drop",
signature(x = "DemographicArray"),
function(x) {
.Data <- x@.Data
.Data <- drop(.Data)
keep <- dim(x) != 1L
not.dim.0 <- !identical(dim(x), 0L)
like.vector.already <- length(dim(x)) == 1L
like.vector.after.drop.length.1 <- sum(keep) == 1L
if (not.dim.0 && (like.vector.already || like.vector.after.drop.length.1))
.Data
else {
names <- names(x)[keep]
dimtypes <- dimtypes(x, use.names = FALSE)[keep]
DimScales <- DimScales(x, use.names = FALSE)[keep]
## correct dimtypes and names for lost pairs
names.pairs <- getNamesPairs(names)
lost.pair <- !(names.pairs %in% names)
names[lost.pair] <- removeSuffixes(names[lost.pair])
dimtypes[lost.pair] <- "state"
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
dimnames(.Data) <- dimnames(metadata)
methods::new(class(x), .Data = .Data, metadata = metadata)
}
})
## HAS_TESTS
#' @rdname extrapolate
#' @export
setMethod("extrapolate",
signature(object = "DemographicArray"),
function(object, along = NULL, labels, growth = 0,
type = c("exponential", "linear", "missing")) {
metadata <- metadata(object)
names <- names(object)
dim <- dim(object)
dimtypes <- dimtypes(object, use.names = FALSE)
dimscales <- dimscales(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
along <- checkAndTidyAlong(along = along,
metadata = metadata,
numericDimScales = TRUE)
has.single.dim <- length(dim) == 1L
name.along <- names[along]
labels <- as.character(labels)
type <- match.arg(type)
if ("quantile" %in% dimtypes)
stop(gettextf("dimension with dimtype \"%s\"", "quantile"))
if (identical(dim[along], 0L))
stop(gettextf("cannot extrapolate along dimension \"%s\" because dimension has length 0",
name.along))
if (methods::is(growth, "DemographicArray")) {
if (name.along %in% names(growth))
stop(gettextf("extrapolating along dimension \"%s\" but '%s' has dimension named \"%s\"",
name.along, "growth", name.along))
growth <- methods::as(growth, "Values")
}
else if (is.numeric(growth)) {
if (!identical(length(growth), 1L))
stop(gettextf("'%s' does not have length %d", "growth", 1L))
if (!has.single.dim) {
metadata.growth <- metadata[-along]
.Data.growth <- rep(growth,
times = prod(dim[-along]))
.Data.growth <- array(.Data.growth,
dim = dim(metadata.growth),
dimnames = dimnames(metadata.growth))
growth <- methods::new("Values",
.Data = .Data.growth,
metadata = metadata.growth)
}
}
else
stop(gettextf("'%s' has class \"%s\"", "growth", class(growth)))
dimtype.extra <- dimtypes[along]
dimscale.extra <- dimscales[along]
DimScale.extra <- inferDimScale(dimtype = dimtype.extra,
dimscale = dimscale.extra,
labels = labels,
name = name.along)
DimScale.existing <- DimScales[[along]]
dv.existing <- dimvalues(DimScale.existing)
dv.extra <- dimvalues(DimScale.extra)
if (methods::is(DimScale.existing, "Points")) {
existing.first <- max(dv.existing) < min(dv.extra)
if (existing.first)
points <- c(dv.existing[length(dv.existing)], dv.extra)
else {
if (min(dv.existing) <= max(dv.extra))
stop(gettextf("extrapolated and existing points overlap"))
points <- c(dv.extra, dv.existing[1L])
}
}
else {
existing.first <- max(dv.existing) == min(dv.extra)
if (existing.first)
dimvalues.tmp <- c(dv.existing[length(dv.existing) - 1L], dv.extra)
else {
if (max(dv.extra) != min(dv.existing))
stop(gettextf("gap or overlap between extrapolated and existing intervals"))
dimvalues.tmp <- c(dv.extra, dv.existing[2L])
}
DimScale.tmp <- methods::new("Intervals", dimvalues = dimvalues.tmp)
points <- intervalsToPoints(DimScale.tmp)
points <- dimvalues(points)
}
if (existing.first)
distance <- points[-1L] - points[1L]
else
distance <- points[-length(points)] - points[length(points)]
metadata.distance <- methods::new("MetaData",
nms = name.along,
dimtypes = dimtypes[along],
DimScales = list(DimScale.extra))
.Data.distance <- array(distance,
dim = length(distance),
dimnames = dimnames(metadata.distance))
distance <- methods::new("Values", .Data = .Data.distance, metadata = metadata.distance)
i.jumpoff <- if (existing.first) length(DimScale.existing) else 1L
jumpoff <- slab(object, dimension = along, elements = i.jumpoff, drop = TRUE)
if (!has.single.dim) {
metadata.jumpoff <- metadata[-along]
.Data.jumpoff <- array(jumpoff@.Data,
dim = dim(metadata.jumpoff),
dimnames = dimnames(metadata.jumpoff))
jumpoff <- new("Values",
.Data = .Data.jumpoff,
metadata = metadata.jumpoff)
}
if (identical(type, "exponential"))
extra <- jumpoff * ((1 + growth) ^ distance)
else if (identical(type, "linear"))
extra <- jumpoff + distance * growth
else if (identical(type, "missing")) {
extra <- jumpoff + distance
extra[] <- as.integer(NA)
}
else
stop(gettextf("invalid value for '%s': \"%s\"", "type", type))
extra <- methods::as(extra, class(object))
dbind(object, extra, along = name.along)
})
## HAS_TESTS
#' @rdname hasRegularAgeTime
#' @export
setMethod("hasRegularAgeTime",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname impute
#' @export
setMethod("impute",
signature(object = "DemographicArray"),
function(object, mult = NULL, max = NULL) {
.Data <- object@.Data
i.missing <- sort(which(is.na(.Data)))
n.missing <- length(i.missing)
if (identical(n.missing, length(.Data)))
stop(gettext("no non-missing values"))
if (identical(n.missing, 0L))
return(object)
if (is.null(mult))
mult <- all(.Data >= 0, na.rm = TRUE)
else {
if (!identical(length(mult), 1L))
stop(gettextf("'%s' does not have length %d",
"mult", 1L))
if (!is.logical(mult))
stop(gettextf("'%s' does not have type \"%s\"",
"mult", "logical"))
if (is.na(mult))
stop(gettextf("'%s' is missing",
"mult"))
if (mult) {
if (any(.Data < 0, na.rm = TRUE))
stop(gettextf("'%s' is %s but '%s' has negative values",
"mult", "TRUE", "object"))
if (all(.Data == 0, na.rm = TRUE))
stop(gettextf("'%s' is %s but '%s' has no positive values",
"mult", "TRUE", "object"))
}
}
if (!is.null(max)) {
if (!is.numeric(max))
stop(gettextf("'%s' does not have type \"%s\"",
"max", "numeric"))
if (any(is.na(max)))
stop(gettextf("'%s' has missing values",
"max"))
if (isTRUE(all.equal(max, round(max))))
max <- as.integer(max)
max <- rep(max, length.out = length(.Data))
}
values <- .Data[!is.na(.Data)]
is.integer.vals <- isTRUE(all.equal(round(values), values))
is.integer.type <- is.integer(.Data)
d <- as.data.frame(object,
direction = "long",
midpoints = TRUE,
stringsAsFactors = TRUE)
if (mult) {
n <- length(d)
is.zero <- !is.na(d[[n]]) & (d[[n]] == 0L)
d[[n]] <- log(d[[n]])
d[[n]][is.zero] <- NA
}
is.factor.one.level <- sapply(d[stats::complete.cases(d), ],
function(x) is.factor(x) && length(unique(x)) == 1L)
d <- d[!is.factor.one.level]
p <- min(length(d) - 1L, sum(stats::complete.cases(d)))
if (p > 1L)
predictors <- paste(names(d)[seq_len(p)], collapse = " + ")
else
predictors <- "1"
formula <- stats::as.formula(sprintf("%s ~ %s",
names(d)[length(d)],
predictors))
mod <- stats::lm(formula, data = d)
xlevels <- mod$xlevels
for (name in names(xlevels)) {
levels.without.obs <- setdiff(levels(d[[name]]), xlevels[[name]])
if (length(levels.without.obs) > 0L)
d[[name]][d[[name]] %in% levels.without.obs] <- xlevels[[name]][1L]
}
predicted <- stats::predict(mod, newdata = d[-length(d)])
predicted <- predicted[i.missing]
if (mult)
predicted <- exp(predicted)
if (is.integer.vals)
imputed.values <- as.integer(stats::rpois(n = n.missing, lambda = predicted))
else
imputed.values <- stats::rnorm(n = n.missing,
mean = predicted,
sd = sqrt(abs(predicted)))
if (!is.null(max)) {
max.imputed <- max[i.missing]
exceeds.max <- imputed.values > max.imputed
imputed.values[exceeds.max] <- max.imputed[exceeds.max]
}
object[i.missing] <- imputed.values
object
})
## HAS_TESTS
#' @rdname intervalContainsTruth
#' @export
setMethod("intervalContainsTruth",
signature(interval = "DemographicArray",
truth = "DemographicArray"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthArray(truth)
checkIntervalAndTruthArrayCompatible(interval = interval,
truth = truth)
metadata <- truth@metadata
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
lower <- makeCompatible(x = lower,
y = truth,
subset = FALSE)
upper <- makeCompatible(x = upper,
y = truth,
subset = FALSE)
truth <- truth@.Data
.Data <- 1L * ((lower <= truth) & (truth <= upper))
new("Values",
.Data = .Data,
metadata = metadata)
})
## HAS_TESTS
#' @rdname intervalContainsTruth
#' @export
setMethod("intervalContainsTruth",
signature(interval = "DemographicArray",
truth = "numeric"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthNumeric(truth)
checkIntervalAndTruthNumericCompatible(interval = interval,
truth = truth)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
ans <- (lower <= truth) & (truth <= upper)
as.integer(ans)
})
#' @rdname intervalScore
setMethod("intervalScore",
signature(interval = "DemographicArray",
truth = "DemographicArray"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthArray(truth)
checkIntervalAndTruthArrayCompatible(interval = interval,
truth = truth)
metadata <- truth@metadata
alpha <- getAlphaInterval(interval)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
lower <- makeCompatible(x = lower,
y = truth,
subset = FALSE)
upper <- makeCompatible(x = upper,
y = truth,
subset = FALSE)
lower <- lower@.Data
upper <- upper@.Data
truth <- truth@.Data
width <- upper - lower
penalty.below.lower <- (2 / alpha) * (lower - truth) * (truth < lower)
penalty.above.upper <- (2 / alpha) * (truth - upper) * (truth > upper)
.Data <- width + penalty.below.lower + penalty.above.upper
new("Counts",
.Data = .Data,
metadata = metadata)
})
#' @rdname intervalScore
setMethod("intervalScore",
signature(interval = "DemographicArray",
truth = "numeric"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthNumeric(truth)
checkIntervalAndTruthNumericCompatible(interval = interval,
truth = truth)
alpha <- getAlphaInterval(interval)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
lower <- lower@.Data
upper <- upper@.Data
width <- upper - lower
penalty.below.lower <- (2 / alpha) * (lower - truth) * (truth < lower)
penalty.above.upper <- (2 / alpha) * (truth - upper) * (truth > upper)
ans <- width + penalty.below.lower + penalty.above.upper
as.numeric(ans)
})
#' @rdname intervalWidth
#' @export
setMethod("intervalWidth",
signature(interval = "DemographicArray"),
function(interval) {
checkIntervalArray(interval)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
upper - lower
})
## NO_TESTS
#' @rdname limits
#' @export
setMethod("limits",
signature(object = "DemographicArray"),
function(object, components = FALSE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
## function is complicated because of 'center = median(x)' argument
#' @method mad DemographicArray
#' @export
mad.DemographicArray <- function(x, center = median(x), constant = 1.4826,
na.rm = FALSE, low = FALSE, high = FALSE) {
.Data <- x@.Data
metadata <- metadata(x)
dimtypes <- dimtypes(metadata, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes
if (has.quantile)
stop(gettextf("'%s' has dimension with dimtype \"%s\"",
"x", "quantile"))
i.iter <- match("iteration", dimtypes, nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
metadata.ans <- metadata[i.iter]
if (methods::hasArg(center)) {
FUN <- function(X)
stats::mad(X,
center = center,
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
else {
FUN <- function(X)
stats::mad(X,
center = stats::median(X, na.rm = na.rm),
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
.Data.ans <- apply(.Data,
MARGIN = i.iter,
FUN = FUN)
.Data.ans <- array(.Data.ans,
dim = dim(metadata.ans),
dimnames = dimnames(metadata.ans))
class <- if(methods::is(x, "Counts")) "Counts" else "Values"
new(class,
.Data = .Data.ans,
metadata = metadata.ans)
}
else {
if (methods::hasArg(center)) {
stats::mad(.Data,
center = center,
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
else {
stats::mad(.Data,
center = stats::median(.Data, na.rm = na.rm),
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
}
}
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("mad",
signature(x = "DemographicArray"),
mad.DemographicArray)
## HAS_TESTS
#' @method mean DemographicArray
#' @export
mean.DemographicArray <- function(x, ...) {
.Data <- x@.Data
metadata <- metadata(x)
dimtypes <- dimtypes(metadata, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes
if (has.quantile)
stop(gettextf("'%s' has dimension with dimtype \"%s\"",
"x", "quantile"))
i.iter <- match("iteration", dimtypes, nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
metadata.ans <- metadata[i.iter]
.Data.ans <- apply(.Data,
MARGIN = i.iter,
FUN = mean,
...)
.Data.ans <- array(.Data.ans,
dim = dim(metadata.ans),
dimnames = dimnames(metadata.ans))
class <- if(methods::is(x, "Counts")) "Counts" else "Values"
new(class,
.Data = .Data.ans,
metadata = metadata.ans)
}
else
mean(.Data, ...)
}
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("mean",
signature(x = "DemographicArray"),
mean.DemographicArray)
## HAS_TESTS
#' @method median DemographicArray
#' @export
median.DemographicArray <- function(x, na.rm = FALSE, ...) {
.Data <- x@.Data
metadata <- metadata(x)
dimtypes <- dimtypes(metadata, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes
if (has.quantile)
stop(gettextf("'%s' has dimension with dimtype \"%s\"",
"x", "quantile"))
i.iter <- match("iteration", dimtypes, nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
metadata.ans <- metadata[i.iter]
.Data.ans <- apply(.Data,
MARGIN = i.iter,
FUN = stats::median,
na.rm = na.rm,
...)
.Data.ans <- array(.Data.ans,
dim = dim(metadata.ans),
dimnames = dimnames(metadata.ans))
class <- if(methods::is(x, "Counts")) "Counts" else "Values"
new(class,
.Data = .Data.ans,
metadata = metadata.ans)
}
else
stats::median(.Data, na.rm = na.rm, ...)
}
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("median",
signature(x = "DemographicArray"),
median.DemographicArray)
## HAS_TESTS
setMethod("metadata",
signature(object = "DemographicArray"),
function(object) object@metadata)
## HAS_TESTS
#' @rdname midpoints
#' @export
setMethod("midpoints",
signature(object = "DemographicArray", dimension = "ANY"),
function(object, dimension) {
.Data <- object@.Data
metadata <- metadata(object)
dimension <- tidySubscript(subscript = dimension,
nDim = length(dim(object)),
names = names(object))
metadata <- midpoints(object = metadata, dimension = dimension)
dimnames(.Data) <- dimnames(metadata)
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @rdname midpoints
#' @export
setMethod("midpoints",
signature(object = "DemographicArray", dimension = "missing"),
function(object) {
dimension <- which(dimscales(object) == "Intervals")
methods::callGeneric(object = object, dimension = dimension)
})
## NO_TESTS
#' @rdname MSE
#' @export
setMethod("MSE",
signature(point = "DemographicArray",
truth = "DemographicArray"),
function(point, truth) {
checkPointArray(point)
checkTruthArray(truth)
checkPointAndTruthCompatible(point = point,
truth = truth)
(truth - point)^2 # 'truth' first, so that answer has same metadata as 'truth'
})
#' Get or set dimension names
#'
#' Query or change the dimension names of a \code{\linkS4class{DemographicArray}}
#' object.
#'
#' @name names-methods
#' @docType methods
#' @param x Object of class \code{\linkS4class{DemographicArray}}.
#' @param value Character vector.
#' @return A character vector. The replacement method returns an object of
#' class \code{\linkS4class{DemographicArray}}.
#' @author John Bryant \email{demographic.packages@@gmail.com}
#' @seealso As described in \code{\link{dimtypes}}, some dimensions must come
#' in pairs, and there are special rules governing the names of these
#' dimensions.
#' @examples
#' library(demdata)
#' popn <- Counts(VAPopn)
#' names(popn)
#' names(popn) <- toupper(names(popn))
NULL
## HAS_TESTS
#' @rdname names-methods
#' @export
setMethod("names",
signature(x = "DemographicArray"),
function(x) {
x <- metadata(x)
methods::callGeneric(x)
})
## HAS_TESTS
#' @rdname names-methods
#' @export
setReplaceMethod("names",
signature(x = "DemographicArray"),
function(x, value) {
value <- as.character(value)
names(x@metadata) <- value
names(dimnames(x@.Data)) <- value
methods::validObject(x)
x
})
## HAS_TESTS
#' @rdname nIteration
#' @export
setMethod("nIteration",
signature(object = "DemographicArray"),
function(object) {
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
if (identical(i.iter, 0L))
stop(gettextf("no dimension with dimtype \"%s\"", "iteration"))
dim(object)[i.iter]
})
#' @rdname pairAligned
#' @export
setMethod("pairAligned",
signature(object = "DemographicArray"),
function(object, base = NULL) {
object <- metadata(object)
callGeneric()
})
## HAS_TESTS
#' @rdname pairToState
#' @export
setMethod("pairToState",
signature(object = "DemographicArray"),
function(object) {
.Data.old <- object@.Data
names.old <- names(object)
dimtypes.old <- dimtypes(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
dimtypes.with.pairs <- getDimtypesWithPairs()
names.new <- names.old
dimtypes.new <- dimtypes.old
for (i in seq_along(names.old)) {
name.old <- names.old[i]
dimtype.old <- dimtypes.old[i]
if (dimtype.old %in% dimtypes.with.pairs) {
dimtypes.new[i] <- "state"
suffix <- getSuffixes(dimtype.old)
pattern <- paste0(suffix, "$")
replacement <- sub("^_", ".", suffix)
name.new <- sub(pattern = pattern,
replacement = replacement,
x = name.old)
names.new[i] <- name.new
}
}
metadata.new <- methods::new("MetaData",
nms = names.new,
dimtypes = dimtypes.new,
DimScales = DimScales)
.Data.new <- array(.Data.old,
dim = dim(metadata.new),
dimnames = dimnames(metadata.new))
new(class(object),
.Data = .Data.new,
metadata = metadata.new)
})
## HAS_TESTS
#' @rdname perturb
#' @export
setMethod("perturb",
signature(object = "DemographicArray"),
function(object, n = 1L, order = 2L, phi = 1, subtotals = NULL) {
if (!is.null(subtotals))
stop("'subtotals' not yet implemented")
for (name in c("n", "order", "phi")) {
value <- get(name)
if (!identical(length(value), 1L))
stop(gettextf("'%s' does not have length %d", name, 1L))
if (is.na(value))
stop(gettextf("'%s' is missing", name))
if (value < 1L)
stop(gettextf("'%s' is less than %d", name, 1L))
}
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter)
perturbUsingIterations(object = object, n = n, i.iter = i.iter)
else
perturbUsingModel(object = object, n = n, order = order, phi = phi)
})
## HAS_TESTS
#' @rdname population
#' @export
setMethod("population",
signature(object = "DemographicArray"),
function(object) {
as(object@population, "Counts")
})
## HAS_TESTS
#' @rdname prop.table
#' @export
setMethod("prop.table",
signature(x = "DemographicArray", margin = "ANY"),
function(x, margin = NULL) {
if ("quantile" %in% dimtypes(x))
stop(gettextf("dimension with dimtype \"%s\"", "quantile"))
i.iter <- match("iteration", dimtypes(x), nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
if (!(i.iter %in% margin))
margin <- c(margin, i.iter)
}
.Data <- prop.table(x@.Data, margin = margin)
metadata <- metadata(x)
methods::new("Values", .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @rdname prop.table
#' @export
setMethod("prop.table",
signature(x = "DemographicArray", margin = "character"),
function(x, margin = NULL) {
margin <- match(margin, names(x), nomatch = 0L)
if (any(margin == 0L))
stop(gettextf("'%s' outside valid range", "margin"))
methods::callGeneric()
})
## HAS_TESTS
#' @rdname recodeCategories
#' @export
setMethod("recodeCategories",
signature(object = "DemographicArray",
dimension = "ANY",
old = "ANY",
new = "ANY",
concordance = "missing"),
function(object, dimension = NULL, old = NULL, new = NULL,
concordance = NULL) {
dim <- dim(object)
names <- names(object)
dimtypes <- dimtypes(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
dimension <- tidySubscript(dimension,
nDim = length(dim),
names = names)
for (name in c("old", "new")) {
value <- get(name)
if (any(is.na(value)))
stop(gettextf("'%s' has missing values",
name))
if (any(duplicated(value)))
stop(gettextf("'%s' has duplicates",
name))
}
if (!identical(length(old), length(new)))
stop(gettextf("'%s' and '%s' have different lengths",
"old", "new"))
for (i.dim in seq_along(dim)) {
recode.this.dimension <- i.dim %in% dimension
if (recode.this.dimension) {
DimScale <- DimScales[[i.dim]]
if (!methods::is(DimScale, "Categories"))
stop(gettextf("dimension \"%s\" has dimscale \"%s\"",
names[i.dim], class(DimScale)))
labels.old <- dimvalues(DimScale)
labels.new <- labels.old
name.dim <- names[i.dim]
for (i.old in seq_along(old)) {
label.old <- old[i.old]
i.label <- match(label.old, labels.old, nomatch = 0L)
has.label <- i.label > 0L
if (has.label)
labels.new[i.label] <- new[i.old]
else {
stop(gettextf("'%s' includes value \"%s\" but \"%s\" dimension of '%s' does not include \"%s\"",
"old", label.old, name.dim, "object", label.old, "strict", "TRUE"))
}
}
class.dimscale <- class(DimScale)
DimScale <- tryCatch(methods::new(class.dimscale, dimvalues = labels.new),
error = function(e) e)
if (methods::is(DimScale, "error"))
stop(gettextf("problem creating \"%s\" %s for \"%s\" dimension : %s",
class.dimscale, "dimscale", name.dim, DimScale$message))
DimScales[[i.dim]] <- DimScale
}
}
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
.Data <- object@.Data
dimnames(.Data)[dimension] <- dimnames(metadata)[dimension]
methods::new(class(object),
.Data = .Data,
metadata = metadata)
})
## HAS_TESTS
#' @rdname recodeCategories
#' @export
setMethod("recodeCategories",
signature(object = "DemographicArray",
dimension = "ANY",
old = "missing",
new = "missing",
concordance = "Concordance"),
function(object, dimension = NULL,
old = NULL, new = NULL,
concordance = NULL) {
dim <- dim(object)
names <- names(object)
dimtypes <- dimtypes(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
dimension <- tidySubscript(dimension,
nDim = length(dim),
names = names)
if (!methods::is(concordance, "OneToOne"))
stop(gettextf("'%s' has class \"%s\"",
"concordance", class(concordance)))
for (i.dim in seq_along(dim)) {
recode.this.dimension <- i.dim %in% dimension
if (recode.this.dimension) {
name.dim <- names[i.dim]
DimScale <- DimScales[[i.dim]]
if (!methods::is(DimScale, "Categories"))
stop(gettextf("\"%s\" dimension has dimscale \"%s\"",
names[i.dim], class(DimScale)))
labels.old <- dimvalues(DimScale)
labels.new <- tryCatch(translate(labels.old,
concordance = concordance),
error = function(e) e)
if (methods::is(labels.new, "error"))
stop(gettextf("unable to recode categories for \"%s\" dimension : %s",
name.dim, labels.new$message))
class.dimscale <- class(DimScale)
DimScale <- tryCatch(methods::new(class.dimscale, dimvalues = labels.new),
error = function(e) e)
if (methods::is(DimScale, "error"))
stop(gettextf("problem creating \"%s\" %s for \"%s\" dimension : %s",
class.dimscale, "dimscale", name.dim, DimScale$message))
DimScales[[i.dim]] <- DimScale
}
}
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
.Data <- object@.Data
dimnames(.Data)[dimension] <- dimnames(metadata)[dimension]
methods::new(class(object),
.Data = .Data,
metadata = metadata)
})
## ## need to deal with pairs of dims
## setMethod("reorderCategories",
## signature(object = "DemographicArray"),
## function(object, dimension, FUN, ...) {
## .Data <- object@.Data
## metadata <- metadata(object)
## dim <- dim(object)
## dimension <- tidySubscript(dimension, nDim = length(dim), names = names(metadata))
## if (identical(length(dimension), 1L)) {
## DimScale <- DimScales(object)[[dimension]]
## if (!methods::is(DimScale, "Categories"))
## stop(gettextf("'%s' has dimscale \"%s\"", "dimension", class(DimScale)))
## res <- numeric(
## }
## else
## stop(gettextf("'%s' has length %d", "dimension", length(dimension)))
## metadata.tmp <- metadata[-dimension]
## slab <- slice.index(.Data, MARGIN = dimension)
## data.tmp <- array(.Data[slab == 1L], dim = dim(metadata.tmp), dimnames = dimnames(metadata.tmp))
## obj.tmp <- methods::new(class(object), .Data.tmp)
## res <- numeric(length = dim[dimension])
## for (i in seq_len(dim[dimension])) {
## obj.tmp@.Data@.Data <- .Data[slab == i]
## res.tmp <- FUN(obj.tmp, ...)
## if (!(identical(length(res.tmp, 1L))))
## stop(gettextf("return value does not have length %d", 1L))
## if (!is.numeric(res.tmp))
## stop(gettextf("return value does not have type \"%s\"", "numeric"))
## if (is.na(res.tmp))
## stop(gettext("return value is missing"))
## res[i] <- res.tmp
## }
## DimScale.reorder <- DimScales(object)[dimension]
## HAS_TESTS
#' @rdname resetIterations
#' @export
setMethod("resetIterations",
signature(object = "DemographicArray"),
function(object) {
.Data <- object@.Data
metadata <- metadata(object)
metadata <- resetIterations(metadata)
dimnames(.Data) <- dimnames(metadata)
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## NO_TESTS
#' @rdname rotateAgeTime
#' @export
setMethod("rotateAgeTime",
signature(object = "DemographicArray"),
function(object, to = NULL, name = NULL) {
choices.at <- c("at", "ta", "age-time", "time-age")
choices.ac <- c("ac", "ca", "age-cohort", "cohort-age")
choices.tc <- c("tc", "ct", "time-cohort", "cohort-time")
choices.to <- c(choices.at, choices.ac, choices.tc)
hasRegularAgeTime(object)
.Data.old <- object@.Data
names.old <- names(object)
dim.old <- dim(object)
dimtypes.old <- dimtypes(object,
use.names = FALSE)
DimScales.old <- DimScales(object,
use.names = FALSE)
n.dim <- length(dim.old)
n.old <- length(.Data.old)
pos.old <- seq_len(n.old) - 1L # C-style
i.age <- match("age", dimtypes.old, nomatch = 0L)
i.time <- match("time", dimtypes.old, nomatch = 0L)
i.cohort <- match("cohort", dimtypes.old, nomatch = 0L)
i.triangle <- match("triangle", dimtypes.old, nomatch = 0L)
has.age <- i.age > 0L
has.time <- i.time > 0L
has.cohort <- i.cohort > 0L
has.triangle <- i.triangle > 0L
if (has.age + has.time + has.cohort != 2L)
stop(gettextf("'%s' must have dimensions with two of the following three dimtypes: \"%s\", \"%s\", \"%s\"",
"object", "age", "time", "cohort"))
has.at <- has.age && has.time
has.ac <- has.age && has.cohort
has.tc <- has.time && has.cohort
if (is.null(to))
stop(gettextf("argument \"%s\" is missing, with no default",
"to"))
to <- tolower(to)
to <- match.arg(to, choices = choices.to)
to.at <- to %in% choices.at
to.ac <- to %in% choices.ac
to.tc <- to %in% choices.tc
no.change <- (has.at && to.at) || (has.ac && to.ac) || (has.tc && to.tc)
if (no.change)
return(object)
if (!is.null(name)) {
if (!identical(length(name), 1L))
stop(gettextf("'%s' does not have length %d",
"name", 1L))
if (is.na(name))
stop(gettextf("'%s' is missing",
"name"))
}
if (has.age) {
DimScale.age <- DimScales.old[[i.age]]
dv.age <- dimvalues(DimScale.age)
if (any(is.infinite(dv.age)))
stop(gettextf("dimension with %s \"%s\" has open interval",
"dimtype", "age"))
if (any(dv.age < 0))
stop(gettext("cannnegative ages"))
n.age <- dim.old[i.age]
step.age <- 1L
for (d in seq_len(i.age - 1L))
step.age <- step.age * dim.old[d]
pos.age <- (pos.old %/% step.age) %% n.age # C-style
}
if (has.time) {
DimScale.time <- DimScales.old[[i.time]]
dv.time <- dimvalues(DimScale.time)
if (any(is.infinite(dv.time)))
stop(gettextf("dimension with %s \"%s\" has open interval",
"dimtype", "time"))
n.time <- dim.old[i.time]
step.time <- 1L
for (d in seq_len(i.time - 1L))
step.time <- step.time * dim.old[d]
pos.time <- (pos.old %/% step.time) %% n.time # C-style
}
if (has.cohort) {
DimScale.cohort <- DimScales.old[[i.cohort]]
dv.cohort <- dimvalues(DimScale.cohort)
if (any(is.infinite(dv.cohort)))
stop(gettextf("dimension with %s \"%s\" has open interval",
"dimtype", "cohort"))
n.cohort <- dim.old[i.cohort]
step.cohort <- 1L
for (d in seq_len(i.cohort - 1L))
step.cohort <- step.cohort * dim.old[d]
pos.cohort <- (pos.old %/% step.cohort) %% n.cohort # C-style
}
if (has.triangle) {
DimScale.triangle <- DimScales.old[[i.triangle]]
n.triangle <- dim.old[i.triangle]
step.triangle <- 1L
for (d in seq_len(i.triangle - 1L))
step.triangle <- step.triangle * dim.old[d]
pos.triangle <- (pos.old %/% step.triangle) %% n.triangle # C-style
}
else
pos.triangle <- rep.int(0L, times = n.old)
if (has.at) { # new dimension is cohort
if (is.null(name))
name <- "cohort"
DimScale.cohort <- makeMissingAgeTimeDimScale(age = DimScale.age,
time = DimScale.time)
pos.along.new <- pos.time - pos.age - pos.triangle
if (to.ac) { # replacing time with cohort
name <- make.unique(c(names.old[-i.time], name))[n.dim]
names.new <- replace(names.old,
list = i.time,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.time,
values = "cohort")
DimScales.new <- replace(DimScales.old,
list = i.time,
values = list(DimScale.cohort))
iAlong <- i.time
}
else { # replacing age with cohort
name <- make.unique(c(names.old[-i.age], name))[n.dim]
names.new <- replace(names.old,
list = i.age,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.age,
values = "cohort")
DimScales.new <- replace(DimScales.old,
list = i.age,
values = list(DimScale.cohort))
iAlong <- i.age
}
}
else if (has.ac) { # new dimension is time
if (is.null(name))
name <- "time"
DimScale.time <- makeMissingAgeTimeDimScale(age = DimScale.age,
cohort = DimScale.cohort)
pos.along.new <- pos.cohort + pos.age + pos.triangle
if (to.at) { # replacing cohort with time
name <- make.unique(c(names.old[-i.cohort], name))[n.dim]
names.new <- replace(names.old,
list = i.cohort,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.cohort,
values = "time")
DimScales.new <- replace(DimScales.old,
list = i.cohort,
values = list(DimScale.time))
iAlong <- i.cohort
}
else { # replacing age with time
name <- make.unique(c(names.old[-i.age], name))[n.dim]
names.new <- replace(names,
list = i.age,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.age,
values = "time")
DimScales.new <- replace(DimScales,
list = i.age,
values = list(DimScale.time))
iAlong <- i.age
}
}
else { # has.tc - new dimension is age
if (!all(dv.cohort <= max(dv.time)))
stop(gettext("cohort starting after final time point or interval"))
if (is.null(name))
name <- "age"
DimScale.age <- makeMissingAgeTimeDimScale(time = DimScale.time,
cohort = DimScale.cohort)
pos.along.new <- pos.time - pos.cohort - pos.triangle
if (to.ac) { # replacing time with age
name <- make.unique(c(names.old[-i.time], name))[n.dim]
names.new <- replace(names.old,
list = i.time,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.time,
values = "age")
DimScales.new <- replace(DimScales.old,
list = i.time,
values = list(DimScale.age))
iAlong <- i.time
}
else { # replacing cohort with age
name <- make.unique(c(names.old[-i.cohort], name))[n.dim]
names.new <- replace(names.old,
list = i.cohort,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.cohort,
values = "age")
DimScales.new <- replace(DimScales.old,
list = i.cohort,
values = list(DimScale.age))
iAlong <- i.cohort
}
}
metadata.new <- new("MetaData",
nms = names.new,
dimtypes = dimtypes.new,
DimScales = DimScales.new)
dim.new <- dim(metadata.new)
dimnames.new <- dimnames(metadata.new)
.Data.new <- array(NA_integer_,
dim = dim.new,
dimnames = dimnames.new)
n.along.old <- dim.old[iAlong]
n.along.new <- dim.new[iAlong]
if (iAlong > 1L) {
s.before <- seq.int(from = 1L, to = iAlong - 1L)
n.within <- prod(dim.old[s.before])
}
else
n.within <- 1L
if (iAlong < n.dim) {
s.after <- seq.int(from = iAlong + 1L, to = n.dim)
n.between <- prod(dim.old[s.after])
}
else
n.between <- 1L
seq.within <- seq_len(n.within) - 1L
seq.along.old <- seq_len(n.along.old) - 1L
seq.between <- seq_len(n.between) - 1L
pos.within.old <- rep(seq.within, times = n.along.old * n.between)
pos.along.old <- rep(rep(seq.along.old, each = n.within), times = n.between)
pos.along.new <- pos.along.new - min(pos.along.new)
pos.between.old <- rep(seq.between, each = n.within * n.along.old)
pos.new <- pos.within.old + n.within * pos.along.new + n.within * n.along.new * pos.between.old
pos.new <- pos.new + 1L # R-style
.Data.new[pos.new] <- .Data.old
class.new <- if (methods::is(object, "Counts")) "Counts" else "Values"
new(class.new,
.Data = .Data.new,
metadata = metadata.new)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("setAgeMax",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = FALSE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("setAgeMin",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = TRUE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("show",
signature(object = "DemographicArray"),
function(object) {
metadata <- metadata(object)
.Data <- object@.Data
cat(gettextf("An object of class \"%s\"\n", class(object)))
showMetaData(metadata)
cat("\n")
methods::show(.Data)
})
## HAS_TESTS
#' @rdname slab
#' @export
setMethod("slab",
signature(object = "DemographicArray"),
function(object, dimension, elements, drop = TRUE) {
dim.before <- dim(object)
dims <- seq_along(dim.before)
if (!identical(length(dimension), 1L))
stop(gettextf("'%s' does not have length %d", "dimension", 1L))
if (!is.numeric(dimension))
dimension <- match(dimension, names(object), nomatch = 0L)
if (!(dimension %in% dims))
stop(gettextf("'%s' outside valid range", "dimension"))
if (any(duplicated(elements)))
stop(gettextf("'%s' has duplicates", "elements"))
if (!is.numeric(elements))
elements <- match(elements, dimnames(object)[[dimension]], nomatch = 0L)
s <- seq_len(dim.before[dimension])
if (!all(elements %in% s))
stop(gettextf("'%s' outside valid range", "elements"))
drop <- checkAndTidyDrop(drop)
indices <- lapply(dim.before, seq_len)
indices[[dimension]] <- match(s, elements, nomatch = 0L)
dim.after <- replace(dim.before,
list = dimension,
values = length(elements))
transform <- methods::new("CollapseTransform",
dims = dims,
indices = indices,
dimBefore = dim.before,
dimAfter = dim.after)
ans <- collapse(object, transform = transform)
if (identical(drop, TRUE)) {
is.length.1 <- dim.after == 1L
if (all(is.length.1))
ans <- ans[[1L]]
else {
metadata <- metadata(ans)[!is.length.1]
.Data <- array(ans@.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
ans <- methods::new(class(ans),
.Data = .Data,
metadata = metadata)
}
}
if (identical(drop, "dimension")) {
dimension.now.has.length.1 <- dim.after[dimension] == 1L
if (dimension.now.has.length.1) {
is.only.dimension <- length(dim.after) == 1L
if (is.only.dimension)
ans <- ans[[1L]]
else {
metadata <- metadata(ans)[-dimension]
.Data <- array(ans@.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
ans <- methods::new(class(ans),
.Data = .Data,
metadata = metadata)
}
}
}
ans
})
## HAS_TESTS
#' @rdname slab
#' @export
setReplaceMethod("slab",
signature(object = "DemographicArray"),
function(object, dimension, elements, drop = TRUE, value) {
dim <- dim(object)
names <- names(object)
dimnames <- dimnames(object)
if (!identical(length(dimension), 1L))
stop(gettextf("'%s' does not have length %d",
"dimension", 1L))
if (!is.numeric(dimension))
dimension <- match(dimension, names, nomatch = 0L)
if (!(dimension %in% seq_along(dim)))
stop(gettextf("'%s' outside valid range", "dimension"))
if (any(duplicated(elements)))
stop(gettextf("'%s' has duplicates", "elements"))
if (!is.numeric(elements))
elements <- match(elements, dimnames[[dimension]], nomatch = 0L)
s <- seq_len(dim[dimension])
if (!all(elements %in% s))
stop(gettextf("'%s' outside valid range", "elements"))
if (methods::hasArg(drop))
warning(gettextf("'%s' argument ignored by replacement method for '%s'",
"drop", "slab"))
if (!is.numeric(value)) {
if (is.logical(value))
value <- as.integer(value)
else
stop(gettext("replacement value is non-numeric"))
}
dim.slab <- replace(dim, list = dimension, values = length(elements))
length.slab <- prod(dim.slab)
length.val <- length(value)
if (length.val == 0L) {
if (length.slab == 0L)
return(object)
else
stop(gettextf("replacement value has length %d",
0L))
}
if (length.val > length.slab)
stop(gettext("length of replacement value greater than length of slab"))
is.multiple <- (length.slab %% length.val) == 0L
if (!is.multiple)
stop(gettext("length of replacement value not multiple of length of slab"))
value <- rep(value, length.out = length.slab)
is.slab <- slice.index(object, dimension) %in% elements
object@.Data[is.slab] <- value
object
})
## HAS_TESTS
## Tried to improve performance when called inside functions via
## subarray <- eval(subarray, envir = DimScales, enclos = parent.frame(n = 2L))
## but it created new problems.
#' @rdname subarray
#' @export
setMethod("subarray",
signature(object = "DemographicArray"),
function(object, subarray, drop = TRUE) {
.Data <- object@.Data
names <- names(object)
metadata <- metadata(object)
DimScales <- DimScales(object)
subarray <- substitute(subarray)
subarray <- eval(subarray, envir = DimScales)
subarray.names <- subarray@nms
subarray.indices <- subarray@indices
dim.before <- dim(object)
dims <- seq_along(dim.before)
indices <- vector(mode = "list", length = length(dims))
for (i in seq_along(dim.before)) {
name <- names[i]
i.subarray <- match(name, subarray.names, nomatch = 0L)
if (i.subarray > 0L) {
index <- subarray.indices[[i.subarray]]
index[index] <- cumsum(index[index])
indices[[i]] <- index
}
else
indices[[i]] <- seq_len(dim.before[i])
}
dim.after <- sapply(indices, max)
transform <- methods::new("CollapseTransform",
dims = dims,
indices = indices,
dimBefore = dim.before,
dimAfter = dim.after)
.Data <- collapse(.Data, transform = transform)
metadata <- collapse(metadata, transform = transform)
.Data <- array(.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
ans <- methods::new(class(object), .Data = .Data, metadata = metadata)
if (drop)
ans <- drop(ans)
ans
})
## HAS_TESTS
#' @method t DemographicArray
#' @export
t.DemographicArray <- function(x) {
if (identical(length(dim(x)), 2L))
aperm(x, perm = 2:1)
else
stop("does not have 2 dimensions")
}
#' @rdname internal-methods
#' @export
setMethod("t",
signature(x = "DemographicArray"),
t.DemographicArray)
## HAS_TESTS
#' @rdname thinIterations
#' @export
setMethod("thinIterations",
signature(object = "DemographicArray"),
function(object, n) {
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
has.iter <- i.iter > 0L
if (!has.iter)
stop(gettextf("'%s' does not have a dimension with dimtype \"%s\"",
"object", "iteration"))
if (!identical(length(n), 1L))
stop(gettextf("'%s' does not have length %d", "n", 1L))
if (!is.numeric(n))
stop(gettextf("'%s' does not have type \"%s\"", "n", "numeric"))
if (is.na(n))
stop(gettextf("'%s' is missing", "n"))
if (round(n) != n)
stop(gettextf("'%s' is not an integer", "n"))
if (n < 1L)
stop(gettextf("'%s' is less than %d", "n", 1L))
n.iter <- dim(object)[i.iter]
if (n > n.iter)
stop(gettextf("'%s' greater than number of iterations", "n"))
elements <- sample.int(n = n.iter, size = n)
ans <- slab(object, dimension = i.iter, elements = elements, drop = FALSE)
DimScales <- replace(DimScales(ans, use.names = FALSE),
list = i.iter,
values = list(methods::new("Iterations", dimvalues = seq_len(n))))
metadata <- methods::new("MetaData",
nms = names(ans),
dimtypes = dimtypes(ans, use.names = FALSE),
DimScales = DimScales)
.Data <- ans@.Data
dimnames(.Data) <- dimnames(metadata)
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @rdname coerce-data
#' @export
setMethod("toDouble",
signature(object = "DemographicArray"),
function(object) {
.Data <- object@.Data
if (!is.double(.Data)) {
object@.Data <- array(as.double(.Data),
dim = dim(.Data),
dimnames = dimnames(.Data))
}
object
})
## HAS_TESTS
#' @rdname coerce-data
#' @export
setMethod("toInteger",
signature(object = "DemographicArray"),
function(object, force = FALSE) {
.Data <- object@.Data
if (!is.integer(.Data)) {
if (!force) {
values <- .Data[!is.na(.Data)]
if (!isTRUE(all.equal(values, round(values))))
stop(gettext("non-integer values"))
}
object@.Data <- array(as.integer(round(.Data)),
dim = dim(.Data),
dimnames = dimnames(.Data))
}
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("unname",
signature(obj = "DemographicArray"),
function(obj, force = FALSE) {
unname(obj@.Data)
})
StatisticsNZ/dembase documentation built on Dec. 25, 2021, 4:49 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions t.DemographicArray median.DemographicArray mean.DemographicArray mad.DemographicArray as.matrix.DemographicArray as.array.DemographicArray aperm.DemographicArray `[.DemographicArray`
## HAS_TESTS
#' @export
setAs(from = "DemographicArray", to = "Counts",
function(from) {
.Data <- from@.Data
metadata <- metadata(from)
methods::new("Counts", .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @export
setAs(from = "DemographicArray", to = "Values",
function(from) {
.Data <- from@.Data
metadata <- metadata(from)
methods::new("Values", .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @export
setAs(from = "DemographicArray",
to = "matrix",
def = function(from) {
if (!identical(length(dim(from)), 2L))
stop("object does not have two dimensions")
ans <- from@.Data
dimnames(ans) <- dimnames(from)
ans
},
replace = function(from, value) {
from@.Data <- value
from
})
## HAS_TESTS
#' @export
`[.DemographicArray` <- function(x, i, j, ..., drop = TRUE) {
nargs <- nargs() - methods::hasArg(drop)
if (nargs == 1L)
return(x)
else if (nargs == 2L)
.Data <- methods::callGeneric(x = x@.Data, i = i, drop = FALSE)
else
.Data <- methods::callGeneric(x = x@.Data, i = i, j = j, ..., drop = FALSE)
dimnames.without.drop <- dimnames(.Data)
if (drop)
.Data <- drop(.Data)
dim.after <- dim(.Data)
if (is.null(dim.after))
return(.Data)
dim.before <- dim(x)
dims <- match(names(x), names(dimnames(.Data)), nomatch = 0L)
indices <- mapply(match,
x = dimnames(x),
table = dimnames.without.drop,
nomatch = 0L,
USE.NAMES = FALSE,
SIMPLIFY = FALSE)
transform <- methods::new("CollapseTransform",
dims = dims,
indices = indices,
dimBefore = dim.before,
dimAfter = dim.after)
metadata <- collapse(metadata(x), transform = transform)
.Data <- array(.Data, dim = dim(metadata), dimnames = dimnames(metadata))
methods::new(class(x), .Data = .Data, metadata = metadata)
}
#' @rdname internal-methods
#' @export
setMethod("[",
signature(x = "DemographicArray"),
`[.DemographicArray`)
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("Summary",
signature = "DemographicArrayOrNumeric",
function(x, ..., na.rm = FALSE) {
dots <- list(...)
n.dots <- length(dots)
## if ((length(x) == 0L) && (n.dots > 0L) && (.Generic != "range"))
## return(callGeneric(..., na.rm = na.rm))
if (methods::is(x, "DemographicArray")) {
.Data.x <- x@.Data
names.x <- names(x)
metadata.x <- metadata(x)
dimtypes.x <- dimtypes(metadata.x, use.names = FALSE)
DimScales.x <- DimScales(metadata.x, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes.x
if (has.quantile)
stop(gettextf("dimension with dimtype \"%s\"",
"quantile"))
i.iter.x <- match("iteration", dimtypes.x, nomatch = 0L)
has.iter.x <- i.iter.x > 0L
if (has.iter.x) {
n.iter.x <- dim(x)[i.iter.x]
if (.Generic == "range") {
name.iter.x <- names.x[i.iter.x]
nms <- c("range", name.iter.x)
nms <- make.unique(nms)
ds.range <- new("Categories", dimvalues = c("min", "max"))
ds.iter <- DimScales.x[[i.iter.x]]
metadata.ans.x <- new("MetaData",
nms = nms,
dimtypes = c("state", "iteration"),
DimScales = list(ds.range, ds.iter))
.Data.ans.x <- matrix(nrow = 2L, ncol = n.iter.x)
}
else {
metadata.ans.x <- metadata.x[i.iter.x]
if (is.integer(x))
.Data.ans.x <- integer(length = n.iter.x)
else
.Data.ans.x <- numeric(length = n.iter.x)
}
if ((length(.Data.x) == 0L) && (.Generic %in% c("min", "max", "range"))) {
if (.Generic == "min")
.Data.ans.x <- rep(Inf, times = n.iter.x)
else if (.Generic == "max")
.Data.ans.x <- rep(-Inf, times = n.iter.x)
else
.Data.ans.x <- rep(c(Inf, -Inf), times = n.iter.x)
}
else {
index <- slice.index(.Data.x, MARGIN = i.iter.x)
if (.Generic == "range") {
for (i in seq_len(n.iter.x))
.Data.ans.x[,i] <- callGeneric(.Data.x[index == i], na.rm = na.rm)
}
else {
for (i in seq_len(n.iter.x))
.Data.ans.x[i] <- callGeneric(.Data.x[index == i], na.rm = na.rm)
}
}
.Data.ans.x <- array(.Data.ans.x,
dim = dim(metadata.ans.x),
dimnames = dimnames(metadata.ans.x))
class.x <- if(methods::is(x, "Counts")) "Counts" else "Values"
ans.x <- methods::new(class.x,
.Data = .Data.ans.x,
metadata = metadata.ans.x)
}
else {
if ((length(.Data.x) == 0L) && (.Generic %in% c("min", "max", "range"))) {
if (.Generic == "min")
ans.x <- Inf
else if (.Generic == "max")
ans.x <- -Inf
else
ans.x <- c(Inf, -Inf)
}
else
ans.x <- methods::callGeneric(.Data.x, na.rm = na.rm)
.Data.ans.x <- ans.x
}
}
else {
has.iter.x <- FALSE
if ((length(x) == 0L) && (.Generic %in% c("min", "max", "range"))) {
if (.Generic == "min")
ans.x <- Inf
else if (.Generic == "max")
ans.x <- -Inf
else
ans.x <- c(Inf, -Inf)
}
else
ans.x <- methods::callNextMethod(x, na.rm = TRUE)
.Data.ans.x <- ans.x
}
if (n.dots == 0L)
return(ans.x)
checkIterationDimvalues(x, dots)
if ((n.dots == 1L) && (length(dots[[1L]]) == 0L))
return(ans.x)
ans.dots <- methods::callGeneric(..., na.rm = na.rm)
if (methods::is(ans.dots, "DemographicArray")) {
dimtypes.dots <- dimtypes(ans.dots, use.names = FALSE)
i.iter.dots <- match("iteration", dimtypes.dots, nomatch = 0L)
has.iter.dots <- i.iter.dots > 0L
.Data.ans.dots <- ans.dots@.Data
}
else {
has.iter.dots <- FALSE
.Data.ans.dots <- ans.dots
}
if (has.iter.x || has.iter.dots) {
if (has.iter.x && has.iter.dots) {
class <- class(ans.x)
metadata.ans <- metadata.ans.x
.Data.ans <- .Data.ans.x
if (.Generic == "range") {
for (i in seq_len(n.iter.x)) {
.Data.ans[1L,i] <- min(.Data.ans.x[1L,i],
.Data.ans.dots[1L,i],
na.rm = na.rm)
.Data.ans[2L,i] <- max(.Data.ans.x[2L,i],
.Data.ans.dots[2L,i],
na.rm = na.rm)
}
}
else {
for (i in seq_len(n.iter.x))
.Data.ans[i] <- methods::callGeneric(.Data.ans.x[i],
.Data.ans.dots[i],
na.rm = na.rm)
}
}
else if (has.iter.x && !has.iter.dots) {
class <- class(ans.x)
metadata.ans <- metadata.ans.x
.Data.ans <- .Data.ans.x
if (.Generic == "range") {
for (i in seq_len(n.iter.x)) {
.Data.ans[1L,i] <- min(.Data.ans.x[1L,i],
.Data.ans.dots[1L],
na.rm = na.rm)
.Data.ans[2L,i] <- max(.Data.ans.x[2L,i],
.Data.ans.dots[2L],
na.rm = na.rm)
}
}
else {
for (i in seq_len(n.iter.x))
.Data.ans[i] <- methods::callGeneric(.Data.ans.x[i],
.Data.ans.dots,
na.rm = na.rm)
}
}
else {
class <- class(ans.dots)
.Data.ans <- .Data.ans.dots
metadata.ans.dots <- metadata(ans.dots)
metadata.ans <- metadata.ans.dots
n.iter.dots <- dim(ans.dots)[i.iter.dots]
if (.Generic == "range") {
for (i in seq_len(n.iter.dots)) {
.Data.ans[1L,i] <- min(.Data.ans.x[1L],
.Data.ans.dots[1L,i],
na.rm = na.rm)
.Data.ans[2L,i] <- max(.Data.ans.x[2L],
.Data.ans.dots[2L,i],
na.rm = na.rm)
}
}
else {
for (i in seq_len(n.iter.dots))
.Data.ans[i] <- methods::callGeneric(.Data.ans.x,
.Data.ans.dots[i],
na.rm = na.rm)
}
}
methods::new(class, .Data = .Data.ans, metadata = metadata.ans)
}
else {
if (.Generic == "range")
c(min(ans.x[1L], ans.dots[1L], na.rm = na.rm),
max(ans.x[2L], ans.dots[2L], na.rm = na.rm))
else
methods::callGeneric(ans.x, ans.dots, na.rm = na.rm)
}
})
## HAS_TESTS
#' @rdname exported-not-api
#' @export
setMethod("DimScales",
signature(object = "DemographicArray"),
function(object, use.names = TRUE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname addDimension
#' @export
setMethod("addDimension",
signature(object = "DemographicArray"),
function(object, name, labels, after = length(dim(object)),
dimtype = NULL, dimscale = NULL, scale = 1L) {
class <- if (methods::is(object, "Counts")) "Counts" else "Values"
n.name <- length(name)
n.dim <- length(dim(object))
if (is.list(labels)) {
if (length(labels) > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"labels", "name"))
}
else
labels <- list(labels)
labels <- rep(labels, length.out = n.name)
labels <- lapply(labels, as.character)
if (!identical(length(after), 1L))
stop(gettextf("'%s' does not have length %d", "after", 1L))
if (is.character(after))
after <- match(after, names(object), nomatch = -1L)
if (!(after %in% seq.int(from = 0, to = n.dim)))
stop(gettextf("'%s' outside valid range", "after"))
if (is.list(scale)) {
if (length(scale) > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"scale", "name"))
}
else
scale <- list(scale)
scale <- rep(scale, length.out = n.name)
for (i in seq_len(n.name)) {
n.scale <- length(scale[[i]])
n.labels <- length(labels[[i]])
if (n.scale < n.labels)
scale[[i]] <- rep(scale[[i]], length.out = n.labels)
else if (n.scale > n.labels)
stop(gettextf("'%s' has more elements than '%s'",
"scale", "labels"))
}
if (is.null(dimtype))
dimtype <- inferDimtypes(name)
else {
n.dimtype <- length(dimtype)
if (n.dimtype < n.name)
dimtype <- rep(dimtype, length.out = n.name)
else if (n.dimtype > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"dimtype", "name"))
}
if (is.null(dimscale))
dimscale <- list(NULL)
else {
n.dimscale <- length(dimscale)
if (n.dimscale < n.name)
dimscale <- rep(dimscale, length.out = n.name)
else if (n.dimscale > n.name)
stop(gettextf("'%s' has more elements than '%s'",
"dimscale", "name"))
}
DimScale <- mapply(inferDimScale,
dimtype = dimtype,
dimscale = dimscale,
labels = labels,
name = name,
SIMPLIFY = FALSE,
USE.NAMES = FALSE)
nms <- c(names(object), name)
dimtypes <- c(dimtypes(object, use.names = FALSE), unlist(dimtype))
DimScales <- c(DimScales(object, use.names = FALSE), DimScale)
metadata <- methods::new("MetaData",
nms = nms,
dimtypes = dimtypes,
DimScales = DimScales)
.Data <- c(object@.Data)
all.integer <- all(sapply(scale, is.integer))
scale <- Reduce("%o%", scale)
if (all.integer)
scale <- as.integer(scale)
scale <- rep(scale, each = length(.Data))
.Data <- scale * .Data
.Data <- array(.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
permute <- !identical(after, n.dim)
if (permute) {
old <- seq_len(n.dim)
new <- seq.int(from = n.dim + 1L, length.out = length(name))
perm <- append(old, values = new, after = after)
.Data <- aperm(.Data, perm = perm)
metadata <- metadata[perm]
}
methods::new(class,
.Data = .Data,
metadata = metadata)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("ageMax",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
ageMinMax(object = object,
min = FALSE)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setReplaceMethod("ageMax",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = FALSE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("ageMin",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
ageMinMax(object = object,
min = TRUE)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setReplaceMethod("ageMin",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = TRUE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname ageTimeStep
#' @export
setMethod("ageTimeStep",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname alignPair
#' @export
setMethod("alignPair",
signature(object = "DemographicArray"),
function(object, base = NULL, omitted = ifelse(methods::is(object, "Counts"), 0L, NA)) {
names <- names(object)
dimtypes <- dimtypes(object, use.names = FALSE)
dimtypes.with.pairs <- getDimtypesWithPairs(firstElementOnly = TRUE)
names.first <- names[dimtypes %in% dimtypes.with.pairs]
if (!is.null(base)) {
## base may legitimately match more than one pair
base.names.first <- removeSuffixes(names.first)
base.found <- base %in% base.names.first
if (any(!base.found))
stop(gettextf("\"%s\" is not a valid base name", base[!base.found][1L]))
names.first <- names.first[base.names.first %in% base]
}
indices.first <- match(names.first, names, nomatch = 0L)
for (i in seq_along(indices.first)) {
## object potentially changed at each iteration
name.first <- names.first[i]
index.first <- indices.first[i]
name.second <- getNamesPairs(name.first)
index.second <- match(name.second, names)
dv.first <- dimvalues(DimScales(object)[[index.first]])
dv.second <- dimvalues(DimScales(object)[[index.second]])
if (!identical(dv.first, dv.second)) {
dv.combined <- union(dv.first, dv.second) ## dv.first comes first
i.second <- match(dv.combined, dv.second, nomatch = 0L)
DimScale.combined <- methods::new("Categories", dimvalues = dv.combined)
DimScales.new <- replace(DimScales(object, use.names = FALSE),
list = c(index.first, index.second),
values = list(DimScale.combined))
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales.new)
.Data <- array(omitted,
dim = dim(metadata),
dimnames = dimnames(metadata))
is.old <- ((slice.index(.Data, MARGIN = index.first) <= length(dv.first)) &
(slice.index(.Data, MARGIN = index.second) %in% which(i.second > 0L)))
.Data.old <- slab(object,
dimension = index.second,
elements = i.second[i.second > 0L])
.Data[is.old] <- .Data.old
object <- methods::new(class(object), .Data = .Data, metadata = metadata)
}
}
object
})
## HAS_TESTS
#' @method aperm DemographicArray
#' @export
aperm.DemographicArray <- function(a, perm, resize = TRUE, keep.class = TRUE, ...) {
if (missing(perm) || is.null(perm))
perm <- seq_along(dim(a))
if (!isTRUE(resize) || !isTRUE(keep.class))
methods::callGeneric(a = a@.Data, perm = perm, resize = resize,
keep.class = keep.class, ...)
else {
.Data.new <- methods::callGeneric(a = a@.Data, perm = perm)
metadata.new <- metadata(a)[perm]
methods::new(class(a), .Data = .Data.new, metadata = metadata.new)
}
}
#' @rdname internal-methods
#' @export
setMethod("aperm",
signature(a = "DemographicArray"),
aperm.DemographicArray)
## ## NO_TESTS
## setMethod("apply",
## signature(X = "DemographicArray"),
## function(X, MARGIN, FUN, ...) {
## kSimpleFun <- c(mean, median, mode, max, min, sum, sd, var)
## FUN <- match.fun(FUN)
## MARGIN <- tidySubscript(MARGIN, nDim = length(dim(X)), names = names(X))
## matchesFUN <- function(f) identical(f, FUN)
## if (any(sapply(kSimpleFun, matchesFUN)))
## applySimple(X = X, MARGIN = MARGIN, FUN = FUN, ...)
## else
## applyComplicated(X = X, MARGIN = MARGIN, FUN = FUN, ...)
## })
## HAS_TESTS
#' @method as.array DemographicArray
#' @export
as.array.DemographicArray <- function(x, ...) {
x@.Data
}
#' @rdname internal-methods
#' @export
setMethod("as.array",
signature(x = "DemographicArray"),
as.array.DemographicArray)
## HAS_TESTS
#' @method as.matrix DemographicArray
#' @export
as.matrix.DemographicArray <- function(x, ...) {
as.matrix(x@.Data)
}
#' @rdname internal-methods
#' @export
setMethod("as.matrix",
signature(x = "DemographicArray"),
as.matrix.DemographicArray)
## HAS_TESTS
#' @rdname collapseIterations
#' @export
setMethod("collapseIterations",
signature(object = "DemographicArray"),
function(object, FUN = quantile, ...) {
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
if (identical(i.iter, 0L))
return(object)
if (length(object) == 0L)
stop(gettextf("'%s' has length %d",
"object", 0L))
name <- make.names(deparse(substitute(FUN)))
FUN <- match.fun(FUN)
n.dim <- length(dim(object))
if (n.dim == 1L) {
.Data <- FUN(object@.Data, ...)
if (is.list(.Data))
return(.Data)
return.value.length.1 <- length(.Data) == 1L
if (return.value.length.1)
return(.Data)
else
.Data <- array(.Data,
dim = length(.Data),
dimnames = list(names(.Data)))
}
else {
MARGIN <- seq_len(n.dim)[-i.iter]
.Data <- apply(object@.Data, MARGIN = MARGIN, FUN = FUN, ...)
if (is.list(.Data))
return(.Data)
if (is.null(dim(.Data)))
.Data <- array(.Data,
dim = length(.Data),
dimnames = dimnames(object)[-i.iter])
return.value.length.1 <- identical(dim(.Data), dim(object)[-i.iter])
}
if (return.value.length.1)
metadata <- metadata(object)[-i.iter]
else {
labels <- dimnames(.Data)[[1L]]
if (is.null(labels))
stop(gettextf("return values of '%s' do not have names", "FUN"))
if (any(is.na(labels)) || !all(nzchar(labels)))
stop(gettextf("return values of '%s' do not have valid names", "FUN"))
if (any(duplicated(labels)))
stop(gettextf("return values of '%s' have duplicated names [%s]",
"FUN", paste(dQuote(labels[duplicated(labels)]), collapse = ", ")))
dimvalues <- inferDimvalues(methods::new("Quantiles"), labels = labels)
looks.like.quantile <- !is.null(dimvalues)
if (looks.like.quantile) {
DimScale <- methods::new("Quantiles", dimvalues = dimvalues)
dimtype <- "quantile"
}
else {
DimScale <- methods::new("Categories", dimvalues = labels)
dimtype <- "state"
}
names <- replace(names(object), list = i.iter, values = name)
dimtypes <- replace(dimtypes(object, use.names = FALSE),
list = i.iter,
values = dimtype)
DimScales <- replace(DimScales(object, use.names = FALSE),
list = i.iter,
values = list(DimScale))
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
if (length(names) > 1L) {
perm <- append(seq.int(from = 2L, to = length(names)),
values = 1L,
after = i.iter - 1L)
.Data <- aperm(.Data, perm = perm)
}
dimnames(.Data) <- dimnames(metadata)
}
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## NO_TESTS
#' @rdname credibleInterval
#' @export
setMethod("credibleInterval",
signature(object = "DemographicArray"),
function(object, width = 95, na.rm = FALSE,
adjust = c("search", "expand", "none")) {
dim <- dim(object)
.Data <- object@.Data
dimtypes.obj <- dimtypes(object, use.names = FALSE)
i.iter <- match("iteration", dimtypes.obj, nomatch = 0L)
has.iter <- i.iter > 0L
if (!has.iter)
stop(gettextf("'%s' does not have a dimension with %s \"%s\"",
"object", "dimtype", "iteration"))
n.iter <- dim[i.iter]
width <- checkAndTidyPercentage(width)
if (isTRUE(all.equal(width, 0)))
stop(gettextf("'%s' equals %d",
"width", 0L))
checkLogicalFlag(value = na.rm,
name = "na.rm")
adjust <- match.arg(adjust)
q <- 1 - width / 100
prob <- c(q/2, 1 - q/2)
if (na.rm) {
quantile <- stats::quantile
ans <- collapseIterations(object,
FUN = quantile,
prob = prob,
na.rm = na.rm)
}
else {
names <- paste0(prob * 100, "%")
quantile <- function(x) {
if (any(is.na(x)))
structure(.Data = c(NA, NA), names = names)
else
stats::quantile(x, prob = prob)
}
ans <- collapseIterations(object,
FUN = quantile)
}
if (all(is.na(ans)))
return(ans)
if (identical(adjust, "none"))
return(ans)
.Data.obs <- !is.na(.Data)
.Data.whole.num <- (is.integer(.Data)
|| (all(.Data[.Data.obs] == as.integer(.Data[.Data.obs]))))
if (!.Data.whole.num)
return(ans)
dimtypes.ans <- dimtypes(ans, use.names = FALSE)
i.quantile <- match("quantile", dimtypes.ans)
lower <- slab(ans,
dimension = i.quantile,
elements = 1L,
drop = "dimension")
upper <- slab(ans,
dimension = i.quantile,
elements = 2L,
drop = "dimension")
floor.lower <- floor(lower)
ceiling.upper <- ceiling(upper)
if (identical(adjust, "search")) {
ceiling.lower <- ceiling(lower)
floor.upper <- floor(upper)
width.floor.floor <- floor.upper@.Data - floor.lower@.Data
width.ceiling.floor <- floor.upper@.Data - ceiling.lower@.Data
width.floor.ceiling <- ceiling.upper@.Data - floor.lower@.Data
width.ceiling.ceiling <- ceiling.upper@.Data - ceiling.lower@.Data
width.all <- matrix(c(width.floor.floor,
width.ceiling.floor,
width.floor.ceiling,
width.ceiling.ceiling),
nrow = length(width.floor.floor),
ncol = 4L)
if (length(lower) > 1L)
x <- as(lower, "Values")
else
x <- lower
transform.extend <- makeTransform(x = x,
y = object)
x <- as(object, "Counts")
dimtypes(x)[i.iter] <- "state"
transform.collapse <- makeTransform(x = x,
y = lower)
floor.lower.ext <- extend(floor.lower@.Data,
transform = transform.extend)
ceiling.lower.ext <- extend(ceiling.lower@.Data,
transform = transform.extend)
floor.upper.ext <- extend(floor.upper@.Data,
transform = transform.extend)
ceiling.upper.ext <- extend(ceiling.upper@.Data,
transform = transform.extend)
inside.floor.floor <- 1L * ((.Data.obs & (floor.lower.ext <= .Data))
& (.Data.obs & (.Data <= floor.upper.ext)))
inside.ceiling.floor <- 1L * ((.Data.obs & (ceiling.lower.ext <= .Data))
& (.Data.obs & (.Data <= floor.upper.ext)))
inside.floor.ceiling <- 1L * ((.Data.obs & (floor.lower.ext <= .Data))
& (.Data.obs & (.Data <= ceiling.upper.ext)))
inside.ceiling.ceiling <- 1L * ((.Data.obs & (ceiling.lower.ext <= .Data))
& (.Data.obs & (.Data <= ceiling.upper.ext)))
sum.floor.floor <- collapse(inside.floor.floor,
transform = transform.collapse)
sum.ceiling.floor <- collapse(inside.ceiling.floor,
transform = transform.collapse)
sum.floor.ceiling <- collapse(inside.floor.ceiling,
transform = transform.collapse)
sum.ceiling.ceiling <- collapse(inside.ceiling.ceiling,
transform = transform.collapse)
sum.obs <- collapse(1L * .Data.obs,
transform = transform.collapse)
cover.floor.floor <- sum.floor.floor / sum.obs
cover.ceiling.floor <- sum.ceiling.floor / sum.obs
cover.floor.ceiling <- sum.floor.ceiling / sum.obs
cover.ceiling.ceiling <- sum.ceiling.ceiling / sum.obs
cover.all <- matrix(c(cover.floor.floor,
cover.ceiling.floor,
cover.floor.ceiling,
cover.ceiling.ceiling),
nrow = length(cover.floor.floor),
ncol = 4L)
width.all[is.na(cover.all) | (cover.all < (width / 100))] <- Inf
best.combination <- apply(width.all, 1, which.min)
lower.all <- matrix(c(floor.lower,
ceiling.lower,
floor.lower,
ceiling.lower),
nrow = length(floor.lower),
ncol = 4L)
upper.all <- matrix(c(floor.upper,
floor.upper,
ceiling.upper,
ceiling.upper),
nrow = length(floor.upper),
ncol = 4L)
index.best <- cbind(seq_along(best.combination),
best.combination)
lower <- lower.all[index.best]
upper <- upper.all[index.best]
}
else if (identical(adjust, "expand")) {
lower <- floor.lower
upper <- ceiling.upper
}
else
stop(gettextf("invalid value for '%s' : \"%s\"",
"adjust", adjust))
slab(ans,
dimension = i.quantile,
elements = 1L) <- lower
slab(ans,
dimension = i.quantile,
elements = 2L) <- upper
ans <- toInteger(ans)
ans
})
## diff.DemographicArray <- function(x, lag = 1L, difference = 1L, dimension) {
## if ("quantile" %in% dimtypes(x))
## stop(gettext("'%s' has dimtype \"%s\"", "x", "quantile"))
## if (methods::hasArg(dimension)) {
## dimension <- tidySubscript(dimension, nDim = length(dim(x)), names = names(x))
## if (!identical(length(dimension), 1L))
## stop(gettext("more than one dimension selected"))
## }
## else {
## i.time <- match("time", dimtypes(x), nomatch = 0L)
## if (i > 0L)
## dimension <- i.time
## else
## stop(gettextf("'%s' not supplied, and '%s' does not have dimtype \"%s\", so no default",
## "dimension", "x", "time"))
## }
## margin <- invertSubscript(dimension, nDim = length(dim(x)))
## .Data <- apply(x@.Data, MARGIN = margin, FUN = diff, lag = lag, difference = difference)
## DimScale.new <- diff(DimScales(x)[[dimension]], lag = lag, difference = difference)
## ## TODO - FINISH
## }
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dim",
signature(x = "DemographicArray"),
function(x) {
x <- metadata(x)
methods::callGeneric(x)
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dim",
signature(x = "DemographicArray"),
function(x, value)
stop(sprintf("%s of object of class \"%s\" cannot be modified directly",
"dimensions", class(x))))
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dimnames",
signature(x = "DemographicArray"),
function(x) {
x <- metadata(x)
methods::callGeneric(x)
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dimnames",
signature(x = "DemographicArray"),
function(x, value)
stop(sprintf("%s of object of class \"%s\" cannot be modified directly",
"dimnames", class(x))))
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dimscales",
signature(object = "DemographicArray"),
function(object, use.names = TRUE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dimscales",
signature(object = "DemographicArray"),
function(object, value) {
object@metadata <- methods::callGeneric(object = metadata(object),
value = value)
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("dimtypes",
signature(object = "DemographicArray"),
function(object, use.names = TRUE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setReplaceMethod("dimtypes",
signature(object = "DemographicArray"),
function(object, value) {
object@metadata <- methods::callGeneric(object = metadata(object),
value = value)
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("drop",
signature(x = "DemographicArray"),
function(x) {
.Data <- x@.Data
.Data <- drop(.Data)
keep <- dim(x) != 1L
not.dim.0 <- !identical(dim(x), 0L)
like.vector.already <- length(dim(x)) == 1L
like.vector.after.drop.length.1 <- sum(keep) == 1L
if (not.dim.0 && (like.vector.already || like.vector.after.drop.length.1))
.Data
else {
names <- names(x)[keep]
dimtypes <- dimtypes(x, use.names = FALSE)[keep]
DimScales <- DimScales(x, use.names = FALSE)[keep]
## correct dimtypes and names for lost pairs
names.pairs <- getNamesPairs(names)
lost.pair <- !(names.pairs %in% names)
names[lost.pair] <- removeSuffixes(names[lost.pair])
dimtypes[lost.pair] <- "state"
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
dimnames(.Data) <- dimnames(metadata)
methods::new(class(x), .Data = .Data, metadata = metadata)
}
})
## HAS_TESTS
#' @rdname extrapolate
#' @export
setMethod("extrapolate",
signature(object = "DemographicArray"),
function(object, along = NULL, labels, growth = 0,
type = c("exponential", "linear", "missing")) {
metadata <- metadata(object)
names <- names(object)
dim <- dim(object)
dimtypes <- dimtypes(object, use.names = FALSE)
dimscales <- dimscales(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
along <- checkAndTidyAlong(along = along,
metadata = metadata,
numericDimScales = TRUE)
has.single.dim <- length(dim) == 1L
name.along <- names[along]
labels <- as.character(labels)
type <- match.arg(type)
if ("quantile" %in% dimtypes)
stop(gettextf("dimension with dimtype \"%s\"", "quantile"))
if (identical(dim[along], 0L))
stop(gettextf("cannot extrapolate along dimension \"%s\" because dimension has length 0",
name.along))
if (methods::is(growth, "DemographicArray")) {
if (name.along %in% names(growth))
stop(gettextf("extrapolating along dimension \"%s\" but '%s' has dimension named \"%s\"",
name.along, "growth", name.along))
growth <- methods::as(growth, "Values")
}
else if (is.numeric(growth)) {
if (!identical(length(growth), 1L))
stop(gettextf("'%s' does not have length %d", "growth", 1L))
if (!has.single.dim) {
metadata.growth <- metadata[-along]
.Data.growth <- rep(growth,
times = prod(dim[-along]))
.Data.growth <- array(.Data.growth,
dim = dim(metadata.growth),
dimnames = dimnames(metadata.growth))
growth <- methods::new("Values",
.Data = .Data.growth,
metadata = metadata.growth)
}
}
else
stop(gettextf("'%s' has class \"%s\"", "growth", class(growth)))
dimtype.extra <- dimtypes[along]
dimscale.extra <- dimscales[along]
DimScale.extra <- inferDimScale(dimtype = dimtype.extra,
dimscale = dimscale.extra,
labels = labels,
name = name.along)
DimScale.existing <- DimScales[[along]]
dv.existing <- dimvalues(DimScale.existing)
dv.extra <- dimvalues(DimScale.extra)
if (methods::is(DimScale.existing, "Points")) {
existing.first <- max(dv.existing) < min(dv.extra)
if (existing.first)
points <- c(dv.existing[length(dv.existing)], dv.extra)
else {
if (min(dv.existing) <= max(dv.extra))
stop(gettextf("extrapolated and existing points overlap"))
points <- c(dv.extra, dv.existing[1L])
}
}
else {
existing.first <- max(dv.existing) == min(dv.extra)
if (existing.first)
dimvalues.tmp <- c(dv.existing[length(dv.existing) - 1L], dv.extra)
else {
if (max(dv.extra) != min(dv.existing))
stop(gettextf("gap or overlap between extrapolated and existing intervals"))
dimvalues.tmp <- c(dv.extra, dv.existing[2L])
}
DimScale.tmp <- methods::new("Intervals", dimvalues = dimvalues.tmp)
points <- intervalsToPoints(DimScale.tmp)
points <- dimvalues(points)
}
if (existing.first)
distance <- points[-1L] - points[1L]
else
distance <- points[-length(points)] - points[length(points)]
metadata.distance <- methods::new("MetaData",
nms = name.along,
dimtypes = dimtypes[along],
DimScales = list(DimScale.extra))
.Data.distance <- array(distance,
dim = length(distance),
dimnames = dimnames(metadata.distance))
distance <- methods::new("Values", .Data = .Data.distance, metadata = metadata.distance)
i.jumpoff <- if (existing.first) length(DimScale.existing) else 1L
jumpoff <- slab(object, dimension = along, elements = i.jumpoff, drop = TRUE)
if (!has.single.dim) {
metadata.jumpoff <- metadata[-along]
.Data.jumpoff <- array(jumpoff@.Data,
dim = dim(metadata.jumpoff),
dimnames = dimnames(metadata.jumpoff))
jumpoff <- new("Values",
.Data = .Data.jumpoff,
metadata = metadata.jumpoff)
}
if (identical(type, "exponential"))
extra <- jumpoff * ((1 + growth) ^ distance)
else if (identical(type, "linear"))
extra <- jumpoff + distance * growth
else if (identical(type, "missing")) {
extra <- jumpoff + distance
extra[] <- as.integer(NA)
}
else
stop(gettextf("invalid value for '%s': \"%s\"", "type", type))
extra <- methods::as(extra, class(object))
dbind(object, extra, along = name.along)
})
## HAS_TESTS
#' @rdname hasRegularAgeTime
#' @export
setMethod("hasRegularAgeTime",
signature(object = "DemographicArray"),
function(object) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
#' @rdname impute
#' @export
setMethod("impute",
signature(object = "DemographicArray"),
function(object, mult = NULL, max = NULL) {
.Data <- object@.Data
i.missing <- sort(which(is.na(.Data)))
n.missing <- length(i.missing)
if (identical(n.missing, length(.Data)))
stop(gettext("no non-missing values"))
if (identical(n.missing, 0L))
return(object)
if (is.null(mult))
mult <- all(.Data >= 0, na.rm = TRUE)
else {
if (!identical(length(mult), 1L))
stop(gettextf("'%s' does not have length %d",
"mult", 1L))
if (!is.logical(mult))
stop(gettextf("'%s' does not have type \"%s\"",
"mult", "logical"))
if (is.na(mult))
stop(gettextf("'%s' is missing",
"mult"))
if (mult) {
if (any(.Data < 0, na.rm = TRUE))
stop(gettextf("'%s' is %s but '%s' has negative values",
"mult", "TRUE", "object"))
if (all(.Data == 0, na.rm = TRUE))
stop(gettextf("'%s' is %s but '%s' has no positive values",
"mult", "TRUE", "object"))
}
}
if (!is.null(max)) {
if (!is.numeric(max))
stop(gettextf("'%s' does not have type \"%s\"",
"max", "numeric"))
if (any(is.na(max)))
stop(gettextf("'%s' has missing values",
"max"))
if (isTRUE(all.equal(max, round(max))))
max <- as.integer(max)
max <- rep(max, length.out = length(.Data))
}
values <- .Data[!is.na(.Data)]
is.integer.vals <- isTRUE(all.equal(round(values), values))
is.integer.type <- is.integer(.Data)
d <- as.data.frame(object,
direction = "long",
midpoints = TRUE,
stringsAsFactors = TRUE)
if (mult) {
n <- length(d)
is.zero <- !is.na(d[[n]]) & (d[[n]] == 0L)
d[[n]] <- log(d[[n]])
d[[n]][is.zero] <- NA
}
is.factor.one.level <- sapply(d[stats::complete.cases(d), ],
function(x) is.factor(x) && length(unique(x)) == 1L)
d <- d[!is.factor.one.level]
p <- min(length(d) - 1L, sum(stats::complete.cases(d)))
if (p > 1L)
predictors <- paste(names(d)[seq_len(p)], collapse = " + ")
else
predictors <- "1"
formula <- stats::as.formula(sprintf("%s ~ %s",
names(d)[length(d)],
predictors))
mod <- stats::lm(formula, data = d)
xlevels <- mod$xlevels
for (name in names(xlevels)) {
levels.without.obs <- setdiff(levels(d[[name]]), xlevels[[name]])
if (length(levels.without.obs) > 0L)
d[[name]][d[[name]] %in% levels.without.obs] <- xlevels[[name]][1L]
}
predicted <- stats::predict(mod, newdata = d[-length(d)])
predicted <- predicted[i.missing]
if (mult)
predicted <- exp(predicted)
if (is.integer.vals)
imputed.values <- as.integer(stats::rpois(n = n.missing, lambda = predicted))
else
imputed.values <- stats::rnorm(n = n.missing,
mean = predicted,
sd = sqrt(abs(predicted)))
if (!is.null(max)) {
max.imputed <- max[i.missing]
exceeds.max <- imputed.values > max.imputed
imputed.values[exceeds.max] <- max.imputed[exceeds.max]
}
object[i.missing] <- imputed.values
object
})
## HAS_TESTS
#' @rdname intervalContainsTruth
#' @export
setMethod("intervalContainsTruth",
signature(interval = "DemographicArray",
truth = "DemographicArray"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthArray(truth)
checkIntervalAndTruthArrayCompatible(interval = interval,
truth = truth)
metadata <- truth@metadata
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
lower <- makeCompatible(x = lower,
y = truth,
subset = FALSE)
upper <- makeCompatible(x = upper,
y = truth,
subset = FALSE)
truth <- truth@.Data
.Data <- 1L * ((lower <= truth) & (truth <= upper))
new("Values",
.Data = .Data,
metadata = metadata)
})
## HAS_TESTS
#' @rdname intervalContainsTruth
#' @export
setMethod("intervalContainsTruth",
signature(interval = "DemographicArray",
truth = "numeric"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthNumeric(truth)
checkIntervalAndTruthNumericCompatible(interval = interval,
truth = truth)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
ans <- (lower <= truth) & (truth <= upper)
as.integer(ans)
})
#' @rdname intervalScore
setMethod("intervalScore",
signature(interval = "DemographicArray",
truth = "DemographicArray"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthArray(truth)
checkIntervalAndTruthArrayCompatible(interval = interval,
truth = truth)
metadata <- truth@metadata
alpha <- getAlphaInterval(interval)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
lower <- makeCompatible(x = lower,
y = truth,
subset = FALSE)
upper <- makeCompatible(x = upper,
y = truth,
subset = FALSE)
lower <- lower@.Data
upper <- upper@.Data
truth <- truth@.Data
width <- upper - lower
penalty.below.lower <- (2 / alpha) * (lower - truth) * (truth < lower)
penalty.above.upper <- (2 / alpha) * (truth - upper) * (truth > upper)
.Data <- width + penalty.below.lower + penalty.above.upper
new("Counts",
.Data = .Data,
metadata = metadata)
})
#' @rdname intervalScore
setMethod("intervalScore",
signature(interval = "DemographicArray",
truth = "numeric"),
function(interval, truth) {
checkIntervalArray(interval)
checkTruthNumeric(truth)
checkIntervalAndTruthNumericCompatible(interval = interval,
truth = truth)
alpha <- getAlphaInterval(interval)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
lower <- lower@.Data
upper <- upper@.Data
width <- upper - lower
penalty.below.lower <- (2 / alpha) * (lower - truth) * (truth < lower)
penalty.above.upper <- (2 / alpha) * (truth - upper) * (truth > upper)
ans <- width + penalty.below.lower + penalty.above.upper
as.numeric(ans)
})
#' @rdname intervalWidth
#' @export
setMethod("intervalWidth",
signature(interval = "DemographicArray"),
function(interval) {
checkIntervalArray(interval)
l <- splitLowerUpper(interval)
lower <- l$lower
upper <- l$upper
upper - lower
})
## NO_TESTS
#' @rdname limits
#' @export
setMethod("limits",
signature(object = "DemographicArray"),
function(object, components = FALSE) {
object <- metadata(object)
methods::callGeneric()
})
## HAS_TESTS
## function is complicated because of 'center = median(x)' argument
#' @method mad DemographicArray
#' @export
mad.DemographicArray <- function(x, center = median(x), constant = 1.4826,
na.rm = FALSE, low = FALSE, high = FALSE) {
.Data <- x@.Data
metadata <- metadata(x)
dimtypes <- dimtypes(metadata, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes
if (has.quantile)
stop(gettextf("'%s' has dimension with dimtype \"%s\"",
"x", "quantile"))
i.iter <- match("iteration", dimtypes, nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
metadata.ans <- metadata[i.iter]
if (methods::hasArg(center)) {
FUN <- function(X)
stats::mad(X,
center = center,
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
else {
FUN <- function(X)
stats::mad(X,
center = stats::median(X, na.rm = na.rm),
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
.Data.ans <- apply(.Data,
MARGIN = i.iter,
FUN = FUN)
.Data.ans <- array(.Data.ans,
dim = dim(metadata.ans),
dimnames = dimnames(metadata.ans))
class <- if(methods::is(x, "Counts")) "Counts" else "Values"
new(class,
.Data = .Data.ans,
metadata = metadata.ans)
}
else {
if (methods::hasArg(center)) {
stats::mad(.Data,
center = center,
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
else {
stats::mad(.Data,
center = stats::median(.Data, na.rm = na.rm),
constant = constant,
na.rm = na.rm,
low = low,
high = high)
}
}
}
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("mad",
signature(x = "DemographicArray"),
mad.DemographicArray)
## HAS_TESTS
#' @method mean DemographicArray
#' @export
mean.DemographicArray <- function(x, ...) {
.Data <- x@.Data
metadata <- metadata(x)
dimtypes <- dimtypes(metadata, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes
if (has.quantile)
stop(gettextf("'%s' has dimension with dimtype \"%s\"",
"x", "quantile"))
i.iter <- match("iteration", dimtypes, nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
metadata.ans <- metadata[i.iter]
.Data.ans <- apply(.Data,
MARGIN = i.iter,
FUN = mean,
...)
.Data.ans <- array(.Data.ans,
dim = dim(metadata.ans),
dimnames = dimnames(metadata.ans))
class <- if(methods::is(x, "Counts")) "Counts" else "Values"
new(class,
.Data = .Data.ans,
metadata = metadata.ans)
}
else
mean(.Data, ...)
}
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("mean",
signature(x = "DemographicArray"),
mean.DemographicArray)
## HAS_TESTS
#' @method median DemographicArray
#' @export
median.DemographicArray <- function(x, na.rm = FALSE, ...) {
.Data <- x@.Data
metadata <- metadata(x)
dimtypes <- dimtypes(metadata, use.names = FALSE)
has.quantile <- "quantile" %in% dimtypes
if (has.quantile)
stop(gettextf("'%s' has dimension with dimtype \"%s\"",
"x", "quantile"))
i.iter <- match("iteration", dimtypes, nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
metadata.ans <- metadata[i.iter]
.Data.ans <- apply(.Data,
MARGIN = i.iter,
FUN = stats::median,
na.rm = na.rm,
...)
.Data.ans <- array(.Data.ans,
dim = dim(metadata.ans),
dimnames = dimnames(metadata.ans))
class <- if(methods::is(x, "Counts")) "Counts" else "Values"
new(class,
.Data = .Data.ans,
metadata = metadata.ans)
}
else
stats::median(.Data, na.rm = na.rm, ...)
}
## HAS_TESTS
#' @rdname Statistical-Functions
#' @export
setMethod("median",
signature(x = "DemographicArray"),
median.DemographicArray)
## HAS_TESTS
setMethod("metadata",
signature(object = "DemographicArray"),
function(object) object@metadata)
## HAS_TESTS
#' @rdname midpoints
#' @export
setMethod("midpoints",
signature(object = "DemographicArray", dimension = "ANY"),
function(object, dimension) {
.Data <- object@.Data
metadata <- metadata(object)
dimension <- tidySubscript(subscript = dimension,
nDim = length(dim(object)),
names = names(object))
metadata <- midpoints(object = metadata, dimension = dimension)
dimnames(.Data) <- dimnames(metadata)
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @rdname midpoints
#' @export
setMethod("midpoints",
signature(object = "DemographicArray", dimension = "missing"),
function(object) {
dimension <- which(dimscales(object) == "Intervals")
methods::callGeneric(object = object, dimension = dimension)
})
## NO_TESTS
#' @rdname MSE
#' @export
setMethod("MSE",
signature(point = "DemographicArray",
truth = "DemographicArray"),
function(point, truth) {
checkPointArray(point)
checkTruthArray(truth)
checkPointAndTruthCompatible(point = point,
truth = truth)
(truth - point)^2 # 'truth' first, so that answer has same metadata as 'truth'
})
#' Get or set dimension names
#'
#' Query or change the dimension names of a \code{\linkS4class{DemographicArray}}
#' object.
#'
#' @name names-methods
#' @docType methods
#' @param x Object of class \code{\linkS4class{DemographicArray}}.
#' @param value Character vector.
#' @return A character vector. The replacement method returns an object of
#' class \code{\linkS4class{DemographicArray}}.
#' @author John Bryant \email{demographic.packages@@gmail.com}
#' @seealso As described in \code{\link{dimtypes}}, some dimensions must come
#' in pairs, and there are special rules governing the names of these
#' dimensions.
#' @examples
#' library(demdata)
#' popn <- Counts(VAPopn)
#' names(popn)
#' names(popn) <- toupper(names(popn))
NULL
## HAS_TESTS
#' @rdname names-methods
#' @export
setMethod("names",
signature(x = "DemographicArray"),
function(x) {
x <- metadata(x)
methods::callGeneric(x)
})
## HAS_TESTS
#' @rdname names-methods
#' @export
setReplaceMethod("names",
signature(x = "DemographicArray"),
function(x, value) {
value <- as.character(value)
names(x@metadata) <- value
names(dimnames(x@.Data)) <- value
methods::validObject(x)
x
})
## HAS_TESTS
#' @rdname nIteration
#' @export
setMethod("nIteration",
signature(object = "DemographicArray"),
function(object) {
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
if (identical(i.iter, 0L))
stop(gettextf("no dimension with dimtype \"%s\"", "iteration"))
dim(object)[i.iter]
})
#' @rdname pairAligned
#' @export
setMethod("pairAligned",
signature(object = "DemographicArray"),
function(object, base = NULL) {
object <- metadata(object)
callGeneric()
})
## HAS_TESTS
#' @rdname pairToState
#' @export
setMethod("pairToState",
signature(object = "DemographicArray"),
function(object) {
.Data.old <- object@.Data
names.old <- names(object)
dimtypes.old <- dimtypes(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
dimtypes.with.pairs <- getDimtypesWithPairs()
names.new <- names.old
dimtypes.new <- dimtypes.old
for (i in seq_along(names.old)) {
name.old <- names.old[i]
dimtype.old <- dimtypes.old[i]
if (dimtype.old %in% dimtypes.with.pairs) {
dimtypes.new[i] <- "state"
suffix <- getSuffixes(dimtype.old)
pattern <- paste0(suffix, "$")
replacement <- sub("^_", ".", suffix)
name.new <- sub(pattern = pattern,
replacement = replacement,
x = name.old)
names.new[i] <- name.new
}
}
metadata.new <- methods::new("MetaData",
nms = names.new,
dimtypes = dimtypes.new,
DimScales = DimScales)
.Data.new <- array(.Data.old,
dim = dim(metadata.new),
dimnames = dimnames(metadata.new))
new(class(object),
.Data = .Data.new,
metadata = metadata.new)
})
## HAS_TESTS
#' @rdname perturb
#' @export
setMethod("perturb",
signature(object = "DemographicArray"),
function(object, n = 1L, order = 2L, phi = 1, subtotals = NULL) {
if (!is.null(subtotals))
stop("'subtotals' not yet implemented")
for (name in c("n", "order", "phi")) {
value <- get(name)
if (!identical(length(value), 1L))
stop(gettextf("'%s' does not have length %d", name, 1L))
if (is.na(value))
stop(gettextf("'%s' is missing", name))
if (value < 1L)
stop(gettextf("'%s' is less than %d", name, 1L))
}
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter)
perturbUsingIterations(object = object, n = n, i.iter = i.iter)
else
perturbUsingModel(object = object, n = n, order = order, phi = phi)
})
## HAS_TESTS
#' @rdname population
#' @export
setMethod("population",
signature(object = "DemographicArray"),
function(object) {
as(object@population, "Counts")
})
## HAS_TESTS
#' @rdname prop.table
#' @export
setMethod("prop.table",
signature(x = "DemographicArray", margin = "ANY"),
function(x, margin = NULL) {
if ("quantile" %in% dimtypes(x))
stop(gettextf("dimension with dimtype \"%s\"", "quantile"))
i.iter <- match("iteration", dimtypes(x), nomatch = 0L)
has.iter <- i.iter > 0L
if (has.iter) {
if (!(i.iter %in% margin))
margin <- c(margin, i.iter)
}
.Data <- prop.table(x@.Data, margin = margin)
metadata <- metadata(x)
methods::new("Values", .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @rdname prop.table
#' @export
setMethod("prop.table",
signature(x = "DemographicArray", margin = "character"),
function(x, margin = NULL) {
margin <- match(margin, names(x), nomatch = 0L)
if (any(margin == 0L))
stop(gettextf("'%s' outside valid range", "margin"))
methods::callGeneric()
})
## HAS_TESTS
#' @rdname recodeCategories
#' @export
setMethod("recodeCategories",
signature(object = "DemographicArray",
dimension = "ANY",
old = "ANY",
new = "ANY",
concordance = "missing"),
function(object, dimension = NULL, old = NULL, new = NULL,
concordance = NULL) {
dim <- dim(object)
names <- names(object)
dimtypes <- dimtypes(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
dimension <- tidySubscript(dimension,
nDim = length(dim),
names = names)
for (name in c("old", "new")) {
value <- get(name)
if (any(is.na(value)))
stop(gettextf("'%s' has missing values",
name))
if (any(duplicated(value)))
stop(gettextf("'%s' has duplicates",
name))
}
if (!identical(length(old), length(new)))
stop(gettextf("'%s' and '%s' have different lengths",
"old", "new"))
for (i.dim in seq_along(dim)) {
recode.this.dimension <- i.dim %in% dimension
if (recode.this.dimension) {
DimScale <- DimScales[[i.dim]]
if (!methods::is(DimScale, "Categories"))
stop(gettextf("dimension \"%s\" has dimscale \"%s\"",
names[i.dim], class(DimScale)))
labels.old <- dimvalues(DimScale)
labels.new <- labels.old
name.dim <- names[i.dim]
for (i.old in seq_along(old)) {
label.old <- old[i.old]
i.label <- match(label.old, labels.old, nomatch = 0L)
has.label <- i.label > 0L
if (has.label)
labels.new[i.label] <- new[i.old]
else {
stop(gettextf("'%s' includes value \"%s\" but \"%s\" dimension of '%s' does not include \"%s\"",
"old", label.old, name.dim, "object", label.old, "strict", "TRUE"))
}
}
class.dimscale <- class(DimScale)
DimScale <- tryCatch(methods::new(class.dimscale, dimvalues = labels.new),
error = function(e) e)
if (methods::is(DimScale, "error"))
stop(gettextf("problem creating \"%s\" %s for \"%s\" dimension : %s",
class.dimscale, "dimscale", name.dim, DimScale$message))
DimScales[[i.dim]] <- DimScale
}
}
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
.Data <- object@.Data
dimnames(.Data)[dimension] <- dimnames(metadata)[dimension]
methods::new(class(object),
.Data = .Data,
metadata = metadata)
})
## HAS_TESTS
#' @rdname recodeCategories
#' @export
setMethod("recodeCategories",
signature(object = "DemographicArray",
dimension = "ANY",
old = "missing",
new = "missing",
concordance = "Concordance"),
function(object, dimension = NULL,
old = NULL, new = NULL,
concordance = NULL) {
dim <- dim(object)
names <- names(object)
dimtypes <- dimtypes(object, use.names = FALSE)
DimScales <- DimScales(object, use.names = FALSE)
dimension <- tidySubscript(dimension,
nDim = length(dim),
names = names)
if (!methods::is(concordance, "OneToOne"))
stop(gettextf("'%s' has class \"%s\"",
"concordance", class(concordance)))
for (i.dim in seq_along(dim)) {
recode.this.dimension <- i.dim %in% dimension
if (recode.this.dimension) {
name.dim <- names[i.dim]
DimScale <- DimScales[[i.dim]]
if (!methods::is(DimScale, "Categories"))
stop(gettextf("\"%s\" dimension has dimscale \"%s\"",
names[i.dim], class(DimScale)))
labels.old <- dimvalues(DimScale)
labels.new <- tryCatch(translate(labels.old,
concordance = concordance),
error = function(e) e)
if (methods::is(labels.new, "error"))
stop(gettextf("unable to recode categories for \"%s\" dimension : %s",
name.dim, labels.new$message))
class.dimscale <- class(DimScale)
DimScale <- tryCatch(methods::new(class.dimscale, dimvalues = labels.new),
error = function(e) e)
if (methods::is(DimScale, "error"))
stop(gettextf("problem creating \"%s\" %s for \"%s\" dimension : %s",
class.dimscale, "dimscale", name.dim, DimScale$message))
DimScales[[i.dim]] <- DimScale
}
}
metadata <- methods::new("MetaData",
nms = names,
dimtypes = dimtypes,
DimScales = DimScales)
.Data <- object@.Data
dimnames(.Data)[dimension] <- dimnames(metadata)[dimension]
methods::new(class(object),
.Data = .Data,
metadata = metadata)
})
## ## need to deal with pairs of dims
## setMethod("reorderCategories",
## signature(object = "DemographicArray"),
## function(object, dimension, FUN, ...) {
## .Data <- object@.Data
## metadata <- metadata(object)
## dim <- dim(object)
## dimension <- tidySubscript(dimension, nDim = length(dim), names = names(metadata))
## if (identical(length(dimension), 1L)) {
## DimScale <- DimScales(object)[[dimension]]
## if (!methods::is(DimScale, "Categories"))
## stop(gettextf("'%s' has dimscale \"%s\"", "dimension", class(DimScale)))
## res <- numeric(
## }
## else
## stop(gettextf("'%s' has length %d", "dimension", length(dimension)))
## metadata.tmp <- metadata[-dimension]
## slab <- slice.index(.Data, MARGIN = dimension)
## data.tmp <- array(.Data[slab == 1L], dim = dim(metadata.tmp), dimnames = dimnames(metadata.tmp))
## obj.tmp <- methods::new(class(object), .Data.tmp)
## res <- numeric(length = dim[dimension])
## for (i in seq_len(dim[dimension])) {
## obj.tmp@.Data@.Data <- .Data[slab == i]
## res.tmp <- FUN(obj.tmp, ...)
## if (!(identical(length(res.tmp, 1L))))
## stop(gettextf("return value does not have length %d", 1L))
## if (!is.numeric(res.tmp))
## stop(gettextf("return value does not have type \"%s\"", "numeric"))
## if (is.na(res.tmp))
## stop(gettext("return value is missing"))
## res[i] <- res.tmp
## }
## DimScale.reorder <- DimScales(object)[dimension]
## HAS_TESTS
#' @rdname resetIterations
#' @export
setMethod("resetIterations",
signature(object = "DemographicArray"),
function(object) {
.Data <- object@.Data
metadata <- metadata(object)
metadata <- resetIterations(metadata)
dimnames(.Data) <- dimnames(metadata)
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## NO_TESTS
#' @rdname rotateAgeTime
#' @export
setMethod("rotateAgeTime",
signature(object = "DemographicArray"),
function(object, to = NULL, name = NULL) {
choices.at <- c("at", "ta", "age-time", "time-age")
choices.ac <- c("ac", "ca", "age-cohort", "cohort-age")
choices.tc <- c("tc", "ct", "time-cohort", "cohort-time")
choices.to <- c(choices.at, choices.ac, choices.tc)
hasRegularAgeTime(object)
.Data.old <- object@.Data
names.old <- names(object)
dim.old <- dim(object)
dimtypes.old <- dimtypes(object,
use.names = FALSE)
DimScales.old <- DimScales(object,
use.names = FALSE)
n.dim <- length(dim.old)
n.old <- length(.Data.old)
pos.old <- seq_len(n.old) - 1L # C-style
i.age <- match("age", dimtypes.old, nomatch = 0L)
i.time <- match("time", dimtypes.old, nomatch = 0L)
i.cohort <- match("cohort", dimtypes.old, nomatch = 0L)
i.triangle <- match("triangle", dimtypes.old, nomatch = 0L)
has.age <- i.age > 0L
has.time <- i.time > 0L
has.cohort <- i.cohort > 0L
has.triangle <- i.triangle > 0L
if (has.age + has.time + has.cohort != 2L)
stop(gettextf("'%s' must have dimensions with two of the following three dimtypes: \"%s\", \"%s\", \"%s\"",
"object", "age", "time", "cohort"))
has.at <- has.age && has.time
has.ac <- has.age && has.cohort
has.tc <- has.time && has.cohort
if (is.null(to))
stop(gettextf("argument \"%s\" is missing, with no default",
"to"))
to <- tolower(to)
to <- match.arg(to, choices = choices.to)
to.at <- to %in% choices.at
to.ac <- to %in% choices.ac
to.tc <- to %in% choices.tc
no.change <- (has.at && to.at) || (has.ac && to.ac) || (has.tc && to.tc)
if (no.change)
return(object)
if (!is.null(name)) {
if (!identical(length(name), 1L))
stop(gettextf("'%s' does not have length %d",
"name", 1L))
if (is.na(name))
stop(gettextf("'%s' is missing",
"name"))
}
if (has.age) {
DimScale.age <- DimScales.old[[i.age]]
dv.age <- dimvalues(DimScale.age)
if (any(is.infinite(dv.age)))
stop(gettextf("dimension with %s \"%s\" has open interval",
"dimtype", "age"))
if (any(dv.age < 0))
stop(gettext("cannnegative ages"))
n.age <- dim.old[i.age]
step.age <- 1L
for (d in seq_len(i.age - 1L))
step.age <- step.age * dim.old[d]
pos.age <- (pos.old %/% step.age) %% n.age # C-style
}
if (has.time) {
DimScale.time <- DimScales.old[[i.time]]
dv.time <- dimvalues(DimScale.time)
if (any(is.infinite(dv.time)))
stop(gettextf("dimension with %s \"%s\" has open interval",
"dimtype", "time"))
n.time <- dim.old[i.time]
step.time <- 1L
for (d in seq_len(i.time - 1L))
step.time <- step.time * dim.old[d]
pos.time <- (pos.old %/% step.time) %% n.time # C-style
}
if (has.cohort) {
DimScale.cohort <- DimScales.old[[i.cohort]]
dv.cohort <- dimvalues(DimScale.cohort)
if (any(is.infinite(dv.cohort)))
stop(gettextf("dimension with %s \"%s\" has open interval",
"dimtype", "cohort"))
n.cohort <- dim.old[i.cohort]
step.cohort <- 1L
for (d in seq_len(i.cohort - 1L))
step.cohort <- step.cohort * dim.old[d]
pos.cohort <- (pos.old %/% step.cohort) %% n.cohort # C-style
}
if (has.triangle) {
DimScale.triangle <- DimScales.old[[i.triangle]]
n.triangle <- dim.old[i.triangle]
step.triangle <- 1L
for (d in seq_len(i.triangle - 1L))
step.triangle <- step.triangle * dim.old[d]
pos.triangle <- (pos.old %/% step.triangle) %% n.triangle # C-style
}
else
pos.triangle <- rep.int(0L, times = n.old)
if (has.at) { # new dimension is cohort
if (is.null(name))
name <- "cohort"
DimScale.cohort <- makeMissingAgeTimeDimScale(age = DimScale.age,
time = DimScale.time)
pos.along.new <- pos.time - pos.age - pos.triangle
if (to.ac) { # replacing time with cohort
name <- make.unique(c(names.old[-i.time], name))[n.dim]
names.new <- replace(names.old,
list = i.time,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.time,
values = "cohort")
DimScales.new <- replace(DimScales.old,
list = i.time,
values = list(DimScale.cohort))
iAlong <- i.time
}
else { # replacing age with cohort
name <- make.unique(c(names.old[-i.age], name))[n.dim]
names.new <- replace(names.old,
list = i.age,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.age,
values = "cohort")
DimScales.new <- replace(DimScales.old,
list = i.age,
values = list(DimScale.cohort))
iAlong <- i.age
}
}
else if (has.ac) { # new dimension is time
if (is.null(name))
name <- "time"
DimScale.time <- makeMissingAgeTimeDimScale(age = DimScale.age,
cohort = DimScale.cohort)
pos.along.new <- pos.cohort + pos.age + pos.triangle
if (to.at) { # replacing cohort with time
name <- make.unique(c(names.old[-i.cohort], name))[n.dim]
names.new <- replace(names.old,
list = i.cohort,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.cohort,
values = "time")
DimScales.new <- replace(DimScales.old,
list = i.cohort,
values = list(DimScale.time))
iAlong <- i.cohort
}
else { # replacing age with time
name <- make.unique(c(names.old[-i.age], name))[n.dim]
names.new <- replace(names,
list = i.age,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.age,
values = "time")
DimScales.new <- replace(DimScales,
list = i.age,
values = list(DimScale.time))
iAlong <- i.age
}
}
else { # has.tc - new dimension is age
if (!all(dv.cohort <= max(dv.time)))
stop(gettext("cohort starting after final time point or interval"))
if (is.null(name))
name <- "age"
DimScale.age <- makeMissingAgeTimeDimScale(time = DimScale.time,
cohort = DimScale.cohort)
pos.along.new <- pos.time - pos.cohort - pos.triangle
if (to.ac) { # replacing time with age
name <- make.unique(c(names.old[-i.time], name))[n.dim]
names.new <- replace(names.old,
list = i.time,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.time,
values = "age")
DimScales.new <- replace(DimScales.old,
list = i.time,
values = list(DimScale.age))
iAlong <- i.time
}
else { # replacing cohort with age
name <- make.unique(c(names.old[-i.cohort], name))[n.dim]
names.new <- replace(names.old,
list = i.cohort,
values = name)
dimtypes.new <- replace(dimtypes.old,
list = i.cohort,
values = "age")
DimScales.new <- replace(DimScales.old,
list = i.cohort,
values = list(DimScale.age))
iAlong <- i.cohort
}
}
metadata.new <- new("MetaData",
nms = names.new,
dimtypes = dimtypes.new,
DimScales = DimScales.new)
dim.new <- dim(metadata.new)
dimnames.new <- dimnames(metadata.new)
.Data.new <- array(NA_integer_,
dim = dim.new,
dimnames = dimnames.new)
n.along.old <- dim.old[iAlong]
n.along.new <- dim.new[iAlong]
if (iAlong > 1L) {
s.before <- seq.int(from = 1L, to = iAlong - 1L)
n.within <- prod(dim.old[s.before])
}
else
n.within <- 1L
if (iAlong < n.dim) {
s.after <- seq.int(from = iAlong + 1L, to = n.dim)
n.between <- prod(dim.old[s.after])
}
else
n.between <- 1L
seq.within <- seq_len(n.within) - 1L
seq.along.old <- seq_len(n.along.old) - 1L
seq.between <- seq_len(n.between) - 1L
pos.within.old <- rep(seq.within, times = n.along.old * n.between)
pos.along.old <- rep(rep(seq.along.old, each = n.within), times = n.between)
pos.along.new <- pos.along.new - min(pos.along.new)
pos.between.old <- rep(seq.between, each = n.within * n.along.old)
pos.new <- pos.within.old + n.within * pos.along.new + n.within * n.along.new * pos.between.old
pos.new <- pos.new + 1L # R-style
.Data.new[pos.new] <- .Data.old
class.new <- if (methods::is(object, "Counts")) "Counts" else "Values"
new(class.new,
.Data = .Data.new,
metadata = metadata.new)
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("setAgeMax",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = FALSE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname ageMinMax
#' @export
setMethod("setAgeMin",
signature(object = "DemographicArray"),
function(object, value) {
metadata.old <- metadata(object)
metadata.new <- ageMinMaxReplace(object = metadata.old,
value = value,
min = TRUE)
object@metadata <- metadata.new
dimnames(object@.Data) <- dimnames(metadata.new)
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("show",
signature(object = "DemographicArray"),
function(object) {
metadata <- metadata(object)
.Data <- object@.Data
cat(gettextf("An object of class \"%s\"\n", class(object)))
showMetaData(metadata)
cat("\n")
methods::show(.Data)
})
## HAS_TESTS
#' @rdname slab
#' @export
setMethod("slab",
signature(object = "DemographicArray"),
function(object, dimension, elements, drop = TRUE) {
dim.before <- dim(object)
dims <- seq_along(dim.before)
if (!identical(length(dimension), 1L))
stop(gettextf("'%s' does not have length %d", "dimension", 1L))
if (!is.numeric(dimension))
dimension <- match(dimension, names(object), nomatch = 0L)
if (!(dimension %in% dims))
stop(gettextf("'%s' outside valid range", "dimension"))
if (any(duplicated(elements)))
stop(gettextf("'%s' has duplicates", "elements"))
if (!is.numeric(elements))
elements <- match(elements, dimnames(object)[[dimension]], nomatch = 0L)
s <- seq_len(dim.before[dimension])
if (!all(elements %in% s))
stop(gettextf("'%s' outside valid range", "elements"))
drop <- checkAndTidyDrop(drop)
indices <- lapply(dim.before, seq_len)
indices[[dimension]] <- match(s, elements, nomatch = 0L)
dim.after <- replace(dim.before,
list = dimension,
values = length(elements))
transform <- methods::new("CollapseTransform",
dims = dims,
indices = indices,
dimBefore = dim.before,
dimAfter = dim.after)
ans <- collapse(object, transform = transform)
if (identical(drop, TRUE)) {
is.length.1 <- dim.after == 1L
if (all(is.length.1))
ans <- ans[[1L]]
else {
metadata <- metadata(ans)[!is.length.1]
.Data <- array(ans@.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
ans <- methods::new(class(ans),
.Data = .Data,
metadata = metadata)
}
}
if (identical(drop, "dimension")) {
dimension.now.has.length.1 <- dim.after[dimension] == 1L
if (dimension.now.has.length.1) {
is.only.dimension <- length(dim.after) == 1L
if (is.only.dimension)
ans <- ans[[1L]]
else {
metadata <- metadata(ans)[-dimension]
.Data <- array(ans@.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
ans <- methods::new(class(ans),
.Data = .Data,
metadata = metadata)
}
}
}
ans
})
## HAS_TESTS
#' @rdname slab
#' @export
setReplaceMethod("slab",
signature(object = "DemographicArray"),
function(object, dimension, elements, drop = TRUE, value) {
dim <- dim(object)
names <- names(object)
dimnames <- dimnames(object)
if (!identical(length(dimension), 1L))
stop(gettextf("'%s' does not have length %d",
"dimension", 1L))
if (!is.numeric(dimension))
dimension <- match(dimension, names, nomatch = 0L)
if (!(dimension %in% seq_along(dim)))
stop(gettextf("'%s' outside valid range", "dimension"))
if (any(duplicated(elements)))
stop(gettextf("'%s' has duplicates", "elements"))
if (!is.numeric(elements))
elements <- match(elements, dimnames[[dimension]], nomatch = 0L)
s <- seq_len(dim[dimension])
if (!all(elements %in% s))
stop(gettextf("'%s' outside valid range", "elements"))
if (methods::hasArg(drop))
warning(gettextf("'%s' argument ignored by replacement method for '%s'",
"drop", "slab"))
if (!is.numeric(value)) {
if (is.logical(value))
value <- as.integer(value)
else
stop(gettext("replacement value is non-numeric"))
}
dim.slab <- replace(dim, list = dimension, values = length(elements))
length.slab <- prod(dim.slab)
length.val <- length(value)
if (length.val == 0L) {
if (length.slab == 0L)
return(object)
else
stop(gettextf("replacement value has length %d",
0L))
}
if (length.val > length.slab)
stop(gettext("length of replacement value greater than length of slab"))
is.multiple <- (length.slab %% length.val) == 0L
if (!is.multiple)
stop(gettext("length of replacement value not multiple of length of slab"))
value <- rep(value, length.out = length.slab)
is.slab <- slice.index(object, dimension) %in% elements
object@.Data[is.slab] <- value
object
})
## HAS_TESTS
## Tried to improve performance when called inside functions via
## subarray <- eval(subarray, envir = DimScales, enclos = parent.frame(n = 2L))
## but it created new problems.
#' @rdname subarray
#' @export
setMethod("subarray",
signature(object = "DemographicArray"),
function(object, subarray, drop = TRUE) {
.Data <- object@.Data
names <- names(object)
metadata <- metadata(object)
DimScales <- DimScales(object)
subarray <- substitute(subarray)
subarray <- eval(subarray, envir = DimScales)
subarray.names <- subarray@nms
subarray.indices <- subarray@indices
dim.before <- dim(object)
dims <- seq_along(dim.before)
indices <- vector(mode = "list", length = length(dims))
for (i in seq_along(dim.before)) {
name <- names[i]
i.subarray <- match(name, subarray.names, nomatch = 0L)
if (i.subarray > 0L) {
index <- subarray.indices[[i.subarray]]
index[index] <- cumsum(index[index])
indices[[i]] <- index
}
else
indices[[i]] <- seq_len(dim.before[i])
}
dim.after <- sapply(indices, max)
transform <- methods::new("CollapseTransform",
dims = dims,
indices = indices,
dimBefore = dim.before,
dimAfter = dim.after)
.Data <- collapse(.Data, transform = transform)
metadata <- collapse(metadata, transform = transform)
.Data <- array(.Data,
dim = dim(metadata),
dimnames = dimnames(metadata))
ans <- methods::new(class(object), .Data = .Data, metadata = metadata)
if (drop)
ans <- drop(ans)
ans
})
## HAS_TESTS
#' @method t DemographicArray
#' @export
t.DemographicArray <- function(x) {
if (identical(length(dim(x)), 2L))
aperm(x, perm = 2:1)
else
stop("does not have 2 dimensions")
}
#' @rdname internal-methods
#' @export
setMethod("t",
signature(x = "DemographicArray"),
t.DemographicArray)
## HAS_TESTS
#' @rdname thinIterations
#' @export
setMethod("thinIterations",
signature(object = "DemographicArray"),
function(object, n) {
i.iter <- match("iteration", dimtypes(object), nomatch = 0L)
has.iter <- i.iter > 0L
if (!has.iter)
stop(gettextf("'%s' does not have a dimension with dimtype \"%s\"",
"object", "iteration"))
if (!identical(length(n), 1L))
stop(gettextf("'%s' does not have length %d", "n", 1L))
if (!is.numeric(n))
stop(gettextf("'%s' does not have type \"%s\"", "n", "numeric"))
if (is.na(n))
stop(gettextf("'%s' is missing", "n"))
if (round(n) != n)
stop(gettextf("'%s' is not an integer", "n"))
if (n < 1L)
stop(gettextf("'%s' is less than %d", "n", 1L))
n.iter <- dim(object)[i.iter]
if (n > n.iter)
stop(gettextf("'%s' greater than number of iterations", "n"))
elements <- sample.int(n = n.iter, size = n)
ans <- slab(object, dimension = i.iter, elements = elements, drop = FALSE)
DimScales <- replace(DimScales(ans, use.names = FALSE),
list = i.iter,
values = list(methods::new("Iterations", dimvalues = seq_len(n))))
metadata <- methods::new("MetaData",
nms = names(ans),
dimtypes = dimtypes(ans, use.names = FALSE),
DimScales = DimScales)
.Data <- ans@.Data
dimnames(.Data) <- dimnames(metadata)
methods::new(class(object), .Data = .Data, metadata = metadata)
})
## HAS_TESTS
#' @rdname coerce-data
#' @export
setMethod("toDouble",
signature(object = "DemographicArray"),
function(object) {
.Data <- object@.Data
if (!is.double(.Data)) {
object@.Data <- array(as.double(.Data),
dim = dim(.Data),
dimnames = dimnames(.Data))
}
object
})
## HAS_TESTS
#' @rdname coerce-data
#' @export
setMethod("toInteger",
signature(object = "DemographicArray"),
function(object, force = FALSE) {
.Data <- object@.Data
if (!is.integer(.Data)) {
if (!force) {
values <- .Data[!is.na(.Data)]
if (!isTRUE(all.equal(values, round(values))))
stop(gettext("non-integer values"))
}
object@.Data <- array(as.integer(round(.Data)),
dim = dim(.Data),
dimnames = dimnames(.Data))
}
object
})
## HAS_TESTS
#' @rdname internal-methods
#' @export
setMethod("unname",
signature(obj = "DemographicArray"),
function(obj, force = FALSE) {
unname(obj@.Data)
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.