Motivation

The Generalized Orthogonal GARCH (GOGARCH) model uses Independent Component Analysis (ICA) to extract independent sources of volatility from multivariate time series, enabling more precise and interpretable modeling of their joint dynamic structure.

In the tsmarch package there are 2 ICA algorithms currently implemented:

• The RADICAL algorithm of Learned-Miller and Fisher (2003) which is based on an efficient entropy estimator (due to Vasicek (1976)) which is robust to outliers and requires no strong characterization assumptions about the data generating process. However, despite best efforts to speed up the original implementation using multi-threading, this remains a relatively slow algorithm and also suffers from convergence issues in high dimensions.
• The FASTICA algorithm of Hyvarinen (1999) is a fixed point iteration method which has proven to be extremely fast and very suitable for high dimensional systems.

Both of the algorithms are implemented locally in tsmarch, and the FASTICA is a direct translation of the Matlab code of the original authors, retaining a lot of additional options not present in other translations in R. Both of the algorithms provide exactly the same type of interface for the whitening stage such as different options for the type of covariance to use.

This short blog post looks at extending the benchmark provided in the iTensor package vignette in order to include the 2 ICA implementations in the tsmarch package.

Benchmark

The benchmark uses a set of 4 data sets with known independent sources (S) and uses the Correlation Index of (Sobhani et al. 2022) to evaluate the performance of each ICA algorithm in extracting the true signals from the mixed series (X).

The 4 data sets are generated from the following processes:

1. ICA with time-independent sub-Gaussian data (tisubg)
2. ICA with time-independent super-Gaussian data (tisupg)
3. ICA with data mixed with signals having no time dependence and different kurtosis (tidkurt)
4. ICA with time-dependent data (td)

data <- list(iTensor::toyModel("ICA_Type1"),
             iTensor::toyModel("ICA_Type2"),
             iTensor::toyModel("ICA_Type3"),
             iTensor::toyModel("ICA_Type4"))
allICA <- function(X, J){
  # Classic ICA Methods
  out.FastICA <- ICA(X = X, J = J, algorithm = "FastICA")
  out.InfoMax <- ICA(X = X, J = J, algorithm = "InfoMax")
  out.ExtInfoMax <- ICA(X = X, J = J, algorithm = "ExtInfoMax")
  out.JADE <- ICA2(X = X, J = J, algorithm = "JADE")
  out.tsmarch_fastica <- fastica(X, components = J, fun = "tanh")
  out.tsmarch_radical <- radical(X, components = J, augment = TRUE, replications = 100)
  list(out.FastICA = out.FastICA, out.InfoMax = out.InfoMax,
       out.ExtInfoMax = out.ExtInfoMax, out.JADE = out.JADE,
       out.tsmarch_fastica = out.tsmarch_fastica,
       out.tsmarch_radical = out.tsmarch_radical)
}
data_names <- c("tisubg","tisupg","tidkurt","td")
out <- lapply(1:4, function(i) {
  allICA(X = data[[i]]$X_observed, J = 3)
})
corr_index <- lapply(1:4, function(i) {
  tmp <- lapply(out[[i]], function(x, S) {CorrIndex(cor(S, Re(x$S)))}, S = data[[i]]$S_true)
  Name <- gsub("out.", "", names(tmp))
  Value <- round(unlist(tmp), 3)
  data.table(Algorithm = Name, DGP = data_names[i], Value = Value)
})
tab <- dcast(rbindlist(corr_index), Algorithm~DGP, value.var = "Value")
tab[Algorithm == "tsmarch_fastica", Algorithm := "FASTICA (tsmarch)"]
tab[Algorithm == "tsmarch_radical", Algorithm := "RADICAL (tsmarch)"]
tab <- flextable(tab) |> separate_header() |> flextable::colformat_double(digits = 3)
tab <- tab |> add_footer_row(colwidths = 5, values = as_paragraph(
  "Notes to table: td (time dependent), tidkurt (data mixed with signals having no time dependence and different kurtosis), tisupg (time-independent super-Gaussian data), tisubg (time-independent sub-Gaussian data). The values represent the Correlation Index of Sobhani (2022) (the closer to 0, the better the performance)."))
tab <- tab |> align(i = 1, j = 1:5, align = "justify", part = "footer")
tab <- tab |> set_caption(caption = "ICA Benchmarks", html_escape = TRUE)
tab <- tab |> set_table_properties(layout = "autofit")
tab

The results of the small toy benchmark show that both ICA implementations in the tsmarch package are very competitive in terms of performance providing a certain degree of confidence.

GOGARCH Demo and Discussion

In this next example, we illustrate the use of the 2 algorithms in the GOGARCH model using dimensionality reduction and compare their weighted output.

