R/aod.R

In legiretraite: Recueil De Paramètres Législatifs et Réglementaires Sur Les Retraites Françaises

#' Récupère tous les AOD, quelle que soit la catégorie ou l'année de naissance
#'
#' Le résultat est caché après le premier appel.
#' La colonne `dateNaissanceEstimee` est ajoutée pour les lignes qui n'ont
#' qu'une `dateApplication` : elle est calculée comme `dateApplication - aod * 12 mois`.
#'
#' @return Un `data.table` de la table de référence des AOD, avec notamment les
#'   colonnes `aod` (âge d'ouverture des droits), `caisse`, `categorie`,
#'   `dateNaissance`, `dateApplication` et `dateNaissanceEstimee`.
#' @examples
#' # Table de référence complète
#' head(aod_reference())
#'
#' # Barème AOD de droit commun par génération (caisse et catégorie non
#' # renseignées), comme utilisé pour tracer l'AOD dans trajectoire
#' aod_reference()[is.na(caisse) & is.na(categorie), .(dateNaissance, aod)]
#' @export
aod_reference <- local({
  cache <- NULL
  function(){
    if(!is.null(cache)) return(cache)
    dt <- fread(
      system.file("extdata", "aod.csv", package = "legiretraite"),
      na.strings = c("", "NA")
    )
    for(col in c("dateNaissance", "dateApplication")){
      if(col %in% names(dt) && is.character(dt[[col]])){
        dt[, (col) := lubridate::make_date(
          year = substr(get(col), 1, 4),
          month = substr(get(col), 6, 7)
        )]
      }
    }
    # Pour les lignes avec dateApplication sans dateNaissance, on estime la
    # dateNaissance charnière : dateApplication - aod * 12 mois.
    # Pour les sentinelles (aod = NA = "la règle spécifique cesse"), on utilise
    # le dernier aod connu du même (caisse, categorie) pour calculer la
    # dateNaissance charnière : sans ça, la sentinelle est ignorée et la règle
    # historique s'applique indéfiniment.
    dt[, .rid := .I]
    setorder(dt, caisse, categorie, dateApplication, na.last = TRUE)
    dt[, aod_locf := nafill(aod, type = "locf"), by = list(caisse, categorie)]
    dt[, dateNaissanceEstimee := fifelse(
      is.na(dateNaissance) & !is.na(dateApplication) & !is.na(aod_locf),
      as.Date(dateApplication - lubridate::dmonths(aod_locf * 12)),
      dateNaissance
    )]
    setorder(dt, .rid)
    dt[, c(".rid", "aod_locf") := NULL]
    cache <<- dt
    dt
  }
})

#' Récupère les AOD pour la caisse, la catégorie et la date de naissance spécifiées
#'
#' @param dateNaissance date de naissance (Date, vectorisé)
#' @param dateLiq date de liquidation (Date, vectorisé, optionnel)
#' @param caisse nom de la caisse (character, vectorisé, optionnel)
#' @param categorie catégorie : "actif", "superactif", "sedentaire", "invalide", "inapte" (character, vectorisé, optionnel)
#'
#' @return Un `data.table` d'une ligne par observation, avec la colonne `aod`
#'   (âge d'ouverture des droits, numérique) et les clés fournies
#'   (`dateNaissance`, `caisse`, `categorie`).
#' @examples
#' # AOD de droit commun pour plusieurs générations
#' aod_individuel(as.Date(c("1955-01-01", "1962-01-01")))
#'
#' # Pour une caisse et une date de liquidation données
#' aod_individuel(as.Date("1962-06-01"), dateLiq = as.Date("2024-01-01"),
#'                caisse = "CNAVPL")
#' @export
aod_individuel <- function(
  dateNaissance,
  dateLiq = NA,
  caisse = NA_character_,
  categorie = NA_character_
){
  aod_lookup(dateNaissance, dateLiq, caisse, categorie)
}

#' Renvoie l'AOD en vecteur
#'
#' Alias de \code{aod_individuel()} qui renvoie uniquement le vecteur d'AOD.
#'
#' @inheritParams aod_individuel
#' @return vecteur numérique des AOD
#' @examples
#' # AOD (âge d'ouverture des droits) de droit commun, génération 1955
#' aod(as.Date("1955-01-01"))
#'
#' # Vectorisé sur plusieurs dates de naissance
#' aod(as.Date(c("1950-01-01", "1954-01-01", "1973-01-01")))
#'
#' # Pour une caisse particulière (usage typique dans trajectoire)
#' aod(as.Date("1958-01-01"), caisse = "MSA exploitant")
#'
#' # Avec une date de liquidation et une caisse
#' aod(as.Date("1962-06-01"), dateLiq = as.Date("2024-01-01"), caisse = "CNAVPL")
#' @export
aod <- function(
  dateNaissance,
  dateLiq = NA,
  caisse = NA_character_,
  categorie = NA_character_
){
  aod_individuel(dateNaissance, dateLiq, caisse, categorie)$aod
}

#' Internal : logique de lookup AOD
#'
#' Séparée de aod_individuel() pour permettre le remplacement dans les benchmarks.
#'
#' @inheritParams aod_individuel
#' @return Un `data.table` avec la colonne `aod` et les clés
#'   (`dateNaissance`, `caisse`, `categorie`).
#' @keywords internal
#' @export
aod_lookup <- function(
  dateNaissance,
  dateLiq = NA,
  caisse = NA_character_,
  categorie = NA_character_
){
  n <- length(dateNaissance)

  # Au-delà de 10 000 observations, on déduplique d'abord
  if(n > 10000){
    query <- data.table(dateNaissance, dateLiq = as.Date(dateLiq), caisse, categorie)
    dedup <- unique(query)
    dedup[, aod := aod_lookup_inner(dedup$dateNaissance, dedup$dateLiq, dedup$caisse, dedup$categorie)$aod]
    res <- dedup[query, on = names(query)]
    return(res[, .(aod, dateNaissance, caisse, categorie)])
  }

  aod_lookup_inner(dateNaissance, dateLiq, caisse, categorie)
}

