diff --git a/DESCRIPTION b/DESCRIPTION index bbeb972..35aa550 100644 --- a/DESCRIPTION +++ b/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 = "marberts@protonmail.com", diff --git a/NEWS.md b/NEWS.md index 56d5542..707ebb2 100644 --- a/NEWS.md +++ b/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. diff --git a/R/helpers.R b/R/helpers.R index 63172be..d2a4fa2 100644 --- a/R/helpers.R +++ b/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, "'")))) + } +} \ No newline at end of file diff --git a/R/means.R b/R/means.R index 3c170a8..73e7a87 100644 --- a/R/means.R +++ b/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) diff --git a/R/price_indexes.R b/R/price_indexes.R index 41ae9e2..0aad9cf 100644 --- a/R/price_indexes.R +++ b/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,6 +744,7 @@ 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) } @@ -701,6 +752,7 @@ cswd_index <- function(p1, p0, na.rm = FALSE) { #' @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) diff --git a/R/weights.R b/R/weights.R index 3b9dc7d..8a9f446 100644 --- a/R/weights.R +++ b/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) diff --git a/cran-comments.md b/cran-comments.md index 0c0ff1e..98c0317 100644 --- a/cran-comments.md +++ b/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 diff --git a/tests/Examples/gpindex-Ex.Rout.save b/tests/Examples/gpindex-Ex.Rout.save index d8ad577..1da8310 100644 --- a/tests/Examples/gpindex-Ex.Rout.save +++ b/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 ---- > diff --git a/tests/testthat/test-price-indexes.R b/tests/testthat/test-price-indexes.R index 3bcc5bb..d583678 100644 --- a/tests/testthat/test-price-indexes.R +++ b/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)) +})