admissibilite1: Admissibilité des individus

#' Structure dataset d'analyse
#'
#' Arrangement des périodes d'admissibilité et d'inadmissiblité
#'
#' @param database Nom du type d'admissibilité à créer. `prior`, `rpam` ou `rqam`.
#' @param save_struct `TRUE` ou `FALSE`. Sauvegarder ou non les résultats structurés sous la forme de dataset représentant une année financière.
#' @return data.table de 7 variables : ID, SEXE, DDN, DDC, DDsld, DDP, DFP.
#' @keywords internal
#' @import data.table
#' @export
struct_admis <- function (
  database,  # sélection de la BD à structurer
  save_struct = TRUE
) {

  t0 <- Sys.time()
  self <- .struct_admis_internal()
  self$verif_args(database)  # vérification des arguments

  t1 <- Sys.time()
  dt <- self$select_database(database)  # importation du dataset d'analyse
  self$time_msg("Importation", t1, t0)
  self$verif1(dt)
  dates_extract <- attr(dt, "dates_extract")  # dates d'analyse [debut, fin]
  date_extraction <- attr(dt, "date_extraction")  # date de création du dataset : extraction
  dt <- self$cols_select(dt)  # nom + class des colonnes

  t1 <- Sys.time()
  dt <- self$dt_arrange1(dt, dates_extract)  # arrangement dates et fusion chevauchement
  self$time_msg("Dates et chevauchements", t1, t0)

  t1 <- Sys.time()
  obs_cas <- self$separate_cas(dt)  # filtrer les obs à gérer
  sans_cas <- obs_cas$sans_cas  # obs sans besoin de modifications
  avec_cas <- obs_cas$avec_cas  # obs ayant besoin de modifications
  rm(dt, obs_cas)
  if (is.null(avec_cas)) {  # si pas de cas à gérer
    dt <- copy(sans_cas)
  } else {
    avec_cas <- self$apply_casX(avec_cas)  # appliquer modifications nécessaires selon statut admissibilite
    attr(avec_cas, "loop") <- NULL  # supprimer attributes de loop
    dt <- rbind(avec_cas, sans_cas)  # combiner toutes les obs
  }
  rm(sans_cas, avec_cas)
  setkey(dt, ID, DDP)
  self$time_msg("Cas", t1, t0)

  t1 <- Sys.time()
  ddsld <- self$import_ddsld()  # dates sld des ID
  dt <- merge(  # ajouter ddsld
    dt, ddsld,
    by = "ID",
    all.x = TRUE  # conserver valeurs de dt
  )
  rm(ddsld)
  self$time_msg("DDsld", t1, t0)
  dt <- dt[PER_ADMIS == TRUE]  # conserver uniquement les périodes d'admissibilité
  dt[, PER_ADMIS := NULL]

  t1 <- Sys.time()
  dt <- self$dt_arrange2(dt)  # combiner obs qui se chevauchent
  self$time_msg("Chevauchements finaux", t1, t0)

  if (save_struct) {
    t1 <- Sys.time()
    self$save_AF(dt, database, dates_extract, date_extraction)
    self$time_msg("Sauvegarde", t1, t0)
  }
  return(dt)

}