data(globalindices)
train_set <- 1:1600
series <- 1:10
y <- as.xts(globalindices[, series])
model_fastica <- gogarch_modelspec(y, distribution = "nig", model = "gjrgarch", ica = "fastica", components = 5) |> estimate(seed = 1010, stabilization = TRUE, fun = "skew", fine = "tanh")
model_radical <- gogarch_modelspec(y, distribution = "nig", model = "gjrgarch", ica = "radical", components = 5) |> estimate(seed = 1010, augment = TRUE)
w_fastica <- tsaggregate(model_fastica, weights = rep(1/10, 10))
w_radical <- tsaggregate(model_radical, weights = rep(1/10, 10))
par(mfrow = c(2,1), mar = c(2,2,2,2))
plot(index(y), as.numeric(w_fastica$sigma), type = "l", ylab = "", xlab = "", main = "Weighted Sigma[t]", xaxt = "n", cex.main = 0.8, cex.axis = 0.8)
lines(index(y), as.numeric(w_radical$sigma), col = 2, lty = 2)
grid()
legend("topleft", c("FASTICA","RADICAL"), col = 1:2, lty = 1:2, bty = "n", cex = 0.8)
plot(index(y), as.numeric(w_fastica$skewness), type = "l", ylab = "", xlab = "", main = "Weighted Skewness[t]", cex.main = 0.8, cex.axis = 0.8)
lines(index(y), as.numeric(w_radical$skewness), col = 2, lty = 2)
grid()

Both algorithms give reasonably close results. However, the FASTICA algorithm has a lot more options, particularly with respect to the choice of non-linearity (fun) and fine tuning (fine) functions. The choices, which relate to assumptions about the underlying source densities, are:

1. pow3 is optimal for sources with power exponential density,
2. skew is optimal for sources with density satisfying ,
3. gauss is optimal for sources with density satisfying ,
4. tanh is optimal for sources with symmetric two-group Gaussian location mixtures.

Additionally, both the tanh and gauss functions take additional parameters which determine the degree of separation of the sources, depending on the underlying densities. A more thorough discussion is available in Virta and Nordhausen (2017).

Based on some experimentation, here are some suggestions when choosing between these algorithms:

1. When components <= 30, choose RADICAL with augment set to TRUE. For speed, use RcppParallel::setThreadOptions as part of the code is written in C++ and benefits from multi-threading.
2. When components> 30, use FASTICA, but experiment with different non-linearity functions and the other arguments provided by the algorithm.

Motivation

Finding stable patterns in data is a key requirement if we are to have any success in forecasting the future. These patterns are identified by analyzing the historical behavior of data, and may include seasonal patterns, particular types of growth, fixed and moving holidays and know causal drivers. These can collectively be termed the signal, and the remainder as the noise. In estimating such signals, we usually make some assumptions about the structure of the noise. However, when the data is contaminated by anomalies which violate our assumptions, then it becomes increasingly difficult to cleanly identify the signals.

Types of Anomalies

Large spikes in data series have typically been associated with the term outliers. These lead to clear contamination of normal process variation under most types of dynamics and is therefore the type of anomaly which is most general across different types of data generating mechanisms. While such spikes usually decay almost instantaneously, others may decay at a slower pace (temporary shifts) and some may even be permanent (level shifts). One generating mechanism for these anomalies if through a recursive AR(1) filter. The figure below shows an example of how such anomalies can be generated with different decay rates. The half-life of the decay of such shocks can be easily derived from the theory on ARMA processes and is equal to , where is the AR(1) coefficient. Thus, the closer this gets to 1, the closer the shock becomes permanent whereas a coefficient close to 0 is equivalent to an instantaneous decay.

x <- rep(0, 100)
x[50] <- 1
plot(filter(x, filter = 0, method = "recursive", init = 0), ylab = "", xlab = "")
lines(filter(x, filter = 0.5, method = "recursive", init = 0), col = 2, lty = 2)
lines(filter(x, filter = 0.8, method = "recursive", init = 0), col = 2, lty = 2)
lines(filter(x, filter = 1, method = "recursive", init = 0), col = 3, lty = 3, lwd = 2)
grid()
legend("topleft", c("Additive Outlier (alpha = 0.0)",
                    "Temporary Change (alpha = 0.5)",
                    "Temporary Change (alpha = 0.8)",
                    "Permanent Shift (alpha = 1.0)"), lty = c(1,2,2,3), bty = "n", col = c(1,2,2,3))

Digression: change in slope

Sudden changes in the slope of the dynamics, may sometimes come about as a result of structural changes, such as technological innovation or other business changes. Such changes would technically fall under anomalies. However, there is another case which is based on the life cycle hypothesis of product adoption.¹ When thinking of variance stabilizing transformations such as the Box-Cox, this is similar to changes in the parameter of the transformation. For instance, in the early stages of product adoption, we may observe exponential growth which may eventually stabilize to linear growth over time. Modelling the dynamics of such a process with standard models is likely to lead to poor long range forecasts. One interesting approach is provided in (Guo, Lichtendahl, and Grushka-Cockayne 2019).

