#######################################################################################
# MODEL REFERENCE AGE SHIFTS AND CONVERT DEMOGRAPHIC SCENARIOS TO PENSION PROJECTIONS #                             #######################################################################################

# Calculate take-up rates for different pension types by sex, nationality and age.

PENSION_RATES <-
  left_join(POP, PEN_N, 
            by = c("sex", "nat", "age", "year"), relationship = "one-to-many") %>%
  # Select reference year. Usually, the reference year lags behind the first 
  # projection year by two. Exceptionally, in 2025 a lag of three is chosen due to
  # observed take-up rate changes that are partly due to fugitive reclassifications into
  # the Swiss 'ständige Wohnbevölkerung'.
  filter(year == first(PAR$pint) - 2) %>%
  mutate(share = n / pop) %>%
  select(- year, - pop, - n)

# Shift the reference old-age pension take-up rates per age and sex in proportion to the
# anticipated reference age changes encoded in the parameter table 'PAR$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 under the following 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 three demographic scenarios to arrive at pension
# stock 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. Normally, the adjustment is multiplicative (i.e. growth rate 
# preserving). In 2025, an additive adjustment is applied instead to remove effects that
# are expected to be transitory (in particular, suppression of take-up rates due to
# reclassification of older fugitives).
ADJ <-
  filter(SCEN, year == first(PAR$pint)) %>%
  summarize(heads = sum(heads), 
            .by = c("scen", "sex", "nat", "type")) %>%
  left_join(
    PEN_N %>% 
      filter(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)

SCEN <- SCEN %>% 
  left_join(ADJ, by = c("scen", "sex", "nat", "type")) %>%
  # Prevent eventual negative counts due to the additive adjustment as a safety measure.
  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 extrapolation purposes. ---------------------

A_DATA <-
  bind_rows(mutate(PEN_NM, scen = "H"), SCEN) %>%
  # Extend analysis data by implicitly 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)
