transmute_weights() gains argument m

DESCRIPTION

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

R/contributions.R

@@ -44,11 +44,13 @@
 #' @inheritParams nested_mean
 #' @param w,w1,w2 A strictly positive numeric vector of weights, the same length
 #' as `x`. The default is to equally weight each element of `x`.
+#' @param m The value of the generalized mean of `x` with weights `w`. The
+#' default computes this when the function is called.
 #'
 #' @returns
 #' `contributions()` returns a function:
 #'
-#' \preformatted{function(x, w = NULL){...}}
+#' \preformatted{function(x, w = NULL, m = NULL){...}}
 #'
 #' This computes the additive contribution for each element of `x` in an
 #' index based on the generalized mean of order `r` with weights `w`.
@@ -247,8 +249,8 @@
 contributions <- function(r) {
   arithmetic_weights <- transmute_weights(r, 1)
 
-  function(x, w = NULL) {
-    (x - 1) * arithmetic_weights(x, w)
+  function(x, w = NULL, m = NULL) {
+    (x - 1) * arithmetic_weights(x, w, m)
   }
 }
 

R/weights.R

@@ -38,6 +38,10 @@ extended_mean_ <- function(r, s) {
 #' vector of weights `v(x, w)` such that
 #'
 #' \preformatted{generalized_mean(r)(x, w) == generalized_mean(s)(x, v(x, w))}
+#' 
+#' The value of the generalized mean can be supplied to help speed up
+#' transmuting the weights if known; otherwise, it is calculated when the
+#' functions is called.
 #'
 #' `nested_transmute(r1, r2, t, s)` and `nested_transmute2(r1, r2, t, s)` do
 #' the same for nested generalized means, so that
@@ -67,7 +71,7 @@ extended_mean_ <- function(r, s) {
 #' @returns
 #' `transmute_weights()` returns a function:
 #'
-#' \preformatted{function(x, w = NULL){...}}
+#' \preformatted{function(x, w = NULL, m = NULL){...}}
 #'
 #' `nested_transmute()` and `nested_transmute2()` similarly return a
 #' function:
@@ -82,7 +86,7 @@ extended_mean_ <- function(r, s) {
 #' `transmute_weights()`.
 #'
 #' [contributions()] for calculating additive percent-change
-#' contributions.
+#' contributions (the main use of transmuting weights).
 #'
 #' [grouped()] to make these functions operate on grouped data.
 #'
@@ -191,18 +195,24 @@ transmute_weights <- function(r, s) {
   gen_mean <- generalized_mean(r)
   ext_mean <- extended_mean_(r, s)
 
-  function(x, w = NULL) {
+  function(x, w = NULL, m = NULL) {
     if (r == s) {
       if (is.null(w)) {
         w <- rep.int(1, length(x))
-      }
-      if (length(x) != length(w)) {
+      } else if (length(x) != length(w)) {
         stop("'x' and 'w' must be the same length")
       }
       w[is.na(x)] <- NA_real_
       scale_weights(w)
     } else {
-      m <- gen_mean(x, w, na.rm = TRUE)
+      if (is.null(m)) {
+        m <- gen_mean(x, w, na.rm = TRUE)
+      } else {
+        m <- as.numeric(m)
+        if (length(m) != 1L) {
+          stop("'m' must be a length 1 numeric")
+        }
+      }
       if (is.null(w)) {
         v <- ext_mean(x, m)
         attributes(v) <- NULL
@@ -280,12 +290,12 @@ nested_transmute2 <- function(r1, r2, s, t = c(1, 1)) {
     m <- c(mean1(x, w1, na.rm = TRUE), mean2(x, w2, na.rm = TRUE))
     v <- s_weights(m, t)
     if (is.na(v[1L]) && !is.na(v[2L])) {
-      s_weights2(x, w2)
+      s_weights2(x, w2, m[2L])
     } else if (!is.na(v[1L]) && is.na(v[2L])) {
-      s_weights1(x, w1)
+      s_weights1(x, w1, m[1L])
     } else {
-      u1 <- s_weights1(x, w1)
-      u2 <- s_weights2(x, w2)
+      u1 <- s_weights1(x, w1, m[1L])
+      u2 <- s_weights2(x, w2, m[2L])
       # The calculation is wrong if NAs in w1 or w2 propagate.
       if (anyNA(w1)) {
         u1[is.na(u1) & !is.na(u2)] <- 0

tests/testthat/test-weights.R

@@ -13,6 +13,7 @@ test_that("weights transmute correctly", {
   )
   expect_equal(transmute_weights(2, 1)(c(1, NA)), c(1, NA))
   expect_equal(transmute_weights(-1, 1)(x, w), scale_weights(w / x))
+  expect_equal(transmute_weights(1, -1)(x, w), scale_weights(w * x))
   expect_equal(
     transmute_weights(7, -3)(x, transmute_weights(-3, 7)(x, w)),
     scale_weights(w)
@@ -38,6 +39,8 @@ test_that("contributions work correctly", {
     as.numeric(tapply(grouped(geometric_contributions)(x, group = f), f, sum)),
     as.numeric(tapply(x, f, geometric_mean) - 1)
   )
+  expect_equal(harmonic_contributions(1:4, m = NA), rep(NA_real_, 4))
+  expect_error(geometric_contributions(1:4, m = 1:2))
 })
 
 test_that("weights factor correctly", {