Identification

Identifying different types of anomalies is usually undertaken as an integrated part of the assumed dynamics of the process. An established and flexible framework for forecasting economic time series is the state space model, or one of its many variants. For example, the basic structural time series model of (Harvey 1990) is a state of the art approach to econometric forecasting, decomposing a series into a number of independent unobserved structural components:

which uses random walk dynamics for the level, slope and seasonal components, each with an independent noise component. Variations to this model include the innovations state space model which assumes fully correlated components and is observationally equivalent to this model but does not require the use of the Kalman filter since it starts from a steady state equilibrium and hence optimizing the log likelihood is somewhat simpler and faster.

In this structural time series representation, additive outliers can be identified by spikes in the observation equation; level shifts by outliers in the level equation; and a large change in the slope as an outlier in the slope equation (and similar logic applies to the seasonal equation). Therefore, testing for such outliers in each of the disturbance smoother errors of the models can form the basis for the identification of anomalies in the series.²

Direct equivalence between a number of different variations of this model and the more well known ARIMA model have been established. In the ARIMA framework, a key method for the identification of anomalies is based on the work of (Chen and Liu 1993), and is the one we use in our approach.³ This approach uses multi-pass identification and elimination steps based on automatic model selection to identify the best anomaly candidates (and types of candidates) based on information criteria. This is a computationally demanding approach, particularly in the presence of multiple components and long time series data sets. As such, we have implemented a slightly modified and faster approach, as an additional option, which first identifies and removes large spikes using a robust STL decomposition and MAD criterion, then deseasonalizes and detrends this cleaned data again using a robust STL decomposition, before finally passing the irregular component to the method of (Chen and Liu 1993), as implemented in the tsoutliers package. Finally, the outliers from the first stage are combined with the anomalies identified in the last step (and duplicates removed), together with all estimated coefficients on these anomalies which can then be used to clean the data. The tsaux package provides 2 functions: auto_regressors automatically returns the identified anomalies, their types and coefficients, whilst auto_clean automatically performs the data cleaning step. The functions allow for the use of the modified approach as well as the direct approach of passing the data to the tso function.

One shortcoming of the current approach is that for temporary change identification, the AR coefficient defaults to 0.7 and there is no search performed on other parameters. Adapting the method to search over different values is left for future research.

Anomaly Detection and Decontamination Demo

We start with an illustration of data contamination. Starting with a simulated series of level + slope, we then proceed to contaminate it with outliers, temporary changes and level shifts.

set.seed(10125)
y <- tsets:::ets_sample(model = "AAN", h = 52*5, alpha = 0.25, beta = 0.01, 
                        gamma = 1e-12, sigma = 10, 
                        seed_states = c("l0" = 100, "b0" = 1))
y <- y$Simulated
par(mfrow = c(4, 1), mar = c(3,3,3,3))
plot(as.zoo(y), main = "Original", ylab = "", xlab = "")
grid()
y_contaminated <- y %>% additive_outlier(time = 25, parameter = 1)
plot(as.zoo(y_contaminated), main = "+Additive Outlier[t=25]",  ylab = "", xlab = "")
grid()
y_contaminated <- y_contaminated %>% temporary_change(time = 120, parameter = 0.75, alpha = 0.7)
plot(as.zoo(y_contaminated), main = "+Temporary Change[t=120]",  ylab = "", xlab = "")
grid()
y_contaminated <- y_contaminated %>% level_shift(time = 200, parameter = -0.25)
plot(as.zoo(y_contaminated), main = "+Level Shift[t=200]",  ylab = "", xlab = "")
grid()

We now pass the contaminated series to the anomaly identification function auto_regressors. The tso function directly identifies the correct number, timing and types of anomalies.⁴

xreg <- auto_regressors(y_contaminated, frequency = 52, 
                        return_table = TRUE, 
                        auto_arima_opts = list(seasonal = FALSE), method = "full")
xreg[,time := which(index(y_contaminated) %in% xreg$date)]
print(xreg)

## Index: <type>
##      type       date filter      coef  time
##    <char>     <Date>  <num>     <num> <int>
## 1:     AO 1992-02-29    0.0 118.81429    25
## 2:     TC 2000-01-31    0.7 174.45303   120
## 3:     LS 2006-09-30    1.0 -65.82534   200

While we can call directly the auto_clean function, we’ll instead show how to use the returned table to decontaminate the data.

x <- cbind(additive_outlier(y_contaminated, time = xreg$time[1], add = FALSE),
           temporary_change(y_contaminated, time = xreg$time[2], alpha = xreg$filter[2], 
                            add = FALSE),
           level_shift(y_contaminated, time = xreg$time[3], add = FALSE))
