Version 0.9.0

DESCRIPTION

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

NAMESPACE

@@ -33,10 +33,6 @@ S3method(as_index,default)
 S3method(as_index,direct_piar_index)
 S3method(as_index,matrix)
 S3method(as_index,mts)
-S3method(carry_backward,data.frame)
-S3method(carry_backward,default)
-S3method(carry_forward,data.frame)
-S3method(carry_forward,default)
 S3method(chain,chainable_piar_index)
 S3method(chain,default)
 S3method(chain,direct_piar_index)
@@ -46,6 +42,10 @@ S3method(elementary_index,default)
 S3method(elementary_index,numeric)
 S3method(end,piar_index)
 S3method(head,piar_index)
+S3method(impute_prices,data.frame)
+S3method(impute_prices,default)
+S3method(impute_prices,matrix)
+S3method(impute_prices,numeric)
 S3method(is.na,piar_index)
 S3method(levels,piar_aggregation_structure)
 S3method(levels,piar_index)
@@ -61,8 +61,6 @@ S3method(print,piar_index)
 S3method(rebase,chainable_piar_index)
 S3method(rebase,default)
 S3method(rebase,direct_piar_index)
-S3method(shadow_price,data.frame)
-S3method(shadow_price,default)
 S3method(split,piar_index)
 S3method(stack,chainable_piar_index)
 S3method(stack,direct_piar_index)
@@ -99,6 +97,7 @@ export(contrib2DF)
 export(elemental_index)
 export(elementary_index)
 export(expand_classification)
+export(impute_prices)
 export(interact_classifications)
 export(is_aggregation_structure)
 export(is_chainable_index)

NEWS.md

@@ -34,11 +34,21 @@ aggregation structure that spans multiple hierarchical classifications.
 - Subscripting an index object with a matrix is now more flexible and can
 return/replace a list of index objects.
 
+- Added a new function `impute_prices()` to consolidate the different
+price-imputation functions.
+
 ## Bug fixes
 
 - Setting `contrib = FALSE` in `aggregate(index)` always returns an index with
 no contributions.
 
+- `set_weights()` no longer returns its result invisibly.
+
+## Deprecations
+
+- `carry_forward()`, `carry_backward()`, and `shadow_price()` are deprecated.
+Use `impute_prices()` instead.
+
 # piar 0.8.3
 
 ## Improvements

R/aggregate.piar_index.R

