R/struct_Rx_analyse.R

In INESSS-QC/polymed1: Polymédication

#' Structure RxAnalyse
#'
#' Structure le dataset d'analyse pour l'étude de la polymédication.
#'
#' @param data_Rx `list()`
#' * **`data`** : Dataset des services.
#' * **`ID`** : Nom de la colonne contenant le numéro du ID.
#' * **`Rx`** : Nom de la colonne indiquant le code d'analyse/médicament/molécule.
#' * **`DateServ`** : Nom de la colonne indiquant la date de service.
#' * **`Duree`** : Nom de la colonne indiquant la durée du service.
#' @param data_Cohorte `list()`
#' * **`data`** : Dataset de la cohorte d'analyse.
#' * **`ID`** : Nom de la colonne contenant le numéro du ID.
#' * **`sexe`** : Nom de la colonne indiquant le sexe de l'individu.
#' * **`age`** : Nom de la colonne indiquant l'âge de l'individu. Peut-être `NULL` si on utilise plutôt la colonne indiquant la date de naissance.
#' * **`naiss`** : Nom de la colonne indiquant la date de naissance de l'individu. Peut-être `NULL` si on utilise plutôt la colonne indiquant l'âge.
#' * **`origin`** : "AAAA-MM-JJ". Date de référence pour le calcul de l'âge à partir de la colonne `naiss`. Peut-être `NULL` si on utilise plutôt la colonne indiquant l'âge.
#' @param data_Hospit `list()`
#' * **`data`** : Dataset des services hospitaliers, les hospitalisations.
#' * **`ID`** : Nom de la colonne contenant le numéro du ID.
#' * **`adm`** : Nom de la colonne indiquant la date d'admission à l'hôpital.
#' * **`dep`** : Nom de la colonne indiquant la date de départ de l'hôpital.
#' * **`ajust`** : Nombre de jours sans activité permis entre deux hospitalisations dans le but de les fusionner.
#' @param IDs `list()` sinon `NULL`.
#' * **`type`** : `"ech"` pour extraire aléatoirement des ID, `"select"`pour sélectionner des ID.
#' * **`value`** : Si `type=="ech"`, nombre entre 0 et 1 indiquant le ratio (pourcentage) de ID à extraire tiré de `data_Cohorte`. Si `type=="select"`, liste des ID à extraire.
#' @param ParamsAnalyse `list()`
#' * **`dataDurees`** : Dataset indiquant pour un code Rx une durée fixe.
#' * **`facteur`** : Calcul de la période de grâce = `Durée x facteur`.
#' * **`fixe`** : Nombre. Calcul de la période de grâce = Période de grâce + `fixe`.
#' @param HospitAjust `list()`
#' * **`nbrJours_avant`** : Nombre de jours sans activité permis entre un *Rx* et une *Hospit* pour qu'on fusionne les deux observations.
#' * **`nbrJours_apres`** : Nombre de jours sans activité permis entre une *Hospit* et un *Rx* pour qu'on fusionne les deux observations.
#' @param max_reserve Entier, nombre de jours qu'un individu peut accumuler des médicaments pour s'en faire une réserve. `NULL` implique une réserve sans limite.
#'
#' @return `list`()
#' * **`RxAnalyse`**
#' * **`Cohorte`**
#' * **`Hospit`**
#' * **`Echantillon`**
#' * **`ParamsAnalyse`**
#' * **`HospitAjust`**
#' * **`max_reserve`**
#' @import data.table
#' @export
struct_RxAnalyse <- function(
  data_Rx,
  data_Cohorte,
  data_Hospit = NULL,
  IDs=list(type="ech", value=0.10),
  ParamsAnalyse=list(dataDurees=DureesSpecifiques, facteur=0.5, fixe=0),
  HospitAjust=list(nbrJours_avant=0, nbrJours_apres=0),
  max_reserve=NULL
){
  ### Structure de la cohorte d'étude et sélection des ID à l'étude si nécessaire
  CohorteAnalyse <- struct_cohorte(  # Structure de data_Cohorte
    x = data_Cohorte$data,
    ID = data_Cohorte$ID,
    sexe = data_Cohorte$sexe,
    age = data_Cohorte$age,
    naiss = data_Cohorte$naiss,
    origin = data_Cohorte$origin
  )
  nID <- uniqueN(CohorteAnalyse$ID)  # nombre de ID totaux, servira pour le % d'échantillon
  rm(data_Cohorte)  # supprimer data initial
  if(!is.null(IDs)){  # sélection des ID si nécessaire
    if(IDs$type == "ech"){  # sélection aléatoire des ID
      nbrID <- ceiling(IDs$val * length(CohorteAnalyse$ID))  # nombre de ID à sélectionner
      if(length(nbrID) > length(CohorteAnalyse$ID)) nbrID <- length(CohorteAnalyse$ID)  # s'il n'y a pas assez de ID pour la quantité demandé
      IDlist <- sample(sunique(CohorteAnalyse$ID),  # numéros ID unique
                       nbrID)  # nombre de ID à l'étude
      IDlist <- sort(IDlist)
    } else if(IDs$type=="select"){  # sélection des ID
      IDlist <- sort(IDs$val)  # numéro des ID à sélectionner
    } else {
      stop("IDs$type doit être égal à 'ech' ou 'select'.")
    }
    # Filtrer les datas avec les ID d'analyse = IDlist
    CohorteAnalyse <- CohorteAnalyse[ID %in% IDlist]
    data_Rx$data <- data_Rx$data[get(data_Rx$ID) %in% IDlist]
    if(!nrow(data_Rx$data)) stop("Aucun Rx à analyser après avoir filtré pour le ou les ID à l'étude.")
    if(!is.null(data_Hospit)) data_Hospit$data <- data_Hospit$data[get(data_Hospit$ID) %in% IDlist]
  }
  ### Structure de data_Rx$data et data_Hospit$data
  RxAnalyse <- struct_Rx(
    x = data_Rx$data,
    ID = data_Rx$ID,
    Rx = data_Rx$Rx,
    DateServ = data_Rx$DateServ,
    Duree = data_Rx$Duree
  ); rm(data_Rx)
  if(is.null(data_Hospit)){
    HospitAnalyse <- NULL
  } else {
    if(!nrow(data_Hospit$data)){
      HospitAnalyse <- NULL
    } else {
      HospitAnalyse <- struct_hospit(
        x = data_Hospit$data,
        ID = data_Hospit$ID,
        adm = data_Hospit$adm,
        dep = data_Hospit$dep,
        ajust = data_Hospit$ajust
      )
    }
  }; rm(data_Hospit)
  ### Structure de RxAnalyse - joindre les périodes continues
  RxAnalyse <- .struct_RxAnalyse_dataAnalyse(
    RxAnalyse, HospitAnalyse,
    ParamsAnalyse, HospitAjust, max_reserve
  )
  return(list(
    RxAnalyse = RxAnalyse,
    Cohorte = CohorteAnalyse,
    Hospit = HospitAnalyse,
    Echantillon = nrow(CohorteAnalyse)/nID * 100,
    ParamsAnalyse = ParamsAnalyse,
    HospitAjust = HospitAjust,
    max_reserve = max_reserve
  ))
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_dataAnalyse <- function(
  RxAnalyse, HospitAnalyse=NULL,
  ParamsAnalyse=list(dataDurees=DureesSpecifiques, facteur=0.5, fixe=0),
  HospitAjust=list(nbrJours_avant=0, nbrJours_apres=0),
  max_reserve=NULL
){
  x <- copy(RxAnalyse)# ; rm(RxAnalyse)
  y <- copy(HospitAnalyse)# ; rm(HospitAnalyse)
  x[, Hospit := 0]  # indiquer que ce n'est pas une hospit
  if(!is.null(y)){
    y <- .add_hospit2Rx(x, y)  # dataset des hospitalisations à ajouter
    if(nrow(y)) x <- rbind(x, y)  # ajout des hospit à Rx
  }
  x <- .struct_RxAnalyse_colInitiales(x, ParamsAnalyse)  # colonnes initiales : Duree, FinServ, PerGrace
  x <- .struct_RxAnalyse_ajustFinServ(x, max_reserve)  # ajuster la fin de service (et la date de service) selon la reserve
  x <- .struct_RxAnalyse_Hospit1ereObs(x, HospitAjust, max_reserve)  # gérer les hospit 1ere obs du groupe
  x <- .struct_RxAnalyse_HospitApRx(x, HospitAjust, max_reserve)  # gérer les hospit précédé d'un Rx
  x <- .struct_RxAnalyse_HospitAvRx(x, HospitAjust, max_reserve)  # gérer les hospit suivi d'un Rx
  x <- x[Hospit!=1]  # supprimer toutes les hospit non gérées
  x <- .struct_RxAnalyse_groupObs(x)  # grouper les obs sans interruption
  return(x)
}
.add_hospit2Rx <- function(x, y){
  hospit2add <- unique(x[, .(ID, Rx)])  # liste des ID et leurs médicaments
  hospit2add <- merge(  # associer chaque hospitalisation à chaque Rx
    hospit2add, y,
    by = "ID",
    all = FALSE,  # si ID pas d'hospit -> supprimé
    allow.cartesian = T  # si plusieurs hospit pour un même ID
  )
  if(nrow(hospit2add)){
    hospit2add <- hospit2add[, .(  # structure du dataset comme celui de Rx pour futur rbind()
      ID,
      Rx,
      DateServ = Adm,
      Duree = as.integer(Dep - Adm + 1),
      Hospit = 1
    )]
  }
  return(hospit2add)
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_ajustFinServ <- function(x, max_reserve){
  x <- copy(x)
  setkey(x, ID, Rx, DateServ)  # tri croissant
  x <- .col_Diff(x)
  x <- .col_ServAjust(x, max_reserve)
  x <- .col_ajustFinServ(x)
  x <- .col_Diff(x)
  x[, ServAjust := NULL]
  return(x)
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_colInitiales <- function(x, ParamsAnalyse){
  x <- copy(x)
  x <- .col_DureesSpecifiques(x, ParamsAnalyse)  # modifie la duree des Rx ayant une duree fixe
  x <- .col_FinServ(x)  # fin de service
  x <- .col_PerGrace(x, ParamsAnalyse)  # periode de grâce
  return(x)
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_groupObs <- function(x){
  x <- copy(x)
  x <- .col_FinGrace(x)
  x <- .col_Diff(x, "grace")
  x <- .col_period(x)
  x <- x[
    , .(DateServ = min(DateServ),
        FinServAjust = max(FinServ)),
    keyby = .(ID, Rx, period)
  ][, period := NULL]
  return(x)
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_Hospit1ereObs <- function(x, HospitAjust, max_reserve){
  x <- copy(x)
  idx <- intersect(  # identifier les 1ere obs où Hospit=1
    x[, .I[1], .(ID, Rx)]$V1,  # 1ere obs du groupe
    x[, .I[Hospit==1 & shift(Hospit,-1)==0 & shift(Diff,-1)<=HospitAjust$nbrJours_apres], .(ID, Rx)][!is.na(V1)]$V1  # conditions recherchées
  )
  if(length(idx)){
    x[
      sort(c(idx, idx+1)),  # sélectionner idx (Hospit=1) et la ligne suivante (Hospit=0)
      `:=` (DureeAv = shift(Duree),
            DateServAv = shift(DateServ),
            FinServInitial = FinServ)  # indiquer la date de service précédente, celle de Hospit=1
    ]
    x[
      idx+1,
      `:=` (DateServ = DateServAv,
            Duree = Duree + DureeAv)
    ]
    x[idx+1, FinServ := DateServ + Duree - 1]
    idx_FinServ <- x[, .I[FinServ<FinServInitial & Hospit==0], .(ID, Rx)][!is.na(V1)]$V1
    if(length(idx_FinServ)){
      x[idx_FinServ, FinServ := FinServInitial]
      x[idx_FinServ, Duree := FinServ - DateServ + 1]
    }
    x[, `:=` (DureeAv = NULL,
              DateServAv = NULL,  # supprimer colonnes ajustement
              FinServInitial = NULL)]
    x <- x[!idx]  # supprimer les cas gérés
    x <- .struct_RxAnalyse_ajustFinServ(x, max_reserve)  # ajustement fin de service selon réserve
  }
  return(x)
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_HospitApRx <- function(x, HospitAjust, max_reserve){
  x <- copy(x)
  idx <- x[, .I[Hospit==1 & shift(Hospit)==0 & Diff<=HospitAjust$nbrJours_avant], .(ID, Rx)][!is.na(V1)]$V1  # lignes recherchées
  while(length(idx)){
    x[
      sunique(c(idx, idx-1)),  # sélection les idx (Hospit==1) et idx-1 (Hospit==0)
      `:=` (DureeAp = shift(Duree,-1),
            FinServAp = shift(FinServ,-1))  # fin de service de l'hospit
    ]
    x[
      idx-1,
      `:=` (Duree = Duree + DureeAp,
            FinServ = FinServ + DureeAp)
    ]
    idx_FinServ <- x[, .I[FinServAp>FinServ & Hospit==0], .(ID, Rx)][!is.na(V1)]$V1
    if(length(idx_FinServ)){
      x[idx_FinServ, FinServ := FinServAp]
      x[idx_FinServ, Duree := FinServ - DateServ + 1]
    }
    x[, `:=` (FinServAp = NULL,
              DureeAp = NULL)]
    x <- x[!idx]  # supprimer les hospit
    x <- .struct_RxAnalyse_ajustFinServ(x, max_reserve)
    idx <- x[, .I[Hospit==1 & shift(Hospit)==0 & Diff<=HospitAjust$nbrJours_avant], .(ID, Rx)][!is.na(V1)]$V1  # lignes recherchées
  }
  return(x)
}
#' Structure
#'
#' @keywords internal
#' @export
.struct_RxAnalyse_HospitAvRx <- function(x, HospitAjust, max_reserve){
  x <- copy(x)
  idx <- x[, .I[Hospit==1 & shift(Hospit,-1)==0 & shift(Diff,-1)<=HospitAjust$nbrJours_apres], .(ID, Rx)][!is.na(V1)]$V1
  while(length(idx)){
    x[
      sort(c(idx, idx+1)),  # sélectionner idx (Hospit=1) et la ligne suivante (Hospit=0)
      `:=` (DureeAv = shift(Duree),
            DateServAv = shift(DateServ),
            FinServInitial = FinServ)  # indiquer la date de service précédente, celle de Hospit=1
    ]
    x[
      idx+1,
      `:=` (DateServ = DateServAv,
            Duree = Duree + DureeAv)
    ]
    x[idx+1, FinServ := DateServ + Duree - 1]
    idx_FinServ <- x[, .I[FinServ<FinServInitial & Hospit==0], .(ID, Rx)][!is.na(V1)]$V1
    if(length(idx_FinServ)){
      x[idx_FinServ, FinServ := FinServInitial]
      x[idx_FinServ, Duree := FinServ - DateServ + 1]
    }
    x[, `:=` (DureeAv = NULL,
              DateServAv = NULL,  # supprimer colonnes ajustement
              FinServInitial = NULL)]
    x <- x[!idx]  # supprimer les cas gérés
    x <- .struct_RxAnalyse_ajustFinServ(x, max_reserve)  # ajustement fin de service selon réserve
    idx <- x[, .I[Hospit==1 & shift(Hospit,-1)==0 & shift(Diff,-1)<=HospitAjust$nbrJours_apres], .(ID, Rx)][!is.na(V1)]$V1
  }
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_ajustFinServ <- function(x){
  x <- copy(x)
  x[ServAjust < 0, FinServ := FinServ - ServAjust]  # ajustement FinServ si réserve
  x[ServAjust < 0, DateServ := FinServ - Duree + 1]  # ajustement de DateServ si réserve
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_Diff <- function(x, type="serv"){
  x <- copy(x)
  if(type=="serv"){
    x[, Diff := as.numeric(DateServ - shift(FinServ) - 1), .(ID, Rx)]  # nbr jours entre DateServ_{i} et FinServ_{i-1}
    x[is.na(Diff), Diff := 0]  # 1ere obs, Diff=NA --> 0
  } else if(type=="grace"){
    x[, DiffGrace := as.numeric(DateServ - shift(FinGrace) - 1), .(ID, Rx)]  # nombre de jours entre DateServ_{i} et FinGrace_{i-1}
    x[is.na(DiffGrace), DiffGrace := 0]
  } else {
    stop("Les valeurs permises de 'type' sont serv ou grace.")
  }
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_DureesSpecifiques <- function(x, ParamsAnalyse){
  x <- copy(x)
  if(!is.null(ParamsAnalyse$dataDurees)){
    x <- merge(  # ajouter les durees spécifiques
      x, ParamsAnalyse$dataDurees,
      by = "Rx",
      all.x = TRUE  # conserver toutes les valeurs de x
    )
    x[!is.na(DureeSpecifique), Duree := DureeSpecifique][, DureeSpecifique := NULL]  # convertir les durees pour les durees spécifiques
  }
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_FinGrace <- function(x){
  x <- copy(x)
  x[, FinGrace := FinServ + PerGrace]
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_FinServ <- function(x){
  x <- copy(x)
  x[, FinServ := DateServ + Duree - 1]  # date fin service
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_PerGrace <- function(x, ParamsAnalyse){
  x <- copy(x)
  x[, PerGrace := 0]
  x[Hospit == 0, PerGrace := Duree*ParamsAnalyse$facteur + ParamsAnalyse$fixe]  # PerGrace pour les Rx
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_period <- function(x){
  x <- copy(x)
  x[, period := 0]
  x[DiffGrace > 0, period := 1]
  x[, period := cumsum(period)+1, .(ID, Rx)]
  return(x)
}
#' Colonne
#'
#' @keywords internal
#' @export
.col_ServAjust <- function(x, max_reserve){
  x <- copy(x)
  x[  # Valeur permettant d'ajuster la fin de service
    , ServAjust := as.integer(

      Reduce(function(val1, val2){
        cumDiff = val1 + val2  # somme cumulative
        if(cumDiff > 0) cumDiff <- 0  # s'il n'y a pas de réserve on laisse à zéro (0)
        if(!is.null(max_reserve)) if(cumDiff < -max_reserve) cumDiff <- -max_reserve  # si on restreint la réserve, on ajuste au besoin
        return(cumDiff)
      },
      Diff,
      accumulate = T)  # faire apparaître les valeurs au fur et à mesure (pas seulement le résultat final)

    ),
    .(ID, Rx)
  ]
  return(x)
}