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"
)