Update CPRS learning application slides

index.qmd

@@ -1605,15 +1605,14 @@ Data:
 - Forecasting European emission allowances (EUA)
 - Daily month-ahead prices
 - Jan 13 - Dec 20 (Phase III, 2092 Obs)
+- Rolling Window (length 250 ~ 1 year)
 
 Combination methods:
 
+- Online
   - Naive, BOAG, EWAG, ML-PolyG, BMA
-
+- Batch
-Tuning paramter grids:
+  - QRlin, QRconv
-
-- Smoothing Penalty: $\Lambda= \{0\}\cup \{2^x|x\in \{-4,-3.5,\ldots,12\}\}$
-- Learning Rates: $\mathcal{E}= \{2^x|x\in \{-1,-0.5,\ldots,9\}\}$
 
 ::::
 
@@ -1625,12 +1624,17 @@ Tuning paramter grids:
 
 ::: {.column width="69%"}
 
-```{r, echo = FALSE, fig.width=7, fig.height=5, fig.align='center', cache = TRUE}
+Tuning paramter grids:
+
+- Smoothing Penalty: $\Lambda= \{0\}\cup \{2^x|x\in \{-4,-3.5,\ldots,12\}\}$
+- Learning Rates: $\mathcal{E}= \{2^x|x\in \{-1,-0.5,\ldots,9\}\}$
+
+```{r, echo = FALSE, fig.width=10, fig.height=5, fig.align='center', cache = TRUE}
 load("assets/crps_learning/overview_data.rds")
 
 data %>%
   ggplot(aes(x = Date, y = value)) +
-  geom_line(size = 1, col = col_blue) +
+  geom_line(size = 1, col = cols[9,"blue"]) +
   theme_minimal() +
   ylab("Value") +
   facet_wrap(. ~ name, scales = "free", ncol = 1) +
@@ -1642,13 +1646,13 @@ data %>%
 
 data %>%
   ggplot(aes(x = value)) +
-  geom_histogram(aes(y = ..density..), size = 1, fill = col_blue, bins = 50) +
+  geom_histogram(aes(y = ..density..), size = 1, fill = cols[9,"blue"], bins = 50) +
   ylab("Density") +
   xlab("Value") +
   theme_minimal() +
   theme(
-    strip.background = element_rect(fill = col_lightgray, colour = col_lightgray),
+    strip.background = element_rect(fill = cols[3,"grey"], colour = cols[3,"grey"]),
-    text = element_text(size = 15)
+    text = element_text(size = text_size)
   ) +
   facet_wrap(. ~ name, scales = "free", ncol = 1, strip.position = "right") -> p2
 
@@ -1702,8 +1706,6 @@ Y_{t} = \mu + Y_{t-1}  + \varepsilon_t \quad \text{with} \quad \varepsilon_t = \
 
 ## Significance
 
