polymedic: Calculs de la polypharmacie

Documented in polyBD

#' Structure BD
#'
#' Structure les données de \code{x} pour réaliser l'analyse de la polypharmacie
#'
#' L'ordre des valeurs de \code{xcols} et \code{ycols} sont importants. Voir \code{xcols[i]} et \code{ycols[i]} dans la section des arguments pour en connaître l'ordre.\cr\cr
#' Période de grâce = \code{xcols[4]} * \code{factor} + \code{constant}.\cr\cr
#' Les colonnes \code{xcols[3]}, \code{ycols[2]} et \code{ycols[3]} doivent être de type \emph{character}.\cr
#' La colonne \code{xcols[4]} doit être de type \emph{numeric}.
#'
#' @param x Base de données des médicaments.
#' @param xcols Noms des colonnes :
#' \itemize{
#'   \item \code{xcols[1]} : Nom de la colonne identifiant l’usager, le ID.
#'   \item \code{xcols[2]} : Nom de la colonne identifiant le médicament.
#'   \item \code{xcols[3]} : Nom de la colonne ayant comme valeurs les dates de service, le jour où il y a eu la prescription.
#'   \item \code{xcols[4]} : Nom de la colonne ayant comme valeurs les durées de chaque service, la durée de la prescription, la durée du traitement.
#'   \item \code{xcols[5]} : Nom de la colonne identifiant le sexe des ID.
#'   \item \code{xcols[6]} : Nom de la colonne identifiant la date de naissance des ID.
#' }
#' @param y Base de donnes des hospitalisations.
#' @param ycols Noms des colonnes
#' \itemize{
#'   \item \code{ycols[1]} : Nom de la colonne identifiant l’usager, le ID.
#'   \item \code{ycols[2]} : Nom de la colonne ayant comme valeurs les dates d’admission à l’hôpital.
#'   \item \code{ycols[3]} : Nom de la colonne ayant comme valeurs les dates de départ de l’hôpital.
#' }
#' @param factor Nombre compris entre 0 et 1. Il sert au calcul de la période de grâce. Voir détails.
#' @param constant Nombre positif. Il sert au calcul de la période de grâce. Voir détails.
#' @param min_ServAjust Nombre négatif. Réserve maximale d’un médicament qu’un usager peut posséder. Nombre de jours avec consommation.
#' @param keephospit1 Nombre positif. Détermine si on conserve une hospitalisation précédée d’un médicament. Nombre de jours maximum accepté sans consommation entre les deux observations.
#' @param keephospit2 Nombre positif. Détermine si on conserve une hospitalisation suivie d’un médicament. Nombre de jours maximum sans consommation acceptée entre les deux observations.
#'
#' @import dplyr
#' @import data.table
#' @import fasttime
#' @export
polyBD <- function(x, xcols,
                   y = NULL, ycols = NULL,
                   factor = 0.5, constant = 0,
                   min_ServAjust = -30, keephospit1 = 0, keephospit2 = 0){
  # Abbréviations :
  # BD : base de données
  # obs : observations


  ### Structure x

  x <- as.data.table(x) #tranformation de x en data.table
  x <- x[, ..xcols]  # sélection des colonnes nécessaires
  # Nom de colonnes fixe
  setnames(x, names(x),
           c("ID", "Med", "DatServ", "Duree", "Sexe", "DatNais"))
  # Dates sous format Date()
  set(x, NULL, "DatServ", as.Date(fastPOSIXct(x[["DatServ"]], "GMT")))
  # SejHosp : 0 indique que ça provient de la BD x
  set(x, NULL, "SejHosp", 0L)
  # BD à conserver pour plus tard
  BDnaiss <- copy(unique(x[, .(ID, DatNais)]))
  set(BDnaiss, NULL, "DatNais", as.Date(BDnaiss[["DatNais"]]))  # date en format DATE
  BDsex <- copy(unique(x[, .(ID, Sexe)]))
  # Conserver colonnes pour calcul indicateur
  x <- x[, .(ID, Med, DatServ, Duree, SejHosp)]


  ### Étapes à suivre si y existe
  if(!is.null(y)){

    y <- as.data.table(y) #tranformation de x en data.table
    y <- y[, ..ycols] #sélection des colonnes
    # Modifier les noms des colonnes
    setnames(y, names(y),
             c("ID", "DatServ", "FinServ"))
    setorder(y, ID, DatServ)
    # Dates sous format Date()
    for (j in c("DatServ", "FinServ")) set(y, NULL, j, as.Date(fastPOSIXct(y[[j]], "GMT")))
    # Si date de fin plus grande que la suivante, la suivante prend la même valeur
    y[
      , Reduce(function(x,y){if(x > y){y <- x; y}}, FinServ, accumulate = TRUE),
      .(ID)
    ]



    ### Fusionner les hospitalisations qui ont des jours communs ou des jours collés

    # Différence entre la date de service et la fin de service précédente
    # NA si pas de valeurs précédentes
    y[, DiffServ := as.numeric(DatServ - shift(FinServ)), ID]
    # Sejour : indiquer par un numéro si c'est le même séjour pour ensuite les regrouper
    # 0 = même séjour, 1 = changement de séjour
    y[is.na(DiffServ), Sejour := 0]
    y[DiffServ <= 1, Sejour := 0]
    y[DiffServ > 1, Sejour := 1]
    # Somme cumulative + 1 indiquera le numéro du séjour
    y[, Sejour := cumsum(Sejour) + 1, ID]
    # Regrouper les séjours ensemble
    y <- y[
      , .(DatServ = min(DatServ),
          FinServ = max(FinServ)),
      .(ID, Sejour)
    ][
      # Supprimer colonne Sejour
      , Sejour := NULL
    ]


    ### Arranger y pour être semblable à x

    # DureeRx : Duree du traitement
    y[, Duree := as.integer(FinServ - DatServ + 1)]
    # SejHosp : 1 indique que c'est une hospitalisation
    set(y, NULL, "SejHosp", 1)


    ### Insérer tous les médicaments consommés par le BenBanls

    # Fusion de la liste unique des médicaments par BenBanls avec la liste des hospitalisations. Chaque hospitalisation
    # aura la liste complète des médicaments. Le tri se fera plus tard.
    y <- merge(y, unique(x[Med != -1, .(ID, Med)]),
               by = "ID", all.x = TRUE)
    # Supprimer les BenBanls hospitalisés, mais absent de la BD x
    y <- y[!is.na(Med)]

    # Sélection des colonnes qui sera ajoutées à x
    y <- y[, .(ID, Med, DatServ, Duree, SejHosp)]
    # Ajout des observations à X
    x <- rbind(x, y)  # ajout des obs

    rm(y) #supprimer BD y, car n'est plus utile

  }

  x[, SejHosp := as.numeric(SejHosp)]
  # Trier x
  setorder(x, ID, Med, DatServ, -SejHosp) #tri, croissant sauf SejHosp

  # FinServ : indique la fin de service théorique
  x[, FinServ := DatServ + Duree - 1]
  # PerGrace : Période de grâce, 0 si c'est une hospit
  x[SejHosp == 0, PerGrace := Duree * factor + constant]
  x[SejHosp == 1, PerGrace := 0]


  # Identifier les observations qui se terminent avant l'observation précédente (FinServ_i < FinServ_i-1) et
  # l'inclure dans celle-ci en additionant Duree et PerGrace
  x[, flag := FALSE]
  idx <- x[, .I[FinServ <= shift(FinServ)], .(ID, Med)]$V1
  idx <- idx[!is.na(idx)]
  x[idx, flag := TRUE]
  # Étape où l'obs est incluse dans celle précédente. Boucle qui calcul les fins de service après chaque
  # inclusion/supression d'obs
  while (any(x[["flag"]])) {
    # Numéros de ligne identifiant les observations recherchées
    idx <- x[, .I[flag == TRUE & shift(flag) == FALSE], .(ID, Med)]$V1
    idx <- idx[!is.na(idx)] #supprimer les NA s'il y a lieu
    # Fusionner les obs sélectionnées avec l'obs précédente
    x[sort(unique(c(idx, idx-1))), #numéro de lignes des obs sélectionnées et celles qui les précèdent
      `:=` (Duree = Duree + shift(Duree, type = "lead"), #addition des durées
            PerGrace = PerGrace + shift(PerGrace, type = "lead"), #addition des période de grâce
            SejHosp = 2), #indique une fusion de plusieurs obs
      .(ID, Med)]
    # Supprimer les obs fusionnées avec l'obs précédente
    x <- x[!idx]
    # Recalculer la nouvelle fin de service
    x[, FinServ := DatServ + Duree - 1]

    # Vérifier avec les nouvelles fin de service s'il y a des obs incluses dans l'observation précédente
    idx <- x[, .I[DatServ <= shift(FinServ) & FinServ <= shift(FinServ)], .(ID, Med)]$V1
    idx <- idx[!is.na(idx)] #supprimer les NA s'il y a lieu
    x[idx, flag := TRUE] #flag = TRUE pour les obs identifiées

    # S'il y a au moins un flag = TRUE, on refait les étapes précédentes.
  }
  x[, flag := NULL]


  # DiffServ : Indique le nombre de jour sans consommation entre une fin de service et une date de service pour
  # un même BenBanls + DIN
  x[, DiffServ := as.numeric(DatServ - shift(FinServ) - 1), .(ID, Med)]
  # Si NA, première obs, doit être 0
  x[is.na(DiffServ), DiffServ := 0]
  # ServAjust : somme cumulative de DiffServ; Ne peut être plus élevé que 'max_ServAjust' ou plus petit que 'min_ServAjust';
  # Sert à contrôler les réserves et les jours de retard.
  x[, ServAjust := Reduce(function(x, y){
    z <- max(x + y, min_ServAjust)
    if(z > 0){z <- 0}
    z
  }, DiffServ, accumulate = TRUE), .(ID, Med)]

  # FinServAjust : Fin de service ajusté s'il y a une réserve de médicament (ServAjust < 0); sinon FinServ
  x[ServAjust < 0, FinServAjust := FinServ - ServAjust][ServAjust >= 0, FinServAjust := FinServ]



  # Conserver les hospitalisations qui respectent les critères
  # critère1 : Pour les hospit, Date de service est avant ou égal à la fin de service ajustée de l'obs précédente
  # critère2 : Pour les hospit, Fin de service ajustée est plus grande que la date de service suivante
  idx <- x[, .I[SejHosp != 1 | #conserver les médicaments
                  SejHosp == 1 & DatServ <= shift(FinServAjust)+keephospit1+1 | #critère1
                  SejHosp == 1 & FinServAjust+keephospit2+1 >= shift(DatServ, type = "lead")],
           .(ID, Med)]$V1 #critere2
  idx <- idx[!is.na(idx)]
  x <- x[idx]


  # Boucle insertion des périodes et recalcul des ServAjust & FinServAjust
  for (i in 1:nrow(x)) {
    if(i == 1){
      x[, `:=` (Periode = 0, #initialiser Periode à 0
                flag = FALSE)]
      # Numéro de ligne où il y a un changement de période
      idx <- x[, .I[DatServ > shift(FinServAjust)+1+shift(PerGrace)],
               .(ID, Med)]$V1
      idx <- idx[!is.na(idx)]
      x[idx, Periode := 1]
      x[, Periode := cumsum(Periode) + 1, .(ID, Med)]
      x[Periode > 2, Periode := 2]
      x[Periode == 1, flag := TRUE]
      poly_BD <- x[flag == TRUE]
      x <- x[flag == FALSE]
    } else {
      # DiffServ : Indique le nombre de jour sans consommation entre une fin de service et une date de service pour
      # un même BenBanls + DIN
      x[, DiffServ := as.numeric(DatServ - shift(FinServ) - 1), .(ID, Med)]
      # Si NA, première obs, doit être 0
      x[is.na(DiffServ), DiffServ := 0]
      # ServAjust : somme cumulative de DiffServ; Ne peut être plus élevé que 'max_ServAjust' ou plus petit que 'min_ServAjust';
      # Sert à contrôler les réserves et les jours de retard.
      x[, ServAjust := Reduce(function(x, y){
        z <- max(x + y, min_ServAjust)
        if(z > 0){z <- 0}
        z
      }, DiffServ, accumulate = TRUE),
      .(ID, Med)]
      # FinServAjust : Fin de service ajusté s'il y a une réserve de médicament (ServAjust < 0); sinon FinServ
      x[ServAjust < 0, FinServAjust := FinServ - ServAjust][ServAjust >= 0, FinServAjust := FinServ]
      x[, `:=` (Periode = 0,
                flag = FALSE)] #initialiser Periode à 0
      idx <- x[, .I[DatServ > shift(FinServAjust)+1+shift(PerGrace)],
               .(ID, Med)]$V1
      idx <- idx[!is.na(idx)]
      x[idx, Periode := 1]
      x[, Periode := cumsum(Periode) + i, .(ID, Med)]
      x[Periode > i+1, Periode := i+1]
      x[Periode == i, flag := TRUE]
      poly_BD <- rbind(poly_BD, x[flag == TRUE])
      x <- x[flag == FALSE]
    }

    # Sortir de la boucle s'il n'y a plus de valeurs dans le tableau x
    if(nrow(x) == 0){ break }

  }


  ## Création du tableau resultat final
  # Trier poly_BD
  setorder(poly_BD, ID, Med, DatServ)
  # Début et fin des périodes
  poly_BD <- poly_BD[, .(PerDebut = min(DatServ),
                         PerFinAjust = max(FinServAjust)),
                     .(ID, Med, Periode)]
  # Inclure les BD de sexe et Naiss
  attributes(poly_BD)$Naissance <- BDnaiss
  attributes(poly_BD)$Sexe <- BDsex

  # Modifier noms pour ceux initiaux
  setnames(poly_BD,
           c("ID", "Med"),
           c(xcols[1], xcols[2]))

  poly_BD
}