Fixed a bug in transmuate_weights() that could change the length of w…

…eights

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: gpindex
 Title: Generalized Price and Quantity Indexes
-Version: 0.6.0.9009
+Version: 0.6.0.9011
 Authors@R: c(
     person("Steve", "Martin", role = c("aut", "cre", "cph"),
     email = "[email protected]",

NEWS.md

@@ -5,6 +5,9 @@
 - Added a parameter to generalize `geks()` by controlling how indexes are
 averaged over the rolling window.
 
+- Fixed a bug where `transmute_weights()` and `factor_weights()` could return
+a result with a different length than `w`.
+
 ## Version 0.6.0
 
 - Bumped minimum version of R to at least 4.0.

R/geks.R

@@ -166,13 +166,15 @@ geks <- function(f, r = 0) {
   gen_mean <- generalized_mean(r)
   function(p, q, period, product,
            window = nlevels(period), n = window - 1L, na.rm = FALSE) {
+    period <- as.factor(period)
+    product <- as.factor(product)
+    attributes(product) <- NULL # faster to match on numeric codes
+
     if (different_lengths(p, q, period, product)) {
       stop("'p', 'q', 'period', and 'product' must be the same length")
     }
 
-    period <- as.factor(period)
     nper <- nlevels(period)
-
     if (nper == 0L) {
       return(list())
     }
@@ -198,8 +200,7 @@ geks <- function(f, r = 0) {
 
     p <- split(p, period)
     q <- split(q, period)
-    product <- as.factor(product)
-    attributes(product) <- NULL # faster to match on numeric codes
+
     product <- split(product, period)
     if (duplicate_products(product)) {
       warning("there are duplicated period-product pairs")

R/offset_prices.R

@@ -4,16 +4,18 @@ offset_period <- function(f) {
   f <- match.fun(f)
 
   function(period, product = gl(1, length(period)), match_first = TRUE) {
+    period <- as.factor(period)
+    product <- as.factor(product)
+    attributes(product) <- NULL # matching is faster on factor codes
+
     if (length(period) != length(product)) {
       stop("'period' and 'product' must be the same length")
     }
-    period <- as.factor(period)
     # factors with no levels throws an error below
     if (nlevels(period) == 0L) {
       return(rep.int(NA_integer_, length(period)))
     }
-    product <- as.factor(product)
-    attributes(product) <- NULL # matching is faster on factor codes
+
     product <- split(product, period)
     if (duplicate_products(product)) {
       warning("there are duplicated period-product pairs")

R/weights.R

@@ -173,6 +173,9 @@ transmute_weights <- function(r, s) {
       if (is.null(w)) {
         w <- rep.int(1, length(x))
       }
+      if (length(x) != length(w)) {
+        stop("'x' and 'w' must be the same length")
+      }
       w[is.na(x)] <- NA_real_
       w
     } else {
@@ -345,6 +348,9 @@ factor_weights <- function(r) {
   }
 
   function(x, w = NULL) {
+    if (!is.null(w) && length(x) != length(w)) {
+      stop("'x' and 'w' must be the same length")
+    }
     if (r == 0) {
       if (is.null(w)) {
         w <- rep.int(1, length(x))

tests/testthat/test-weights.R

@@ -17,6 +17,9 @@ test_that("weights transmute correctly", {
     grouped(transmute_weights(1, 2))(x, w, group = f),
     unsplit(Map(transmute_weights(1, 2), split(x, f), split(w, f)), f)
   )
+
+  expect_error(transmute_weights(1, 1)(1:5, 1:4))
+  expect_error(transmute_weights(1, 2)(1:5, 1:4))
 })
 
 test_that("contributions work correctly", {
@@ -39,6 +42,9 @@ test_that("weights factor correctly", {
   expect_equal(factor_weights(0)(x, w), w)
   expect_equal(update_weights(xna, w), xna * w)
   expect_equal(grouped(update_weights)(x, w, group = f), x * w)
+
+  expect_error(factor_weights(2)(1:5, 1:4))
+  expect_error(factor_weights(0)(1:5, 1:4))
 })
 
 test_that("weights scale correctly", {