R/merge_dates.R

In guiboucher/INESSS-inesss: INESSS

#' Regrouper observations
#'
#' Regroupe en une observation toutes celles dont la date de fin chevauche la date de début suivante.
#'
#' @param data dataset.
#' @param debut Nom de la colonne de date de début.
#' @param fin Nom de la colonne de date de fin.
#' @param by Regrouper les observation par `by`.
#' @param keep.cols Vecteur des noms de colonnes à conserver. Doit être une valeur unique comme le sexe, l'âge, la date de naissance, etc.
#'
#' @return data.table avec les colonnes `by`, `debut`, `fin` et peut-être `keep.cols`.
#' @import data.table
#' @importFrom lubridate is.Date as_date
#' @export
#' @examples
#' DT <- data.frame(
#'   ID = c(rep(123,4),
#'          rep(789, 2)),
#'   Date_debut = c("2000-01-01", "2000-02-15", "2000-02-28", "2000-03-01",
#'                  "2005-06-25", "2005-06-17"),
#'   Date_fin = c("2000-02-16", "2000-02-28", "2000-03-04", "2000-03-15",
#'                "2005-06-15", "2005-06-30")
#' )
#' merge_dates(DT, "Date_debut", "Date_fin", "ID")
merge_dates <- function(data, debut, fin, by, keep.cols = NULL){
  x <- as.data.table(data); rm(data)
  setnames(x, c(debut, fin), c("debut", "fin"))  # renommer colonne
  if(!is.null(keep.cols)){  # s'il y a des colonnes d'informations à conserver
    if(any(by %in% keep.cols)){  # vérification des variables by et keep.col
      stop("Les valeurs 'keep.cols' ne peuvent être également dans 'by'.")
    }
    keep_cols <- c(by, keep.cols)  # colonnes à sélectionner
    dt_keepCols <- unique(x[, ..keep_cols])  # sélection des colonnes
    if(nrow(dt_keepCols) != nrow(unique(dt_keepCols, by = by))){  # vérification pour futur merge
      stop("Revoir les noms de colonne de la variable 'keep.col'. Doit être de l'information unique comme l'âge, le sexe, date de naissance...")
    }
  }
  cols <- c(by, "debut", "fin")  # colonnes à sélectionner
  x <- x[, ..cols]  # sélection des colonnes
  if(!is.Date(x$debut)) x[, debut := as_date(debut)]  # convertir en DATE si nécessaire
  if(!is.Date(x$fin)) x[, fin := as_date(fin)]
  setkeyv(x, c(by, "debut"))  # trier by+debut

  # Dataset des colonnes à conserver autre que 'by'

  idx <- x[, .I[.N > 1], by]$V1  # no de ligne avec plus de 2 obs par 'by'
  if(length(idx)){  # appliquer merge_date seulement sur les groupes ayant 2 obs et plus *optimisation
    x[
      idx,  # numéro des ligne où appliquer la formule
      diff := as.integer(debut - shift(fin)),  # nombre de jours entre le début et la fin précédente
      by
    ]
    x[is.na(diff), diff := 0L]
    x[, periode := 0L]  # variable indiquant la période
    x[diff > 1L, periode := 1L]  # indique un changement de période
    x[, periode := cumsum(periode) + 1L, by]  # les périodes à 'merge'
    x <- x[
      , .(debut = min(debut),  # merge les dates pour en faire 1 obs
          fin = max(fin)),
      keyby = c(by, "periode")  # par 'by' + période
    ]
    x[, periode := NULL]  # supprimer colonne
  }
  setnames(x, c("debut", "fin"), c(debut, fin))  # colnames initiales

  # Ajouter les colonnes de keep.cols
  if(!is.null(keep.cols)){
    x <- merge(x, dt_keepCols, by)
  }

  return(x)
}