-<br/>
-
 ```{r, echo = FALSE, fig.width=7, fig.height=5.5, fig.align='center', cache = TRUE, results='asis'}
 load("assets/crps_learning/bernstein_application_study_estimations+learnings_rev1.RData")
 
@@ -1745,7 +1747,7 @@ class(OUT.num) <- "numeric"
 
 xxx <- OUT.num
 xxxx <- OUT
-table <- OUT
+table <- round(OUT, 3)
 table_col <- OUT
 i.p <- 1
 for (i.p in 1:MO) {
@@ -1761,11 +1763,18 @@ for (i.p in 1:MO) {
   fblue <- round(approxfun(seq(crange[1], crange[2], length = length(cblue)), cblue)(pmin(xxx[, i.p], xmax)), 3)
   tmp <- format(round(xxx[, i.p], 3), nsmall = 3)
   xxxx[, i.p] <- paste("\\cellcolor[rgb]{", fred, ",", fgreen, ",", fblue, "}", tmp, " {\\footnotesize (", Pallout[IDX[i.p]], ")}", sep = "")
-  table[, i.p] <- paste0(tmp, " (", Pallout[i.p], ")") # TODO: Improve here?
   table_col[, i.p] <- rgb(fred, fgreen, fblue, maxColorValue = 1)
-} # i.p
+  table[, i.p] <- paste0(
+    table[, i.p],
+    '<sup>(', Pallout[i.p], ")</sup>"
+  )
+}
 
-table_out <- kbl(table, align = rep("c", ncol(table)), bootstrap_options = c("condensed")) %>%
+table_out <- kbl(
+  table, 
+  align = rep("c", ncol(table)), 
+  bootstrap_options = c("condensed"),
+  escape = FALSE) %>%
   kable_paper(full_width = TRUE) %>%
   row_spec(0:nrow(table), color = cols[9, "grey"])
 
@@ -1800,18 +1809,39 @@ for (i.p in 1:MO) {
   fblue <- round(approxfun(seq(crange[1], crange[2], length = length(cblue)), cblue)(pmin(xxx[, i.p], xmax)), 3)
   tmp <- format(round(xxx[, i.p], 3), nsmall = 3)
   xxxx[, i.p] <- paste("\\cellcolor[rgb]{", fred, ",", fgreen, ",", fblue, "}", tmp, " {\\footnotesize  (", Pallout[K + 3 + 5 * (i.p - 1) + 1:5], ")}", sep = "")
-  table2[, i.p] <- paste0(tmp, " (", Pallout[K + 3 + 5 * (i.p - 1) + 1:5], ")")
+  # table2[, i.p] <- paste0(tmp, " (", Pallout[K + 3 + 5 * (i.p - 1) + 1:5], ")")
+
+  table2[, i.p] <- paste0(
+    tmp,
+    "<sup>(", Pallout[K + 3 + 5 * (i.p - 1) + 1:5], ")</sup>"
+  )
+
   table_col2[, i.p] <- rgb(fred, fgreen, fblue, maxColorValue = 1)
 } # i.p
 
-table_out2 <- kableExtra::kbl(table2, align = rep("c", ncol(table2)), bootstrap_options = c("condensed")) %>%
+rownames(table2) <- c("Pointwise", "B-Smooth", "P-Smooth", "B-Constant", "P-Constant")
-  kable_paper(full_width = TRUE) %>%
+rownames(table_col2) <- rownames(table2)
-  row_spec(0:nrow(table2), color = cols[9, "grey"])
 
-for (j in 1:ncol(table2)) {
+table2["B-Smooth", c("QRlin", "QRconv")] <- "-"
+table_col2["B-Smooth", c("QRlin", "QRconv")] <- cols[2, "grey"]
+
+idx <- c("Pointwise", "B-Constant", "P-Constant", "B-Smooth", "P-Smooth")
+
+table2["P-Smooth", "BOAG"] <- "<strong>-0.182</strong><sup>(0.039)</sup>"
+
+table_out2 <- kableExtra::kbl(
+  table2[idx, ],
+  align = rep("c", ncol(table2)),
+  bootstrap_options = c("condensed"),
+  escape = FALSE
+) %>%
+  kable_paper(full_width = TRUE) %>%
+  row_spec(0:nrow(table2[idx, ]), color = cols[9, "grey"])
+
+for (j in seq_len(ncol(table2[idx, ]))) {
   table_out2 <- table_out2 %>%
     column_spec(1 + j,
-      background = table_col2[, j]
+      background = table_col2[idx, j]
     )
 }
 
@@ -1819,6 +1849,11 @@ table_out2 %>%
   column_spec(1, bold = T)
 ```
 
+<div style="font-size: 0.7em;">
+  CRPS difference to Naive. Negative values correspond to better performance (the best value is bold). <br/>
+  Additionally, we show the p-value of the DM-test, testing against Naive. The cells are colored with respect to their values (the greener better).
+</div>
+
 ## QL
 
 ```{r, echo = FALSE, fig.width=13, fig.height=5.5, fig.align='center', cache = TRUE}