Merge pull request #57 from marberts/unbalanced

Added pad for unbalanced classifications, closes #56

Author: marberts

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: piar
 Title: Price Index Aggregation
-Version: 0.8.2.9003
+Version: 0.8.2.9004
 Authors@R: c(
     person("Steve", "Martin", role = c("aut", "cre", "cph"),
            email = "marberts@protonmail.com",

NEWS.md

@@ -8,6 +8,9 @@ control how product contributions are made when there are duplicate products.
 - Coercing an index or an aggregation structure to a matrix now has dimension
 names.
 
+- `expand_classification()` and `split_classification()` get a new argument
+`pad` to better manage unbalanced classifications.
+
 ## Bug fixes
 
 - Fixed description of how product contributions are combined across subperiods

R/expand_classification.R

@@ -16,6 +16,8 @@
 #'   the hierarchy (as made by `expand_classification()`).
 #' @param sep A character used to combine codes/labels across elements of `...`.
 #'   The default uses ":".
+#' @param pad A string used to pad the shorter labels for an unbalanced
+#'   classification. The default pads with NA.
 #'
 #' @returns
 #' `expand_classification()` returns a list with a entry for each level
@@ -30,6 +32,9 @@
 #' [split_classification()] to expand a classification by splitting along
 #' a delimiter.
 #'
+#' `csh_from_digits()` in the \pkg{accumulate} package for different handling
+#' of unbalanced classifications.
+#'
 #' @examples
 #' # A simple classification structure
 #' #            1
@@ -57,7 +62,7 @@
 #' expand_classification(c("01.1.1", "01.1.2", "01.2.1"), width = 2)
 #'
 #' @export
-expand_classification <- function(x, width = 1L) {
+expand_classification <- function(x, width = 1L, pad = NA) {
   x <- as.character(x)
   if (length(x) == 0L) {
     return(list())
@@ -77,7 +82,7 @@ expand_classification <- function(x, width = 1L) {
   w <- cumsum(width)
   x <- strsplit(x, character(0L), fixed = TRUE)
   lapply(w, function(i) {
-    vapply(x, \(x) paste(x[seq_len(i)], collapse = ""), character(1L))
+    vapply(x, \(x) paste(padded_extract(x, i, pad), collapse = ""), character(1L))
   })
 }
 

R/helpers.R

@@ -1,3 +1,13 @@
+padded_extract <- function(x, i, pad) {
+  pad <- as.character(pad)
+  if (length(pad) != 1L) {
+    stop("'pad' must be a length 1 character")
+  }
+  res <- x[seq_len(i)]
+  res[seq.int(to = i, length.out = max(i - length(x), 0L))] <- pad
+  res
+}
+
 #---- Replacing contributions ----
 near <- function(x, y, tol = .Machine$double.eps^0.5) {
   abs(x - y) < tol

R/split_classification.R

@@ -11,6 +11,8 @@
 #' @param ... Additional argument to pass to [strsplit()].
 #' @param sep A character used to delineate levels in `x` in the result. The
 #'   default separates levels by ".".
+#' @param pad A string used to pad the shorter labels for an unbalanced
+#'   classification. The default pads with NA.
 #'
 #' @returns
 #' A list with a entry for each level in `x` giving the "digits" that
@@ -37,7 +39,7 @@
 #' split_classification(c("01.1.1", "01.1.2", "01.2.1"), ".", fixed = TRUE)
 #'
 #' @export
-split_classification <- function(x, split, ..., sep = ".") {
+split_classification <- function(x, split, ..., sep = ".", pad = NA) {
   x <- as.character(x)
   if (length(x) == 0L) {
     return(list())
@@ -47,7 +49,7 @@ split_classification <- function(x, split, ..., sep = ".") {
   if (n == 0L) {
     return(list(rep.int("", length(x))))
   }
-  res <- do.call(rbind, lapply(x, `[`, seq_len(n)))
+  res <- do.call(rbind, lapply(x, \(z) padded_extract(z, n, pad)))
   Reduce(
     \(...) paste(..., sep = sep),
     split(res, gl(ncol(res), nrow(res))),

man/contrib.Rd

@@ -395,7 +395,8 @@ levels         1 2 3
 > index <- elemental_index(prices, rel ~ period + ea, contrib = TRUE)
 > 
 > pias <- aggregation_structure(
-+   list(c("top", "top", "top"), c("a", "b", "c")), weights = 1:3
++   list(c("top", "top", "top"), c("a", "b", "c")),
++   weights = 1:3
 + )
 > 
 > index <- aggregate(index, pias, na.rm = TRUE)

man/expand_classification.Rd

@@ -1,32 +1,57 @@
 test_that("expand classification works", {
-  expect_equal(expand_classification(c("1.1.1", "1.1.2", "1.2.1"), c(2, 2, 1)),
-               list(c("1.", "1.", "1."),
-                    c("1.1.", "1.1.", "1.2."),
-                    c("1.1.1", "1.1.2", "1.2.1")))
-  expect_equal(expand_classification(c("1.1.1", "1.1.2", "1.2.1"), c(3, 2)),
-               list(c("1.1", "1.1", "1.2"),
-                    c("1.1.1", "1.1.2", "1.2.1")))
-  expect_equal(expand_classification(c("1.1.1", "1.1.2", "1.2.1"), 3),
-               list(c("1.1", "1.1", "1.2"),
-                    c("1.1.1NA", "1.1.2NA", "1.2.1NA")))
+  expect_equal(
+    expand_classification(c("1.1.1", "1.1.2", "1.2.1"), c(2, 2, 1)),
+    list(
+      c("1.", "1.", "1."),
+      c("1.1.", "1.1.", "1.2."),
+      c("1.1.1", "1.1.2", "1.2.1")
+    )
+  )
+  expect_equal(
+    expand_classification(c("1.1.1", "1.1.2", "1.2.1"), c(3, 2)),
+    list(
+      c("1.1", "1.1", "1.2"),
+      c("1.1.1", "1.1.2", "1.2.1")
+    )
+  )
+  expect_equal(
+    expand_classification(c("1.1.1", "1.1.2", "1.2.1"), 3),
+    list(
+      c("1.1", "1.1", "1.2"),
+      c("1.1.1NA", "1.1.2NA", "1.2.1NA")
+    )
+  )
   expect_equal(expand_classification(character(0)), list())
   expect_equal(expand_classification(c("", "")), list(c("NA", "NA")))
 })
 
 test_that("expand classification fails when expected", {
   expect_error(expand_classification("123", width = c(1, 0, 1)))
   expect_error(expand_classification("123", width = c(1, NA, 1)))
+  expect_error(expand_classification("123", pad = 1:3))
+  expect_error(expand_classification("123", pad = NULL))
+})
+
+test_that("expand classification works with unbalanced classification", {
+  expect_identical(
+    expand_classification(c(1234, 12345), c(1, 3, 1), pad = 0),
+    list(c("1", "1"), c("1234", "1234"), c("12340", "12345"))
+  )
+  expect_identical(
+    expand_classification(c(1234, 12345), c(1, 3, 1), pad = "00"),
+    list(c("1", "1"), c("1234", "1234"), c("123400", "12345"))
+  )
 })
 
 test_that("interaction works", {
-  c1 = expand_classification(c(11, 11, 12, 12))
-  c2 = expand_classification(c(111, 112, 121, 122))
-  
+  c1 <- expand_classification(c(11, 11, 12, 12))
+  c2 <- expand_classification(c(111, 112, 121, 122))
+
   expect_identical(
     interact_classifications(c1),
     list(c1)
   )
-  
+
   expect_identical(
     interact_classifications(c1, c2),
     list(list(
@@ -39,7 +64,7 @@ test_that("interaction works", {
       c("11:111", "11:112", "12:121", "12:122")
     ))
   )
-  
+
   expect_identical(
     interact_classifications(list(rep(1, 4)), c1, c2),
     list(list(
@@ -52,7 +77,7 @@ test_that("interaction works", {
       c("1:11:111", "1:11:112", "1:12:121", "1:12:122")
     ))
   )
-  
+
   expect_error(interact_classifications(c1, list(c2)))
   expect_error(interact_classifications(list(), c1))
   expect_error(interact_classifications(c1, list(1)))
@@ -62,7 +87,7 @@ test_that("interacting a single classification does nothing", {
   expect_identical(interact_classifications(), list())
   expect_identical(interact_classifications(list(), list()), list())
   expect_identical(interact_classifications(list(1)), list(list(1)))
-  
-  x = expand_classification(c("1.1.1", "1.1.2", "1.2.1"), c(2, 2, 1))
+
+  x <- expand_classification(c("1.1.1", "1.1.2", "1.2.1"), c(2, 2, 1))
   expect_identical(interact_classifications(x)[[1]], x)
-})
+})