Version 0.10.0

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: piar
 Title: Price Index Aggregation
-Version: 0.9.0.9006
+Version: 0.9.0.9007
 Authors@R: c(
     person("Steve", "Martin", role = c("aut", "cre", "cph"),
            email = "marberts@protonmail.com",
@@ -23,10 +23,11 @@ Imports:
     stats,
     utils,
     Matrix (>= 1.5-0)
-Suggests: 
+Suggests:
     data.tree,
-    knitr,
-    quarto,
+    litedown,
+    rsmatrix,
+    spelling,
     sps,
     tinytest,
     treemap
@@ -35,6 +36,7 @@ Encoding: UTF-8
 URL: https://marberts.github.io/piar/, https://github.com/marberts/piar
 BugReports: https://github.com/marberts/piar/issues
 LazyData: true
-VignetteBuilder: quarto
+VignetteBuilder: litedown
 Roxygen: list(markdown = TRUE)
 Config/roxygen2/version: 8.0.0
+Language: en-US

NAMESPACE

@@ -89,8 +89,6 @@ export(aggregation_structure)
 export(as_aggregation_structure)
 export(as_index)
 export(back_period)
-export(carry_backward)
-export(carry_forward)
 export(chain)
 export(combine_classifications)
 export(contrib)
@@ -119,7 +117,6 @@ export(set_contrib_from_index)
 export(set_levels)
 export(set_time)
 export(set_weights)
-export(shadow_price)
 export(splice_index)
 export(split_classification)
 export(transmute_weights)

NEWS.md

@@ -12,7 +12,7 @@ two separate packages. In particular:
 
     - Core mathematical machinery used to aggregate indexes and make product contributions.
 
-    - A new vignette outlining some theory that unlies how indexes are calculated.
+    - A new vignette outlining some theory that underlies how indexes are calculated.
 
 - The argument `r` in `elementary_index()`, `aggregate()`, `mean()`, `update()`,
 and `impute_prices()` is deprecated and will be removed in a future version.
@@ -31,6 +31,8 @@ contributions.
 - `impute_prices()` no longer matches missing products across consecutive time
 periods when passed a matrix.
 
+- `impute_prices()` no longer returns all `NA`s with no time periods.
+
 - Setting `include_ea = FALSE` in `aggregate(index)` no longer gives an error with
 a one-level aggregation structure.
 

R/aggregate.piar_index.R

@@ -49,9 +49,9 @@
 #'
 #' If two aggregation structures are given then the steps above are done for
 #' each aggregation structure, with the aggregation for `pias` done with a
-#' generalized mean of order `r` the aggregation for `pias2` done with a
-#' generalized mean of order `-r`. The resulting indexes are combined with a
-#' geometric mean to make a superlative quadratic mean of order `2*r` index.
+#' generalized mean of order `order` the aggregation for `pias2` done with a
+#' generalized mean of order `-order`. The resulting indexes are combined with a
+#' geometric mean to make a superlative quadratic mean of order `2*order` index.
 #' Percent-change contributions are combined using a generalized van IJzeren
 #' decomposition; see [`transmute_weights2()`] for details.
 #'

R/aggregation_structure-class.R

@@ -22,6 +22,9 @@ piar_aggregation_structure <- function(child, parent, levels, weights) {
 }
 
 #---- Validator ----
+# The first two validators are not extensively used and duplicate checking
+# already done by aggregation_structure(). They're here in case a validator
+# is needed in the future.
 validate_pias_levels <- function(x) {
   lev <- unlist(x$levels, use.names = FALSE)
   if (missing_names(lev)) {

R/aggregation_structure.R

@@ -124,7 +124,7 @@ aggregation_structure <- function(x, weights = NULL) {
   }
   upper <- x[-len] # nodes above eas
   lower <- x[-1L] # nodes below initial nodes
-  child <- parent <- vector("list", len)[-1L]
+  child <- parent <- vector("list", length(upper))
   # Produce a list for each level with all the parent and child nodes.
   for (i in seq_along(upper)) {
     child[[i]] <- lapply(

R/back_period.R

@@ -66,25 +66,28 @@ back_period <- function(
     x[c(rep.int(1L, offset), seq_len(length(x) - offset))]
   }
   offset <- as.integer(offset)
-  if (offset < 0L || offset > length(period)) {
-    stop("`offset` must be a positive integer less than the length of `period`")
-  }
   period <- as.factor(period)
-  product <- as.factor(product %||% gl(1, length(period)))
-  attributes(product) <- NULL # matching is faster on factor codes
+  if (!is.null(product)) {
+    product <- as.factor(product)
+    attributes(product) <- NULL # matching is faster on factor codes
+  } else {
+    product <- rep.int(1L, length(period))
+  }
 
   if (length(period) != length(product)) {
     stop("`period` and `product` must be the same length")
   }
-  # Factors with no levels throw an error below.
-  if (nlevels(period) == 0L) {
-    return(rep.int(NA_integer_, length(period)))
+  if (offset < 0L || offset > nlevels(period)) {
+    stop("`offset` must be a positive integer less than `nlevels(period)`")
   }
 
   product <- split(product, period)
   if (duplicate_products(product)) {
     warning("there are duplicated period-product pairs")
   }
+  if (offset == 0L) {
+    return(seq_along(period))
+  }
   m <- Map(match, product, f(product, offset), incomparables = NA)
   if (!match_first) {
     m[seq_len(offset)][] <- NA_integer_

R/combine_classifications.R

@@ -29,15 +29,15 @@
 combine_classifications <- function(..., sep = ".") {
   dots <- lapply(list(...), \(x) lapply(x, as.character))
   Reduce(
-    \(x, y) combine_classifications_(x, y, sep = sep),
+    \(x, y) .combine_classifications(x, y, sep = sep),
     dots,
     simplify = FALSE
   )
 }
 
 #' Combine classifications (internal)
 #' @noRd
-combine_classifications_ <- function(x, y, sep) {
+.combine_classifications <- function(x, y, sep) {
   lx <- lengths(x)
   if (length(lx) == 0L) {
     return(y)

R/contrib.R

@@ -56,8 +56,8 @@
 #' contrib2DF(index)
 #'
 #' # Calculate EA contributions for the chained index.
-#' arithmetic_contributions <- function(x, w, r = 1) {
-#'   (x - 1) * transmute_weights(x, w, r, to = 1)
+#' arithmetic_contributions <- function(x, w, order = 1) {
+#'   (x - 1) * transmute_weights(x, w, order, to = 1)
 #' }
 #'
 #' arithmetic_contributions(

R/elementary_index.R

@@ -14,7 +14,7 @@
 #' be unique within each elementary aggregate at each time period when making
 #' contributions and, if not, are
 #' passed to [make.unique()] with a warning. The default
-#' (\code{r = 0} and no weights) makes Jevons elementary indexes. See chapter 8
+#' (`order = 0` and no weights) makes Jevons elementary indexes. See chapter 8
 #' (pp. 175--190) of the CPI manual (2020) for more detail about making
 #' elementary indexes, or chapter 9 of the PPI manual (2004), and chapter 5 of
 #' Balk (2008).
@@ -161,7 +161,7 @@
 #'   prices,
 #'   rel ~ period + ea,
 #'   weights = unsplit(cswd_weights, interaction(period, ea)),
-#'   r = 1
+#'   order = 1
 #' )
 elementary_index <- function(x, ...) {
   if ("r" %in% ...names()) {
@@ -201,8 +201,11 @@ elementary_index.numeric <- function(
   r <- as.numeric(r)
   period <- as.factor(period %||% gl(1, length(x)))
   ea <- as.factor(ea %||% gl(1, length(x)))
+  if (!is.null(product)) {
+    product <- as.character(product)
+  }
 
-  if (different_length(x, period, ea, weights)) {
+  if (different_length(x, period, ea, weights, product)) {
     stop("input vectors must be the same length")
   }
   if (any(x <= 0, na.rm = TRUE)) {
@@ -214,7 +217,7 @@ elementary_index.numeric <- function(
 
   if (contrib) {
     if (!is.null(product)) {
-      names(x) <- as.character(product)
+      names(x) <- product
     }
     if (is.null(names(x))) {
       names(x) <- paste(ea, sequential_names(period, ea), sep = ".")

R/emean.R

@@ -78,12 +78,12 @@ emean <- function(
   # length of the other.
   if (length(x) > length(y)) {
     if (length(y) > 0 && length(x) %% length(y) != 0) {
-      warning("length of `y` is not a multiple of length of `x`")
+      warning("length of `x` is not a multiple of length of `y`")
       y <- rep_len(y, length(x))
     }
   } else if (length(x) < length(y)) {
     if (length(x) > 0 && length(y) %% length(x) != 0) {
-      warning("length of `x` is not a multiple of length of `y`")
+      warning("length of `y` is not a multiple of length of `x`")
       x <- rep_len(x, length(y))
     }
   }
@@ -104,7 +104,7 @@ emean <- function(
   } else {
     res <- ((x^s - y^s) / (x^r - y^r) * (r / s))^(1 / (s - r))
   }
-  # Set output to a when a == b.
+  # Set output to `x` when `x` == `y`.
   i <- which(abs(x - y) <= tol)
   res[i] <- x[(i - 1L) %% length(x) + 1L]
   res

R/geks_index.R

@@ -53,10 +53,12 @@
 #' subtle implications for a multilateral index.
 #'
 #' @seealso
+#' [`splice_index()`] to splice the rolling-window indexes together.
+#'
 #' `GEKSIndex()` in the \pkg{IndexNumR} package for an implementation of the
 #' GEKS index with more options.
 #'
-#' [`splice_index()`] to splice the rolling-window indexes together.
+#' The \pkg{rsmatrix} package for multilateral repeat-sales indexes.
 #'
 #' @references
 #' Balk, B. M. (2008). *Price and Quantity Index Numbers*.
@@ -125,8 +127,8 @@ geks_index <- function(
   }
 
   window <- as.integer(window)
-  if (length(window) > 1L || window < 2L) {
-    stop("`window` must be a integer greater than or equal to 2")
+  if (window < 2L) {
+    stop("`window` must be greater than or equal to 2")
   }
   if (window > nlevels(period)) {
     stop(
@@ -136,8 +138,8 @@ geks_index <- function(
   }
 
   n <- as.integer(n)
-  if (length(n) > 1L || n < 1L) {
-    stop("`n` must be an integer greater than or equal to 1")
+  if (n < 1L) {
+    stop("`n` must be greater than or equal to 1")
   }
   if (n > window - 1L) {
     stop("`n` must be less than or equal to `window` minus 1")

R/gmean.R

@@ -5,7 +5,7 @@
 #' The generalized mean is also called the power mean, Hölder mean, or \eqn{l_p}
 #' mean; see Bullen (2003, p. 175) for details.
 #'
-#' Both `x` and `weights` should be strictly positive
+#' Both `x` and `weights` are usually strictly positive
 #' (and finite), especially for the purpose of making a price index. This is not
 #' enforced, but the results may not make sense if the generalized mean is not
 #' defined. There are two exceptions to this.
@@ -15,7 +15,7 @@
 #' one element of `x` is `Inf`: the generalized mean is `Inf` whenever the
 #' weights are strictly positive and `order > 0`.
 #'
-#' 2. Some authors let the weighs be non-negative and sum to 1. If there are
+#' 2. Some authors let the weights be non-negative and sum to 1. If there are
 #' zero weights then the corresponding element
 #' of `x` has no impact on the result whenever `x` is strictly
 #' positive. Unlike [weighted.mean()], however,

R/impute_prices.R

@@ -154,12 +154,15 @@ impute_prices.matrix <- function(
   # it just does it period-by-period and keeps track of prices to impute.
   chkDots(...)
   method <- match.arg(method)
-  period <- as.factor(period)
-  product <- as.factor(product)
-  attributes(product) <- NULL
   if (not_finite_pair(r)) {
     stop("`r` must be a pair of finite numbers")
   }
+  if (ncol(x) != 2L) {
+    stop("`x` must be a two-column matrix")
+  }
+  period <- as.factor(period)
+  product <- as.factor(product)
+  attributes(product) <- NULL
   if (!is.null(ea)) {
     ea <- as.factor(ea)
   }
@@ -170,9 +173,6 @@ impute_prices.matrix <- function(
   if (different_length(x[, 1L], period, product, ea, weights)) {
     stop("input vectors must be the same length")
   }
-  if (nlevels(period) == 0L) {
-    return(matrix(NA_real_, nrow = length(period), ncol = 2))
-  }
 
   res <- split.data.frame(x, period)
   product <- split(product, period)
@@ -253,15 +253,15 @@ impute_prices.numeric <- function(
   # it just does it period-by-period and keeps track of prices to impute.
   chkDots(...)
   method <- match.arg(method)
+  if (not_finite_pair(r)) {
+    stop("`r` must be a pair of finite numbers")
+  }
   period <- as.factor(period)
   if (method == "carry-backward") {
     period <- factor(period, rev(levels(period)))
   }
   product <- as.factor(product)
   attributes(product) <- NULL
-  if (not_finite_pair(r)) {
-    stop("`r` must be a pair of finite numbers")
-  }
   if (!is.null(ea)) {
     ea <- as.factor(ea)
   }
@@ -272,9 +272,6 @@ impute_prices.numeric <- function(
   if (different_length(x, period, product, ea, weights)) {
     stop("input vectors must be the same length")
   }
-  if (nlevels(period) == 0L) {
-    return(rep.int(NA_real_, length(period)))
-  }
 
   res <- split(x, period)
   product <- split(product, period)
@@ -329,7 +326,8 @@ impute_prices.numeric <- function(
       res[[t]][impute] <- res[[t - 1L]][matches]
     }
   }
-  unsplit(res, period)
+  split(x, period) <- res
+  x
 }
 
 #' @rdname impute_prices
@@ -354,24 +352,3 @@ impute_prices.data.frame <- function(
     ...
   )
 }
-
-#' @rdname impute_prices
-#' @export
-carry_forward <- function(x, ...) {
-  warning("'carry_forward() is deprecated; use 'impute_prices()' instead")
-  impute_prices(x, method = "carry-forward", ...)
-}
-
-#' @rdname impute_prices
-#' @export
-carry_backward <- function(x, ...) {
-  warning("'carry_backward() is deprecated; use 'impute_prices()' instead")
-  impute_prices(x, method = "carry-backward", ...)
-}
-
-#' @rdname impute_prices
-#' @export
-shadow_price <- function(x, ...) {
-  warning("'shadow_price() is deprecated; use 'impute_prices()' instead")
-  impute_prices(x, method = "overall-mean", ...)
-}

R/window.piar_index.R

@@ -9,7 +9,8 @@
 #' @param end `[character(1)]` The time period to end the window. The default
 #'   is the last period of `x`.
 #' @param ... Not currently used.
-#' @param value `[numeric > 0 | piar_index]` A numeric vector or price index.
+#' @param value `[numeric > 0 | piar_index]` A numeric vector or price index
+#'   of replacement values.
 #'
 #' @returns
 #' `window()` extracts a price index over a window of time periods that