#' Estimation des EPRC à partir de la population
#'
#' Ce module calcule les équivalents pleine rente cumulés (EPRC) à
#' partir des données d'une certaine population en les faisant évoluer selon
#' les taux de mortalité.
#'
#' @param PARAM_GLOBAL 
#'
#' @param POPULATION_TOT data frame contenant les données de la population
#' calculé dans la fonction \code{\link{mod_population}}.
#'
#' @param MORTALITE data frame contenant les taux de mortalité, cf. fonction
#' \code{\link{mod_input_mortalite}}.
#'
#' @return une `tidylist` contenant le data frame suivant:
#' - `EPRC_ESTIMATION`
#'
#' @author [MAS BSV](mailto:sekretariat.mas@bsv.admin.ch)
#'
#' @export
#'

# setwd("~/data/appl-wb/20_staff/kjo/fhh/2025-06-10T1804_u80874371_ahv_basis_kjo")
# 
# PARAM_GLOBAL <-
#   read_delim("PARAM_GLOBAL.csv")
# 
# BEVOELKERUNG <-
#   read_delim("BEVOELKERUNG.csv")
# 
# TAUX_MORTALITE <-
#   read_delim("TAUX_MORTALITE.csv")
# 
# RR_AVS <-
#   read_delim("RR_AVS.csv")
  
