Skip to content

Commit

Permalink
Added user-options to decide whether (I) a bias correction to externa…
Browse files Browse the repository at this point in the history 
…l point forecasts should be performed and (II) certain signals must be included in the subset combinations.
  • Loading branch information
@lehmasve
lehmasve committed Jun 4, 2024
1 parent d9912d9 commit 52a7026
Show file tree
Hide file tree
Showing 15 changed files with 2,104 additions and 1,648 deletions.
12 changes: 6 additions & 6 deletions R/RcppExports.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -29,15 +29,15 @@ dsc_loop <- function(weights, gamma, psi, oos_target_var, oos_forecast_tvp, oos_
.Call(`_hdflex_dsc_loop`, weights, gamma, psi, oos_target_var, oos_forecast_tvp, oos_variance_tvp, len_para_grid, oos_length, n_models)
}

stsc_loop_ <- function(y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, risk_aversion_ = NULL, min_weight_ = NULL, max_weight_ = NULL) {
.Call(`_hdflex_stsc_loop_`, y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, risk_aversion_, min_weight_, max_weight_)
stsc_loop_ <- function(y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, bias, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, incl_, risk_aversion_, min_weight_, max_weight_) {
.Call(`_hdflex_stsc_loop_`, y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, bias, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, incl_, risk_aversion_, min_weight_, max_weight_)
}

stsc_loop_par_ <- function(y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, n_threads, risk_aversion_ = NULL, min_weight_ = NULL, max_weight_ = NULL) {
.Call(`_hdflex_stsc_loop_par_`, y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, n_threads, risk_aversion_, min_weight_, max_weight_)
stsc_loop_par_ <- function(y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, bias, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, incl_, n_threads, risk_aversion_, min_weight_, max_weight_) {
.Call(`_hdflex_stsc_loop_par_`, y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, burn_in_tvc, bias, gamma_grid, psi_grid, delta, burn_in_dsc, method, equal_weight, incl_, n_threads, risk_aversion_, min_weight_, max_weight_)
}

tvc_ <- function(y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid) {
.Call(`_hdflex_tvc_`, y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid)
tvc_ <- function(y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, bias) {
.Call(`_hdflex_tvc_`, y, X_, Ext_F_, sample_length, lambda_grid, kappa_grid, bias)
}

419 changes: 235 additions & 184 deletions R/stsc.R
View file

Large diffs are not rendered by default.

59 changes: 36 additions & 23 deletions R/tvc.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -16,6 +16,8 @@
#' @param Ext_F A matrix with `T` rows containing
#' point forecasts of y in each column.
#' Use NULL if no point forecasts shall be included.
#' @param sample_length An integer that denotes the number of observations used
#' to initialize the observational variance and the coefficients' variance.
#' @param lambda_grid A numeric vector denoting the discount factor(s)
#' that control the dynamics of the coefficients.
#' Each signal in combination with each value of
Expand All @@ -27,8 +29,10 @@
#' Constant variance is nested for the case `kappa = 1`.
#' Each signal in combination with each value of
#' kappa provides a separate forecast.
#' @param sample_length An integer that denotes the number of observations used
#' to initialize the observational variance and the coefficients' variance.
#' @param bias A boolean to indicate whether the TVC-Models should
#' perform a bias correction to external point forecasts
#' (TRUE -> time-varying intercept) or
#' take it 'as is' (FALSE -> constant intercept of 0.0).
#' @return A list that contains:
#'
#' * (1) a matrix with the first moments (point forecasts)
Expand Down Expand Up @@ -75,43 +79,45 @@
#'
#' ########## Get Data ##########
#' # Load Data
#' inflation_data <- inflation_data
#' benchmark_ar2 <- benchmark_ar2
#' inflation_data <- inflation_data
#' benchmark_ar2 <- benchmark_ar2
#'
#' # Set Index for Target Variable
#' i <- 1 # (1 -> GDPCTPI; 2 -> PCECTPI; 3 -> CPIAUCSL; 4 -> CPILFESL)
#' i <- 1 # (1 -> GDPCTPI; 2 -> PCECTPI; 3 -> CPIAUCSL; 4 -> CPILFESL)
#'
#' # Subset Data (keep only data relevant for target variable i)
#' dataset <- inflation_data[, c(1+(i-1), # Target Variable
#' 5+(i-1), # Lag 1
#' 9+(i-1), # Lag 2
#' (13:16)[-i], # Remaining Price Series
#' 17:452, # Exogenous Predictor Variables
#' seq(453+(i-1)*16,468+(i-1)*16))] # Ext. Point Forecasts
#' dataset <- inflation_data[, c(1+(i-1), # Target Variable
#' 5+(i-1), # Lag 1
#' 9+(i-1), # Lag 2
#' (13:16)[-i], # Remaining Price Series
#' 17:452, # Exogenous Predictor Variables
#' seq(453+(i-1)*16,468+(i-1)*16))] # Ext. Point Forecasts
#'
#' ########## STSC ##########
#' ### Part 1: TV-C Model ###
#' # Set Target Variable
#' y <- dataset[, 1, drop = FALSE]
#' y <- dataset[, 1, drop = FALSE]
#'
#' # Set 'Simple' Signals
#' X <- dataset[, 2:442, drop = FALSE]
#' X <- dataset[, 2:442, drop = FALSE]
#'
#' # Set External Point Forecasts (Koop & Korobilis 2023)
#' Ext_F <- dataset[, 443:458, drop = FALSE]
#' Ext_F <- dataset[, 443:458, drop = FALSE]
#'
#' # Set TV-C-Parameter
#' sample_length <- 4 * 5
#' lambda_grid <- c(0.90, 0.95, 1)
#' kappa_grid <- 0.98
#' sample_length <- 4 * 5
#' lambda_grid <- c(0.90, 0.95, 1)
#' kappa_grid <- 0.98
#' bias <- TRUE
#'
#' # Apply TV-C-Function
#' results <- hdflex::tvc(y,
#' X,
#' Ext_F,
#' sample_length,
#' lambda_grid,
#' kappa_grid,
#' sample_length)
#' bias)
#'
#' # Assign TV-C-Results
#' forecast_tvc <- results[[1]]
Expand Down Expand Up @@ -222,10 +228,11 @@
tvc <- function(y,
X,
Ext_F,
sample_length,
lambda_grid,
kappa_grid,
sample_length) {
bias) {

########################################################
### Checkmate
# Check if y is numeric vector without missing / infinite values
Expand Down Expand Up @@ -267,21 +274,26 @@ tvc <- function(y,
any.missing = FALSE,
finite = TRUE)

# Check if bias is Boolean
checkmate::assertLogical(bias,
len = 1,
any.missing = FALSE)

# Check if sample_length is Integer between 2 and N
checkmate::assertInt(sample_length,
lower = 2,
upper = length(y))

# Check if any column in X is constant for the first observations
if (!is.null(X)) {
if (any(apply(X[1:sample_length, , drop = FALSE], 2, function(x) length(unique(x)) == 1))) {
if (any(apply(X, 2, function(x) length(unique(na.omit(x)[1:sample_length])) == 1))) {
print("One or more columns in X are constant for the first 1:sample_length observations.")
}
}

# Check if any column in Ext_F is constant for the first observations
if (!is.null(Ext_F)) {
if (any(apply(Ext_F[1:sample_length, , drop = FALSE], 2, function(x) length(unique(x)) == 1))) {
if (any(apply(Ext_F, 2, function(x) length(unique(na.omit(x)[1:sample_length])) == 1))) {
print("One or more columns in Ext_F are constant for the first 1:sample_length observations.")
}
}
Expand All @@ -293,7 +305,8 @@ tvc <- function(y,
Ext_F,
sample_length,
lambda_grid,
kappa_grid)
kappa_grid,
bias)

### Assign Results
forecast_tvc <- tvc_results[[1]]
Expand Down
Loading

0 comments on commit 52a7026

Please sign in to comment.