From f271eecaef6c52899ca2b18bc0260f5902a8c3c5 Mon Sep 17 00:00:00 2001 From: Steve Martin Date: Tue, 26 Mar 2024 22:32:00 -0400 Subject: [PATCH] splice_index() now does regular splicing --- DESCRIPTION | 2 +- R/geks.R | 2 +- R/price_indexes.R | 4 ++-- R/splice.R | 40 ++++++++++++++++++++++++++++-------- man/geks.Rd | 4 ++-- man/index_weights.Rd | 4 ++-- man/price_indexes.Rd | 4 ++-- man/splice_index.Rd | 18 +++++++++++++--- tests/testthat/test-splice.R | 25 +++++++++++++++++----- 9 files changed, 76 insertions(+), 27 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 4cd1a66..d60cf18 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: gpindex Title: Generalized Price and Quantity Indexes -Version: 0.6.0.9014 +Version: 0.6.0.9015 Authors@R: c( person("Steve", "Martin", role = c("aut", "cre", "cph"), email = "marberts@protonmail.com", diff --git a/R/geks.R b/R/geks.R index 641a4ab..0fd0a3e 100644 --- a/R/geks.R +++ b/R/geks.R @@ -149,7 +149,7 @@ geks_matrix <- function(index, p, q, product, n, nper, window, na.rm) { #' jevons_geks <- geks(\(p1, p0, ..., na.rm) jevons_index(p1, p0, na.rm)) #' jevons_geks(price, quantity, period, product) #' -#' @family price-indexes +#' @family price index functions #' @export geks <- function(f, r = 0) { f <- match.fun(f) diff --git a/R/price_indexes.R b/R/price_indexes.R index 72a8450..bd678cb 100644 --- a/R/price_indexes.R +++ b/R/price_indexes.R @@ -228,7 +228,7 @@ pythagorean_index <- function(r) { #' #' all.equal(index_weights("Young")(pb, qb), pb * qb) #' -#' @family price-indexes +#' @family price index functions #' @export index_weights <- function( type = c( @@ -599,7 +599,7 @@ index_weights <- function( #' all.equal(arithmetic_index("Drobisch")(p1a, p0a, q1a, q0a), Ia) #' all.equal(arithmetic_index("Drobisch")(p1b, p0b, q1b, q0b), Ib) #' -#' @family price-indexes +#' @family price index functions #' @export arithmetic_index <- pythagorean_index(1) diff --git a/R/splice.R b/R/splice.R index 111bda8..5065f0e 100644 --- a/R/splice.R +++ b/R/splice.R @@ -12,10 +12,21 @@ #' @param initial A numeric vector giving an initial period-over-period index #' series onto which the elements of `x` are spliced. The default uses the #' first element of `x`. +#' @param published Should the splice be done against the published series? The +#' default splices using the recalculated index series. #' #' @returns #' A numeric vector giving the spliced (fixed-base) index series. #' +#' @references +#' Chessa, A. G. (2019). +#' *A Comparison of Index Extension Methods for Multilateral Methods.* Paper +#' presented at the 16th Meeting of the Ottawa Group on Price Indices, +#' 8-10 May 2019, Rio de Janeiro, Brazil. +#' +#' Krsinich, F. (2016). The FEWS index: Fixed effects with a window splice. +#' *Journal of Official Statistics*, 32(2), 375-404. +#' #' @examples #' # Make an index series over a rolling window #' x <- list(c(1.1, 0.9, 1.2), c(0.8, 1.3, 1.4), c(1.3, 1.3, 0.8)) @@ -32,9 +43,9 @@ #' #' splice_index(x, 1) #' -#' @family price-indexes +#' @family price index functions #' @export -splice_index <- function(x, periods = NULL, initial = NULL) { +splice_index <- function(x, periods = NULL, initial = NULL, published = FALSE) { x <- as.list(x) if (do.call(different_lengths, x)) { stop("all elements of 'x' must be the same length") @@ -49,22 +60,33 @@ splice_index <- function(x, periods = NULL, initial = NULL) { return(initial) } + n <- length(x[[1L]]) offset <- length(initial) - if (offset < length(x[[1L]])) { + if (offset < n) { stop("'initial' must be at least as long as each element of 'x'") } if (is.null(periods)) { - periods <- seq_along(x[[1L]]) + periods <- seq_len(n) } - x <- lapply(x, \(z) rev(cumprod(rev(z)))) + y <- lapply(x, \(z) rev(cumprod(rev(z)))[periods]) res <- numeric(offset + length(x)) res[seq_along(initial)] <- initial - for (i in seq_along(x)) { - window <- x[[i]] - iw <- seq.int(to = i + offset - 1L, length.out = length(window)) - res[i + offset] <- geometric_mean(window[periods] * res[iw[periods]]) + + iw <- seq.int(to = offset - 1L, length.out = n)[periods] + if (published) { + for (i in seq_along(x)) { + res[i + offset] <- geometric_mean(y[[i]] * res[iw + i]) + } + } else { + links <- c(list(rep.int(1, length(periods))), + lapply(x[-length(x)], `[`, periods)) + links <- Reduce(`*`, links, accumulate = TRUE) + base <- res[iw + 1L] + for (i in seq_along(x)) { + res[i + offset] <- geometric_mean(y[[i]] * links[[i]] * base) + } } res } \ No newline at end of file diff --git a/man/geks.Rd b/man/geks.Rd index 6339584..58ce6bf 100644 --- a/man/geks.Rd +++ b/man/geks.Rd @@ -154,9 +154,9 @@ aggregation and the construction of price indexes. \code{GEKSIndex()} in the \pkg{indexNumR} package for an implementation of the GEKS index with more options. -Other price-indexes: +Other price index functions: \code{\link{index_weights}()}, \code{\link{price_indexes}}, \code{\link{splice_index}()} } -\concept{price-indexes} +\concept{price index functions} diff --git a/man/index_weights.Rd b/man/index_weights.Rd index a604040..a5cd9ac 100644 --- a/man/index_weights.Rd +++ b/man/index_weights.Rd @@ -178,9 +178,9 @@ all.equal(index_weights("Young")(pb, qb), pb * qb) \code{\link[=quantity_index]{quantity_index()}} to remap the arguments in these functions for a quantity index. -Other price-indexes: +Other price index functions: \code{\link{geks}()}, \code{\link{price_indexes}}, \code{\link{splice_index}()} } -\concept{price-indexes} +\concept{price index functions} diff --git a/man/price_indexes.Rd b/man/price_indexes.Rd index 27df0be..4fc7449 100644 --- a/man/price_indexes.Rd +++ b/man/price_indexes.Rd @@ -370,9 +370,9 @@ than two time periods. The \pkg{piar} package has more functionality working with price indexes for multiple groups of products over many time periods. -Other price-indexes: +Other price index functions: \code{\link{geks}()}, \code{\link{index_weights}()}, \code{\link{splice_index}()} } -\concept{price-indexes} +\concept{price index functions} diff --git a/man/splice_index.Rd b/man/splice_index.Rd index cd59087..5331790 100644 --- a/man/splice_index.Rd +++ b/man/splice_index.Rd @@ -4,7 +4,7 @@ \alias{splice_index} \title{Splice an index series} \usage{ -splice_index(x, periods = NULL, initial = NULL) +splice_index(x, periods = NULL, initial = NULL, published = FALSE) } \arguments{ \item{x}{A list of equal-length numeric vectors giving the period-over-period @@ -17,6 +17,9 @@ point in the window.} \item{initial}{A numeric vector giving an initial period-over-period index series onto which the elements of \code{x} are spliced. The default uses the first element of \code{x}.} + +\item{published}{Should the splice be done against the published series? The +default splices using the recalculated index series.} } \value{ A numeric vector giving the spliced (fixed-base) index series. @@ -42,11 +45,20 @@ splice_index(x, 3) splice_index(x, 1) +} +\references{ +Chessa, A. G. (2019). +\emph{A Comparison of Index Extension Methods for Multilateral Methods.} Paper +presented at the 16th Meeting of the Ottawa Group on Price Indices, +8-10 May 2019, Rio de Janeiro, Brazil. + +Krsinich, F. (2016). The FEWS index: Fixed effects with a window splice. +\emph{Journal of Official Statistics}, 32(2), 375-404. } \seealso{ -Other price-indexes: +Other price index functions: \code{\link{geks}()}, \code{\link{index_weights}()}, \code{\link{price_indexes}} } -\concept{price-indexes} +\concept{price index functions} diff --git a/tests/testthat/test-splice.R b/tests/testthat/test-splice.R index 9e419be..0574264 100644 --- a/tests/testthat/test-splice.R +++ b/tests/testthat/test-splice.R @@ -3,11 +3,18 @@ x <- list(1:3, 3:5, 5:7) test_that("key splice methods works", { # Movement splice. expect_equal(splice_index(x, 3), c(1, 2, 6, 30, 210)) + expect_equal(splice_index(x, 3, published = TRUE), c(1, 2, 6, 30, 210)) # Window splice. - expect_equal(splice_index(x, 1), c(1, 2, 6, 60, 420)) + expect_equal(splice_index(x, 1), c(1, 2, 6, 60, 630)) + expect_equal(splice_index(x, 1, published = TRUE), c(1, 2, 6, 60, 420)) # Mean splice. expect_equal( splice_index(x), + c(1, 2, 6, geometric_mean(c(60, 40, 30)), + geometric_mean(rev(cumprod(rev(5:7))) * 3:5 * c(1, 2, 6))) + ) + expect_equal( + splice_index(x, published = TRUE), c(1, 2, 6, geometric_mean(c(60, 40, 30)), geometric_mean(c(420, 252, 7 * geometric_mean(c(60, 40, 30))))) ) @@ -20,6 +27,10 @@ test_that("result length is correct", { ) expect_equal( splice_index(x[-1], 1, c(1, 1, 1, 1, 2, 3)), + c(1, 1, 1, 1, 2, 6, 60, 630) + ) + expect_equal( + splice_index(x[-1], 1, c(1, 1, 1, 1, 2, 3), published = TRUE), c(1, 1, 1, 1, 2, 6, 60, 420) ) }) @@ -30,14 +41,18 @@ test_that("splicing is invariant", { expect_equal(splice_index(x, 3), splice_index(x[-(1:2)], 3, c(1, 2, 3, 5))) # Window expect_equal(splice_index(x, 1), splice_index(x[-1], 1, x[[1]])) - expect_equal(splice_index(x, 1), splice_index(x[-(1:2)], 1, c(1, 2, 3, 10))) + expect_equal( + splice_index(x, 1, published = TRUE), + splice_index(x[-(1:2)], 1, c(1, 2, 3, 10), published = TRUE) + ) # Mean expect_equal(splice_index(x), splice_index(x[-1], initial = x[[1]])) expect_equal( - splice_index(x), + splice_index(x, published = TRUE), splice_index( x[-(1:2)], - initial = c(1, 2, 3, geometric_mean(c(10, 40 / 6, 5))) + initial = c(1, 2, 3, geometric_mean(c(10, 40 / 6, 5))), + published = TRUE ) ) }) @@ -59,4 +74,4 @@ test_that("corner cases work", { test_that("errors work", { expect_error(splice_index(list(1:3, 1:2))) expect_error(splice_index(list(1:3, 1:3), initial = 1:2)) -}) \ No newline at end of file +})