###########################################################################################
# MODEL REFERENCE AGE SHIFTS AND TRANSLATE DEMOGRAPHIC SCENARIOS INTO PENSION PROJECTIONS #
###########################################################################################

# Postpone the observed old-age pension take-up rates per age and sex in proportion to the
# anticipated reference age shifts encoded in parameter 'reftab'.
PENSION_RATES <- 
  bind_rows(PAR$pint %>% map(\(x) mutate(PENSION_RATES, year = x))) %>%
  relocate(year) %>%
  left_join(refage_table(PAR$reftab, PAR$pint), 
            by = c("sex", "type", "year"), relationship = "many-to-one") %>%
  replace_na(list(dage = 0)) %>% 
  group_by(sex, nat, type, year) %>%
  arrange(age, .by_group = TRUE) %>% 
  # Shift take-up rates according to changes in reference ages. Implicit assumptions:
  # 1. birthdays are evenly distributed across months per year;
  # 2. take-up decisions shift in parallel to the reference age;
  # 3. distinction of partial early or late uptakes is negligible.
  mutate(
    share =
      ifelse(type == "alt",
             (1 - (dage - floor(dage))) * dplyr::lag(share, n =   first(floor(dage)), def = 0) +
                  (dage - floor(dage))  * dplyr::lag(share, n = first(ceiling(dage)), def = 0),
             share)) %>%
  ungroup()

# Apply modified take-up rates to the demographic scenarios.
SCEN <- SCEN %>%  
  left_join(PENSION_RATES, 
            by = c("year", "sex", "nat", "age"), relationship = "many-to-many") %>%
  replace_na(list(share = 0)) %>% 
  mutate(heads = val * share) %>%
  summarize(heads = sum(heads), 
            .by = c("scen", "sex", "nat", "type", "year"))

# Adjust scenario-derived pension counts to the observed ones in the relevant pension 
# registry entry.
ADJ <-
  filter(SCEN, year == first(PAR$pint)) %>%
  summarize(heads = sum(heads), 
            .by = c("scen", "sex", "nat", "type")) %>%
  left_join(filter(PEN_N, year == first(PAR$pint)) %>%
              summarize(n = sum(n), .by = c("sex", "nat", "type")), 
            by = c("sex", "nat", "type")) %>%
  mutate(adj = n - heads) %>%
  select(- heads, - n)

# Additive adjustment (normally multiplicative; exception in 2025 due to Ukrainian 
# fugitives' re-registration into the 'ständige Wohnbevölkerung'). 
SCEN <- SCEN %>% 
  left_join(ADJ, by = c("scen", "sex", "nat", "type")) %>%
  # Prevent eventual negative counts due to additive adjustment.
  mutate(heads = pmax(0, heads + adj)) %>%
  select(- adj) %>% 
  summarize(heads = sum(heads), .by = c("scen", "year", "sex", "type")) %>%
  mutate(dom = "ch") %>%
  select(scen, year, sex, dom, type, n = heads) %>%
  mutate(m = NA) %>%
  filter(year > first(PAR$pint))

# Consolidation into final analysis data for regression. ---------------------------------

A_DATA <-
  bind_rows(mutate(PEN_NM, scen = "H"), SCEN) %>%
  # Extend analysis data by missing 'dom == au' combinations.
  right_join(
    expand_grid(year = min(PEN_NM$year):last(PAR$pint), 
                scen = c("H", "A", "B", "C"),
                dom  = c("ch", "au"), sex = c("m", "f"),
                type = c("alt", "kin", "wai", "wit")) %>% 
      filter(!(scen == "H" & year > first(PAR$pint)),
             !(scen %in% c("A", "B", "C") & year <= first(PAR$pint))),
    by = c("scen", "dom", "sex", "type", "year")
  ) %>% 
  relocate(scen, dom, sex, type, year, n) %>% 
  left_join(MINIMAL_PENSION, by = "year") %>%
  # Express mean pensions as multiples of contemporaneous minimal pensions.
  mutate(m = 12 * m / mp) %>% 
  arrange(scen, year)

# Save analysis data for later usage in script '6_uncertainty_bands.R'.
write_delim(A_DATA, "data/output/A_DATA.csv")