mod_wf_eprc <- function(PARAM_GLOBAL,
                        BEVOELKERUNG,
                        TAUX_MORTALITE,
                        RR_AVS) {
  
  print("Run module: mod_eprc_estimation")
  
  # Aufbereitung der historischen und Szenario-bedingten Bevölkerungsentwicklungen zur 
  # Anwendung des Alogrithmus, welcher die kumulierten Vollrentenäquivalente projiziert.
  POPULATION_TOT <- BEVOELKERUNG %>%
    mutate(dom = "ch") %>%
    select(sex, nat, dom, jahr, alt, bevendejahr) %>%
    # Ausländische Rentenpopulation.
    bind_rows(
      BEVOELKERUNG %>%
        mutate(bevendejahr = rowSums(select(., auswanderung, saisonniers, frontaliers, 
                                               assures_facultatifs), na.rm = TRUE), 
               dom = "au") %>%
        select(sex, nat, dom, jahr, alt, bevendejahr))
  
  # Berechnung des jahresweisen Bewertungsfaktors, welcher je nach Geschlecht bzw.
  # Kohorte Beitragsjahre in erworbene Skalen übersetzt.
  POPU <- POPULATION_TOT %>%
    left_join(TAUX_MORTALITE, by = c("sex", "nat", "jahr", "alt")) %>%
    mutate(
      
      # ID nach Geburtskohorte.
      coh = jahr - alt, 
      
      # Vereinfachende Annahme: die Übersetzung von Beitragsjahr zu Skala ist proportional
      # zur maximalen Anzahl Beitragsjahre der entsprechenden Kohorte. Auf individuellem
      # Level sind eigentlich noch Rundungsregeln zu beachten, welche hier nicht 
      # berücksichtigt werden können.
      bewertungsjahrfaktor = case_when(
        
        alt %in% 21:64 & sex == "m" ~ 
          pmax(
            1 / (65 - 21              ),
            1 / (65 - 21 + coh - 1927)),
        
        alt %in% 21:61 & sex == "f" & coh <= 1938 ~ 
          pmax(
            1 / (62 - 21              ),
            1 / (62 - 21 + coh - 1927)),
        
        alt %in% 21:62 & sex == "f" & coh %in% 1939:1941 ~ 
          pmax(
            1 / (63 - 21              ),
            1 / (63 - 21 + coh - 1927)),
        
        alt %in% 21:63 & sex == "f" & coh >= 1942 ~ 
          pmax(
            1 / (64 - 21              ),
            1 / (64 - 21 + coh - 1927)),
        
        TRUE ~ 0), 
      
      # Flussgrösse der Vollrentenäquivalente-Bildung.
      epr = bewertungsjahrfaktor * bevendejahr,
      
      # Imputation der kohortenweisen hypothetischen Vollrentenbestände im Initialisierungs-
      # jahr des Algorithmus.
      eprc = epr * 
        
        case_when(
          
          # Annahme: wer sich in der Schweiz befindet bzw. arbeitet leistet im betreffenden
          # Jahr rentenwirksame Beiträge. Die Kappung am Referenzalter nach Kohorte 
          # verhindert die Bewertung von Jahren nach Eintritt in die Rentenpopulation
          # (ignoriert eventuelle Schliessung von Beitragslücken nach dem Referenzalter,
          # welche seit der Reform AHV 21 möglich ist).
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "m"                      
            ~ pmin(alt, 65) - 21,
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "f" & coh <= 1938        
            ~ pmin(alt, 62) - 21,
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "f" & coh %in% 1939:1941 
            ~ pmin(alt, 63) - 21,
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "f" & coh >= 1942        
            ~ pmin(alt, 64) - 21,
          
          # Implizite Annahme: Emigranten transferieren nur ein Beitragsjahr ins Ausland
          # und kehren niemals in die Schweiz zurück. Diese Annahme wird durch eine 
          # spätere Justierung der projizierten Vollrentenansprüche auf das Rentenregister 
          # kompensiert.
          (alt == 21 | jahr == min(jahr)) & nat != "ch"                                   
            ~                  1,
          
          TRUE ~ 0)
      ) %>%
    ungroup()
  
  # Funktion zur iterativen Berechnung der akkumulierten Vollrentenäquivalente.
  calculate_eprc_extrapolation <- function(DTA) {
    
    # Jahr und Alter
    jahr <- unique(DTA$jahr)
    alt  <- unique(DTA$alt)
    
    # Taux de mortalité
    Q <- tibble_to_matrix(dplyr::select(DTA, jahr, alt, quotients_mortalite))
    
    # Equivalents pleine rente
    V <- tibble_to_matrix(dplyr::select(DTA, jahr, alt, epr))
    
    # Equivalents pleine rente cumulés
    K <- tibble_to_matrix(dplyr::select(DTA, jahr, alt, eprc))
    
    for (i in (seq_along(jahr[-1]) + 1)) {
      for (j in (seq_along(alt[-1]) + 1)) {
        
        K[i, j] <- (1 - Q[i - 1, j - 1]) * K[i - 1, j - 1] + V[i, j]
        
      }
    }
    
    matrix_to_tibble(K, select(DTA, jahr, alt, eprc))
  }
  
  # Anwendung der EPRC-Funktion auf das kartesische Produkt von Geschlecht, Nationalität
  # und Domizil.
  EPRC_ESTIMATION <- 
    expand_grid(sex = c("m", "f"), nat = c("ch", "au"), dom = c("ch", "au")) %>%
    group_by(sex, nat, dom) %>%
    do(dta0 = calculate_eprc_extrapolation(
      filter(POPU, 
             sex == .$sex, nat == .$nat, dom == .$dom))) %>%
    unnest(cols = c(dta0)) %>%
    filter(!is.na(eprc)) %>%
    left_join(POPULATION_TOT, 
              by = c("sex", "nat", "dom", "jahr", "alt"))
  
  # Adjustierung der Vollrenten-Projektionen auf den aktuellsten Eintrag des Renten-
  # registers. Diese Justierung beeinflusst nicht die Folgeergebnisse, da ausschliesslich
  # die projizierten Wachstumsraten verwendet werden (welche durch multiplikative 
  # Justierungen unverändert bleiben). Diese Justierung ist jedoch zu Kontrollzwecken 
  # nützlich, da sie eine gute Reproduktion historischer Rentenbestände aufzeigt. Zudem 
  # werden so inkohärente Zwischen-Outputs verhindert.
  ADJ <- RR_AVS %>% 
    filter(gpr == "rvieillesse", jahr == PARAM_GLOBAL$jahr_rr) %>%
    select(sex, nat, dom, jahr, alt, eprc) %>%
    dplyr::summarize(eprc = sum(eprc),  
                     .by = c("sex", "nat", "dom", "jahr", "alt")) %>%
    group_by(sex, nat, dom, alt) %>%  
    left_join(select(EPRC_ESTIMATION, sex, nat, dom, jahr, alt, eprc_est = eprc), 
              by = c("sex" , "nat", "dom", "jahr", "alt")) %>%
    mutate(adj = eprc / eprc_est) %>%
    select(sex, nat, dom, alt, adj) %>% 
    na.omit()
  
  EPRC_ESTIMATION <- EPRC_ESTIMATION %>% 
    left_join(ADJ, 
              by = c("sex", "nat", "dom", "alt"), relationship = "many-to-one") %>%
    replace_na(list(adj = 1)) %>% 
    mutate(eprc = eprc * adj) %>%
    select(- adj)

  # Übersetzung in Wachstumsraten.
  WF_TEMP <- EPRC_ESTIMATION %>%
    filter(jahr >= PARAM_GLOBAL$jahr_rr) %>%
    group_by(sex, nat, dom, alt) %>%
    arrange(jahr, .by_group = TRUE) %>%
    mutate(wf_eprc = eprc / lag(eprc),
           wf_pop  = bevendejahr / lag(bevendejahr)) %>%
    mutate(across(c(wf_eprc, wf_pop), ~ ifelse(!is.finite(.x), 1, .x))) %>% 
    ungroup() %>% 
    select(sex, nat, dom, jahr, alt, wf_eprc, wf_pop)
  
  # Altersrenten. ------------------------------------------------------------------------
  
  RR_AV <- RR_AVS %>%
    filter(jahr == PARAM_GLOBAL$jahr_rr, gpr == "rvieillesse") %>%
    dplyr::summarize(eprc_ref = sum(eprc, na.rm = TRUE),
                     .by = c("sex", "nat", "dom", "gpr", "alt"))
  
  PROJ_AV <- WF_TEMP %>%
    right_join(RR_AV, 
               by = c("sex", "nat", "dom", "alt"), relationship = "many-to-many") %>%
    filter(jahr >= PARAM_GLOBAL$jahr_rr) %>%
    group_by(sex, nat, dom, gpr, alt) %>%
    arrange(jahr, .by_group = TRUE) %>% 
    mutate(eprc = cumprod(wf_eprc) * eprc_ref,
           coh  = jahr - alt) %>%
    select (coh, sex, nat, dom, gpr, jahr, alt, eprc) %>% 
    arrange(coh, sex, nat, dom, gpr, jahr, alt)
  
  # Restliche Rententypen. ---------------------------------------------------------------
  
  RR_AS <- RR_AVS %>%
    filter(jahr == PARAM_GLOBAL$jahr_rr, gpr != "rvieillesse") %>%
    dplyr::summarize(eprc_ref = sum(eprc),
                     .by = c("sex", "nat", "dom", "gpr", "alt"))
  
  PROJ_AS <- WF_TEMP %>%
    select(sex, nat, dom, jahr, alt, wf_pop) %>% 
    right_join(RR_AS, 
               by = c("sex", "nat", "dom", "alt"), relationship = "many-to-many") %>%
    filter(jahr >= PARAM_GLOBAL$jahr_rr) %>%
    group_by(sex, nat, dom, gpr, alt) %>%
    arrange(jahr, .by_group = TRUE) %>% 
    # 1ère étape: Projeter les eprc selon les facteurs de croissance de la
    # population (cf. étape 1 et 2).
    mutate(eprc = eprc_ref * cumprod(wf_pop)) %>%
    ungroup() %>% 
    # select(sex, nat, dom, zv, gpr, jahr, alt, eprc = bez_av) %>% 
    dplyr::summarize(eprc = sum(eprc),
                     .by = c("sex", "nat", "dom", "gpr", "jahr", "alt"))
  
  # Übersetzung in Wachstumsraten. -------------------------------------------------------
  
  WF_EPRC <- bind_rows(PROJ_AV, PROJ_AS) %>%
    group_by(sex, nat, dom, gpr, alt) %>%
    arrange(jahr, .by_group = TRUE) %>%
    mutate(wf_eprc = eprc / lag(eprc),
           wf_eprc = ifelse(!is.finite(wf_eprc), 1, wf_eprc)) %>%
    ungroup() %>% 
    select(sex, nat, dom, gpr, jahr, alt, eprc, wf_eprc)
  
  return(WF_EPRC)
}
