Version 0.6.2

DESCRIPTION

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

NEWS.md

@@ -4,6 +4,8 @@
 
 - Fixed a bug with `transmute_weights()` where the weights could be negative.
 
+- Price-index functions have better argument checking.
+
 ## Version 0.6.1
 
 - Updated maintainer email.

R/helpers.R

@@ -22,3 +22,12 @@ different_lengths <- function(...) {
 duplicate_products <- function(x) {
   any(vapply(x, anyDuplicated, numeric(1L), incomparables = NA) > 0)
 }
+
+#' Check price and quantity arguments
+#' @noRd
+check_pqs <- function(...) {
+  vars <- as.character(match.call()[-1L])
+  if (different_lengths(...)) {
+    stop(gettextf("%s must be the same length", toString(sQuote(vars, "'"))))
+  }
+}

R/means.R

@@ -445,7 +445,7 @@ extended_mean <- function(r, s) {
     } else if (r == s) {
       res <- exp((a^r * log(a) - b^r * log(b)) / (a^r - b^r) - 1 / r)
     } else {
-      res <- ((a^s - b^s) / (a^r - b^r) * r / s)^(1 / (s - r))
+      res <- ((a^s - b^s) / (a^r - b^r) * (r / s))^(1 / (s - r))
     }
     # Set output to a when a == b.
     i <- which(abs(a - b) <= tol)
@@ -606,6 +606,9 @@ lehmer_mean <- function(r) {
   function(x, w = NULL, na.rm = FALSE) {
     v <- x^(r - 1)
     if (!is.null(w)) {
+      if (length(x) != length(w)) {
+        stop("'x' and 'w' must be the same length")
+      }
       v <- v * w
     }
     arithmetic_mean(x, v, na.rm = na.rm)

R/price_indexes.R

@@ -27,13 +27,16 @@ pythagorean_index <- function(r) {
       Dutot = ,
       Jevons = ,
       Coggeshall = function(p1, p0, na.rm = FALSE) {
+        check_pqs(p1, p0)
         gen_mean(p1 / p0, weights(p0), na.rm)
       },
       Laspeyres = function(p1, p0, q0, na.rm = FALSE) {
+        check_pqs(p1, p0, q0)
         gen_mean(p1 / p0, weights(p0, q0), na.rm)
       },
       Paasche = ,
       Palgrave = function(p1, p0, q1, na.rm = FALSE) {
+        check_pqs(p1, p0, q1)
         gen_mean(p1 / p0, weights(p1, q1), na.rm)
       },
       Drobisch = ,
@@ -44,24 +47,30 @@ pythagorean_index <- function(r) {
       Tornqvist = ,
       Theil = ,
       Rao = function(p1, p0, q1, q0, na.rm = FALSE) {
+        check_pqs(p1, p0, q1, q0)
         gen_mean(p1 / p0, weights(p1, p0, q1, q0), na.rm)
       },
       Vartia1 = ,
       MontgomeryVartia = function(p1, p0, q1, q0, na.rm = FALSE) {
+        check_pqs(p1, p0, q1, q0)
         exp(sum(log(p1 / p0) * weights(p1, p0, q1, q0), na.rm = na.rm))
       },
       Walsh1 = ,
       MarshallEdgeworth = ,
       GearyKhamis = function(p1, p0, q1, q0, na.rm = FALSE) {
+        check_pqs(p1, p0, q1, q0)
         gen_mean(p1 / p0, weights(p0, q1, q0), na.rm)
       },
       Lowe = function(p1, p0, qb, na.rm = FALSE) {
+        check_pqs(p1, p0, qb)
         gen_mean(p1 / p0, weights(p0, qb), na.rm)
       },
       Young = function(p1, p0, pb, qb, na.rm = FALSE) {
+        check_pqs(p1, p0, pb, qb)
         gen_mean(p1 / p0, weights(pb, qb), na.rm)
       },
       HybridCSWD = function(p1, p0, na.rm = FALSE) {
+        check_pqs(p1, p0)
         gen_mean(p1 / p0, weights(p1, p0), na.rm)
       }
     )
@@ -271,52 +280,91 @@ index_weights <- function(
       p0
     },
     Dutot = function(p0) p0,
-    Young = function(pb, qb) pb * qb,
-    Lowe = function(p0, qb) p0 * qb,
+    Young = function(pb, qb) {
+      check_pqs(pb, qb)
+      pb * qb
+    },
+    Lowe = function(p0, qb) {
+      check_pqs(p0, qb)
+      p0 * qb
+    },
     LloydMoulton = ,
-    Laspeyres = function(p0, q0) p0 * q0,
-    HybridLaspeyres = function(p1, q0) p1 * q0,
+    Laspeyres = function(p0, q0) {
+      check_pqs(p0, q0)
+      p0 * q0
+    },
+    HybridLaspeyres = function(p1, q0) {
+      check_pqs(p1, q0)
+      p1 * q0
+    },
     Palgrave = ,
-    Paasche = function(p1, q1) p1 * q1,
-    HybridPaasche = function(p0, q1) p0 * q1,
+    Paasche = function(p1, q1) {
+      check_pqs(p1, q1)
+      p1 * q1
+    },
+    HybridPaasche = function(p0, q1) {
+      check_pqs(p0, q1)
+      p0 * q1
+    },
     Drobisch = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
       v0 <- scale_weights(p0 * q0)
       v01 <- scale_weights(p0 * q1)
       (v0 + v01) / 2
     },
     Unnamed = ,
     Tornqvist = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
       v0 <- scale_weights(p0 * q0)
       v1 <- scale_weights(p1 * q1)
       (v0 + v1) / 2
     },
-    Walsh1 = function(p0, q1, q0) p0 * sqrt(q0 * q1),
-    Walsh2 = function(p1, p0, q1, q0) sqrt(p0 * q0 * p1 * q1),
-    MarshallEdgeworth = function(p0, q1, q0) p0 * (q0 + q1),
-    GearyKhamis = function(p0, q1, q0) p0 / (1 / q0 + 1 / q1),
+    Walsh1 = function(p0, q1, q0) {
+      check_pqs(p0, q1, q0)
+      p0 * sqrt(q0 * q1)
+    },
+    Walsh2 = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
+      sqrt(p0 * q0 * p1 * q1)
+    },
+    MarshallEdgeworth = function(p0, q1, q0) {
+      check_pqs(p0, q1, q0)
+      p0 * (q0 + q1)
+    },
+    GearyKhamis = function(p0, q1, q0) {
+      check_pqs(p0, q1, q0)
+      p0 / (1 / q0 + 1 / q1)
+    },
     Vartia1 = ,
     MontgomeryVartia = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
       v0 <- p0 * q0
       v1 <- p1 * q1
       logmean(v0, v1) / logmean(sum(v0, na.rm = TRUE), sum(v1, na.rm = TRUE))
     },
     Vartia2 = ,
     SatoVartia = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
       v0 <- scale_weights(p0 * q0)
       v1 <- scale_weights(p1 * q1)
       logmean(v0, v1)
     },
     Theil = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
       w0 <- scale_weights(p0 * q0)
       w1 <- scale_weights(p1 * q1)
       ((w0 + w1) / 2 * w0 * w1)^(1 / 3)
     },
     Rao = function(p1, p0, q1, q0) {
+      check_pqs(p1, p0, q1, q0)
       w0 <- scale_weights(p0 * q0)
       w1 <- scale_weights(p1 * q1)
       w0 * w1 / (w0 + w1)
     },
