Example 1: Carpart
In this example, we consider a monthly time series of car
part sales, from Jan. 1998 to Mar. 2002.
This is actually the time series #2655 of the carparts dataset
(R. Hyndman et al. 2008). It is available
from bayesRecon::carpart.
The time series consists of count data, and the distribution of its values is skewed. Hence, we produce base forecasts using a method specialized for count time series.
layout(mat = matrix(c(1, 2), nrow = 1, ncol = 2), widths = c(2, 1))
plot(carpart, xlab = "Time", ylab = "Car part sales", main = NULL)
hist(carpart, xlab = "Car part sales", main = NULL)
Figure 1: Carpart - monthly car part sales.
We divide the time series into train and test; we want to
forecast the test set, i.e., the last 12 observations (1 year
ahead).
We now build the temporal hierarchy and compute the base forecasts.
We build the hierarchy using the temporal aggregation
function. We aggregate at 2-Monthly, Quarterly,
4-Monthly, Biannual, and Annual by specifying
the agg_levels argument.
train.agg <- bayesRecon::temporal_aggregation(train, agg_levels = c(2, 3, 4, 6, 12))
levels <- c("Annual", "Biannual", "4-Monthly", "Quarterly", "2-Monthly", "Monthly")
names(train.agg) <- levelsThe function returns a list of aggregated time series, ordered from the top (most aggregated) to the bottom (most disagreggated).
par(mfrow = c(2, 3), mai = c(0.6, 0.6, 0.5, 0.5))
for (l in levels) {
plot(train.agg[[l]], xlab = "Time", ylab = "Car part sales", main = l)
}
Figure 2: Carpart - visualization of the aggregated time series.
We use the glarma package (R CRAN) to generate
the forecasts. This package is specialized in forecasting count time
series and it is based on a Generalized Linear Autoregressive Moving
Average model. In this example, we adopt a Poisson predictive
distribution.
The models produce forecasts for 1 year ahead; this is h=12 steps ahead for the monthly level, h=4 steps ahead for the quarterly level, etc. Each forecast is constituted by \(D\) integer samples; we set \(D=20000\).
Below we use a for loop to iterate over the levels of the temporal
hierarchy. For each level, we fit an independent model; then we obtain
the samples of the forecasts using the function
glarma::forecast.glarma. Overall we have 28 predictive
distributions (one for Annual, two for Biannual,
etc.). We collect the samples of the 28 distributions in a list.
The following lines of code take ~ 30 seconds on a personal computer.
# install.packages("glarma", dependencies = TRUE)
#library(glarma)
fc.samples <- list()
D <- 20000
fc.count <- 1
# iterating over the temporal aggregation levels
for (l in seq_along(train.agg)) {
f.level <- frequency(train.agg[[l]])
print(paste("Forecasting at ", levels[l], "...", sep = ""))
# fit an independent model for each aggregation level
model <- glarma::glarma(
train.agg[[l]],
phiLags = if (f.level == 1) 1 else 1:(min(6, f.level - 1)),
thetaLags = if (f.level == 1) NULL else f.level,
X = cbind(intercept = rep(1, length(train.agg[[l]]))),
offset = cbind(intercept = rep(0, length(train.agg[[l]]))),
type = "Poi"
)
# forecast 1 year ahead
h <- f.level
tmp <- matrix(data = NA, nrow = h, ncol = D)
for (s in (1:D)) {
# each call to 'forecast.glarma' returns a simulation path
tmp[, s] <- glarma::forecast(
model,
n.ahead = h,
newdata = cbind(intercept = rep(1, h)),
newoffset = rep(0, h)
)$Y
}
# collect the forecasted samples
for (i in 1:h) {
fc.samples[[fc.count]] <- tmp[i, ]
fc.count <- fc.count + 1
}
}
#> [1] "Forecasting at Annual..."
#> [1] "Forecasting at Biannual..."
#> [1] "Forecasting at 4-Monthly..."
#> [1] "Forecasting at Quarterly..."
#> [1] "Forecasting at 2-Monthly..."
#> [1] "Forecasting at Monthly..."Base forecasts do not sum up correctly. In order to address incoherence we can now use a reconciliation algorithm.
First, we obtain the summing matrix \(\mathbf{S}\) using the function
get_reconc_matrices. It requires:
- the aggregation factors used before to build the hierarchy, \(\{2, 3, 4, 6, 12\}\) in this example;
- the length of the forecasting horizon for the bottom time series (h=12 in this example).
recon.matrices <- bayesRecon::get_reconc_matrices(agg_levels = c(2, 3, 4, 6, 12), h = 12)
# Summing matrix
S <- recon.matrices$S
# A matrix
A <- recon.matrices$A Then, we use the function reconc_BUIS which implements
the Bottom-Up Important Sampling (BUIS) algorithm. It requires the \(\mathbf{S}\) matrix, the base
forecasts, the type of the base forecasts (“samples” in this
example) and the specification of the base forecasts distributions
(“discrete” in this example, since the predictive distributions are
Poisson).
The in_type argument is a string with two possible
values: “samples” if the base forecasts are in the form of samples,
“params” if the base forecasts are in the form of estimated parameters.
The distr argument is a string describing the type of base
forecasts. It can be: “continuous” or “discrete” if
in_type = "samples"; “gaussian”, “poisson” or “nbinom” if
in_type = "params".
recon.res <- bayesRecon::reconc_BUIS(
S,
base_forecasts = fc.samples,
in_type = "samples",
distr = "discrete",
seed = 42
)The function returns samples from the reconciled forecast distribution.
We now compute the Mean Absolute Error (MAE) and the Continuous
Ranked Probability Score (CRPS) for the bottom (i.e., monthly)
time series. For CRPS, we use crps_sample from the package
scoringRules (R CRAN).
# install.packages("scoringRules", dependencies = TRUE)
library(scoringRules)
ae.fc <- list()
ae.reconc <- list()
crps.fc <- list()
crps.reconc <- list()
for (h in 1:length(test)) {
y.hat_ <- median(fc.samples[[nrow(A) + h]])
y.reconc_ <- median(recon.res$bottom_reconciled_samples[, h])
# Compute Absolute Errors
ae.fc[[h]] <- abs(test[h] - y.hat_)
ae.reconc[[h]] <- abs(test[h] - y.reconc_)
# Compute Continuous Ranked Probability Score (CRPS)
crps.fc[[h]] <-
scoringRules::crps_sample(y = test[h], dat = fc.samples[[nrow(A) + h]])
crps.reconc[[h]] <-
scoringRules::crps_sample(y = test[h], dat = recon.res$bottom_reconciled_samples[, h])
}
mae.fc <- mean(unlist(ae.fc))
mae.reconc <- mean(unlist(ae.reconc))
crps.fc <- mean(unlist(crps.fc))
crps.reconc <- mean(unlist(crps.reconc))
metrics <- data.frame(
row.names = c("MAE", "CRPS"),
base.forecasts = c(mae.fc, crps.fc),
reconciled.forecasts = c(mae.reconc, crps.reconc)
)
metrics
#> base.forecasts reconciled.forecasts
#> MAE 1.2500000 1.0416667
#> CRPS 0.7093284 0.6840278Note the improvements with respect to the base forecast on both MAE and CRPS metrics.
