pias levels are now a list

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: piar
 Title: Price Index Aggregation
-Version: 0.6.0.9020
+Version: 0.6.0.9021
 Authors@R: c(
     person("Steve", "Martin", role = c("aut", "cre", "cph"),
            email = "[email protected]",

NEWS.md

@@ -32,6 +32,10 @@ are aggregated over subperiods.
 
 - Added a `split()` method for index objects.
 
+- `levels(aggregation_structure)` now returns a list of levels to denote
+the position of each level in the hierarchy. Use `unlist()` to get the old
+behavior.
+
 ## Bug fixes
 
 - The default for `ea_only` has changed to `TRUE` when calling

R/aggregate.piar_index.R

@@ -159,13 +159,12 @@ aggregate.piar_index <- function(x, pias, ...,
   w <- rev(weights(pias, ea_only = FALSE, na.rm = na.rm))
 
   has_contrib <- has_contrib(x) && contrib
-  pias_eas <- match(pias$eas, pias$levels)
-  eas <- match(pias$eas, x$levels)
+  eas <- match(pias$levels[[length(pias$levels)]], x$levels)
 
   # loop over each time period
   index <- contrib <- vector("list", length(x$time))
   for (t in seq_along(x$time)) {
-    rel <- con <- vector("list", pias$height)
+    rel <- con <- vector("list", length(pias$levels))
     # align epr with weights so that positional indexing works
     rel[[1L]] <- x$index[[t]][eas]
     con[[1L]] <- x$contrib[[t]][eas]
@@ -207,14 +206,14 @@ aggregate.piar_index <- function(x, pias, ...,
     contrib[[t]] <- unlist(rev(con), recursive = FALSE, use.names = FALSE)
     # price update weights for all periods after the first
     if (chainable) {
-      weights(pias) <- price_update(index[[t]][pias_eas], w[[1L]])
+      weights(pias) <- price_update(rel[[1L]], w[[1L]])
       w <- rev(weights(pias, ea_only = FALSE, na.rm = na.rm))
     }
   }
 
   aggregate_piar_index(
-    index, contrib, pias$levels, x$time, r,
-    pias[c("child", "parent", "eas", "height")],
+    index, contrib, unlist(pias$levels, use.names = FALSE), x$time, r,
+    pias[c("child", "parent", "levels")],
     chainable
   )
 }

R/aggregation_structure-class.R

@@ -1,51 +1,44 @@
 #---- Class generator ----
-new_piar_aggregation_structure <- function(child, parent, levels, eas,
-                                           weights, height) {
+new_piar_aggregation_structure <- function(child, parent, levels, weights) {
   stopifnot(is.list(child))
   stopifnot(is.list(parent))
-  stopifnot(is.character(levels))
-  stopifnot(is.character(eas))
+  stopifnot(is.list(levels))
   stopifnot(is.double(weights))
-  stopifnot(is.integer(height))
   res <- list(
-    child = child, parent = parent, levels = levels,
-    eas = eas, weights = weights, height = height
+    child = child, parent = parent, levels = levels, weights = weights
   )
   structure(res, class = "piar_aggregation_structure")
 }
 
-piar_aggregation_structure <- function(child, parent, levels, eas,
-                                       weights, height) {
-  levels <- as.character(levels)
-  eas <- as.character(eas)
+piar_aggregation_structure <- function(child, parent, levels, weights) {
+  levels <- lapply(as.list(levels), as.character)
   weights <- as.numeric(weights)
-  names(weights) <- eas
-  height <- as.integer(height)
+  names(weights) <- levels[[length(levels)]]
   validate_piar_aggregation_structure(
-    new_piar_aggregation_structure(child, parent, levels, eas, weights, height)
+    new_piar_aggregation_structure(child, parent, levels, weights)
   )
 }
 
 #---- Validator ----
 validate_pias_levels <- function(x) {
-  if (anyNA(x$levels) || any(x$levels == "")) {
+  lev = unlist(x$levels, use.names = FALSE)
+  if (anyNA(lev) || any(lev == "")) {
     stop("cannot make an aggregation structure with missing levels")
   }
-  if (anyDuplicated(x$levels)) {
+  if (anyDuplicated(lev)) {
     stop("cannot make an aggregation structure with duplicated levels")
   }
   invisible(x)
 }
 
 validate_pias_structure <- function(x) {
-  eas <- seq.int(to = length(x$levels), length.out = length(x$eas))
-  if (!identical(x$eas, x$levels[eas]) ||
-    x$height != length(x$child) + 1L ||
-    x$height != length(x$parent) + 1L ||
-    anyNA(x$child, recursive = TRUE) ||
-    anyNA(x$parent, recursive = TRUE) ||
-    any(vapply(x$child, \(x) any(lengths(x) == 0L), logical(1L)))
-  ) {
+  height <- length(x$levels)
+  if (height != length(x$child) + 1L ||
+      height != length(x$parent) + 1L ||
+      anyNA(x$child, recursive = TRUE) ||
+      anyNA(x$parent, recursive = TRUE) ||
+      any(vapply(x$child, \(x) any(lengths(x) == 0L), logical(1L)))
+    ) {
     stop(
       "invalid aggregation structure; the input is likely not a nested ",
       "hierachy"
@@ -55,7 +48,7 @@ validate_pias_structure <- function(x) {
 }
 
 validate_pias_weights <- function(x) {
-  if (length(x$weights) != length(x$eas)) {
+  if (length(x$weights) != length(x$levels[[length(x$levels)]])) {
     stop(
       "cannot make an aggregation structure with a different number of ",
       "weights and elemental aggregates"
@@ -74,8 +67,9 @@ validate_piar_aggregation_structure <- function(x) {
 #' @export
 print.piar_aggregation_structure <- function(x, ...) {
   cat(
-    "Aggregation structure for", length(x$eas), "elemental aggregates with",
-    x$height - 1L, "levels above the elemental aggregates", "\n"
+    "Aggregation structure for", length(x$levels[[length(x$levels)]]),
+    "elemental aggregates with",
+    length(x$levels) - 1L, "levels above the elemental aggregates", "\n"
   )
   print(as.data.frame(x), ...)
   invisible(x)

R/aggregation_structure.R

@@ -25,12 +25,9 @@
 #' \item{parent}{A list that gives the position of the
 #' immediate parent for each node of the aggregation structure below the
 #' initial nodes.}
-#' \item{levels}{A character vector that gives the levels of `x`.}
-#' \item{eas}{A character vector that gives the subset of
-#' `levels` that are elemental aggregates.}
+#' \item{levels}{A list of character vectors that give the levels of `x`.}
 #' \item{weights}{A named vector giving the weight for each elemental
 #' aggregate.}
-#' \item{height}{The length of `x`.}
 #'
 #' @section Warning: The `aggregation_structure()` function does its best
 #' to check its arguments, but there should be no expectation that the result
@@ -73,20 +70,17 @@
 #'   weight = c(1, 3, 4)
 #' )
 #'
-#' pias <- aggregation_structure(
+#' aggregation_structure(
 #'   aggregation_weights[1:3],
 #'   weights = aggregation_weights[[4]]
 #' )
 #'
 #' # The aggregation structure can also be made by expanding the
 #' # elemental aggregates
 #'
-#' all.equal(
-#'   with(
-#'     aggregation_weights,
-#'     aggregation_structure(expand_classification(ea), weight)
-#'   ),
-#'   pias
+#' with(
+#'   aggregation_weights,
+#'   aggregation_structure(expand_classification(ea), weight)
 #' )
 #'
 #' @export
@@ -144,6 +138,6 @@ aggregation_structure <- function(x, weights = NULL) {
     )
   }
   parent <- lapply(parent, unlist)
-  levels <- unlist(lapply(x, levels), use.names = FALSE)
-  piar_aggregation_structure(child, parent, levels, ea, weights, len)
+  levels <- lapply(x, levels)
+  piar_aggregation_structure(child, parent, levels, weights)
 }

R/as_aggregation_structure.R

@@ -86,13 +86,12 @@ as_aggregation_structure.matrix <- function(x, ...) {
 as_aggregation_structure.aggregate_piar_index <- function(x,
                                                           weights = NULL, ...) {
   if (is.null(weights)) {
-    weights <- rep.int(1, length(x$pias$eas))
+    weights <- rep.int(1, length(x$pias$levels[[length(x$pias$levels)]]))
   } else if (any(weights <= 0, na.rm = TRUE)) {
     warning("some elements of 'w' are less than or equal to 0")
   }
   piar_aggregation_structure(
-    x$pias$child, x$pias$parent, x$levels,
-    x$pias$eas, weights, x$pias$height
+    x$pias$child, x$pias$parent, x$pias$levels, weights
   )
 }
 

R/coerce-aggregation_structure.R

@@ -48,9 +48,10 @@
 #' @family aggregation structure methods
 #' @export
 as.matrix.piar_aggregation_structure <- function(x, ..., sparse = FALSE) {
-  nea <- length(x$eas)
-  if (x$height == 1L) {
-    res <- matrix(numeric(0L), ncol = nea, dimnames = list(NULL, x$eas))
+  nea <- length(x$weights)
+  height <- length(x$levels)
+  if (height == 1L) {
+    res <- matrix(numeric(0L), ncol = nea, dimnames = list(NULL, x$levels[[1L]]))
     if (sparse) {
       return(Matrix::Matrix(res, sparse = TRUE))
     } else {
@@ -59,7 +60,7 @@ as.matrix.piar_aggregation_structure <- function(x, ..., sparse = FALSE) {
   }
   cols <- seq_len(nea)
   # don't need the eas
-  lev <- lapply(as.list(x)[-x$height], \(z) factor(z, unique(z)))
+  lev <- lapply(as.list(x)[-height], \(z) factor(z, unique(z)))
   res <- vector("list", length(lev))
   # generate the rows for each level of the matrix and rbind together
   for (i in seq_along(res)) {
@@ -72,7 +73,7 @@ as.matrix.piar_aggregation_structure <- function(x, ..., sparse = FALSE) {
       mat <- matrix(0, nlevels(lev[[i]]), nea)
       mat[cbind(lev[[i]], cols)] <- w
     }
-    dimnames(mat) <- list(levels(lev[[i]]), x$eas)
+    dimnames(mat) <- list(levels(lev[[i]]), x$levels[[height]])
     res[[i]] <- mat
   }
   do.call(rbind, res)
@@ -93,8 +94,8 @@ as.data.frame.piar_aggregation_structure <- function(x, ...,
 
 #' @export
 as.list.piar_aggregation_structure <- function(x, ...) {
-  if (x$height == 1L) {
-    return(list(x$eas))
+  if (length(x$levels) == 1L) {
+    return(x$levels[1L])
   }
   res <- vector("list", length(x$parent))
   res[[1L]] <- x$parent[[1L]]

R/index-class.R

@@ -31,7 +31,7 @@
 #' \describe{
 #' \item{r}{The order of the generalized mean used to aggregated the
 #' index (usually 1).}
-#' \item{pias}{A list containing the `child`, `parent`, `eas`, and `height`
+#' \item{pias}{A list containing the `child`, `parent`, and `levels`
 #' components of the aggregation structured used to aggregate the index.}
 #' }
 #'

R/levels.piar_aggregation_structure.R

@@ -5,5 +5,5 @@ levels.piar_aggregation_structure <- function(x) {
 
 #' @export
 `levels<-.piar_aggregation_structure` <- function(x, value) {
-  stop("cannot replace levels attribute for aggregation structure")
+  stop("cannot replace levels attribute for an aggregation structure")
 }

R/update.aggregation_structure.R

@@ -59,7 +59,7 @@ update.piar_aggregation_structure <- function(object, index,
     r <- if (is.null(index$r)) 1 else index$r
   }
   price_update <- gpindex::factor_weights(r)
-  eas <- match(object$eas, index$levels)
+  eas <- match(object$levels[[length(object$levels)]], index$levels)
   if (anyNA(eas)) {
     warning("not all weights in 'object' have a corresponding index value")
   }

R/vcov.aggregate_piar_index.R

@@ -83,7 +83,7 @@
 vcov.aggregate_piar_index <- function(object, repweights, ...,
                                       mse = TRUE, sparse = FALSE) {
   repweights <- as.matrix(repweights)
-  eas <- object$pias$eas
+  eas <- object$pias$levels[[length(object$pias$levels)]]
   if (nrow(repweights) != length(eas)) {
     stop("'repweights' must have a row for each weight in 'pias'")
   }

R/weights.piar_aggregation_structure.R

@@ -55,7 +55,7 @@ weights.piar_aggregation_structure <- function(object, ..., ea_only = TRUE,
   if (ea_only) {
     return(object$weights)
   }
-  res <- vector("list", object$height)
+  res <- vector("list", length(object$levels))
   res[[1L]] <- object$weights
 
   for (i in seq_along(res)[-1L]) {

tests/Examples/piar-Ex.Rout.save

@@ -103,22 +103,28 @@ top 2.462968 16.4796
 +   weight = c(1, 3, 4)
 + )
 > 
-> pias <- aggregation_structure(
+> aggregation_structure(
 +   aggregation_weights[1:3],
 +   weights = aggregation_weights[[4]]
 + )
+Aggregation structure for 3 elemental aggregates with 2 levels above the elemental aggregates 
+  level1 level2  ea weight
+1      1     11 111      1
+2      1     11 112      3
+3      1     12 121      4
 > 
 > # The aggregation structure can also be made by expanding the
 > # elemental aggregates
 > 
-> all.equal(
-+   with(
-+     aggregation_weights,
-+     aggregation_structure(expand_classification(ea), weight)
-+   ),
-+   pias
+> with(
++   aggregation_weights,
++   aggregation_structure(expand_classification(ea), weight)
 + )
-[1] TRUE
+Aggregation structure for 3 elemental aggregates with 2 levels above the elemental aggregates 
+  level1 level2  ea weight
+1      1     11 111      1
+2      1     11 112      3
+3      1     12 121      4
 > 
 > 
 > 
@@ -982,7 +988,7 @@ top 0.007818832 0.003929299
 > cleanEx()
 > options(digits = 7L)
 > base::cat("Time elapsed: ", proc.time() - base::get("ptime", pos = 'CheckExEnv'),"\n")
-Time elapsed:  0.105 0.01 0.117 0 0 
+Time elapsed:  0.109 0.008 0.118 0 0 
 > grDevices::dev.off()
 null device 
           1 

tests/testthat/test-aggregation-structure-attributes.R

@@ -4,8 +4,10 @@ x3 <- c("111", "211", "121", "112")
 agg <- aggregation_structure(list(x1, x2, x3))
 
 test_that("levels method works", {
-  expect_identical(levels(agg),
-                   c("1", "2", "11", "21", "12", "111", "211", "121", "112"))
+  expect_identical(
+    levels(agg),
+    list(c("1", "2"), c("11", "21", "12"), c("111", "211", "121", "112"))
+  )
   expect_error(levels(agg) <- 1:9)
 })