@@ -225,8 +225,8 @@ aggregate_index <- function(
       stop("'pias' and 'pias2' must represent the same aggregation structure")
     }
     if (
-      any(missing_weights(pias$weights) != missing_weights(pias2$weights)) &&
-        contrib
+      contrib &&
+        any(missing_weights(pias$weights) != missing_weights(pias2$weights))
     ) {
       stop(
         "any NA or zero weights must appear in both 'pias' and 'pias2' when",
@@ -261,7 +261,7 @@ aggregate_index <- function(
     lev <- unlist(drop_last(pias$levels), use.names = FALSE)
   }
 
-  piar_index(res$index, res$contrib, lev, x$time, chainable)
+  piar_index(res$index, res$contrib, lev, x$time, chainable = chainable)
 }
 
 aggregate_ <- function(

R/aggregation_structure-class.R

@@ -32,7 +32,7 @@ validate_pias_levels <- function(x) {
   if (anyDuplicated(lev)) {
     stop("cannot make an aggregation structure with duplicated levels")
   }
-  invisible(x)
+  x
 }
 
 validate_pias_structure <- function(x) {
@@ -49,7 +49,7 @@ validate_pias_structure <- function(x) {
       "hierachy"
     )
   }
-  invisible(x)
+  x
 }
 
 validate_pias_weights <- function(x) {
@@ -62,14 +62,13 @@ validate_pias_weights <- function(x) {
   if (any(x$weights < 0, na.rm = TRUE)) {
     stop("cannot make an aggregation structure with negative weights")
   }
-  invisible(x)
+  x
 }
 
 validate_piar_aggregation_structure <- function(x) {
   validate_pias_levels(x)
   validate_pias_structure(x)
   validate_pias_weights(x)
-  x
 }
 
 #---- Undocumented methods ----

R/as_index.R

@@ -79,9 +79,13 @@ as_index.matrix <- function(x, ..., chainable = TRUE, contrib = FALSE) {
   index <- as.numeric(x)
   dim(index) <- c(length(levels), length(periods))
 
-  contributions <- if (contrib) index2contrib(index, levels, periods)
-
-  piar_index(index, contributions, levels, periods, chainable)
+  piar_index(
+    index,
+    if (contrib) index2contrib(index, levels, periods),
+    levels,
+    periods,
+    chainable = chainable
+  )
 }
 
 #' @rdname as_index

R/contrib.R

@@ -63,8 +63,12 @@
 #' @export contrib
 #' @family index methods
 contrib <- function(x, level = NULL, period = NULL, pad = 0) {
-  level <- match_levels(as.character(level %||% x$levels[1L]), x)
-  period <- match_time(as.character(period %||% x$time), x, several = TRUE)
+  level <- if (!is.null(level)) match_levels(as.character(level), x) else 1L
+  period <- if (!is.null(period)) {
+    match_time(as.character(period), x, several = TRUE)
+  } else {
+    seq_along(x$time)
+  }
   pad <- as.numeric(pad)
   if (length(pad) != 1L) {
     stop("'pad' must be a length 1 numeric value")
@@ -99,12 +103,16 @@ contrib <- function(x, level = NULL, period = NULL, pad = 0) {
 #' @rdname contrib
 #' @export
 contrib2DF <- function(x, levels = NULL, period = NULL) {
-  level <- match_levels(
-    as.character(levels %||% x$levels[1L]),
-    x,
-    several = TRUE
-  )
-  period <- match_time(as.character(period %||% x$time), x, several = TRUE)
+  level <- if (!is.null(levels)) {
+    match_levels(as.character(levels), x, several = TRUE)
+  } else {
+    1L
+  }
+  period <- if (!is.null(period)) {
+    match_time(as.character(period), x, several = TRUE)
+  } else {
+    seq_along(x$time)
+  }
   if (is.null(x$contrib)) {
     return(
       data.frame(
@@ -141,8 +149,12 @@ contrib2DF <- function(x, levels = NULL, period = NULL) {
 #' @rdname contrib
 #' @export
 `contrib<-` <- function(x, level = NULL, period = NULL, value) {
-  level <- match_levels(as.character(level %||% x$levels[1L]), x)
-  period <- match_time(as.character(period %||% x$time), x, several = TRUE)
+  level <- if (!is.null(level)) match_levels(as.character(level), x) else 1L
+  period <- if (!is.null(period)) {
+    match_time(as.character(period), x, several = TRUE)
+  } else {
+    seq_along(x$time)
+  }
 
   if (is.null(x$contrib)) {
     x$contrib <- contrib_skeleton(x$levels, x$time)
@@ -156,7 +168,12 @@ contrib2DF <- function(x, levels = NULL, period = NULL) {
       "number of items to replace is not a multiple of replacement length"
     )
   }
-  value[] <- as.numeric(value)
+  value <- matrix(
+    as.numeric(value),
+    nrow = nrow(value),
+    ncol = ncol(value),
+    dimnames = dimnames(value)
+  )
 
   products <- if (nrow(value) > 0L) {
     if (is.null(rownames(value))) {
@@ -173,7 +190,7 @@ contrib2DF <- function(x, levels = NULL, period = NULL) {
     names(con) <- products
     x$contrib[level, t] <- list(con)
   }
-  validate_piar_index(x)
+  validate_contrib(x)
 }
 
 #' @rdname contrib
@@ -184,5 +201,5 @@ set_contrib <- `contrib<-`
 #' @export
 set_contrib_from_index <- function(x) {
   x$contrib <- index2contrib(x$index, x$levels, x$time)
-  x
+  validate_contrib(x)
 }

R/elementary_index.R

@@ -82,8 +82,9 @@
 #'   a Paasche index). Other values are possible; see
 #'   [gpindex::generalized_mean()] for details.
 #' @param ... Further arguments passed to or used by methods.
-#' @param formula A two-sided formula with price relatives on the left-hand
-#'   side, and time periods and elementary aggregates (in that order) on the
+#' @param formula A two-sided formula, or something that can be coerced into
+#'   one, with price relatives on the left-hand
+#'   side and time periods and elementary aggregates (in that order) on the
 #'   right-hand side.
 #'
 #' @returns
@@ -196,16 +197,16 @@ elementary_index.numeric <- function(
   }
   period <- as.factor(period %||% gl(1, length(x)))
   ea <- as.factor(ea %||% gl(1, length(x)))
-  ea_by_period <- period:ea
-  time <- levels(period)
-  levels <- levels(ea)
 
   if (different_length(x, period, ea, weights)) {
     stop("input vectors must be the same length")
   }
   if (any(x <= 0, na.rm = TRUE)) {
     stop("all elements of 'x' must be strictly positive")
   }
+  ea_by_period <- period:ea
+  time <- levels(period)
+  levels <- levels(ea)
 
   if (contrib) {
     if (!is.null(product)) {
@@ -219,11 +220,7 @@ elementary_index.numeric <- function(
   }
 
   x <- split(x, ea_by_period)
-  if (is.null(weights)) {
-    weights <- list(NULL)
-  } else {
-    weights <- split(weights, ea_by_period)
-  }
+  weights <- if (is.null(weights)) list(NULL) else split(weights, ea_by_period)
 
   index <- mapply(
     gpindex::generalized_mean(r),
@@ -243,9 +240,9 @@ elementary_index.numeric <- function(
       USE.NAMES = FALSE
     )
     dim(contributions) <- c(nlevels(ea), nlevels(period))
-    piar_index(index, contributions, levels, time, chainable)
+    piar_index(index, contributions, levels, time, chainable = chainable)
   } else {
-    piar_index(index, NULL, levels, time, chainable)
+    piar_index(index, NULL, levels, time, chainable = chainable)
   }
 }
 

R/extract.piar_index.R

@@ -69,7 +69,7 @@ extract_index <- function(x, levels, periods) {
   }
   x$levels <- x$levels[levels]
   x$time <- x$time[periods]
-  validate_piar_index(x)
+  validate_index_structure(x)
 }
 
 #' @rdname sub-.piar_index
@@ -86,18 +86,18 @@ extract_index <- function(x, levels, periods) {
     if (is_index(value)) {
       value <- list(value)
     }
-    if (is.list(value)) {
-      x <- replace_matrix_list(x, i, value)
+    x <- if (is.list(value)) {
+      replace_matrix_list(x, i, value)
     } else {
-      x <- replace_matrix_numeric(x, i, value)
+      replace_matrix_numeric(x, i, value)
     }
   } else {
     levels <- subscript_index(x$levels, i)
     periods <- subscript_index(x$time, j)
-    if (is_index(value)) {
-      x <- replace_index(x, levels, periods, value)
+    x <- if (is_index(value)) {
+      replace_index(x, levels, periods, value)
     } else {
-      x <- replace_numeric(x, levels, periods, value)
+      replace_numeric(x, levels, periods, value)
     }
   }
   # Replacement value should be validated; e.g., x[1] <- -1.
@@ -151,9 +151,8 @@ replace_matrix_list <- function(x, i, value) {
     stop("'value' must be a list of indexes with one level and time period")
   }
   # Make `value` the same length as replacement to avoid two warnings.
-  value <- rep_len(value, nrow(i))
-  index <- vapply(value, \(x) x$index, numeric(1L))
-  contributions <- unlist(lapply(value, \(x) x$contrib), recursive = FALSE)
+  index <- rep_len(vapply(value, \(x) x$index[[1]], numeric(1L)), nrow(i))
+  contributions <- rep_len(lapply(value, \(x) x$contrib[[1]]), nrow(i))
   has_contrib <- any(vapply(contributions, Negate(is.null), logical(1L)))
   # It's possible that only some elements of `value` have contributions.
   if (has_contrib || !is.null(x$contrib)) {

R/head.piar_index.R

@@ -31,7 +31,7 @@ head.piar_index <- function(x, n = 6L, ...) {
   if (!is.na(n[2L])) {
     x$time <- head(x$time, n[2L])
   }
-  validate_piar_index(x)
+  validate_index_structure(x)
 }
 
 #' @rdname head.piar_index
@@ -47,5 +47,5 @@ tail.piar_index <- function(x, n = 6L, ...) {
   if (!is.na(n[2L])) {
     x$time <- tail(x$time, n[2L])
   }
-  validate_piar_index(x)
+  validate_index_structure(x)
 }

R/helpers.R

@@ -14,7 +14,7 @@ missing_weights <- function(x) {
 }
 
 missing_names <- function(x) {
-  anyNA(x) || any(x == "")
+  anyNA(x) || !all(nzchar(x))
 }
 
 last <- function(x) {
@@ -104,6 +104,7 @@ different_length <- function(...) {
 }
 
 formula_vars <- function(formula, x, n = 2L) {
+  formula <- stats::as.formula(formula)
   if (length(formula) != 3L) {
     stop("'formula' must have a left-hand and right-hand side")
   }
@@ -195,19 +196,10 @@ index_skeleton <- function(levels, time) {
   matrix(NA_real_, length(levels), length(time))
 }
 
-empty_contrib <- function(x) {
-  res <- rep.int(list(numeric(0L)), length(x))
-  list(res)
-}
-
 contrib_skeleton <- function(levels, time) {
   matrix(list(numeric(0L)), length(levels), length(time))
 }
 
-has_contrib <- function(x) {
-  any(lengths(x$contrib) > 0L)
-}
-
 # Backport Reduce and %||%
 # TODO: Remove once min R version gets bumped.
 if (getRversion() < "4.4.0") {