Value of economic constraints

library(tidyverse)
library(lubridate)
library(viridis)
library(cowplot)
library(latex2exp)
library(plotly)
library(ggallin)
load("res_premium.RData")

We test what happens to the R^2 if we remove the negative part of predictions. (akin to ReLU activation in neural networks).

prediction_threshold <- 3

g1 <- res %>% 
    filter(pred < prediction_threshold, pred > (-0.99)) %>%
    mutate(pred_const = if_else(pred < 0, 0, pred),
           TT = as.factor(TT)) %>%
    group_by(x, y, TT) %>%              # Grouping variables
    summarize(mse = mean(e2, na.rm = T),
              v_y = var(y_test, na.rm = T),
              mse_const = mean((pred_const-y_test)^2), na.rm = T) %>%
    mutate(r2 = 1-mse/v_y) %>%
    ggplot() + 
    geom_point(aes(x = r2, y = 1-mse_const/v_y, color = TT), size = 0.7) +
    stat_function(fun = function(x)(x)) +
    #xlim(0,0.3) + ylim(0,0.3) +
    theme(legend.position = c(0.8,0.3)) +
    scale_x_continuous(trans = pseudolog10_trans) +
    scale_y_continuous(trans = pseudolog10_trans) +
    scale_color_viridis(begin = 0.18, end = 0.98, discrete = T, option = "B") +
    ylab("OOS R squared with constraint (log-scale)") +
    xlab("OOS R squared (log-scale)")

`summarise()` regrouping output by 'x', 'y' (override with `.groups` argument)

g2 <- res %>% 
    filter(pred < prediction_threshold, pred > (-0.99)) %>%
    mutate(pred_const = if_else(pred < 0, 0, pred)) %>%
    group_by(x, y, TT) %>%              # Grouping variables
    summarize(mse = mean(e2, na.rm = T),
              v_y = var(y_test, na.rm = T),
              r_x = mean(rho_x, na.rm = T),
              mse_const = mean((pred_const-y_test)^2), na.rm = T) %>%
    ggplot() + 
    geom_point(aes(x = 1-mse/v_y, y = 1-mse_const/v_y, color = r_x), size = 0.5) +
    stat_function(fun = function(x)(x)) +
    #xlim(0,0.3) + ylim(0,0.3) +
    theme(legend.position = c(0.8,0.3)) +
    scale_x_continuous(trans = pseudolog10_trans) +
    scale_y_continuous(trans = pseudolog10_trans) +
    scale_color_viridis(begin = 0.18, end = 0.98, direction = -1) +
    ylab("OOS R squared with constraint (log-scale)") +
    xlab("OOS R squared (log-scale)")

`summarise()` regrouping output by 'x', 'y' (override with `.groups` argument)

plot_grid(g1, g2, nrow=1)

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

res %>% 
    filter(pred < prediction_threshold, pred > (-0.99)) %>%
    mutate(pred_const = if_else(pred < 0, 0, pred)) %>%
    group_by(x, y, TT) %>%              # Grouping variables
    summarize(mse = mean(e2),
              mse_const = mean((pred_const-y_test)^2)) %>%
    ungroup() %>%
    summarise(m = mean(mse),
              m_const = mean(mse_const))

`summarise()` regrouping output by 'x', 'y' (override with `.groups` argument)

Below, we look at the histogram of the MSE (raw versus constrained predictions).

prediction_threshold <- 3

res %>% 
    filter(pred < prediction_threshold, pred > (-0.99)) %>%
    mutate(pred_const = if_else(pred < 0, 0, pred)) %>%
    group_by(x, y, TT) %>%              # Grouping variables
    summarize(mse = mean(e2),
              mse_const = mean((pred_const-y_test)^2)) %>%
    select(mse, mse_const) %>%
    pivot_longer(cols = c("mse", "mse_const"), names_to = "type", values_to = "mse") %>%
    ggplot(aes(x = mse, fill = type)) + 
    geom_histogram(position = "dodge") 

`summarise()` regrouping output by 'x', 'y' (override with `.groups` argument)
Adding missing grouping variables: `x`, `y`