x <- x %*% xreg$coef
y_clean <- y_contaminated - x
par(mfrow = c(2,1), mar = c(3,3,3,3))
plot(as.zoo(y_contaminated), main = "Anomaly Decomtanination", xlab = "", ylab = "")
lines(as.zoo(y_clean), col = 2, lty = 2, lwd = 2)
lines(as.zoo(y), col = 3, lty = 3, lwd = 2.5)
grid()
legend("topleft", c("Contaminated", "Clean", "Original"), col = 1:3, bty = "n", lty = 1:3)
plot(zoo(x, index(y)), main = "Anomalies", xlab = "", ylab = "")

Next, we perform a simulation exercise to see how well the method works on a series with anomalies arriving at random times. To keep things simple, we contaminate the series with 4 additive outliers and 2 temporary changes, all arriving at random times with random coefficients. There are two key ways to measure the performance of this simulation; the very detailed looks at measuring the correct number, type and and timing of anomalies; the other way is to simply measure the goodness of fit of the decontaminated series against the original series. We choose the latter since the detailed method requires writing a lot of coding for matching which is not conducive to a blog post. We measure goodness of fit using MAPE since it’s simple and explainable. It should be noted that this is a purely artificial example, since most real data is much more noisy and can contain anomalies which happen at or near the same time point.

plan(multisession)
simulation <- future_lapply(1:1000, function(i){
 random_parameters <- runif(6, 0.3, 0.8)
 random_times <- sample(2:((52*5) - 1), 6, replace = FALSE)
 y_contaminated <- y %>% additive_outlier(time = random_times[1], parameter = random_parameters[1]) %>% 
  additive_outlier(time = random_times[2], parameter = random_parameters[2]) %>% 
  additive_outlier(time = random_times[3], parameter = random_parameters[3]) %>%
  additive_outlier(time = random_times[4], parameter = random_parameters[4]) %>%
  temporary_change(time = random_times[5], parameter = random_parameters[5]) %>%
  temporary_change(time = random_times[6], parameter = random_parameters[6])
 y_clean <- try(auto_clean(y_contaminated, frequency = 52, maxit.iloop = 20, maxit.oloop = 20, types = c("AO","TC"), 
                       auto_arima_opts = list(seasonal = FALSE), method = "full", cval = 3.5, check.rank = T), silent = TRUE)
 if (inherits(y_clean,'mod-error')) {
  stat <- as.numeric(NA)
 } else {
  if (NROW(na.omit(y_clean)) != NROW(y)) {
   stat <- as.numeric(NA)
  } else {
   stat <- mape(y, y_clean)
  }
 }
  return(data.table(sim = i, mape = stat))
}, future.seed = TRUE, future.packages = c("tsets","tsaux","xts","data.table","magrittr"))
plan(sequential)
simulation <- rbindlist(simulation)

ggplot(simulation, aes(x = mape*100)) + 
 geom_density(adjust = 2, alpha = 0.5, fill = "orange", colour = NA) + 
 ggthemes::theme_pander() + ylab("") + 
 xlab("Goodness of Fit (%MAPE)") + ggtitle("Decontaminated Series")

The very low MAPE we observe overall provides clear evidence that the detection algorithm performs quite well in eliminating the anomalies to the point where the decontaminated data is almost identical to the original series.

Future Anomalies: Incorporating Uncertainty

In some cases, we may be interested in incorporating the uncertainty of future anomalies in the data.⁵ There are many ways to address this, but here we consider a change of distribution by infusing non-normal errors into the predict function. The example below illustrates how to use a skewed and heavy tailed distribution. This leaves the standard deviation of the decontaminated model intact, but allows for fatter tails and skewness. However, it would also be possible to simply change the standard deviation to a higher value and continue to use the Normal distribution.

set.seed(12111)
random_parameters <- runif(6, 0.5, 1)
 random_times <- sample(2:((52*5) - 1), 6, replace = FALSE)
 y_contaminated <- y %>% additive_outlier(time = random_times[1], parameter = random_parameters[1]) %>% 
  additive_outlier(time = random_times[2], parameter = random_parameters[2]) %>% 
  additive_outlier(time = random_times[3], parameter = random_parameters[3]) %>%
  additive_outlier(time = random_times[4], parameter = random_parameters[4]) %>%
  temporary_change(time = random_times[5], parameter = random_parameters[5]) %>%
  temporary_change(time = random_times[6], parameter = random_parameters[6])
 y_clean <- try(auto_clean(y_contaminated, frequency = 52, maxit.iloop = 20, maxit.oloop = 20, types = c("AO","TC"), 
                       auto_arima_opts = list(seasonal = FALSE), method = "full", cval = 3.5, check.rank = T), silent = TRUE)
