# Get baseline F1 per country at RP=4/RP=4
df_baseline_f1 <- df_or_grid |>
filter(rp_lt0 == 4, rp_lt1 == 4) |>
select(country_aoi, f1_baseline = f1)
# Function to calculate empirical combined RP for OR trigger
calc_empirical_or_rp <- function(df, rp_lt0, rp_lt1, baseline_start = 1981, baseline_end = 2024) {
df_baseline <- df |>
filter(year >= baseline_start, year <= baseline_end, window == "postrera")
# Get forecast thresholds per leadtime
fcst_thresh_lt0 <- df_baseline |>
filter(leadtime == 0) |>
group_by(country_aoi) |>
summarise(fcst_thresh_lt0 = calc_rp_threshold(fcst_mm, rp_lt0, -1), .groups = "drop")
fcst_thresh_lt1 <- df_baseline |>
filter(leadtime == 1) |>
group_by(country_aoi) |>
summarise(fcst_thresh_lt1 = calc_rp_threshold(fcst_mm, rp_lt1, -1), .groups = "drop")
# Pivot and calculate OR trigger
df_baseline |>
filter(leadtime %in% c(0, 1)) |>
select(country_aoi, year, leadtime, fcst_mm) |>
pivot_wider(names_from = leadtime, values_from = fcst_mm, names_prefix = "fcst_lt") |>
left_join(fcst_thresh_lt0, by = "country_aoi") |>
left_join(fcst_thresh_lt1, by = "country_aoi") |>
mutate(
fcst_drought_lt0 = fcst_lt0 <= fcst_thresh_lt0,
fcst_drought_lt1 = fcst_lt1 <= fcst_thresh_lt1,
fcst_drought_or = fcst_drought_lt0 | fcst_drought_lt1
) |>
group_by(country_aoi) |>
summarise(
n_years = n(),
n_triggers = sum(fcst_drought_or, na.rm = TRUE),
rp_empirical = (n_years + 1) / n_triggers,
.groups = "drop"
)
}
# Get empirical RP for each threshold combo in the optimal set
df_rp_country <- map2_dfr(
df_optimal_country$rp_lt0,
df_optimal_country$rp_lt1,
~calc_empirical_or_rp(df_joined, .x, .y) |>
mutate(rp_lt0 = .x, rp_lt1 = .y)
)
df_rp_overall <- calc_empirical_or_rp(df_joined, df_optimal_overall$rp_lt0, df_optimal_overall$rp_lt1) |>
mutate(rp_lt0 = df_optimal_overall$rp_lt0, rp_lt1 = df_optimal_overall$rp_lt1)
df_rp_baseline <- calc_empirical_or_rp(df_joined, 4, 4)
# Country-specific optima
df_country_summary <- df_optimal_country |>
left_join(df_baseline_f1, by = "country_aoi") |>
left_join(df_rp_country |> select(country_aoi, rp_lt0, rp_lt1, rp_empirical),
by = c("country_aoi", "rp_lt0", "rp_lt1")) |>
mutate(
f1_improvement = f1 - f1_baseline,
type = "Country-specific"
) |>
select(type, country_aoi, rp_lt0, rp_lt1, rp_empirical, f1, f1_baseline, f1_improvement)
# Overall optimum applied to each country
df_overall_applied <- df_or_grid |>
filter(rp_lt0 == df_optimal_overall$rp_lt0, rp_lt1 == df_optimal_overall$rp_lt1) |>
left_join(df_baseline_f1, by = "country_aoi") |>
left_join(df_rp_overall |> select(country_aoi, rp_empirical), by = "country_aoi") |>
mutate(
f1_improvement = f1 - f1_baseline,
type = "Overall optimal"
) |>
select(type, country_aoi, rp_lt0, rp_lt1, rp_empirical, f1, f1_baseline, f1_improvement)
# Get average baseline empirical RP
rp_baseline_avg <- mean(df_rp_baseline$rp_empirical)
bind_rows(df_overall_applied, df_country_summary) |>
mutate(type = factor(type, levels = c("Overall optimal", "Country-specific"))) |>
arrange(type, country_aoi) |>
gt() |>
fmt_number(columns = c(rp_lt0, rp_lt1, rp_empirical), decimals = 2) |>
fmt_number(columns = c(f1, f1_baseline, f1_improvement), decimals = 3) |>
cols_label(
type = "Optimization",
country_aoi = "Country",
rp_lt0 = "RP (LT0)",
rp_lt1 = "RP (LT1)",
rp_empirical = "RP (OR)",
f1 = "F1",
f1_baseline = "Baseline F1",
f1_improvement = "Δ F1"
) |>
tab_header(
title = "OR-Trigger Threshold Optimization Results",
subtitle = sprintf("Baseline = RP=4/4 (empirical OR RP ≈ %.1f)", rp_baseline_avg)
) |>
tab_style(
style = cell_fill(color = "#d4edda"),
locations = cells_body(columns = f1_improvement, rows = f1_improvement > 0)
) |>
tab_row_group(
label = md("**Overall Optimal Thresholds**"),
rows = type == "Overall optimal"
) |>
tab_row_group(
label = md("**Country-Specific Optimal Thresholds**"),
rows = type == "Country-specific"
) |>
cols_hide(type)
