rebase() now accepts a time to use as the base period

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: piar
 Title: Price Index Aggregation
-Version: 0.7.0.9015
+Version: 0.7.0.9016
 Authors@R: c(
     person("Steve", "Martin", role = c("aut", "cre", "cph"),
            email = "[email protected]",

NEWS.md

@@ -30,6 +30,10 @@ drop them.
 - Added `window(index)` to extract a window of price indexes and
 `window(index) <- value` to replace them.
 
+- The base period for `rebase()` can now be a time period specifying a new base
+period. This makes it easier to rebase with pipes; e.g.,
+`index |> mean() |> rebase("202001")`.
+
 # Version 0.7.0
 
 ## Significant changes

R/chain.R

@@ -26,15 +26,17 @@
 #' period-over-period index does nothing.
 #'
 #' Percent-change contributions are removed when chaining/unchaining/rebasing
-#' an index, as it's not usually possible to update them correctly.
+#' an index as it's not usually possible to update them correctly.
 #'
 #' @param x A price index, as made by, e.g., [elemental_index()].
 #' @param link A numeric vector, or something that can coerced into one, of
 #' link values for each level in `x`. The default is a vector of 1s so
 #' that no linking is done.
 #' @param base A numeric vector, or something that can coerced into one, of
 #' base-period index values for each level in `x`. The default is a vector
-#' of 1s so that the base period remains the same.
+#' of 1s so that the base period remains the same. If `base` is a length-one
+#' character vector giving a time period of `x` then the index values for this
+#' time period are used as the base-period values.
 #' @param ... Further arguments passed to or used by methods.
 #'
 #' @returns
@@ -117,9 +119,13 @@ unchain.chainable_piar_index <- function(x, ...) {
 #' @rdname chain
 #' @export
 unchain.direct_piar_index <- function(x, base = rep(1, nlevels(x)), ...) {
-  base <- as.numeric(base)
-  if (length(base) != length(x$levels)) {
-    stop("'base' must have a value for each level of 'x'")
+  if (length(base) == 1L && is.character(base)) {
+    base <- x$index[[match(match.arg(base, x$time), x$time)]] / x$index[[1L]]
+  } else {
+    base <- as.numeric(base)
+    if (length(base) != length(x$levels)) {
+      stop("'base' must have a value for each level of 'x'")
+    }
   }
   x$index[-1L] <- Map(`/`, x$index[-1L], x$index[-length(x$index)])
   x$index[[1L]] <- x$index[[1L]] * base
@@ -148,9 +154,13 @@ rebase.chainable_piar_index <- function(x, ...) {
 #' @rdname chain
 #' @export
 rebase.direct_piar_index <- function(x, base = rep(1, nlevels(x)), ...) {
-  base <- as.numeric(base)
-  if (length(base) != length(x$levels)) {
-    stop("'base' must have a value for each level of 'x'")
+  if (length(base) == 1L && is.character(base)) {
+    base <- x$index[[match(match.arg(base, x$time), x$time)]]
+  } else {
+    base <- as.numeric(base)
+    if (length(base) != length(x$levels)) {
+      stop("'base' must have a value for each level of 'x'")
+    }
   }
   x$index <- Map(`/`, x$index, list(base))
   # Contributions are difficult to rebase, so remove them.

tests/testthat/test-chain.R

@@ -83,3 +83,10 @@ test_that("link and base values are the right length", {
   expect_error(chain(epr1, link = 1))
   expect_error(rebase(chain(epr1), base = 1))
 })
+
+test_that("rebasing with a character vector works", {
+  index1_chain <- chain(index1)
+  index1_rebase <- rebase(index1_chain, index1_chain[, end(index1_chain)])
+  expect_equal(index1_rebase, rebase(index1_chain, end(index1_chain)))
+  expect_equal(index2, unchain(index1_rebase, end(index1_rebase)))
+})