#' @title Scénario de l'évolution du niveau des premières rentes
#'
#' @description Etant donné qu'il n'est pas possible d'appliquer le facteur
#' structurel de l'OFAS aux valeurs des rentes tirées du registre des rentes
#' mais uniquement à la somme des salaires (Lohnsumme) déterminant les
#' cotisations, il est important d'introduire un facteur de correction
#' modélisant l'évolution du niveau des premières rentes en tenant compte des
#' variations structurelles futures (comme les changements de carrière et des
#' moeurs qui ont un effet sur le salaire déterminant le niveau des premières
#' rentes).
#'
#' @param PARAM_GLOBAL un dataframe d'une seule ligne, dont nous utilisons les
#'   paramètres suivants:
#'   - `jahr_rr`: année du registre des rentes
#'   - `jahr_ende`: dernière année de projection
#'
#' @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.
#'
#' @return Un tidy dataframe
#' - "RENTENZYKLUS"
#'
#' @author [MAS BSV](mailto:sekretariat.mas@bsv.admin.ch)
#'
#' @export
#'

mod_rentenzyklus <- function(PARAM_GLOBAL,
                                    RENTENENTWICKLUNG,
                                    RR_AVS) {
  
  # Projektion der Rentenniveaus vor und inklusive Lebensalter 65. -----------------------
  RR_0 <- RR_AVS %>% 
    filter(gpr == "rvieillesse") %>%
    mutate(coh = jahr - alt) %>%
    dplyr::summarise(pen  = sum(monatliche_rentensumme), eprc = sum(eprc),
                     .by = c("coh", "sex", "nat", "dom", "jahr", "alt")) %>% 
    left_join(select(RENTENENTWICKLUNG, jahr, minimalrente), 
              by = "jahr", relationship = "many-to-one") %>%
    # Ausdruck der durchschnittlichen Renten pro Vollrentenäquivalent relativ zur
    # kontemporären Minimalrente.
    mutate(pen = pen / (minimalrente * eprc)) %>% 
    select(coh, sex, nat, dom, jahr, alt, pen) %>%
    # Restriktion auf mögliche Eintrittsalter bis hin zum Beginn des Rentenzyklus. Die 
    # Unmöglichkeit für die Frauen-Kohorten 1970+ im Alter 62 vorzubeziehen aufgrund der
    # AHV 21 wird dabei bewusst ignoriert.
    filter(alt %in% 62:65) %>% 
    # Expansion der Daten um zukünftige Kohorten-IDs und Kalenderjahre.
    mutate(jahr = factor(jahr, levels =  (min(.$coh) + 65):PARAM_GLOBAL$jahr_ende),
           coh  = factor(coh , levels = c(min(.$coh):(PARAM_GLOBAL$jahr_ende - 62)))) %>%
    complete(coh, jahr, sex, nat, dom, alt) %>%
    mutate(jahr = parse_number(as.character(jahr)),
           coh  = parse_number(as.character(coh))) %>%
    # Entfernung inkohärenter Kombinationen.
    filter(jahr - coh == alt, !(sex == "m" & alt < 63)) %>%
    select(coh, sex, nat, dom, jahr, alt, pen) %>% 
    group_by(sex, nat, dom, alt) %>% 
    arrange(jahr, .by_group = TRUE) %>% 
    # Eingrenzung der zur Extrapolation verwendeten Datenpunkte. Das Fenster wurde 
    # gewählt, um Kontaminationen durch die vorteilhaften Vorbezugssätze der 10. AHV 
    # Revision zu vermeiden, welche 2012 ausgelaufen sind.
    mutate(pen_c = ifelse(jahr %in% 2014:2023, pen, NA)) %>% 
    ungroup() %>% 
    impute_lm(pen_c ~ jahr | sex + nat + dom + alt) %>% 
    group_by(sex, nat, dom, alt) %>% 
    arrange(jahr, .by_group = TRUE) %>% 
    # Zusammenführen der historischen und projizierten Rentenniveaus.
    mutate(pen = coalesce(pen, pen_c)) %>% 
    select(- pen_c) %>%  
    select(coh, jahr, sex, nat, dom, alt, pen) %>% 
    ungroup()
  
  # Projektion des Rentenniveaus der konsolidierten Gruppe im Alter > 65 + rz_b. -----------
  RR_F <- RR_AVS %>% 
    filter(gpr == "rvieillesse") %>%
    mutate(coh = jahr - alt) %>%
    dplyr::summarize(pen  = sum(monatliche_rentensumme), eprc = sum(eprc),
                     .by = c("coh", "sex", "nat", "dom", "zv", "jahr", "alt")) %>% 
    left_join(select(RENTENENTWICKLUNG, jahr, minimalrente), 
              by = "jahr", relationship = "many-to-one")
  
  # Imputation der kontrafaktischen Wachstumsraten der laufenden Renten in 2001, als die
  # die 10. AHV Revision die Anpassung aller laufenden Renten erforderte. Wichtig: 
  # aufgrund des Prinzips der Besitzstandswahrung waren nur Anpassungen nach oben möglich.
  # Die exakten Regeln zur Aufwertung sind zu kompliziert um kontrafaktische Renten zu
  # berechnen.
  CORR <- RR_F %>% 
    # Eingrenzung auf Renten, welche bereits vor 1997 bezogen und damit im neuen Renten-
    # system berechnet wurden. Ledige werden ausgeschlossen, da deren Renten nicht von 
    # dieser Anpassung betroffen waren.
    filter(!(sex == "f" & coh >= 1935), !(sex == "m" & coh >= 1932),
           jahr %in% 1999:2002, zv != "ledig") %>%
    group_by(coh, sex, nat, dom, zv) %>%
    arrange(jahr, .by_group = TRUE) %>%
    # Restriktion auf Gruppen, die von 1999:2002 auch durchweg beobachtbar sind.
    filter(n() == 4) %>%
    mutate(pen = pen / (minimalrente * eprc)) %>%
    mutate(w_f = pen / lag(pen) - 1) %>%
    na.omit() %>%
    # Löschen des Wachstumssprungs in 2001 zur nachfolgenden Imputation.
    mutate(w_c = ifelse(jahr == 2001, NA, w_f)) %>%
    ungroup() %>%
    impute_lm(w_c ~ 1 | coh + sex + nat + dom + zv) %>%
    filter(jahr == 2001) %>%
    # Berechnung des kontrafaktischen Wachstumsfaktors.
    mutate(corr = (1 + w_c) / (1 + w_f)) %>%
    select(coh, sex, nat, dom, zv, corr)
  
  RR_F <- RR_F %>% 
    left_join(CORR, by = c("coh", "sex", "nat", "dom", "zv")) %>%
    # Ersetzung nötig für Ledige sowie Kohorten, welche ab 1997 oder später erstmals
    # bezogen haben.
    replace_na(list(corr = 1)) %>%
    # Anwendung der Korrektur ab 2001 auf laufende Renten mit Erstbezug vor 1997.
    mutate(
      pen_c = pen / (minimalrente * eprc),
      pen_c = ifelse(jahr >= 2001, pen_c * corr, pen_c),
      pen_c = pen_c * (eprc * minimalrente)) %>%
    select(- corr) %>%
    # Einschränkung auf Altersgruppen oberhalb der Lebenszyklus-Obergrenze.
    filter(alt > PARAM_GLOBAL$rentenzyklus_max_alt) %>% 
    select(sex, nat, dom, jahr, eprc, pen, pen_c, minimalrente) %>% 
    dplyr::summarize(
      pen  = sum(pen), pen_c = sum(pen_c), eprc = sum(eprc),
      .by  = c("sex", "nat", "dom", "jahr", "minimalrente")) %>%  
    mutate(
      pen   = pen   / (minimalrente * eprc),
      pen_c = pen_c / (minimalrente * eprc),
      jahr = factor(jahr, levels = min(RR_AVS$jahr):PARAM_GLOBAL$jahr_ende)) %>%
    complete(sex, nat, dom, jahr) %>%
    mutate(jahr = parse_number(as.character(jahr))) %>%
    select(sex, nat, dom, jahr, eprc, pen, pen_c) %>% 
    group_by(sex, nat, dom) %>% 
    arrange(jahr, .by_group = TRUE) %>% 
    filter(jahr >= 2001) %>% 
    mutate(d_pen = pen_c - lag(pen_c)) %>%
    ungroup()
  
  # Projektion zukünftiger Rentenniveaus via NNETAR-Methode (basierend auf einlagigem
  # neuralem autoregressivem Netzwerk). 'set.seed' wird gesetzt, da bei der Initiali-
  # sierung des Algorithmus minimale Abweichungen auftreten (Grund: bislang unbekannt).
  set.seed(123)
  NN_PRED <-
    model(filter(as_tsibble(RR_F, index = jahr, key = c(sex, nat, dom)),
                 !(is.na(d_pen))), net = NNETAR(d_pen)) %>%
    fabletools::forecast(h = PARAM_GLOBAL$jahr_ende - PARAM_GLOBAL$jahr_lj + 1, 
                         times = 0) %>%
    as_tibble(mod) %>%
    select(jahr, sex, nat, dom, pred = .mean)
  
  RR_F <- RR_F %>% 
    left_join(NN_PRED, by = c("sex", "nat", "dom", "jahr")) %>%
    mutate(d_pen = coalesce(d_pen, pred)) %>%
    tidyr::replace_na(list(d_pen = 0)) %>% 
    select(- pred) %>%
    group_by(sex, nat, dom) %>%
    arrange(jahr, .by_group = TRUE) %>%
    fill(pen) %>%
    mutate(d_pen = is.na(pen) * d_pen) %>%
    mutate(pen = pen + cumsum(d_pen),
           pen_c = coalesce(pen_c, pen)) %>%
    group_by(sex, nat, dom) %>%
    arrange(jahr, .by_group = TRUE) %>%
    # Die Kohorten ID 9999 wird zur Kennzeichnung der konsolidierten Altersgruppe
    # verwendet.
    mutate(coh = 9999, alt = PARAM_GLOBAL$rentenzyklus_max_alt + 1) %>%
    select(coh, jahr, sex, nat, dom, alt, pen)
  
  # Imputation des Rentenzyklus vom Alter 65 bis 'rentenzyklus_max_alt' ------------------
  RR_EV <- RR_AVS %>% 
    filter(gpr == "rvieillesse") %>%
    mutate(coh = jahr - alt) %>%
    dplyr::summarise(pen  = sum(monatliche_rentensumme), eprc = sum(eprc),
                     .by = c("coh", "sex", "jahr", "alt")) %>% 
    left_join(select(RENTENENTWICKLUNG, jahr, minimalrente), 
              by = "jahr", relationship = "many-to-one") %>% 
    mutate(pen = pen / (minimalrente * eprc)) %>% 
    # Restriktion auf Kohorten, welche frühestens seit 1997 beziehen. Vorige Kohorten sind
    # zu kontaminiert für die Schätzung des Zyklus.
    filter(!(sex == "f" & coh < 1935), !(sex == "m" & coh < 1932), alt >= 65) %>% 
    select(coh, sex, jahr, alt, pen)
  
  # Manuelle Korrektur der männlichen Erstrentenniveaus, welche aufgrund der
  # Referenzalterverschiebungen der Frauen Sprünge aufweisen. Diese Sprünge sollten nicht 
  # extrapoliert werden.
  for (x in 65:68) {
    
    M_DAT <- RR_EV %>% 
      filter(sex == "m", alt == x) %>%
      ungroup() %>%
      mutate(ind = case_when(
        # Die Zeiträume umfassen die Referenzaltererhöhungen sowie den Auslauf der 
        # vorteilhaften Vorbezugssätze in 2012.
        jahr %in% 1997:2000 ~ "a",
        jahr %in% 2001:2004 ~ "b",
        jahr %in% 2005:2011 ~ "c",
        jahr %in% 2012:2024 ~ "d"))
    
    # Der Kontrafakt besteht darin, unterschiedliche Achsenabschnitte für die gewählten
    # Zeiträume zu schätzen, und nachfolgend ausschliesslich den letzten geschätzen
    # Achsenabschnitt zur Rückwärtsextrapolation zu verwenden. Das Subskript "_c" wird
    # verwendet, um 'counterfactual' abzukürzen.
    M_DAT <- M_DAT %>% 
      mutate(pen_c = lm(pen ~ 0 + jahr + ind, M_DAT) %>% predict(mutate(M_DAT, ind = "d")),
             pen_c = ifelse(jahr <= 2011, pen_c, pen)) %>%
      arrange(jahr) %>%
      select(jahr, sex, alt, pen, pen_c)
    
    RR_EV <- RR_EV %>% 
      left_join(select(M_DAT, - pen), by = c("jahr", "sex", "alt")) %>%
      mutate(pen = ifelse(alt == x & sex == "m", pen_c, pen)) %>%
      select(- pen_c)
  }
  
  RR_EV <- RR_EV %>% 
    arrange(sex, alt, jahr) %>%
    mutate(pen_ref = ifelse(alt == 65, pen, NA)) %>%
    group_by(sex, coh) %>% 
    fill(pen_ref, .direction = "downup") %>%
    mutate(rz = pen / pen_ref) %>% 
    filter(alt <= PARAM_GLOBAL$rentenzyklus_max_alt) %>% 
    select(- pen, - pen_ref)
  
  RR_EV <- RR_EV %>%  
    ungroup() %>%
    # Jahres-/Kohortengrenzen werden über den Projektionshorizont gesetzt, um Randpunkt-
    # probleme in der späteren LOESS-Glättung zu vermeiden.
    mutate(jahr = factor(jahr, levels = 1997:(PARAM_GLOBAL$jahr_ende + 10)),
           coh  = factor(coh , levels = c(min(.$coh):((PARAM_GLOBAL$jahr_ende + 20) - 65)))) %>%
    complete(coh, jahr, sex, alt) %>%
    mutate(jahr = parse_number(as.character(jahr)),
           coh  = parse_number(as.character(coh))) %>%
    # Ausschluss inkohärenter Fälle sowie einzelner Männer-Kohorte wegen abnormalem 
    # Verlauf.
    filter(jahr - coh == alt, !(sex == "m" & coh == 1938),
           !(jahr <= PARAM_GLOBAL$jahr_rr & is.na(rz))) %>%
    group_by(sex, alt) %>%
    arrange(jahr, .by_group = TRUE) %>%
    # Bruchpunktanalyse zur Selektion der Extrapolationspunkte pro Zyklus-Zeitreihe 
    # konditional auf die vergangenen Lebensjahre seit 65. Die minimale Anzahl von Punkten
    # pro Segment 'h' wurde auf 3 gesetzt, um Cauchy-verteilte Prognosen zu vermeiden 
    # (gegeben normalverteilter Störterme). Die Restriktion auf Gruppen mit zumindest
    # '2 * h' Beobachtungen ist notwendig, um die minimalen Datenanforderungen der Methode 
    # zu erfüllen.
    mutate(w_rz = rz / lag(rz) - 1) %>%
    slice(- 1) %>% 
    mutate(bp = ifelse(sum(!is.na(w_rz)) >= 6,
                       max(breakpoints(w_rz ~ 1, h = 3)$breakpoints, 0, na.rm = TRUE), 
                       0),
           rz_c = ifelse(1:n() > bp, rz, NA)) %>%
    mutate(w_rz = rz_c / lag(rz_c) - 1) %>%
    # Restriktion auf Altersgruppen unterhalb der Zyklus-Altersobergrenze.
    filter(alt <= PARAM_GLOBAL$rentenzyklus_max_alt) %>%
    # Definition von 't' notwendig aufgrund der händisch entfernten Männer-Kohorte von 
    # 1938.
    mutate(t = c(1, diff(jahr - 1997)), fl = is.na(rz)) %>%
    ungroup() %>% 
    impute_lm(w_rz ~ 0 + t | sex + alt) %>%
    group_by(sex, alt) %>%
    arrange(jahr, .by_group = TRUE) %>%
    mutate(w_rz = is.na(rz) * w_rz) %>%
    fill(rz) %>%
    mutate(rz = rz * cumprod(1 + w_rz)) %>%
    select(coh, jahr, sex, alt, rz, rz_c) %>% 
    ungroup() 
  
  # Glättung der Zyklus-Prognosen anhand der LOESS-Methode.
  RR_L <- list()
  
  for (c in unique(RR_EV$coh)) {
    for (s in unique(RR_EV$sex)) {
      
      suppressWarnings({
        try({
          
          temp <-
            filter(RR_EV, coh == c, sex == s) %>%
            mutate(fl = ifelse(alt == 65, FALSE, TRUE)) %>%
            arrange(alt)
          
          temp$rz[temp$fl] <-
            predict(loess(rz ~ alt, temp))[temp$fl]
          
          RR_L[[paste0(c, s)]] <- temp
          
        }, silent = TRUE)
      })
    }
  }
  
  RR_EV <-
    bind_rows(RR_L) %>%
    filter(jahr <= PARAM_GLOBAL$jahr_ende)
  
  # Erweiterung der Projektionen um Nationalität und Domizil zur Kompatibilität mit Skript
  # 'mod_ahv_rentensumme_go'.
  RR_EV <- RR_EV %>% 
    expand(nat = c("ch", "au"), dom = c("ch", "au"), nesting(coh, jahr, sex, alt, rz)) %>% 
    select(coh, jahr, sex, nat, dom, alt, rz) %>% 
    filter(alt > 65) %>% 
    left_join(filter(RR_0, alt == 65) %>% select(coh, sex, nat, dom, pen), 
              by = c("coh", "sex", "nat", "dom"), relationship = "many-to-one") %>% 
    mutate(pen = pen * rz) %>% 
    select(- rz)
  
  # Zusammenführung der Prognosen zu den Rentenniveaus im Alter 62-65 (RR_0), der 
  # Durchschnittsrenten im Alter > 65 + rz_b (RR_F) sowie des Rentenzyklus (RR_EV) ---------
  RR_C <- 
    bind_rows(RR_0, RR_EV, RR_F) %>% 
    filter(jahr >= PARAM_GLOBAL$jahr_rr) %>% 
    group_by(sex, nat, dom, alt) %>% 
    arrange(jahr, .by_group = TRUE) %>% 
    mutate(w_pen = cumprod(pen / lag(pen, def = first(pen)))) %>%
    ungroup() %>% 
    select(sex, nat, dom, jahr, alt, pen, cumprod_param_erstrente = w_pen)
  
  RR_C <- RR_C %>% 
    arrange(alt, jahr) %>% 
    distinct() %>% 
    mutate(gpr = "rvieillesse") %>%
    # Unterscheidung von faktischem und konsolidiertem Alter über der Zyklus-Obergrenze
    # zu späteren Merge-Zwecken.
    rename(alt_c = alt)
  
  return(RENTENZYKLUS = RR_C)
}
