Fixed incorrect validation for contributions

Author: marberts

DESCRIPTION

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

R/aggregate.piar_index.R

@@ -235,7 +235,7 @@ aggregate_index <- function(
     )
     if (has_contrib) {
       res$contrib <- Map(
-        super_aggregate_contrib(),
+        super_aggregate_contrib(0),
         res$contrib,
         res2$contrib,
         res$index,
@@ -361,11 +361,10 @@ aggregate_contrib <- function(r, duplicate_contrib = c("make.unique", "sum")) {
   }
 }
 
-
 #' Aggregate product contributions for a superlative index
 #' @noRd
-super_aggregate_contrib <- function() {
-  arithmetic_weights <- gpindex::transmute_weights(0, 1)
+super_aggregate_contrib <- function(r) {
+  arithmetic_weights <- gpindex::transmute_weights(r, 1)
   Vectorize(
     function(x, y, rel1, rel2) {
       w <- arithmetic_weights(c(rel1, rel2))

R/contrib.R

@@ -92,9 +92,8 @@ contrib.piar_index <- function(x,
   # replace with the actual values so products that didn't sell have 0 and
   # not NA contributions.
   out[] <- list(structure(rep.int(pad, length(products)), names = products))
-  res <- Map(replace, out, con_names, con)
-  res <- do.call(cbind, res)
-  names(dimnames(res)) <- c("levels", "time")
+  res <- do.call(cbind, Map(replace, out, con_names, con))
+  names(dimnames(res)) <- c("product", "time")
   res
 }
 

R/helpers.R

@@ -9,17 +9,17 @@ padded_extract <- function(x, i, pad) {
 }
 
 #---- Replacing contributions ----
-near <- function(x, y, tol = .Machine$double.eps^0.5) {
-  abs(x - y) < tol
-}
-
-valid_replacement_contrib <- function(index, contrib) {
+valid_replacement_contrib <- function(index,
+                                      contrib,
+                                      tol = .Machine$double.eps^0.5) {
   if (length(contrib) == 0L) {
-    TRUE
-  } else if (is.na(index)) {
-    anyNA(contrib)
+    return(TRUE)
+  }
+  valid <- sum(contrib, na.rm = TRUE) <= index - 1 + tol
+  if (is.na(index)) {
+    anyNA(contrib) || valid
   } else {
-    near(sum(contrib, na.rm = TRUE), index - 1)
+    valid
   }
 }
 

R/mean.piar_index.R

@@ -50,7 +50,8 @@
 #' A price index, averaged over subperiods, that inherits from the same
 #' class as `x`.
 #'
-#' @references Balk, B. M. (2008). *Price and Quantity Index Numbers*.
+#' @references
+#' Balk, B. M. (2008). *Price and Quantity Index Numbers*.
 #' Cambridge University Press.
 #'
 #' @examples
@@ -62,15 +63,14 @@
 #' @family index methods
 #' @export
 mean.chainable_piar_index <- function(
-  x,
-  ...,
-  weights = NULL,
-  window = ntime(x),
-  na.rm = FALSE,
-  contrib = TRUE,
-  r = 1,
-  duplicate_contrib = c("make.unique", "sum")
-) {
+    x,
+    ...,
+    weights = NULL,
+    window = ntime(x),
+    na.rm = FALSE,
+    contrib = TRUE,
+    r = 1,
+    duplicate_contrib = c("make.unique", "sum")) {
   chkDots(...)
   mean_index(
     x,
@@ -87,15 +87,14 @@ mean.chainable_piar_index <- function(
 #' @rdname mean.piar_index
 #' @export
 mean.direct_piar_index <- function(
-  x,
-  ...,
-  weights = NULL,
-  window = ntime(x),
-  na.rm = FALSE,
-  contrib = TRUE,
-  r = 1,
-  duplicate_contrib = c("make.unique", "sum")
-) {
+    x,
+    ...,
+    weights = NULL,
+    window = ntime(x),
+    na.rm = FALSE,
+    contrib = TRUE,
+    r = 1,
+    duplicate_contrib = c("make.unique", "sum")) {
   chkDots(...)
   mean_index(
     x,
@@ -112,15 +111,14 @@ mean.direct_piar_index <- function(
 #' Internal function to aggregate over subperiods
 #' @noRd
 mean_index <- function(
-  x,
-  weights,
-  window,
-  na.rm,
-  contrib,
-  r,
-  chainable,
-  duplicate_contrib
-) {
+    x,
+    weights,
+    window,
+    na.rm,
+    contrib,
+    r,
+    chainable,
+    duplicate_contrib) {
   if (!is.null(weights)) {
     weights <- as.numeric(weights)
     if (length(weights) != length(x$time) * length(x$levels)) {

tests/Examples/piar-Ex.Rout.save

@@ -404,12 +404,12 @@ levels         1 2 3
 > # Percent-change contributions for the top-level index
 > 
 > contrib(index)
-      time
-levels         1         2
-   a.1 0.0000000 0.5081686
-   a.2 0.2440169 0.6442213
-   b.1 0.3905243 2.0513858
-   b.2 0.8284271 2.4871732
+       time
+product        1         2
+    a.1 0.0000000 0.5081686
+    a.2 0.2440169 0.6442213
+    b.1 0.3905243 2.0513858
+    b.2 0.8284271 2.4871732
 > 
 > contrib2DF(index)
   period level product     value

tests/test-making-price-indexes.Rout.save

@@ -361,28 +361,28 @@ levels 202001    202002    202003   202004
 > 
 > ## -----------------------------------------------------------------------------
 > contrib(ms_elemental)
-      time
-levels 202001     202002     202003 202004
-     1      0  0.0000000  0.0000000      0
-     2     NA         NA -0.6657061      0
-     3      0 -0.1050903         NA     NA
+       time
+product 202001     202002     202003 202004
+      1      0  0.0000000  0.0000000      0
+      2     NA         NA -0.6657061      0
+      3      0 -0.1050903         NA     NA
 > 
 > ## -----------------------------------------------------------------------------
 > contrib(aggregate(ms_elemental, pias, na.rm = TRUE))
-      time
-levels 202001      202002     202003       202004
-    1       0  0.00000000  0.0000000  0.000000000
-    10      0 -0.08782076  0.2731949 -0.078173579
-    11      0  0.00000000         NA  0.059392635
-    12      0  0.00000000         NA  1.322915301
-    2      NA          NA -0.2928098  0.000000000
-    3       0 -0.06718490         NA           NA
-    4       0          NA         NA -0.018209690
-    5       0          NA         NA  0.094562963
-    6       0          NA         NA  0.427935081
-    7       0  0.51646606 -0.2054665 -0.011177530
-    8       0  0.01906845  0.1755868 -0.003784845
-    9       0 -0.07980493  0.1125689 -0.058699008
+       time
+product 202001      202002     202003       202004
+     1       0  0.00000000  0.0000000  0.000000000
+     10      0 -0.08782076  0.2731949 -0.078173579
+     11      0  0.00000000         NA  0.059392635
+     12      0  0.00000000         NA  1.322915301
+     2      NA          NA -0.2928098  0.000000000
+     3       0 -0.06718490         NA           NA
+     4       0          NA         NA -0.018209690
+     5       0          NA         NA  0.094562963
+     6       0          NA         NA  0.427935081
+     7       0  0.51646606 -0.2054665 -0.011177530
+     8       0  0.01906845  0.1755868 -0.003784845
+     9       0 -0.07980493  0.1125689 -0.058699008
 > 
 > ## -----------------------------------------------------------------------------
 > ms_prices1 <- subset(ms_prices, period <= "202003")
@@ -677,20 +677,20 @@ levels 202001    202002    202003   202004
 +   w[2, col(paasche_contrib)] * paasche_contrib
 > 
 > fisher_contrib
-      time
-levels 202001      202002      202003       202004
-    1       0  0.00000000  0.00000000  0.000000000
-    10      0 -0.13327742  0.17296129 -0.131946938
-    11      0  0.00000000          NA  0.039533034
-    12      0  0.00000000          NA  0.880561300
-    2      NA          NA -0.42962331  0.000000000
-    3       0 -0.04756479          NA           NA
-    4       0          NA          NA -0.012019870
-    5       0          NA          NA  0.062419211
-    6       0          NA          NA  0.282471798
-    7       0  0.78379264 -0.13008203 -0.018866231
-    8       0  0.02893842  0.11116498 -0.006388331
-    9       0 -0.12111255  0.07126804 -0.099076370
+       time
+product 202001      202002      202003       202004
+     1       0  0.00000000  0.00000000  0.000000000
+     10      0 -0.13327742  0.17296129 -0.131946938
+     11      0  0.00000000          NA  0.039533034
+     12      0  0.00000000          NA  0.880561300
+     2      NA          NA -0.42962331  0.000000000
+     3       0 -0.04756479          NA           NA
+     4       0          NA          NA -0.012019870
+     5       0          NA          NA  0.062419211
+     6       0          NA          NA  0.282471798
+     7       0  0.78379264 -0.13008203 -0.018866231
+     8       0  0.02893842  0.11116498 -0.006388331
+     9       0 -0.12111255  0.07126804 -0.099076370
 > 
 > ## -----------------------------------------------------------------------------
 > chain(fisher)

tests/testthat/test-aggregate.R

@@ -387,7 +387,13 @@ test_that("partial contributions are correct", {
 })
 
 test_that("duplicate products get unique names during aggregation", {
-  epr1 <- elemental_index(setNames(1:4, 1:4), ea = gl(2, 2), period = gl(1, 4), contrib = TRUE, r = 1)
+  epr1 <- elemental_index(
+    setNames(1:4, 1:4),
+    ea = gl(2, 2),
+    period = gl(1, 4),
+    contrib = TRUE,
+    r = 1
+  )
   epr2 <- epr1
   levels(epr2) <- 3:4
   index <- aggregate(
@@ -396,7 +402,7 @@ test_that("duplicate products get unique names during aggregation", {
   )
   expect_equal(
     contrib(index, "a"),
-    matrix(c(0, 0.25, 0.5, 0.75), 4, dimnames = list(levels = 1:4, time = 1))
+    matrix(c(0, 0.25, 0.5, 0.75), 4, dimnames = list(product = 1:4, time = 1))
   )
   expect_equal(
     contrib(index, "a"),
@@ -406,7 +412,7 @@ test_that("duplicate products get unique names during aggregation", {
     contrib(index),
     matrix(rep(c(0, 0.125, 0.25, 0.375), each = 2), 8,
       dimnames = list(
-        levels = c(1, "1.1", 2, "2.1", 3, "3.1", 4, "4.1"),
+        product = c(1, "1.1", 2, "2.1", 3, "3.1", 4, "4.1"),
         time = 1
       )
     )
@@ -631,3 +637,18 @@ test_that("superlative index aggregates correctly", {
     aggregate(epr, pias, pias2 = pias, r = 0, na.rm = TRUE)
   )
 })
+
+test_that("duplicate product methods work with NAs", {
+  x <- as_index(c(1, 2, NA))
+  contrib(x, 1) <- c(0.5, -0.25, NA, -0.25)
+  contrib(x, 3) <- c(1, NA, NA)
+  pias <- list(c(0, 0, 0), 1:3)
+  expect_equal(
+    contrib(aggregate(x, pias, duplicate_contrib = "sum")),
+    matrix(c(0.25, -0.125, NA, -0.125), dimnames = list(product = 1:4, time = 1))
+  )
+  expect_equal(
+    contrib(aggregate(x, pias, duplicate_contrib = "sum", na.rm = TRUE)),
+    matrix(c(0.25, -0.125, NA, -0.125), dimnames = list(product = 1:4, time = 1))
+  )
+})

tests/testthat/test-as_index.R

@@ -1,6 +1,8 @@
-dat <- data.frame(rel = c(1:6, NA, 7, 8),
-                  period = c(1, 1, 1, 1, 1, 2, 2, 2, 2),
-                  ea = c("11", "11", "12", "12", "13", "11", "12", "11", "14"))
+dat <- data.frame(
+  rel = c(1:6, NA, 7, 8),
+  period = c(1, 1, 1, 1, 1, 2, 2, 2, 2),
+  ea = c("11", "11", "12", "12", "13", "11", "12", "11", "14")
+)
 
 pias <- as_aggregation_structure(
   data.frame(level1 = 1, level2 = c(11, 12, 13, 14), weight = 1)
@@ -24,9 +26,10 @@ test_that("as_index works with matrices", {
   expect_equal(as_index(as.matrix(epr)), epr2)
   expect_equal(
     contrib(as_index(as.matrix(epr), contrib = TRUE)),
-    as.matrix(epr)[1, , drop = FALSE] - 1
+    as.matrix(epr)[1, , drop = FALSE] - 1,
+    ignore_attr = TRUE
   )
-  
+
   # A character vector used to get pass through without coercion.
   mat <- as.matrix(epr)
   mat[] <- as.character(mat)
@@ -38,7 +41,8 @@ test_that("as_index works for data frames", {
   expect_equal(as_index(as.data.frame(epr)), epr2)
   expect_equal(
     contrib(as_index(as.data.frame(epr), contrib = TRUE)),
-    as.matrix(epr)[1, , drop = FALSE] - 1
+    as.matrix(epr)[1, , drop = FALSE] - 1,
+    ignore_attr = TRUE
   )
   df <- as.data.frame(epr)
   df[[1]] <- factor(df[[1]], levels = 2:1)
@@ -49,12 +53,12 @@ test_that("as_index works for data frames", {
       elemental_index(rel, period = factor(period, levels = 2:1), ea = ea)
     )
   )
-  
+
   expect_equal(
     as_index(data.frame(1:5, 1:5, 1:5)),
     as_index(matrix(replace(NA, c(1, 7, 13, 19, 25), 1:5), 5))
   )
-  
+
   expect_error(as_index(df[1:2]))
 })
 
@@ -74,17 +78,17 @@ test_that("as_index works with contribs", {
     as_index(as.data.frame(epr2, contrib = TRUE), contrib = TRUE),
     epr2
   )
-  
+
   index2 <- aggregate(epr, pias, contrib = FALSE)
   index2df <- as.data.frame(index2, contrib = TRUE)
   expect_equal(
     as_index(index2df[-1, ], contrib = TRUE),
     index2
   )
-  
+
   index2df[1, 4] <- list(a = 0)
   expect_error(as_index(index2df, contrib = TRUE))
-  
+
   index2df[1, 4][[1]] <- list(c(a = 2, a = 1, b = NA))
   expect_warning(index2 <- as_index(index2df, contrib = TRUE))
   expect_identical(rownames(contrib(index2)), c("a", "a.1", "b"))