model_contaminated <- estimate(ets_modelspec(y_contaminated, model = "AAN", frequency = 52))
model_clean <- estimate(ets_modelspec(y_clean, model = "AAN", frequency = 52))
nig_distribution <- estimate(distribution_modelspec(scale(residuals(model_contaminated, raw = TRUE)), 
                                                    distribution = "nig"))
r <- rdist("nig", n = 5000 * 52, mu = 0, sigma = 1, 
           skew = coef(nig_distribution)["skew"], shape = coef(nig_distribution)["shape"])
r <- matrix(r, ncol = 52, nrow = 5000)
p_clean_nig <- predict(model_clean, h = 52, nsim = 5000, innov = r, innov_type = "z")
p_clean_norm <- predict(model_clean, h = 52, nsim = 5000)

par(mar = c(3,3,3,3), mfrow = c(1,1))
plot(p_clean_nig, gradient_color = "white", interval_color = "steelblue", 
     interval_quantiles = c(0.005, 0.995), interval_type = 1, 
      main = "Prediction [99% Coverage]")
plot(p_clean_norm$distribution, interval_color = "orange", 
     interval_quantiles = c(0.005 , 0.995), add = TRUE, interval_type = 1)
lines(index(y), as.numeric(y_contaminated), col = 3)
legend("topleft", c("Clean|Series","Contaminated|Series",
                    "Prediction|NIG","Prediction|Norm"), 
       col = c("red","green","steelblue","orange"), lty = 1, bty = "n")

With 99% coverage. we can see that the NIG distributed errors provide for heavier tails, skewed towards positive shocks, which is what we observed given the way we generated the anomalies (to be positive).

Conclusion

Anomalies contaminate process dynamics with noise which is not part of normal variation. This make it difficult to extract clean signals and should therefore be addressed as part of any forecasting strategy. This should be distinct from how one thinks about future uncertainty which can be addressed separately.

Ensembling Predictive Distributions

When ensembling predictive distributions on the same series, it’s important to consider how to ensemble them given the fact that they are unlikely to be independent.

This can be seen from an investigation of the model residuals and their correlations. As demonstrated in the tsmethods ensembling section, we can make use of a copula to generate correlated uniform variates which can then be passed to the predict function of any of the tsmodels packages which then convert them into innovations. In this way, the conditional 1-step ahead errors will at least retain their dependence and the distributions will be ensembled in a more accurate way. If instead we were to assume independence, then the coverage of the ensembled predictions would significantly underestimate the true coverage as a result of assuming that the off diagonals of the covariance of series residuals were zero.

A similar argument follows when ensembling for the purpose of aggregation, which is more typical in hierarchical forecasting approaches.

Demonstration

For the purpose of this article, we use the gas data set, which is available in the tsdatasets package, representing the US finished motor gasoline products supplied (in thousands of barrels per day) from February 1991 to May 2005. This is a weekly data set with seasonal and trend components.

While we could consider multiple different models, for this example we only consider the rather flexible innovations state space model (issm) with level, slope, trigonometric seasonality and ARMA terms. Whether to include or not the slope, slope dampening, the number of harmonics and the number of ARMA terms is what will determine the models we use for ensembling. To this end, we will enumerate a space of combinations using the auto_issm function to obtain a selection matrix ranked by AIC. We then choose the top 5 models for ensembling.

We split out data into a training set and leave a year (52 weeks) for testing.

# Load packages and data
library(tsissm)
library(xts)
library(data.table)
library(future)
library(progressr)
library(copula)
library(tsmethods)
data("gas", package = "tsdatasets")
n <- NROW(gas)
train <- gas[1:(n - 52)]
test <- tail(gas, 52)

plan(list(
 tweak(remote, workers = "home_server"),
 tweak(multiprocess, workers = 60)
))
mod <- auto_issm(train, slope = c(TRUE, FALSE), seasonal_damped = c(TRUE, FALSE), 
                 seasonal = TRUE, seasonal_frequency = 52, 
                 seasonal_type = "trigonometric", seasonal_harmonics = list(4:12), 
                 ar = 0:5, ma = 0:5, return_table = TRUE, trace = FALSE)
plan(sequential)

print(head(mod$selection))

##     iter  slope slope_damped seasonal    ar    ma    K1
##    <int> <lgcl>       <lgcl>   <lgcl> <int> <int> <int>
## 1:   941   TRUE        FALSE     TRUE     1     4    12
## 2:   956   TRUE        FALSE     TRUE     0     5    12
## 3:   958   TRUE         TRUE     TRUE     1     5    12
## 4:   776   TRUE        FALSE     TRUE     0     1    11
## 5:   800   TRUE        FALSE     TRUE     2     2    11
## 6:   773   TRUE        FALSE     TRUE     5     0    11
##         AIC       MAPE
##       <num>      <num>
## 1: 11879.73 0.01920864
## 2: 11880.63 0.01911436
## 3: 11914.47 0.01938119
## 4: 11924.07 0.01987139
## 5: 11933.70 0.01979659
## 6: 11934.09 0.01974837