#' Internal : logique de lookup AOD sans déduplication
#'
#' @keywords internal
aod_lookup_inner <- function(
  dateNaissance,
  dateLiq = NA,
  caisse = NA_character_,
  categorie = NA_character_
){
  ref <- aod_reference()

  query <- data.table(
    dateNaissance = dateNaissance,
    dateLiq = as.Date(dateLiq),
    caisse = caisse,
    categorie = categorie,
    aod = NA_real_
  )

  # Caisses individuelles des régimes spéciaux : agrégées sous "Regime special"
  # pour le lookup. Tant qu'on n'a pas de barème AOD propre à chacune (SNCF,
  # ENIM, etc.), on applique le barème commun des régimes spéciaux.
  # À étendre / éclater si un régime introduit un calendrier distinct.
  query[caisse %in% caissesRegimesSpeciauxIndividuels, caisse := "Regime special"]

  # Pour les caisses FP/régimes spéciaux, sédentaire par défaut si categorie absente
  caisses_avec_sedentaire <- ref[categorie == "sedentaire" & !is.na(caisse), unique(caisse)]
  query[!is.na(caisse) & is.na(categorie) & caisse %in% caisses_avec_sedentaire,
        categorie := "sedentaire"]

  ref_dateApp <- ref[!is.na(dateApplication) & !is.na(caisse)]
  ref_dateNai <- ref[is.na(dateApplication) & !is.na(caisse)]
  ref_generique <- ref[is.na(caisse) & is.na(dateApplication)]

  # 1a. caisse + dateApplication + dateLiq fourni
  idx <- which(!is.na(query$caisse) & !is.na(query$dateLiq) & is.na(query$aod))
  if(length(idx) > 0){
    matched <- ref_dateApp[
      query[idx],
      on = list(caisse, categorie, dateApplication = dateLiq),
      roll = TRUE, rollends = c(TRUE, TRUE),
      nomatch = NA
    ]$aod
    set(query, i = idx, j = "aod", value = matched)
  }

  # 1b. caisse + dateApplication + dateLiq absent → dateNaissanceEstimee
  ref_estime <- ref_dateApp[!is.na(dateNaissanceEstimee)]
  idx <- which(!is.na(query$caisse) & is.na(query$dateLiq) & is.na(query$aod))
  if(length(idx) > 0 && nrow(ref_estime) > 0){
    matched <- ref_estime[
      query[idx],
      on = list(caisse, categorie, dateNaissanceEstimee = dateNaissance),
      roll = TRUE, rollends = c(TRUE, TRUE),
      nomatch = NA
    ]$aod
    set(query, i = idx, j = "aod", value = matched)
  }

  # 1c. caisse + dateNaissance (pas de dateApplication dans la ref)
  idx <- which(!is.na(query$caisse) & is.na(query$aod))
  if(length(idx) > 0 && nrow(ref_dateNai) > 0){
    matched <- ref_dateNai[
      query[idx],
      on = list(caisse, categorie, dateNaissance),
      roll = TRUE, rollends = c(TRUE, TRUE),
      nomatch = NA
    ]$aod
    set(query, i = idx, j = "aod", value = matched)
  }

  # 2. fallback sur les lignes génériques (par categorie)
  idx <- which(is.na(query$aod))
  if(length(idx) > 0){
    matched <- ref_generique[
      query[idx],
      on = list(categorie, dateNaissance),
      roll = TRUE, rollends = c(TRUE, TRUE),
      nomatch = NA
    ]$aod
    set(query, i = idx, j = "aod", value = matched)
  }

  # 3. dernier fallback : si toujours NA, on réessaie sans categorie (droit commun)
  idx <- which(is.na(query$aod))
  if(length(idx) > 0){
    matched <- ref_generique[
      query[idx, .(categorie = NA_character_, dateNaissance)],
      on = list(categorie, dateNaissance),
      roll = TRUE, rollends = c(TRUE, TRUE),
      nomatch = NA
    ]$aod
    set(query, i = idx, j = "aod", value = matched)
  }

  query[, dateLiq := NULL]
  setcolorder(query, c("aod", "dateNaissance", "caisse", "categorie"))
  query
}

#' Internal : lookup avec déduplication
#'
#' @inheritParams aod_individuel
#' @return Un `data.table` avec la colonne `aod` et les clés
#'   (`dateNaissance`, `caisse`, `categorie`).
#' @keywords internal
#' @export
aod_lookup_dedup <- function(
  dateNaissance,
  dateLiq = NA,
  caisse = NA_character_,
  categorie = NA_character_
){
  query <- data.table(dateNaissance, dateLiq = as.Date(dateLiq), caisse, categorie)
  dedup <- unique(query)
  dedup_res <- aod_lookup(
    dedup$dateNaissance, dedup$dateLiq, dedup$caisse, dedup$categorie
  )
  dedup[, aod := dedup_res$aod]
  query[dedup, on = names(query), nomatch = NA][, .(aod, dateNaissance, caisse, categorie)]
}