#' 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 un dataframe d'une seule ligne, dont nous utilisons les
#'   paramètres suivants:
#'   - `jahr_rr`: aktuelles Jahr des Rentenregisters der 1. Säule
#'
#' @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}}.
#'
#'
#' @references \href{https://www.bsv.admin.ch/dam/bsv/fr/dokumente/ahv/finanzperspektiven/validierung-modellansatz-ahv.pdf.download.pdf/2018_07_09_definitif_ld_rapport_ofas.pdf}{Rapport de Prof. Dr Laurent Donzé}
#'
#' @return une `tidylist` contenant le data frame suivant:
#' - `EPRC_ESTIMATION`
#'
#' @author [MAS BSV](mailto:sekretariat.mas@bsv.admin.ch)
#'
#' @export
#'

mod_eprc_estimation <- function(PARAM_GLOBAL,
                                BEVOELKERUNG,
                                TAUX_MORTALITE) {
  
  print("Run module: mod_eprc_estimation")

  POPULATION_TOT <- BEVOELKERUNG %>%
      mutate(bevendejahr = bevendejahr, dom = "ch") %>%
      select(jahr, sex, nat, alt, dom, bevendejahr) %>%
      bind_rows(
        BEVOELKERUNG %>%
          mutate(bevendejahr = 
                   # Ableitung der Rentenanspruch-generierenden Population im Ausland 
                   # anhand der Szenarien zu Grenzgängern, Saisonniers und freiweillig
                   # Versicherten. Zusätzlich wird bei Auswanderungen angenommen, die
                   # Auswandernden transferieren ein Beitragsjahr ins Ausland.
                   rowSums(select(., auswanderung, frontaliers, saisonniers, 
                                  assures_facultatifs), na.rm = TRUE), 
                           dom = "au") %>%
                    select(jahr, sex, nat, alt, dom, bevendejahr))

  # Berechnung des Faktors, mit welchem Beitragsjahre kohorten-spezifisch in Skalen
  # übersetzt werden. Der zweite Fall in den 'pmax' Aufrufen berücksichtigt, dass sehr
  # alte Kohorten garnicht in der Lage waren, seit Lebensalter 21 Beiträge zu leisten.
  POPU <- POPULATION_TOT %>%
    left_join(TAUX_MORTALITE, by = c("jahr", "alt", "sex", "nat")) %>%
    mutate(coh = jahr - alt) %>% 
    mutate(
      
      # Vereinfachende Annahme: die Anzahl geleisteter Beitragsjahre übersetzt sich in 
      # Skalen relativ zur maximal möglichen Anzahl geleisteter Beitragsjahre bis zum
      # Erreichen des Referenzalters. Eine exakte Skalenberechnung kann nicht implementiert
      # werden, da die Rechenregeln auf individuellen Beitragsjahren beruhen; siehe
      # https://sozialversicherungen.admin.ch/de/d/18438/download. Feinheiten im Falle des
      # Vorbezugs, welche insbesondere beim Inkrafttreten der Reform AHV21 relevant
      # werden, sind ebenfalls nicht berücksichtigt.
      bewertungsjahrfaktor = case_when(
        
        alt %in% 21:64 & sex == "m" ~ 
          pmax(
            1 / (65 - 21             ),
            1 / (65 - 21 + coh - 1927)),
        
        alt %in% 21:62 & sex == "f" & coh <= 1938 ~ 
          pmax(
            1 / (62 - 21             ),
            1 / (62 - 21 + coh - 1927)),
        
        alt %in% 21:63 & sex == "f" & coh %in% 1939:1941 ~ 
          pmax(
            1 / (63 - 21             ),
            1 / (63 - 21 + coh - 1927)),
        
        alt %in% 21:64 & sex == "f" & coh >= 1942 ~ 
          pmax(
            1 / (64 - 21             ),
            1 / (64 - 21 + coh - 1927)),
        
        # Die Nullsetzung für andere Fälle verhindert, dass vor dem 21. Lebensjahr oder
        # nach dem Rentenbezug Skalen generiert werden. Vereinfachende Annahme: 
        # Nachmeldungen und Schliessungen von Beitragslücken durch Arbeit während des 
        # Rentenaufschubs sowie Phänomene wie die Jugendjahre sind vernachlässigbar.
        TRUE ~ 0
      )
    ) %>% 
    mutate(
      # Flussgrösse.
      epr = bewertungsjahrfaktor * bevendejahr,
      # Initialisierung der Bestandsgrösse. Annahme im ESPOP Startjahr 1971: die 
      # beobachteten Schweizer Kohorten im Erwerbsalter haben keine Beitragslücken, 
      # während eventuelle Anspruchsbestände von Ausländern ignoriert werden.
      eprc = epr * 
        case_when(
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "m"                      
            ~ pmin(alt, 65) - 21 + 1,
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "f" & coh <= 1938        
            ~ pmin(alt, 62) - 21 + 1,
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "f" & coh %in% 1939:1941 
            ~ pmin(alt, 63) - 21 + 1,
          
          (alt == 21 | jahr == min(jahr)) & nat == "ch" & sex == "f" & coh >= 1942        
            ~ pmin(alt, 64) - 21 + 1,
          
          TRUE ~ 1)
      ) %>%
    ungroup()
  
  # Algorithmus zur jahresweisen Projektion der kumulierten Vollrentenäquivalente (EPRC).
  calculate_eprc_extrapolation <- function(DTA) {
  
    # Jahr und Alter.
    jahr <- unique(DTA$jahr)
    alt  <- unique(DTA$alt)
  
    # Jahresweise Sterberaten nach Lebensalter.
    Q <- tibble_to_matrix(dplyr::select(DTA, jahr, alt, quotients_mortalite))
  
    # Vollrentenäquivalente.
    V <- tibble_to_matrix(dplyr::select(DTA, jahr, alt, epr))
  
    # Kumulierte Vollrentenäquivalente.
    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)) {
        
        # Lies: kumulierte Ansprüche von heute sind die mortalitätsadjustierten von
        # gestern plus die neu generierten im aktuellen Jahr. Annahme: alle Personen im
        # Erwerbsalter, welche sich in der Schweiz aufhalten oder als Grenzgänger
        # arbeiten, zahlen jährlich auch ein.
        K[i, j] <- (1 - Q[i - 1, j - 1]) * K[i - 1, j - 1] + V[i, j]
        
      }
    }
    
    matrix_to_tibble(K, dplyr::select(DTA, jahr, alt, eprc))
  }
  
  # Anwendung des Algorithmus auf die Bevölkerungspartition nach Geschlecht, 
  # Nationalität und Domizil.
  EPRC_ESTIMATION <- crossing(
    sex = c("f", "m"), 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("jahr", "sex", "nat", "alt", "dom")) %>% 
    select(jahr, sex, nat, dom, alt, eprc, pop = bevendejahr) %>% 
    # Auschluss von Sonderfällen, wobei Personen vor den gesetzlich möglichen Renten-
    # bezugsaltern im Register verzeichnet wurden.
    filter(!(sex == "f" & alt < 62), !(sex == "m" & alt < 63),
           jahr >= PARAM_GLOBAL$jahr_rr) %>% 
    group_by(sex, nat, dom, alt) %>%
    arrange(jahr) %>%
    filter(jahr >= PARAM_GLOBAL$jahr_rr) %>% 
    # Berechnung der kumulierten EPRC-Wachstumsraten nach Alter und Gruppe relativ
    # zum Rentenregister-Stand des Laufjahres.
    mutate(growth = cumprod(eprc  / lag(eprc , def = first(eprc)))) %>% 
    select(jahr, sex, nat, dom, alt, growth) %>% 
    ungroup() %>% 
    # Übertragung der EPRC-Wachstumsraten auf alle Zivilstände und möglichen Renten-
    # bezugsalter. Annahme: der Anteil der Vor- und Nachbeziehenden sowie der Zivilstands-
    # angehörigkeiten bleiben ab dem Laufjahr konstant.
    expand(nesting(jahr, sex, nat, dom, alt, growth), 
           zv = c("ledig", "verheiratet", "geschieden", "verwitwet"), 
           age_ret = 62:70) %>% 
    filter(alt >= age_ret, !(sex == "m" & age_ret < 63)) %>% 
    mutate(gpr = "rvieillesse_simple") %>% 
    select(jahr, sex, nat, dom, zv, gpr, age_ret, alt, growth)
  
  OTHER_ESTIMATION <- 
    group_by(POPULATION_TOT, sex, nat, dom, alt) %>% 
    arrange(jahr) %>% 
    filter(jahr >= PARAM_GLOBAL$jahr_rr) %>% 
    mutate(growth = cumprod(bevendejahr / lag(bevendejahr, def = first(bevendejahr)))) %>% 
    select(- bevendejahr) %>% 
    ungroup() %>% 
    expand(nesting(jahr, sex, nat, dom, alt, growth), 
           zv  = c("ledig", "verheiratet", "geschieden", "verwitwet"), 
           gpr = c("rorphelin", "renfant", "rveuve"),
           age_ret = NA) %>% 
    select(jahr, sex, nat, dom, zv, gpr, age_ret, alt, growth)
    
  return(FACTEURS_CROISSANCE_EPRC_PROJETES_FLEX = 
           bind_rows(EPRC_ESTIMATION, OTHER_ESTIMATION))
}