The returned selection table shows the list of different model choices ranked from lowest to highest AIC for the training data used. We proceed by calculating the correlation of the model residuals for use in generating random uniform variates from a Normal Copula.

mod_list <- lapply(1:5, function(i){
 spec <- issm_modelspec(train, slope = mod$selection[i]$slope, slope_damped = mod$selection[i]$slope_damped, 
                        seasonal_frequency = 52,
                        seasonal = mod$selection[i]$seasonal, seasonal_type = "trigonometric",
                        seasonal_harmonics = mod$selection[i]$K1, ar = mod$selection[i]$ar,
                        ma = mod$selection[i]$ma)
 mod <- estimate(spec)
 return(mod)
})
r <- do.call(cbind, lapply(1:5, function(i){
 residuals(mod_list[[i]], raw = TRUE)
}))
colnames(r) <- paste0("model",1:5)
C <- cor(r, method = "kendall")
print(C, digits = 2)

##        model1 model2 model3 model4 model5
## model1   1.00   0.82   0.80   0.75   0.77
## model2   0.82   1.00   0.96   0.84   0.87
## model3   0.80   0.96   1.00   0.85   0.87
## model4   0.75   0.84   0.85   1.00   0.95
## model5   0.77   0.87   0.87   0.95   1.00

We generate the 5000 (samples) by 52 (forecast horizon) random draws from the Normal Copula and pass them to the predict function. All models in the tsmodels framework accept either uniform (innov_type = “q”), standardized (innov_type = “z”) or non-standardized innovations (innov_type = “r”). In the former case the quantile transformation will be applied to transform the uniform values to standard normal innovations. The resulting standardized innovations are then re-scaled to have standard deviation equal to that of the estimated models’ residuals.

cop <- normalCopula(P2p(C), dim = 5, dispstr = "un")
U <- rCopula(52 * 5000, cop)
predictions <- lapply(1:5, function(i){
 predict(mod_list[[i]], h = 52, nsim = 5000, innov = U[,i], innov_type = "q")
})

The final step is to ensemble the forecasts for which we make use of the functionality from the tsmethods package which takes a list of tsmodel.predict objects and ensembles them.²

weights <- rep(1/5, 5)
spec <- ensemble_modelspec(predictions)
p <- tsensemble(spec, weights = weights)
# infuse some additional information into the ensembled object so we can use
# other methods on this
class(p) <- c("tsissm.predict", class(p))
p$frequency <- 52
predictions[[6]] <- p

Comparing our predictions across each of the 5 models and the ensembled one, against the testing data set, we observe some interesting, but not surprising findings. The top model selected by AIC during the training phase now has the second worst performance in the testing phase, whereas the 4th worst model by AIC in the training now has the best performance in the testing phase. This should make clear the comments made in the introduction about future uncertainty. The ensemble model sits right in the middle, coming in third in terms of MAPE, and second in terms of the distribution calibration metrics (MIS and CRPS).

prediction_metrics <- do.call(rbind, lapply(1:6, function(i){
 tsmetrics(predictions[[i]], actual = test, alpha = 0.1)
}))
rownames(prediction_metrics) <- c(paste0("model",1:5),"ensemble")
prediction_metrics

##           h       MAPE      MASE        MSLRE          BIAS
## model1   52 0.02069121 0.5739093 0.0006255166 -0.0014976744
## model2   52 0.02194529 0.6087442 0.0007034767 -0.0004547551
## model3   52 0.02248476 0.6237508 0.0007739192 -0.0063832761
## model4   52 0.02847264 0.7895135 0.0011947730 -0.0030526928
## model5   52 0.02034886 0.5643485 0.0006353729 -0.0006761913
## ensemble 52 0.02087266 0.5792841 0.0006744860 -0.0024129179
##                MIS     CRPS
## model1    913.8911 130.4708
## model2   1044.9567 140.3905
## model3   1121.0820 147.7341
## model4   1321.6796 180.0566
## model5   1056.5165 134.4742
## ensemble 1031.4426 136.0655

plot(p, n_original = 52*4, xlab = "", main = "Ensemble GAS Prediction", 
     gradient_color = "yellow", interval_color = "orange")
lines(index(test), as.numeric(test), col = "violet", lwd = 2)

Some Additional Notes

Because the models were all estimated with the same transformation³, their state decompositions can also be ensembled. This could be particularly useful should custom views need to be incorporated into the prediction, which is usually done on the Trend component or the growth rate, allowing one to rebuild the full predictive distribution after intervening in some part of the state decomposition.

