#' #' 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:
#' #'   - `ra_f_2005`: Age de la retraite pour les femmes dès 2005 (64)
#' #'   - `ra_m`: Age de la retraite pour les hommes
#' #'   - `21`: Age à partir duquel on verse des cotisations
#' #'
#' #' @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}}.
#' #'
#' #' @param list `tidylist`. Elément obligatoire dans tous les modules. Au lieu de
#' #'   fournir des dataframes au module, il est possible de l'alimenter uniquement
#' #'   avec une`tidylist` qui contient les tidy dataframes. Tous les datframes
#' #'   listés doivent être présents dans la tidylist, avec le même nom. De plus,
#' #'   la `tidylist` peut aussi contenir des dataframes qui ne sont pas utilisés
#' #'   par le module.
#' #'
#' #' @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_ <-
#' 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 = rowSums(select(., auswanderung, frontaliers, saisonniers, 
#'                                                 assures_facultatifs), na.rm = TRUE), 
#'                    dom = "au") %>%
#'                       select(jahr, sex, nat, alt, dom, bevendejahr))
#'   
#'   # Bewertungsjahrfaktor
#'   # Version avec le même facteur pour tout le monde (pour les hommes et les femmes)
#' 
#'   POPU <- POPULATION_TOT %>%
#'     left_join(TAUX_MORTALITE, by = c("jahr", "alt", "sex", "nat")) %>%
#'     mutate(
#'       coh = jahr - alt,
#'       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)),
#'         
#'         # all other cases
#'         TRUE ~ 0
#'       )
#'     ) %>% 
#'     mutate(
#'       epr = bewertungsjahrfaktor * bevendejahr,
#'       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,
#'         # all other cases
#'         TRUE ~ 0)
#'     ) %>%
#'     ungroup()
#'   
#'   # EXTRAPOLATION DES EPRC : Fonction de calcul des EPRC
#'   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, dplyr::select(DTA, jahr, alt, eprc))
#'   }
#' 
#'   # Estimation des EPRC pour les 4 groupes
#'   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"))
#' 
#' 
#'   return(EPRC_ESTIMATION = EPRC_ESTIMATION)
#' }

#' 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
#'

# source("~/delfinverse/dinput/R/utils.R")
# 
# options(readr.show_col_types = FALSE)
# 
# PARAM_GLOBAL <- 
#   read_delim("~/data/appl-wb/20_staff/kjo/fhh/2025-05-05T1039_u80874371_basiscontainer/param/ahv_basiscontainer/PARAM_GLOBAL.csv") %>% 
#   pivot_wider(names_from = key) %>% 
#   mutate(jahr_abr = as.numeric(jahr_abr))
# 
# setwd("~/data/appl-wb/20_staff/kjo/fhh/2025-05-05T1039_u80874371_basiscontainer/")
# 
# BEVOELKERUNG <- 
#   read_delim("BEVOELKERUNG.csv")
# 
# TAUX_MORTALITE <- 
#   read_delim("TAUX_MORTALITE.csv")
# 
# RR <- 
#   read_delim("RR_AVS.csv")

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,
          
          (alt == 21 | jahr == min(jahr)) & nat != "ch"
          ~ 1,
          
          TRUE ~ 0)
    ) %>%
    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, eprc, 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, eprc, 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, eprc, 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, eprc = NA) %>% 
    select(jahr, sex, nat, dom, zv, gpr, age_ret, alt, eprc, growth)
  
  return(FACTEURS_CROISSANCE_EPRC_PROJETES_FLEX = 
           bind_rows(EPRC_ESTIMATION, OTHER_ESTIMATION))
}
