Forecasting variance

For starters

Load the data & the packages.

library(tidyverse)
library(lubridate)
library(viridis)
library(Rcpp)
sourceCpp("c_functions.cpp")
source("r_func.R")
load("data_exp.RData")
t_vec <- data_exp$date[25:1788]                    # vector of dates
time <- as.Date("1937-10-15")                      # point in time
y <- "svar"                                        # name of dependent variable
x <- "lty"                                        # name of predictor 
TT <- 60                                           # sample size
y_mat <- 1                                         # y maturity
#rolling(y, x, time, y_mat, TT, t_vec, data_exp)   # Just testing

More stock variance forward for prediction purpose.

data_exp <- data_exp %>%
    mutate(svar = lead(svar)) %>%
    na.omit()

The long list of parameters.

TT <- c(6, 12, 24, 36, 60, 84, 120)                # Choices of sample size
N_TT <- length(TT)                                 # Number of TTs
y <- c("svar")     # Dependent variables
not_x <- c("date", "svar", "r01m", "r03m", "r06m", "r12m", "r24m")
x <- colnames(data_exp)[!(colnames(data_exp) %in% not_x)]  # Name of predictors: BEWARE HARD CODED
year <-  1937:2017                                 # All years for study
month <- 1:12                                      # Months
pars <- expand.grid(y, x, TT, year, month)         # ALL COMBINATIONS!
y <- pars[,1]                                      # Retrieving x
x <- pars[,2]                                      # Retrieving y
TT <- pars[,3]                                     # Retrieving TT
time <- make_date(year = pars[,4],                 # Making dates
                  month = pars[,5], 
                  day = 15)
y_mat <- rep(1, nrow(pars))                        # how far to go bakc in time for the training sample
t_vec <- data_exp$date %>% unique()                # Vector of dates, also for the training sample selection

The core task

tictoc::tic()                         # To compute CPU time
test_var <- pmap_df(list(y = y,           # This is the functional part
                     x = x, 
                     time = time,
                     y_mat = y_mat,
                     TT = TT), 
                rolling,              # These arguments are outside the list!
                t_vec = t_vec,
                data = data_exp)
tictoc::toc()
#save(test_var, file = "test_var.RData")

A bit of data wrangling.

source <- test_var %>%                # Order first according to TT, then the rest
    arrange(TT, y, x, time)
L <- nrow(source)/N_TT            # Number of rows for each value of TT
colnums <- c(1,2,3,4,5,20,21,22)  # Be careful!!!
for(j in 1:(N_TT-1)){             # Overwriting the columns to keep 120-point estimates only
    source[((j-1)*L+1):(j*L), colnums] <- source[((N_TT-1)*L+1):(N_TT*L),colnums]
}


res_var <- source %>%                 
    na.omit() %>%                 # Remove missing values
    mutate(error = y_test - pred, # Add error
           e2 = error^2)          # Add squared error
# save(res_var, file = "res_var.RData")     # Save

pers <- bind_rows(
    bind_cols(x = c("bm", "de12", "dfy", "dp12", "ep12", "lty", "tbl", "tms"), pers = rep("high",8)),
    bind_cols(x = c("svar", "temp", "D_de12"), pers = rep("medium",3)),
    bind_cols(x = c("D_dp12", "D_ep12", "dfr", "ltr"), pers = rep("low",4) ))

res_var <- res_var %>%
    mutate(date = as.Date(date)) %>%
    left_join(pers, by = "x") 
res_var$pers <- as.factor(res_var$pers)

prediction_threshold <- 3
res_var %>%
    filter(pred > 0, pred < prediction_threshold) %>%
    group_by(x, y, TT, pers) %>%
    summarise(mse = mean(e2),
              m_sy = mean(sig2_y),
              v_y = var(y_test)) %>%
    ggplot(aes(x = TT, y = 1 - mse/v_y, color = as.factor(pers))) + 
    geom_point(size = 1.5) + geom_smooth(method = "lm", se = F) +
    theme(legend.position = c(0.1,0.25)) +                    # Legend position
    labs(x = "T",      # x-axis
         y = "R squared") +                             # y-axis
    scale_color_viridis(begin = 0.01, end = 0.91,        # Color management
                        option = "plasma", discrete = T,
                        direction = -1) 

# ggsave("variance.pdf", width = 7, height = 4)