Conclusion

There should be no doubt about the value of ensembling. The key takeaway is: When in doubt, ensemble.

Introduction

The Generalized Hyperbolic Skew Student distribution, described in (Aas and Haff 2006), is a sub-family of the Generalized Hyperbolic distribution of (Barndorff-Nielsen 1977). It has the unique property of allowing the 2 tails to exhibit different behaviors, namely one polynomial and one exponential. This is important in some applications such as financial time series where negative shocks exhibit heavy tails, whereas positive shocks have a more Gaussian type tail.

Tail Behavior

This distribution is a limiting case of the Generalized Hyperbolic when and , where is the shape parameter of the Student distribution. The domain of variation of the parameters is and , but for the variance to be finite , while for the existence of skewness and kurtosis, and respectively.

Following (Aas and Haff 2006), the heaviest tail decays as:

and the semi-heavy tail decays as:

The skew and shape parameters of the standardized parameterization in the tsdistributions have bounds and respectively. The further the skew parameter is from zero and the smaller the shape parameter is, the larger the skewness. The plot below illustrates an example of the tail behavior that can be generated from this distribution.

library(tsdistributions)
library(data.table)
library(ggplot2)
f1 <- function(x) ddist("ghst", x, 0, 1, skew = -30, shape = 30)
f2 <- function(x) ddist("ghst", x, 0, 1, skew = -30, shape = 10)
ggplot(NULL, aes(c(-6,6))) + 
  geom_area(aes(colour = "plotA", fill = "plotA"), stat = "function", fun = f1, fill = "orange", alpha = 0.4, xlim = c(-6, 6)) + 
  geom_area(aes(colour = "plotB", fill = "plotB"), stat = "function", fun = f2, fill = "steelblue", alpha = 0.4, xlim = c(-6, 6)) +
  ggthemes::theme_tufte() + xlab("") + 
  ylab("") + 
  ggtitle("The GHST") + 
  theme(legend.position = "right") + 
  scale_fill_manual(name = " ", values =  c(plotA = "orange", plotB = "steelblue"), aesthetics = c("colour","fill"),
                    labels = c("{skew = -30, shape = 30}","{skew = -30, shape = 10}"))

With a skew parameter of -30 common across both, the orange distribution has a shape parameter of 30 with skewness and excess kurtosis of (-0.92, 1.9) while the blue distribution has a shape parameter of 10 with skewness and excess kurtosis of (-3.37, 40.15). For the blue distribution (with the lower shape parameter) the lower heavy and upper semi-heavy tails are quite obvious and hopefully illustrate the value of this distributions for a number of possible applications.

Parameter Distribution and Consistency

The question of how much data (size) is needed to confidently estimate the true parameter values is one we address here through a small simulation exercise.

Let’s assume that that the true parameters are given , , and . We simulate 2000 draws from sizes of 100, 200, 400, 800, 1200, 1600, 3200 and estimate their parameters. In order to ensure the existence of the higher moments, we also set a lower bound for the shape parameter at 9 and use parallel computation to speed things up.

library(future.apply)
plan(list(
    tweak(remote, workers = "home_server"),
    tweak(multisession, workers = 100)
))
pars %<-% future_lapply(X = 1:2000, function(i){
  r <- rdist("ghst", n = 3200, mu = 0.1, sigma = 0.5, skew = -5, shape = 12)
  sim_lengths <- c(100, 200, 400, 800, 1200, 1600, 3200)
  x <- lapply(sim_lengths, function(j){
   spec <- distribution_modelspec(r[1:j], "ghst")
   spec$parmatrix[parameter == "shape", lower := 9]
   mod <- try(estimate(spec), silent = TRUE)
   if (inherits(mod, "try-error")) {
    v <- rep(as.numeric(NA), 4)
    .skewness <- as.numeric(NA)
    .kurtosis <- as.numeric(NA)
   } else {
    v <- coef(mod)
    .skewness <- dskewness("ghst", skew = v[3], shape = v[4])
    .kurtosis <- dkurtosis("ghst", skew = v[3], shape = v[4])
   }
   return(data.table(sim = i, size = j, mu = as.numeric(v[1]), sigma = as.numeric(v[2]), 
                     skew = as.numeric(v[3]), shape = as.numeric(v[4]),
                     skewness = .skewness, kurtosis = .kurtosis))
  })
  x <- rbindlist(x)
  return(x)
}, future.packages = c("data.table","tsdistributions","tsmethods"), future.seed = TRUE)
pars <- eval(pars)
pars <- rbindlist(pars)
pars <- pars[!is.na(mu)]
plan(sequential)

p1 <- ggplot(pars, aes(mu, fill = size, colour = size)) + 
  xlim(0, 0.2) +
  geom_density(alpha = 0.1, adjust = 2) + 
  geom_vline(xintercept = 0.1, colour = "black", linetype = "longdash") + 
  labs(title = "GHST[mu]") + 
  ylab("") + 
  xlab("") + 
  ggthemes::theme_pander()
