Skip to content

Commit

Permalink
Updated vignette
Browse files Browse the repository at this point in the history
  • Loading branch information
@marberts
marberts committed Oct 12, 2023
1 parent ce7d6df commit e048077
Show file tree
Hide file tree
Showing 5 changed files with 222 additions and 65 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
View file
Original file line number Diff line number Diff line change
@@ -1,6 +1,6 @@
Package: piar
Title: Price Index Aggregation
Version: 0.5.0.9014
Version: 0.5.0.9015
Authors@R: c(
person("Steve", "Martin", role = c("aut", "cre", "cph"), email = "[email protected]", comment = c(ORCID = "0000-0003-2544-9480"))
)
Expand Down
13 changes: 9 additions & 4 deletions R/aggregation_structure-class.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -26,10 +26,6 @@ piar_aggregation_structure <- function(child, parent, levels, eas,

#---- Validator ----
validate_pias_levels <- function(x) {
if (length(x$w) != length(x$eas)) {
stop("cannot make an aggregation structure with a different number of ",
"weights and elemental aggregates")
}
if (anyNA(x$levels) || any(x$levels == "")) {
stop("cannot make an aggregation structure with missing levels")
}
Expand All @@ -54,9 +50,18 @@ validate_pias_structure <- function(x) {
invisible(x)
}

validate_pias_weights <- function(x) {
if (length(x$weights) != length(x$eas)) {
stop("cannot make an aggregation structure with a different number of ",
"weights and elemental aggregates")
}
invisible(x)
}

validate_piar_aggregation_structure <- function(x) {
validate_pias_levels(x)
validate_pias_structure(x)
validate_pias_weights(x)
x
}

Expand Down
100 changes: 72 additions & 28 deletions tests/test-making-price-indexes.R
View file
Original file line number Diff line number Diff line change
@@ -1,3 +1,9 @@
## ---- include = FALSE---------------------------------------------------------
knitr::opts_chunk$set(
collapse = TRUE,
comment = "#>"
)

## -----------------------------------------------------------------------------
library(piar)

Expand All @@ -8,14 +14,16 @@ ms_weights
## -----------------------------------------------------------------------------
relative <- with(ms_prices, price_relative(price, period, product))

(ms_epr <- with(ms_prices, elemental_index(relative, period, business, na.rm = TRUE)))
(ms_epr <- with(ms_prices,
elemental_index(relative, period, business, na.rm = TRUE)))

## -----------------------------------------------------------------------------
ms_epr[, "202004"]
ms_epr["B1", ]

## -----------------------------------------------------------------------------
hierarchy <- with(ms_weights, c(expand_classification(classification), list(business)))
hierarchy <- with(ms_weights,
c(expand_classification(classification), list(business)))

pias <- aggregation_structure(hierarchy, ms_weights$weight)

Expand All @@ -32,7 +40,8 @@ t(apply(as.matrix(ms_index), 1, cumprod))
rebase(ms_index_chained, ms_index_chained[, "202004"])

## -----------------------------------------------------------------------------
rebase(ms_index_chained, rowMeans(as.matrix(ms_index_chained)[, c("202003", "202004")]))
rebase(ms_index_chained,
rowMeans(as.matrix(ms_index_chained)[, c("202003", "202004")]))

## -----------------------------------------------------------------------------
(ms_weights <- transform(ms_weights, stratum = c("TS", "TA", "TS", "TS", "TS")))
Expand All @@ -41,7 +50,8 @@ rebase(ms_index_chained, rowMeans(as.matrix(ms_index_chained)[, c("202003", "202
(classification_sps <- with(ms_weights, paste0(classification, stratum)))

## -----------------------------------------------------------------------------
(classification_sps <- expand_classification(classification_sps, width = c(1, 1, 2)))
(classification_sps <- expand_classification(classification_sps,
width = c(1, 1, 2)))
pias_sps <- with(
ms_weights,
aggregation_structure(c(classification_sps, list(business)), weight)
Expand All @@ -59,10 +69,12 @@ ms_epr2
aggregate(ms_epr2, pias, na.rm = TRUE)

## -----------------------------------------------------------------------------
with(ms_prices, elemental_index(relative, period, business, na.rm = TRUE, r = 1))
with(ms_prices,
elemental_index(relative, period, business, na.rm = TRUE, r = 1))

## -----------------------------------------------------------------------------
with(ms_prices, elemental_index(relative, period, business, na.rm = TRUE, r = -1))
with(ms_prices,
elemental_index(relative, period, business, na.rm = TRUE, r = -1))

## -----------------------------------------------------------------------------
ms_prices2 <- transform(ms_prices, quantity = 10 - price)
Expand All @@ -73,20 +85,25 @@ library(gpindex)
tw <- grouped(index_weights("Tornqvist"))

ms_prices2[c("back_price", "back_quantity")] <-
ms_prices2[back_period(ms_prices2$period, ms_prices2$product), c("price", "quantity")]
ms_prices2[back_period(ms_prices2$period, ms_prices2$product),
c("price", "quantity")]

ms_prices2 <- na.omit(ms_prices2) # can't have NAs for Tornqvist weights

ms_prices2$weight <- with(
ms_prices2,
tw(price, back_price, quantity, back_quantity, group = interaction(period, business))
tw(price, back_price, quantity, back_quantity,
group = interaction(period, business))
)

## -----------------------------------------------------------------------------
with(ms_prices2, elemental_index(price / back_price, period, business, weight))

## -----------------------------------------------------------------------------
ms_epr <- with(ms_prices, elemental_index(relative, period, business, contrib = TRUE, na.rm = TRUE))
ms_epr <- with(
ms_prices,
elemental_index(relative, period, business, contrib = TRUE, na.rm = TRUE)
)

## -----------------------------------------------------------------------------
contrib(ms_epr)
Expand All @@ -98,14 +115,16 @@ ms_prices2 <- subset(ms_prices, period >= "202003")
## -----------------------------------------------------------------------------
ms_epr1 <- with(
ms_prices1,
elemental_index(price_relative(price, period, product), period, business, na.rm = TRUE)
elemental_index(price_relative(price, period, product), period, business,
na.rm = TRUE)
)

(ms_index1 <- aggregate(ms_epr1, pias, na.rm = TRUE))

## -----------------------------------------------------------------------------
ms_epr2 <- with(
subset(transform(ms_prices2, rel = price_relative(price, period, product)), period > "202003"),
subset(transform(ms_prices2, rel = price_relative(price, period, product)),
period > "202003"),
elemental_index(rel, period, business, na.rm = TRUE)
)

Expand All @@ -118,10 +137,11 @@ chain(stack(ms_index1, ms_index2))
## -----------------------------------------------------------------------------
(ms_epr2 <- with(
ms_prices,
elemental_index(price_relative(carry_forward(price, period, product), period, product),
period, business, na.rm = TRUE)
)
)
elemental_index(
price_relative(carry_forward(price, period, product),period, product),
period, business, na.rm = TRUE
)
))

## -----------------------------------------------------------------------------
(ms_index <- aggregate(ms_epr2, pias, na.rm = TRUE))
Expand All @@ -133,12 +153,14 @@ ms_prices2 <- subset(ms_prices, business == "B4")
## -----------------------------------------------------------------------------
ms_epr1 <- with(
ms_prices1,
elemental_index(price_relative(price, period, product), period, business, na.rm = TRUE)
elemental_index(price_relative(price, period, product),
period, business, na.rm = TRUE)
)
ms_epr1
ms_epr2 <- with(
transform(ms_prices2, period = factor(period, levels = time(ms_epr1))),
elemental_index(price_relative(price, period, product), period, business, na.rm = TRUE)
elemental_index(price_relative(price, period, product),
period, business, na.rm = TRUE)
)
ms_epr2

Expand All @@ -153,30 +175,52 @@ ms_prices2 <- subset(
ms_prices2

## -----------------------------------------------------------------------------
ms_epr2 <- with(ms_prices2, elemental_index(value, period, level))
ms_epr2 <- as_index(ms_prices2)
aggregate(merge(ms_epr1, ms_epr2), pias, na.rm = TRUE)

## -----------------------------------------------------------------------------
weights <- data.frame(period = rep(c("202001", "202002", "202003", "202004"), each = 5),
classification = ms_weights$classification,
weight = 1:20)
weights <- data.frame(
period = rep(c("202001", "202002", "202003", "202004"), each = 5),
classification = ms_weights$classification,
weight = 1:20
)
head(weights)

## -----------------------------------------------------------------------------
(ms_epr <- unstack(ms_epr))

## -----------------------------------------------------------------------------
pias <- with(
weights,
Map(aggregation_structure,
list(hierarchy),
split(weight, period))
pias <- with(weights,
Map(aggregation_structure,
list(hierarchy),
split(weight, period))
)

## -----------------------------------------------------------------------------
(paasche <- Reduce(stack, Map(aggregate, ms_epr, pias, na.rm = TRUE, r = -1)))

## -----------------------------------------------------------------------------
laspeyres <- Reduce(stack, Map(aggregate, ms_epr, pias[c(1, 1, 2, 3)], na.rm = TRUE))
sqrt(as.matrix(laspeyres) * as.matrix(paasche))
laspeyres <- Reduce(stack,
Map(aggregate, ms_epr, pias[c(1, 1, 2, 3)], na.rm = TRUE))

(fisher <- sqrt(as.matrix(laspeyres) * as.matrix(paasche)))

## -----------------------------------------------------------------------------
geometric_weights <- transmute_weights(0, 1)
w <- mapply(\(x, y) scale_weights(geometric_weights(c(x, y))),
as.numeric(laspeyres[1]),
as.numeric(paasche[1]))

laspeyres_contrib <- contrib(laspeyres)
paasche_contrib <- contrib(paasche)

fisher_contrib <- w[1, col(laspeyres_contrib)] * laspeyres_contrib +
w[2, col(paasche_contrib)] * paasche_contrib

fisher_contrib

## -----------------------------------------------------------------------------
chain(fisher)

## -----------------------------------------------------------------------------
sqrt(as.matrix(chain(laspeyres)) * as.matrix(chain(paasche)))
Loading

0 comments on commit e048077

Please sign in to comment.