-    HybridCSWD = function(p1, p0) sqrt(p0 / p1)
+    HybridCSWD = function(p1, p0) {
+      check_pqs(p1, p0)
+      sqrt(p0 / p1)
+    }
   )
 }
 
@@ -665,6 +713,7 @@ nested_index <- function(r, s) {
   nest_mean <- nested_mean(r, s)
 
   function(p1, p0, q1, q0, na.rm = FALSE) {
+    check_pqs(p1, p0, q1, q0)
     nest_mean(p1 / p0, p0 * q0, p1 * q1, na.rm)
   }
 }
@@ -686,6 +735,7 @@ lm_index <- function(elasticity) {
   gen_mean <- generalized_mean(1 - elasticity)
 
   function(p1, p0, q0, na.rm = FALSE) {
+    check_pqs(p1, p0, q0)
     gen_mean(p1 / p0, p0 * q0, na.rm)
   }
 }
@@ -694,13 +744,15 @@ lm_index <- function(elasticity) {
 #' @rdname price_indexes
 #' @export
 cswd_index <- function(p1, p0, na.rm = FALSE) {
+  check_pqs(p1, p0)
   fisher_mean(p1 / p0, na.rm = na.rm)
 }
 
 #' Caruthers Sellwood Ward Dalen Balk index
 #' @rdname price_indexes
 #' @export
 cswdb_index <- function(p1, p0, q1, q0, na.rm = FALSE) {
+  check_pqs(p1, p0, q1, q0)
   sqrt(arithmetic_mean(p1 / p0, na.rm = na.rm) /
     arithmetic_mean(q1 / q0, na.rm = na.rm) *
     arithmetic_mean(p1 * q1 / (p0 * q0), na.rm = na.rm))
@@ -710,6 +762,7 @@ cswdb_index <- function(p1, p0, q1, q0, na.rm = FALSE) {
 #' @rdname price_indexes
 #' @export
 bw_index <- function(p1, p0, na.rm = FALSE) {
+  check_pqs(p1, p0)
   rel <- sqrt(p1 / p0)
   arithmetic_mean(rel, na.rm = na.rm) * harmonic_mean(rel, na.rm = na.rm)
 }
@@ -728,6 +781,7 @@ stuvel_index <- function(a, b) {
   }
 
   function(p1, p0, q1, q0, na.rm = FALSE) {
+    check_pqs(p1, p0, q1, q0)
     v0 <- p0 * q0
     v1 <- p1 * q1
     pl <- arithmetic_mean(p1 / p0, v0, na.rm)
@@ -745,6 +799,7 @@ agmean_index <- function(r) {
   function(elasticity) {
     nest_mean <- nested_mean(r, c(0, 1), c(elasticity, 1 - elasticity))
     function(p1, p0, q0, na.rm = FALSE) {
+      check_pqs(p1, p0, q0)
       v0 <- p0 * q0
       nest_mean(p1 / p0, v0, v0, na.rm)
     }
@@ -765,6 +820,7 @@ geometric_agmean_index <- agmean_index(0)
 #' @rdname price_indexes
 #' @export
 lehr_index <- function(p1, p0, q1, q0, na.rm = FALSE) {
+  check_pqs(p1, p0, q1, q0)
   v1 <- p1 * q1
   v0 <- p0 * q0
   v <- (v1 + v0) / (q1 + q0)

R/weights.R

@@ -189,7 +189,7 @@ transmute_weights <- function(r, s) {
   r <- as.numeric(r)
   s <- as.numeric(s)
   gen_mean <- generalized_mean(r)
-  ext_mean <- extended_mean_(r, s)
+  pow_ext_mean <- extended_mean_(r, s)
 
   function(x, w = NULL) {
     if (r == s) {
@@ -204,10 +204,10 @@ transmute_weights <- function(r, s) {
     } else {
       m <- gen_mean(x, w, na.rm = TRUE)
       if (is.null(w)) {
-        v <- ext_mean(x, m)
+        v <- pow_ext_mean(x, m)
         attributes(v) <- NULL
       } else {
-        v <- w * ext_mean(x, m)
+        v <- w * pow_ext_mean(x, m)
         attributes(v) <- attributes(w)
       }
       scale_weights(v)

cran-comments.md

@@ -1,7 +1,8 @@
 ## Test environments
 
-- local Ubuntu 20.04 installation, R 4.3.3
+- local Ubuntu 20.04 installation, R 4.4.1
 - win-builder (devel, release, oldrelease)
+- mac-builder (release)
 
 ## R CMD check results
 

tests/Examples/gpindex-Ex.Rout.save

@@ -1514,7 +1514,7 @@ t5   1.6720 1.0712    1.2477             0.9801 1.1850  1.2540  1.2678 0.9770
 +     x, nested_transmute2(0, c(1, -1), 2)(x, w1, w2)
 +   )
 + )
-[1] "Mean relative difference: 17.81836"
+[1] "Mean relative difference: 0.0015427"
 > 
 > #---- Monotonicity ----
 > 

tests/testthat/test-price-indexes.R

@@ -137,3 +137,8 @@ test_that("quantity indexes work", {
 test_that("vartia1 weights are less than 1", {
   expect_true(sum(index_weights("Vartia1")(p1, p0, q0, q1)) < 1)
 })
+
+test_that("arguments with different lengths give an error", {
+  expect_error(jevons_index(1:4, 1:5))
+  expect_error(index_weights("Vartia1")(1, 2, 3, 1:4))
+})