#' Internal
#' @keywords internal
#' @import data.table
#' @importFrom stringr str_detect str_sub
#' @importFrom lubridate as_date
#' @importFrom crayon green
#' @export
.struct_admis_internal <- function () {return(list(

  ### Arguments
  dir_donnes_brutes = "V:/_ADMIS/R data/Données Brutes/",  # répertoire des données brutes
  save_dir = "V:/_Tables_Admissibilite_Agregees/",  # répertoire où sauvegarder les données
  ### Vérifications
  verif_args = function (database) {
    # Verif arguments
    check <- newArgCheck()
    if (!database %in% c("prior", "rpam", "rqam"))
      addError("Valeurs permises de database : {'prior', 'rpam', 'rqam'}.", check)
    finishArgCheck(check)
  },
  verif1 = function (dt) {
    # Vérifications suivant l'importation du dataset d'analyse
    # 1) Nom des colonnes, 2) attribut dates_extract, 3) attribut date_extraction
    check <- newArgCheck()
    # Colonnes nécessaires
    dt_cols <- c(
      "ID", "SEXE", "DDN", "DDC",
      "PER_ADMIS" , "DDP", "DFP"
    )
    for (col in dt_cols) {
      if (!col %in% names(dt))
        addError(paste0(col," n'est pas une variable du dataset importé."), check)
    }
    # dates_extract : périodes d'analyse disponibles
    dates_extract <- attr(dt, "dates_extract")
    if (is.null(dates_extract))
      addError("L'attribut dates_extract n'existe pas selon le dataset importé.", check)
    # date_extraction : date à laquelle l'extraction SQL a été faite
    date_extraction <- attr(dt, "date_extraction")
    if (is.null(date_extraction))
      addError("L'attribut date-extraction n'existe pas selon le dataset importé.", check)

    finishArgCheck(check)
  },
  ### Fonctions
  select_database = function (database) {
    # Importation des données brutes selon le type de dataset d'analyse
    files <- list.files(.struct_admis_internal()$dir_donnes_brutes)  # nom des fichiers présents
    if (database %in% c("rpam", "rqam")) {
      file <- files[str_detect(files, database)]  # sélectionner le bon fichier à importer
      return(  # importation du fichier
        as.data.table(
          readRDS(paste0(.struct_admis_internal()$dir_donnes_brutes,
                         file))
        )
      )
    } else if (database == "prior") {
      file <- files[str_detect(files, "rpam")]  # sélectionner le bon fichier à importer
      dt <- readRDS(  # importation du fichier
        paste0(.struct_admis_internal()$dir_donnes_brutes,
               file)
      )
      dt <- as.data.table(dt)
      dt <- dt[VUE_SRC == "V_ADMIS_ASSU_MED_PLAN_PRIOR_CM"]  # filtrer les observations pour conserver prior seulement
      return(dt)
    }
  },
  cols_select = function (dt) {
    # Sélection des colonnes nécessaires
    return(dt[
      , .(ID = as.integer(ID),
          SEXE = as.character(SEXE),
          DDN = as_date(DDN),
          DDC = as_date(DDC),
          PER_ADMIS = as.logical(PER_ADMIS),
          DDP = as_date(DDP),
          DFP = as_date(DFP))
    ])
  },
  dt_arrange1 = function (dt, dates_extract) {
    # Arrangement du dataset d'analyse
    # 1) Modifier les dates de début+fin hors analyse
    # 2) Fusionner les périodes qui se chevauchent
    dt[  # modifier date de début et de fin selon l'intervalle d'analyse
      DDP < dates_extract$debut,
      DDP := as_date(dates_extract$debut)
    ]
    dt[
      DFP > dates_extract$fin,
      DFP := as_date(dates_extract$fin)
    ]
    if (nrow(dt[DDP > DFP]))  # afficher avertissement si valeurs inabituelles
      warning("Voir extraction, DDP > DFP après modifications.")
    # Fusionner les périodes qui se chevauchent
    idx <- dt[, .I[.N > 1], .(ID, PER_ADMIS)]$V1
    if (length(idx)) {
      setkey(dt, ID, PER_ADMIS, DDP)
      dt[  # nbre jours entre DDP{i} et DFP{i-1}
        ,
        diff := int(DDP - shift(DFP)),
        .(ID, PER_ADMIS)
      ][is.na(diff), diff := 0L]
      dt[, period := 0L]
      dt[diff > 1, period := 1L]  # 1 indique un changement de période
      dt[, period := cumsum(period) + 1, .(ID, PER_ADMIS)]  # période allant de 1 à n
      dt <- dt[  # fusionner les périodes qui se chevauchent
        , .(DDP = min(DDP),
            DFP = max(DFP)),
        .(ID, SEXE, DDN, DDC, PER_ADMIS, period)
      ][, period := NULL]
    }
    setkey(dt, ID, DDP)
    return(dt)
  },
  dt_arrange2 = function (dt) {
    # 2e Fusion des périodes qui se chevauchent après avoir été modifiées
    idx <- dt[, .I[.N > 1], .(ID)]$V1
    if (length(idx)) {
      dt[idx, diff := int(DDP - shift(DFP)), .(ID)]
      dt[is.na(diff), diff := 0L]
      dt[, period := 0L][diff > 1, period := 1L]
      dt[, period := cumsum(period) + 1L]
      dt <- dt[
        , .(DDP = min(DDP),
            DFP = max(DFP)),
        .(ID, SEXE, DDN, DDC, DDsld, period)
      ][, period := NULL]
    }
    return(dt)
  },
  separate_cas = function (dt) {
    # Séparer les cas à gérer de ceux qui n'en ont pas besoin :
    # 1) 1 seule obs, 2) tous TRUE, 3) tous FALSE

    # Id ayant une seule obs
    idx <- dt[, .I[.N == 1], .(ID)]$V1
    if (length(idx)) {
      obs1 <- dt[idx]
      dt <- dt[!idx]
    } else {
      obs1 <- NULL
    }
    # ID ayant 1 seul type d'admissibilite
    idx <- dt[, .I[
      all(PER_ADMIS == TRUE) | all(PER_ADMIS == FALSE)
    ], .(ID)]$V1
    if (length(idx)) {
      all_TorF <- dt[idx]
      dt <- dt[!idx]
    } else {
      all_TorF <- NULL
    }
    # Regrouper les obs qui n'ont pas besoin d'être gérées
    sans_cas <- data.table()
    if (!is.null(obs1)) {  # insérer les obs1 s'il y en a
      sans_cas <- rbind(sans_cas, obs1)
    }
    if (!is.null(all_TorF)) {  # obs ayant tous les même type d'admissibilite
      sans_cas <- rbind(sans_cas, all_TorF)
    }
    if (!nrow(sans_cas)) {  # s'il n'y a pas d'obs, convertir le data.table en NULL
      sans_cas <- NULL
    }
    if (nrow(dt)) avec_cas <- copy(dt) else avec_cas <- NULL

    return(list(
      sans_cas = sans_cas,
      avec_cas = avec_cas
    ))

  },
  ### Fonctions qui gèrent les cas
  apply_casX = function (avec_cas) {
    # Appliquer toutes les fonctions casX(avec_cas) les unes après les autres et
    # recommencer s'il y a au moins une modification -> une modification peut
    # impliquer une nouvelle modification qui n'était pas là au tour précédent.
    attr(avec_cas, "loop") <- TRUE
    while (attr(avec_cas, "loop")) {
      attr(avec_cas, "loop") <- FALSE
      for (cas in 1:4)
        avec_cas <- .struct_admis_internal()[[paste0(".cas",cas)]](avec_cas)
    }
    return(avec_cas)
  },
  .cas1 = function (avec_cas) {
    # nonAdmis (0) suivi d'un Admis (1) : Admis_{i}=1 & Admis_{i-1}=0
    # DDP_{i} > Debut_Admis_{i-1}
    # DFP de l'Admis <= DFP du nonAdmis : DFP_{i} <= DFP_{i-1}
    avec_cas <- copy(avec_cas)
    setkey(avec_cas, ID, DDP, PER_ADMIS)
    idx <- avec_cas[, .I[  # no de lignes à gérer
      PER_ADMIS == TRUE & shift(PER_ADMIS) == FALSE  # Admis précédé d'un nonAdmis
      & DFP <= shift(DFP)  # sa fin est <= que la précédente
    ], .(ID)][!is.na(V1)]$V1
    if (length(idx)) {
      avec_cas <- avec_cas[!idx]
      attr(avec_cas, "loop") <- TRUE
    }
    return(avec_cas)
  },
  .cas2 = function (avec_cas) {
    # nonAdmis (0) suivi d'un Admis (1) : Admis_{i}=1 & Admis_{i-1}=0
    # Admis chevauche nonAdmis : DDP_{i} <= DFP_{i-1}
    # Admis se termine après : DFP_{i} > DFP_{i-1}
    avec_cas <- copy(avec_cas)
    setkey(avec_cas, ID, DDP, PER_ADMIS)
    idx <- avec_cas[, .I[
      PER_ADMIS == TRUE & shift(PER_ADMIS) == FALSE  # Admis précédé d'un nonAdmis
      & DDP <= shift(DFP)  # debut du nonAdmis est avant celui du Admis
      & DFP > shift(DFP)  # la fin du nonAdmis est plus grande que celle du Admis
    ], .(ID)][!is.na(V1)]$V1
    if (length(idx)) {
      avec_cas[  # indiquer la fin précédente
        sort(c(idx, idx-1)),
        FinAv := shift(DFP),
        .(ID)
      ]
      avec_cas[  # nouveau debut = fin précédente + 1
        idx,
        DDP := FinAv + 1
      ]
      avec_cas[, FinAv := NULL]  # supprimer colonne ajustement date
      attr(avec_cas, "loop") <- TRUE
    }
    return(avec_cas)
  },
  .cas3 = function (avec_cas) {
    # Admis suivi d'un nonAdmis : Admis_{i}=0 & Admis_{i-1}=1
    # nonAdmis chevauche Admis : DDP_{i} <= DFP_{i-1}
    # nonAdmis se termine après : DFP_{i} > DFP_{i-1}
    avec_cas <- copy(avec_cas)
    setkey(avec_cas, ID, DDP, PER_ADMIS)
    idx <- avec_cas[, .I[
      PER_ADMIS == FALSE & shift(PER_ADMIS) == TRUE  # nonAdmis
      & DDP <= shift(DFP)
      & DFP >= shift(DFP)
    ], .(ID)][!is.na(V1)]$V1
    if (length(idx)) {
      avec_cas[  # indiquer le début suivant
        sort(c(idx, idx-1)),
        DebutAp := shift(DDP,-1),
        .(ID)
      ]
      avec_cas[idx-1, DFP := DebutAp - 1]  # nouvelle fin = debut suivant - 1
      avec_cas[, DebutAp := NULL]   # supprimer colonne ajustement date
      attr(avec_cas, "loop") <- TRUE
    }
    return(avec_cas)
  },
  .cas4 = function (avec_cas) {
    # Admis suivi d'un nonAdmis : Admis_{i} == FALSE et Admis_{i-1} == TRUE
    # nonAdmis inclut dans Admis : DFP_{i} < DFP_{i-1}
    avec_cas <- copy(avec_cas)
    setkey(avec_cas, ID, DDP, PER_ADMIS)
    idx <- avec_cas[, .I[
      PER_ADMIS == FALSE & shift(PER_ADMIS) == TRUE
      & DFP < shift(DFP)
    ], .(ID)][!is.na(V1)]$V1
    if (length(idx)) {
      avec_cas[  # indiquer la date de début du nonAdmis
        sort(c(idx, idx-1)),
        DebutAp := shift(DDP,-1),
        .(ID)
      ]
      avec_cas[
        idx-1,
        `:=` (d1 = DDP,  # indiquer la période Admis qui précède celle du nonAdmis
              f1 = DebutAp - 1)
      ]
      avec_cas[, DebutAp := NULL]  # supprimer colonne ajustement
      # Section à droite du nonAdmis
      avec_cas[  # indiquer la date de début du nonAdmis
        sort(c(idx, idx-1)),
        FinAp := shift(DFP,-1),
        .(ID)
      ]
      avec_cas[
        idx-1,
        `:=` (d2 = FinAp + 1,  # indiquer la période Admis qui précède celle du nonAdmis
              f2 = DFP)
      ]
      avec_cas[, FinAp := NULL]  # supprimer colonne ajustement
      # Arrangement du data
      avec_cas[  # indiquer date de début et de fin pour ceux qui n'ont pas été géré
        is.na(d1) & is.na(d2),
        `:=` (d1 = DDP,
              f1 = DFP)
      ]
      melt_varName <- paste(sample(letters, 5, T), collapse = "")  # créer un nom de colonne qui n'existe pas dans x
      while(melt_varName %in% names(avec_cas)) melt_varName <- paste(sample(letters, 5, T), collapse = "")  # recréer si existe
      melt_varID <- names(avec_cas)[!names(avec_cas) %in% c("DDP", "DFP", "d1", "f1", "d2", "f2")]
      avec_cas <- melt(
        avec_cas,
        id.vars = melt_varID,  # colonnes à conserver
        measure.vars = list(c("d1", "d2"), c("f1", "f2")),  # colonnes à mettre en ligne
        variable.name = melt_varName,
        value.name = c("DDP", "DFP"),
        na.rm = TRUE  # supprimer colonnes sans valeur (d2 et f2)
      )
      avec_cas[, paste(melt_varName) := NULL]  # supprimer colonne variable créer au melt()
      attr(avec_cas, "loop") <- TRUE
    }
    return(avec_cas)
  },
  ### DDsld
  import_ddsld = function () {
    files <- list.files(.struct_admis_internal()$dir_donnes_brutes)  # nom des fichiers présents
    file <- files[str_detect(files, "ddsld")]
    ddsld <- readRDS(paste0(.struct_admis_internal()$dir_donnes_brutes, file))
    ddsld <- ddsld[
      , .(ID = as.integer(ID),
          DDsld = as_date(DDsld))
    ]
    return(ddsld)
  },
  ### Save
  save_AF = function (dt, database, dates_extract, date_extraction) {
    # Sauvegarder le dataset sous plusieurs datas représentant chacun une
    # année financière
    AFfirst <- year(as_date(dates_extract$debut))  # années financières à créer
    AFlast <- year(as_date(dates_extract$fin)) - 1L
    for (af in AFfirst:AFlast) {
      deb <- as_date(paste0(af,"-04-01"))  # debut de l'année financière
      fin <- as_date(paste0(af+1,"-03-31"))  # fin de l'année financière
      dt_af <- dt[deb <= DFP & fin >= DDP]  # select obs chevauche intervale année financière
      dt_af[DDP < deb, DDP := deb]  # arranger les dates hors de l'intervale
      dt_af[DFP > fin, DFP := fin]
      saveRDS(  # sauvegarde de l'année financière
        dt_af, paste0(
          .struct_admis_internal()$save_dir,  # répertoire
          toupper(database),"/",  # sous-dossier
          toupper(database),
          "_AF",af,"_",  # indiquer AF
          "extract",str_sub(date_extraction, 1, 10),"_",  # date extraction SQL
          Sys.Date(),  # date création
          ".rds"
        )
      )
    }
  },
  ### Time messages
  time_msg = function (desc, deb, tot) {
    # Affiche le temps de l'exécution et le temps total : temps units (total units)
    #   desc : Texte décrivant l'étape qui vient de se terminer.
    #   deb : temps où l'étape a commencé.
    #   tot : temps où la fonction a commencé.
    fin <- Sys.time()
    message(green(paste0(  # indiquer le temps nécessaire pour l'importation
      desc," : ",
      round(difftime(fin, deb), 2)," ", attr(difftime(fin, deb), "units"),
      " (", round(difftime(fin, tot), 2)," ", attr(difftime(fin, tot), "units"),")"
    )))
  }

))}