79 lines
1.6 KiB
R
79 lines
1.6 KiB
R
library(tidyverse)
|
|
|
|
source("assets/01_common.R")
|
|
|
|
set.seed(2002)
|
|
# Experts
|
|
N <- 2
|
|
# Observations
|
|
T <- 2^5
|
|
# Size of probability grid
|
|
P <- 999
|
|
prob_grid <- 1:P / (P + 1)
|
|
|
|
# Realized observations
|
|
y <- rnorm(T)
|
|
|
|
# Deviation of the experts
|
|
dev <- c(-1, 3)
|
|
experts_sd <- c(1, sqrt(4))
|
|
|
|
# Expert predictions
|
|
experts <- array(dim = c(P, N))
|
|
|
|
seq(-5, 10, length.out = P) -> x_grid
|
|
|
|
experts[, 1] <- qnorm(prob_grid, mean = dev[1], sd = experts_sd[1])
|
|
experts[, 2] <- qnorm(prob_grid, mean = dev[2], sd = experts_sd[2])
|
|
|
|
experts <- rbind(c(rep(min(experts), N)), experts)
|
|
experts <- rbind(experts, c(rep(max(experts), N)))
|
|
prob_grid <- c(0, prob_grid, 1)
|
|
|
|
naive <- 1
|
|
|
|
df <- data.frame(
|
|
x = rep(prob_grid, each = N),
|
|
y = c(t(experts)),
|
|
expert = rep(1:N, (P + 2)),
|
|
naive = rep(naive, (P + 2) * N)
|
|
)
|
|
|
|
naive <- seq(0, 1, length.out = 11)
|
|
|
|
dfs <- list()
|
|
|
|
df_old <- df
|
|
|
|
for (i in seq_along(naive)) {
|
|
df_old$naive <- naive[i]
|
|
|
|
df_new <- data.frame(
|
|
x = prob_grid,
|
|
y = (experts[, 1] * (naive[i] * (0.5) + (1 - naive[i]) * (1 - prob_grid)) + (naive[i] * 0.5 + (1 - naive[i]) * (prob_grid)) * experts[, 2]),
|
|
expert = 3,
|
|
naive = rep(naive[i], (P + 2))
|
|
)
|
|
|
|
dfs[[i + 1]] <- bind_rows(df_old, df_new)
|
|
}
|
|
|
|
dfs <- reduce(dfs, bind_rows)
|
|
|
|
colnames(dfs) <- c("y", "x", "b", "mu")
|
|
|
|
dfs %>%
|
|
ggplot(aes(x = x, y = y, color = factor(b))) +
|
|
geom_line() +
|
|
labs(
|
|
title = "Expert Predictions",
|
|
x = "Probability Grid",
|
|
y = "Predicted Value"
|
|
) +
|
|
theme_minimal() +
|
|
scale_color_brewer(palette = "Set1") +
|
|
theme(legend.position = "top") +
|
|
facet_wrap(. ~ mu, ncol = 3)
|
|
|
|
write_csv(dfs, "assets/crps_learning/weights_plot/cdf_data.csv")
|