From 4b9efd690666bf3b0badcea121fee721c9240d7a Mon Sep 17 00:00:00 2001
From: Steve Martin <marberts@protonmail.com>
Date: Wed, 13 Mar 2024 22:48:31 -0400
Subject: [PATCH] Fixed a bug in transmuate_weights() that could change the
 length of weights

---
 DESCRIPTION                   | 2 +-
 NEWS.md                       | 3 +++
 R/geks.R                      | 9 +++++----
 R/offset_prices.R             | 8 +++++---
 R/weights.R                   | 6 ++++++
 tests/testthat/test-weights.R | 6 ++++++
 6 files changed, 26 insertions(+), 8 deletions(-)

diff --git a/DESCRIPTION b/DESCRIPTION
index 8a2da4d..9854303 100644
--- a/DESCRIPTION
+++ b/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 = "marberts@protonmail.com",
diff --git a/NEWS.md b/NEWS.md
index 996cf56..f49ed2d 100644
--- a/NEWS.md
+++ b/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.
diff --git a/R/geks.R b/R/geks.R
index 0338f65..edeaed8 100644
--- a/R/geks.R
+++ b/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")
diff --git a/R/offset_prices.R b/R/offset_prices.R
index de7dead..f27195d 100644
--- a/R/offset_prices.R
+++ b/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")
diff --git a/R/weights.R b/R/weights.R
index 67b7da6..c67c97a 100644
--- a/R/weights.R
+++ b/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))
diff --git a/tests/testthat/test-weights.R b/tests/testthat/test-weights.R
index 7d95438..67266c0 100644
--- a/tests/testthat/test-weights.R
+++ b/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", {