splice_index() now does regular splicing

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 = "[email protected]",

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)

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)
 

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
 }

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))
-})
+})