p2 <- ggplot(pars, aes(sigma, fill = size, colour = size)) + 
  xlim(0.25, 0.75) +
  geom_density(alpha = 0.1, adjust = 2) + 
  geom_vline(xintercept = 0.5, colour = "black", linetype = "longdash") + 
  labs(title = "GHST[sigma]") + 
  ylab("") + 
  xlab("") + 
  ggthemes::theme_pander()
p3 <- ggplot(pars, aes(skew, fill = size, colour = size)) + 
  xlim(-15, 0) +
  geom_density(alpha = 0.1, adjust = 3) + 
  geom_vline(xintercept = -5, colour = "black", linetype = "longdash") + 
  labs(title = "GHST[skew]") + 
  ylab("") + 
  xlab("") + 
  ggthemes::theme_pander()
p4 <- ggplot(pars, aes(shape, fill = size, colour = size)) + 
  xlim(0, 24) + 
  geom_density(alpha = 0.1, adjust = 3) + 
  geom_vline(xintercept = 12, colour = "black", linetype = "longdash") + 
  labs(title = "GHST[shape]") + 
  ylab("") + 
  xlab("") + 
  ggthemes::theme_pander()
exact_skewness <- dskewness("ghst", skew = -5, shape = 12)
exact_kurtosis <- dkurtosis("ghst", skew = -5, shape = 12)
p5 <- ggplot(pars, aes(skewness, fill = size, colour = size)) + 
  xlim(exact_skewness * 2, 0) + 
  geom_density(alpha = 0.1, adjust = 3) + 
  geom_vline(xintercept = exact_skewness, colour = "black", linetype = "longdash") + 
  labs(title = "GHST[skewness]") + 
  ylab("") + 
  xlab("") + 
  ggthemes::theme_pander()
p6 <- ggplot(pars, aes(kurtosis, fill = size, colour = size)) + 
  xlim(0, exact_kurtosis * 2) +
  geom_density(alpha = 0.1, adjust = 3) +  
  geom_vline(xintercept = exact_kurtosis, colour = "black", linetype = "longdash") + 
  labs(title = "GHST[excess kurtosis]") + 
  ylab("") + 
  xlab("") + 
  ggthemes::theme_pander()
grid.arrange(p1,p2,p3,p4,p5,p6, nrow = 3, ncol = 2)

skew_mape <- pars[,list(mape = mean(abs((skew - -5)/(-5)))), by = "size"]
p3 <- ggplot(skew_mape, aes(y = mape, x = size)) + geom_line() + 
  labs(title = "GHST[skew]") + 
  xlab("") +  ylab("") + 
  scale_y_continuous(labels = scales::percent)
shape_mape <- pars[,list(mape = mean(abs((shape - 12)/12))), by = "size"]
p4 <- ggplot(shape_mape, aes(y = mape, x = as.numeric(size))) + geom_line() + 
  labs(title = "GHST[shape]") + 
  xlab("") +  ylab("") + 
  scale_y_continuous(labels = scales::percent)
skewness_mape <- pars[,list(mape = mean(abs((skewness - exact_skewness)/exact_skewness))), by = "size"]
p5 <- ggplot(skewness_mape, aes(y = mape, x = as.numeric(size))) + geom_line() + 
  labs(title = "GHST[skewness]") + 
  xlab("") +  ylab("") + 
  scale_y_continuous(labels = scales::percent)
kurtosis_mape <- pars[,list(mape = mean(abs((kurtosis - exact_kurtosis)/exact_kurtosis))), by = "size"]
p6 <- ggplot(kurtosis_mape, aes(y = mape, x = as.numeric(size))) + geom_line() + 
  labs(title = "GHST[excess kurtosis]") + 
  xlab("") + ylab("") + 
  scale_y_continuous(labels = scales::percent) 
grid.arrange(p3,p4,p5,p6, nrow = 2, ncol = 2)

plot(pars$kurtosis + 3, pars$skewness, ylab = "Skewness", xlab = "Kurtosis")
abline(v = exact_kurtosis + 3, h = exact_skewness, col = 2, lty = 2)
points(exact_kurtosis + 3, exact_skewness, pch = 2, lwd = 2, col = 2)

Final Thoughts

The GHST distribution has some interesting properties, but we also found that a considerable amount of data is needed to provide confident estimates of the higher moments, and we suspect this gets worse the lower the shape parameter is. This could also be due to the fact that our estimation code makes use of the modified Bessel function of the second kind for which the derivatives are not yet implemented. An implementation exists in Julia based on the paper by (Geoga et al. 2022) and it may be worthwhile porting this to TMB in the future.