R/echantillonage.R

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

case_when <- function(...) {
  dots <- list(...)
  n <- length(dots)
  stopifnot(n %% 2 == 0)  # must be condition/value pairs
  conds  <- dots[c(TRUE, FALSE)]
  values <- dots[c(FALSE, TRUE)]
  
  # find the common length (assumes vectorization)
  len <- max(vapply(conds, length, integer(1)))
  out <- vector("list", len)
  assigned <- rep(FALSE, len)
  
  for (i in seq_along(conds)) {
    idx <- which(conds[[i]] & !assigned)
    out[idx] <- values[i]
    assigned[idx] <- TRUE
  }
  
  out
}

#' Jours de naissance échantillonnés des enquêtes EIR et EIC
#'
#' Reconstitue, pour une ou plusieurs enquêtes de la DREES (Échantillon
#' interrégimes de retraités, EIR, et Échantillon interrégimes de cotisants,
#' EIC), l'ensemble des jours de naissance retenus dans l'échantillon : par
#' génération, l'échantillonnage sélectionne certaines dates de naissance
#' précises (souvent en début de mois), selon un calendrier propre à chaque
#' enquête et à chaque génération.
#'
#' @param enquete Vecteur de codes d'enquêtes à inclure. Valeurs possibles :
#'   `"EIR_2016"`, `"EIR_2020"`, `"EIR_2024"`, `"EIC_2013"`, `"EIC_2017"`,
#'   `"EIC_2021"`. Par défaut, toutes les enquêtes connues.
#' @param format Forme du résultat : `"long"` (défaut) pour une ligne par
#'   couple (enquête, jour de naissance) ; `"large"` pour une ligne par jour de
#'   naissance et une colonne booléenne par enquête indiquant l'appartenance à
#'   son échantillon.
#'
#' @return Un `data.table`. En format `"long"`, les colonnes `enquete` et
#'   `jour_de_naissance` (`Date`). En format `"large"`, la colonne
#'   `jour_de_naissance` et une colonne logique par enquête.
#'
#' @examples
#' # Jours de naissance échantillonnés de l'EIR 2020
#' echantillonage("EIR_2020")
#'
#' # Croiser plusieurs enquêtes en format large
#' echantillonage(c("EIC_2017", "EIC_2021"), format = "large")
#'
#' @export
echantillonage <- function(enquete = c(
  "EIR_2016", "EIR_2020", "EIR_2024",
  "EIC_2013", "EIC_2017", "EIC_2021"
), format = "long"){

  enquetes <- c(
    "EIR_2016", "EIR_2020", "EIR_2024",
    "EIC_2013", "EIC_2017", "EIC_2021"
  )
  generationPremiere <- 1914
  generationDerniere <- 2004
  
  enquetes_inconnues <- setdiff(enquete, enquetes)
  if(length(enquetes_inconnues) > 0) stop(
    "Les enquetes ", paste(enquetes_inconnues, collapse = ", "),
    " sont inconnues, mal orthographi\u00e9es ou n'ont pas encore \u00e9t\u00e9 impl\u00e9ment\u00e9es. ",
    "\nLes enqu\u00eates connues sont : ", paste(enquetes, collapse = ", ")
  )
  
  tmp <- CJ(
    generation = as.integer(generationPremiere:generationDerniere),
    enquete
  )[
    j = list(
      generation, enquete,
      jours = mapply(generation, enquete, FUN = function(g, q) case_when(
        # ------- EIR ---------------------------
        q %in% c("EIR_2016", "EIR_2020") & g==1915, lubridate::make_date(g, 10L, 1: 5),
        q=="EIR_2016" & g %in% c(1918, 1922, 1926), lubridate::make_date(g, 10L, 1:10),
        q=="EIR_2016" & g %in% c(1920, 1924, 1928), lubridate::make_date(g, 10L, 1: 3),
        q=="EIR_2020" & g %in% seq(1918, 1930, 2L), lubridate::make_date(g, 10L, 1:10),
        q=="EIR_2016" & g %in% seq(1930, 1940, 2L), lubridate::make_date(g, 10L, 1: 6),
        q=="EIR_2020" & g %in% 1931:1941,           lubridate::make_date(g, 10L, 1:10),
        q=="EIR_2024" & g %in% 1914:1941,           lubridate::make_date(g, 10L, 1:10),
        (
          (q=="EIR_2016" & g %in% c(1942, 1944, 1946:1949)) |
          (q=="EIR_2020" & g %in% 1942:1949) |
          (q=="EIR_2024" & g %in% 1942:1952)
        ), c(
          lubridate::make_date(g,  1L, 2: 5),
          lubridate::make_date(g,  4L, 1: 4),
          lubridate::make_date(g,  7L, 1: 4),
          lubridate::make_date(g, 10L, 1:10)
        ),
        q %in% c("EIR_2016", "EIR_2020") & g==1950, c(
          lubridate::make_date(g,  1L, 2: 5),
          lubridate::make_date(g,  4L, 1: 4),
          lubridate::make_date(g,  7L, 1: 4),
          lubridate::make_date(g, 10L, 1:24) # ATTENTION: 24
        ),
        q=="EIR_2016" & g %in% 1951:1960, c(
          lubridate::make_date(g,  1L, 2: 5),
          lubridate::make_date(g,  4L, 1: 4),
          lubridate::make_date(g,  7L, 1: 4),
          lubridate::make_date(g, 10L, 1:10)
        ),
        (
          (q=="EIR_2020" & g %in% 1951:1960) |
          (q=="EIR_2024" & g %in% 1953:1966)
        ), c(
          lubridate::make_date(g,  1L, 2: 5),
          lubridate::make_date(g,  2L, 1: 4),
          lubridate::make_date(g,  3L, 1: 4),
          lubridate::make_date(g,  4L, 1: 4),
          lubridate::make_date(g,  5L, 1: 4),
          lubridate::make_date(g,  6L, 1: 4),
          lubridate::make_date(g,  7L, 1: 4),
          lubridate::make_date(g,  8L, 1: 4),
          lubridate::make_date(g,  9L, 1: 4),
          lubridate::make_date(g, 10L, 1:10),
          lubridate::make_date(g, 11L, 1: 4),
          lubridate::make_date(g, 12L, 1: 4)
        ),
        (
          (q=="EIR_2016" & g %in% c(1961:1964, seq(1966, 1982, 2))) |
          (q=="EIR_2020" & g %in% 1961:2000) |
          (q=="EIR_2024" & g %in% 1967:2004)
        ), c(
          lubridate::make_date(g,  1L, 2: 5),
          lubridate::make_date(g,  4L, 1: 4),
          lubridate::make_date(g,  7L, 1: 4),
          lubridate::make_date(g, 10L, 1:10)
        ),
        # ------- EIC ---------------------------
        (
            (q=="EIC_2013" & g %in% seq(1942, 1990, 4)) |
            (q=="EIC_2017" & g %in% seq(1946, 1994, 4)) |
            (q=="EIC_2021" & g %in% seq(1946, 1998, 4)) # on garde 1946
        ), c(
            lubridate::make_date(g,  1L, 2: 3),
            lubridate::make_date(g,  4L, 1: 2),
            lubridate::make_date(g,  7L, 1: 2),
            lubridate::make_date(g, 10L, 1:10)
        ),
        (
            (q=="EIC_2013" & g %in% seq(1956, 1988, 4)) |
            (q=="EIC_2017" & g %in% seq(1956, 1992, 4)) | # on garde 1956
            (q=="EIC_2021" & g %in% seq(1956, 1996, 4))   # on garde 1956
        ), c(
            lubridate::make_date(g,  1L, 2: 3),
            lubridate::make_date(g,  4L, 1: 2),
            lubridate::make_date(g,  7L, 1: 2),
            lubridate::make_date(g, 10L, 1: 2)
        )
      )[[1]])
    )
  ] |>
      tidyr::unnest(cols = jours) |>
      as.data.table() |>
      _[, let(generation = NULL)][] |>
      setnames(old = "jours", new = "jour_de_naissance")

    if(format == "long") return(tmp) else if(format == "large") return(
        tmp |>
            _[, let(dummy = TRUE)] |>
            tidyr::pivot_wider(
                names_from = enquete,
                values_from = dummy,
                values_fill = FALSE
            )
    ) else stop("Format", format, "inconnu. Essayez avec 'long' ou 'large'.")
}