The MC output here consists of coefficient-conditioned mean samples.
These intervals reflect coefficient uncertainty conditional on the
supplied AR rows; they omit the conditional new-input GP field variance.
The calibration vignette explicitly includes that covariance in its
likelihood and field recovery. These conditional validation plots
therefore do not by themselves establish full predictive coverage.
Points close to the diagonal indicate accurate emulation. Wider
intervals indicate larger predictive uncertainty.
{
### Error plot ----
#### Specific time, one spatial location, all inputs ----
{
alpha_error <- 0.5
res_pre <- res_pre_MC
time_num <- 15
sp_num <- 2
y_true <- dt_pde_test[[time_num]][,sp_num]
y_pre <- res_pre[[time_num]][,sp_num,]
y_pre_stat <- data.frame(y_true = y_true,
med = apply(X = y_pre, MARGIN = 1, FUN = median),
lower = apply(X = y_pre, MARGIN = 1, FUN = quantile, prob = 0.025),
upper = apply(X = y_pre, MARGIN = 1, FUN = quantile, prob = 0.975))
error_width <- (max(y_true) - min(y_true)) / 30 # denominator is for aesthetic
y_pre_stat %>% ggplot(aes(x = y_true, y = med)) +
geom_pointrange(aes(ymin = lower, ymax = upper), size =.2)+
geom_errorbar(aes(ymin = lower, ymax = upper), width = error_width) +
geom_abline(col = "red")
}
#### Specific time, one input, all spatial locations ----
{
time_num <- 20
sp_num <- c(1:N_sp)
y_true <- dt_pde_test[[time_num]][input_num,sp_num]
y_pre <- res_pre[[time_num]][input_num,sp_num,]
y_pre_stat <- data.frame(y_true = y_true,
med = apply(X = y_pre, MARGIN = 1, FUN = median),
lower = apply(X = y_pre, MARGIN = 1, FUN = quantile, prob = 0.025),
upper = apply(X = y_pre, MARGIN = 1, FUN = quantile, prob = 0.975))
y_pre_stat <- y_pre_stat / N_people
error_width <- (max(y_pre_stat["y_true"]) - min(y_pre_stat["y_true"])) / 30
plot_error_1 <- y_pre_stat %>% ggplot(aes(x = y_true, y = med)) +
geom_pointrange(aes(ymin = lower, ymax = upper), size =.2, alpha = alpha_error)+
geom_errorbar(aes(ymin = lower, ymax = upper), width = error_width, alpha = alpha_error) +
geom_abline(col = "red") +
labs(x = "PDE solution", y = "FFBS prediction")
}
# panel
time_p <- tstamp[c(4, 6, 8)]
sp_num <- c(1:N_sp)
plot_error_comp_ls <- list()
plot_band_ls <- list()
y_pre_stat_error_comp_ls <- list()
for (t in 1:length(time_p)) {
time_num <- time_p[t]
y_true <- dt_pde_test[[time_num]][input_num,sp_num]
y_pre <- res_pre[[time_num]][input_num,sp_num,]
y_pre_stat <- data.frame(y_true = y_true,
med = apply(X = y_pre, MARGIN = 1, FUN = median),
lower = apply(X = y_pre, MARGIN = 1, FUN = quantile, prob = 0.025),
upper = apply(X = y_pre, MARGIN = 1, FUN = quantile, prob = 0.975))
y_pre_stat <- y_pre_stat / N_people
y_pre_stat_error_comp_ls[[t]] <- y_pre_stat
}
for (t in 1:length(time_p)) {
# scatter plot
error_width <- (max(y_pre_stat_error_comp_ls[[t]]["y_true"]) - min(y_pre_stat_error_comp_ls[[t]]["y_true"])) / 30
plot_error_1 <- y_pre_stat_error_comp_ls[[t]] %>% ggplot(aes(x = y_true, y = med)) +
geom_pointrange(aes(ymin = lower, ymax = upper), size =.2, alpha = alpha_error / 3)+
geom_errorbar(aes(ymin = lower, ymax = upper), width = error_width, alpha = alpha_error / 3) +
geom_abline(col = "red") +
labs(x = "PDE solution", y = "FFBS emulation")
plot_error_comp_ls[[t]] <- plot_error_1
# error band plot
plot_band_predict <- y_pre_stat_error_comp_ls[[t]] %>%
ggplot(aes(x = y_true, y = med)) +
geom_ribbon(aes(ymin = lower, ymax = upper, x = y_true), fill = "#A6CEE3", alpha = 1) +
geom_point(aes(y = med), color = "#1F78B4", size = 0.7, alpha = 1) +
geom_abline(color = "#E31A1C", linewidth = 1) +
labs(x = "PDE solution", y = "FFBS emulation") +
theme_minimal()
plot_band_ls[[t]] <- plot_band_predict
}
}
labels <- paste0("t = ", tstamp[c(4, 6, 8)] - 1)
ggarrange(
plotlist = plot_error_comp_ls[1:3],
ncol = 3,
nrow = 1,
labels = labels,
font.label = list(size = 16, face = "bold"),
hjust = -0.1,
vjust = 1.2,
align = "hv",
common.legend = TRUE,
legend = "right"
)