tests/testthat/test-tvc.R

In hdflex: High-Dimensional Aggregate Density Forecasts

###########################################################
### Simulate Data
# Set Seed
set.seed(123)

# Set Dimensions
n_obs <- 500
n_sigs <- 90

### Simulate Data
# Generate Covariates
X <- matrix(rnorm(n_obs * n_sigs), nrow = n_obs, ncol = n_sigs)

# Generate Beta-Coefficients
n_relevant <- 10
beta <- runif(n_relevant, -1.0, 1.0)

# Compute f(x)
f_x <- X[, seq(n_relevant)] %*% beta

# Generate Error-Term
eps <- rnorm(n_obs)

# Calculate Response
y <- as.matrix(f_x + eps, ncol = 1)

# F-Signals 
Ext_F <- matrix(rep(y, 10), nrow = n_obs, ncol = 10) + rnorm(n_obs * 10)

# Add Names
colnames(X) <- paste0("X", seq_len(n_sigs))
colnames(y) <- "response"
colnames(Ext_F) <- paste0("F", seq_len(10))

###########################################################
### STSC Parameter
# TV-C-Parameter
init <- 10
lambda_grid <- c(0.95, 1.00)
kappa_grid <- c(0.95, 0.97)
bias <- TRUE

###########################################################
### Test TVC
test_that("Test TVC", {

  # Apply TVC-Function
  results <- hdflex::tvc(y,
                         X,
                         Ext_F,
                         init,
                         lambda_grid,
                         kappa_grid,
                         bias)

  # List Contains three Elements
  expect_equal(length(results), 2)

  # Forecasts List Contains three Elements
  expect_equal(length(results$Forecasts), 3)

  # Point Forecasts
  expect_matrix(results$Forecasts$Point_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Variance Forecasts
  expect_matrix(results$Forecasts$Variance_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Ensure minimum value is 0
  expect_true(all(results$Forecasts$Variance_Forecasts[-1, ] >= 0))

  # Realization
  expect_numeric(results$Forecasts$Realization,
                            len = n_obs,
                            finite = TRUE)

  # Model List Contains 4 Elements
  expect_equal(length(results$Model), 4)

  # Lambda Grid
  expect_numeric(results$Model$Lambda_grid,
                            len = length(lambda_grid),
                            finite = TRUE)

  # Kappa Grid
  expect_numeric(results$Model$Kappa_grid,
                            len = length(kappa_grid),
                            finite = TRUE)

  # Init
  expect_numeric(results$Model$Init,
                            len = 1,
                            finite = TRUE)

  # Bias
  expect_logical(results$Model$Bias,
                            len = 1,
                            any.missing = FALSE)
})

###########################################################
### Test STSC with X
test_that("Test whether the STSC-Function works with X", {

  # Apply TVC-Function
  results <- hdflex::tvc(y,
                         X,
                         NULL,
                         init,
                         lambda_grid,
                         kappa_grid,
                         bias)

  # List Contains three Elements
  expect_equal(length(results), 2)

  # Forecasts List Contains three Elements
  expect_equal(length(results$Forecasts), 3)

  # Point Forecasts
  expect_matrix(results$Forecasts$Point_Forecasts,
                           nrow = n_obs,
                           ncol = ncol(X) * length(lambda_grid) * length(kappa_grid))

  # Variance Forecasts
  expect_matrix(results$Forecasts$Variance_Forecasts,
                           nrow = n_obs,
                           ncol = ncol(X) * length(lambda_grid) * length(kappa_grid))

  # Ensure minimum value is 0
  expect_true(all(results$Forecasts$Variance_Forecasts[-1, ] >= 0))
})

###########################################################
### Test STSC with Ext_F
test_that("Test whether the STSC-Function works with Ext_F", {

  # Apply TVC-Function
  results <- hdflex::tvc(y,
                         NULL,
                         Ext_F,
                         init,
                         lambda_grid,
                         kappa_grid,
                         bias)

  # List Contains three Elements
  expect_equal(length(results), 2)

  # Forecasts List Contains three Elements
  expect_equal(length(results$Forecasts), 3)

  # Point Forecasts
  expect_matrix(results$Forecasts$Point_Forecasts,
                           nrow = n_obs,
                           ncol =  ncol(Ext_F) * length(lambda_grid) * length(kappa_grid))

  # Variance Forecasts
  expect_matrix(results$Forecasts$Variance_Forecasts,
                           nrow = n_obs,
                           ncol = ncol(Ext_F) * length(lambda_grid) * length(kappa_grid))

  # Ensure minimum value is 0
  expect_true(all(results$Forecasts$Variance_Forecasts[-1, ] >= 0))
})

###########################################################
### Test TVC without Bias Correction
test_that("Test TVC without Bias Correction", {

  # Apply TVC-Function
  results <- hdflex::tvc(y,
                         X,
                         Ext_F,
                         init,
                         lambda_grid,
                         kappa_grid,
                         FALSE)

  # List Contains three Elements
  expect_equal(length(results), 2)

  # Forecasts List Contains three Elements
  expect_equal(length(results$Forecasts), 3)

  # Point Forecasts
  expect_matrix(results$Forecasts$Point_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Variance Forecasts
  expect_matrix(results$Forecasts$Variance_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Ensure minimum value is 0
  expect_true(all(results$Forecasts$Variance_Forecasts[-1, ] >= 0))
})

###########################################################
### Test TVC with Missing Values
test_that("Test TVC with Missing / Constant Values", {

  # Add Missing Values
  X[1, 1:10] <- NA
  Ext_F[1, 1:10] <- NA

  X[2, 1:10] <- 1
  Ext_F[2, 1:10] <- 1

  # Apply TVC-Function
  results <- hdflex::tvc(y,
                         X,
                         Ext_F,
                         init,
                         lambda_grid,
                         kappa_grid,
                         bias)

  # List Contains three Elements
  expect_equal(length(results), 2)

  # Forecasts List Contains three Elements
  expect_equal(length(results$Forecasts), 3)

  # Point Forecasts
  expect_matrix(results$Forecasts$Point_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Variance Forecasts
  expect_matrix(results$Forecasts$Variance_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Ensure minimum value is 0
  expect_true(all(results$Forecasts$Variance_Forecasts[-c(1:11), ] >= 0))
})

###########################################################
### Test TVC without providing colnames
test_that("Test TVC without providing colnames", {

  # Remove Colnames
  colnames(X) <- NULL
  colnames(y) <- NULL

  # Apply TVC-Function
  results <- hdflex::tvc(y,
                         X,
                         Ext_F,
                         init,
                         lambda_grid,
                         kappa_grid,
                         bias)

  # List Contains three Elements
  expect_equal(length(results), 2)

  # Forecasts List Contains three Elements
  expect_equal(length(results$Forecasts), 3)

  # Point Forecasts
  expect_matrix(results$Forecasts$Point_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Variance Forecasts
  expect_matrix(results$Forecasts$Variance_Forecasts,
                           nrow = n_obs,
                           ncol = (ncol(X) + ncol(Ext_F)) * length(lambda_grid) * length(kappa_grid))

  # Ensure minimum value is 0
  expect_true(all(results$Forecasts$Variance_Forecasts[-1, ] >= 0))
})