R/trivialize.R

In guiboucher/INESSS-inesss: INESSS

#' Banalisation
#'
#' Modifie les valeurs d'un tableau pour banaliser celui-ci.
#'
#' `select_rows` sélectionne les lignes avant la banalisation du dataset.
#'
#' @param data Dataset à banaliser.
#' @param cols Nom des colonnes à banaliser. `NULL` implique toutes les colonnes.
#' @param select_rows Numéro des lignes à conserver. `NULL` implique toutes les lignes.
#'
#' @return `data.table`
#' @import data.table
#' @export
#'
#' @examples
#' library(data.table)
#' trivialize(mtcars)[]
#' trivialize(mtcars, cols = c("mpg", "hp"))[]
#' trivialize(mtcars, select_rows = 1:5)[]
trivialize <- function(data, cols = NULL, select_rows = NULL){

# Fonctions ---------------------------------------------------------------

  ### Vérification de chaque argument. Affichera un message d'erreur si les valeurs
  ### ne sont pas permises.
  verif_args <- function(data, cols, select_rows){
    check <- newArgCheck()  # argument contenant les erreurs
    if(!is.data.frame(data))  # doit être un dataframe
      addError("data n'est pas de type DATA.FRAME.", check)
    if(!is.null(cols)){
      if(!length(cols)){  # cols doit contenir au moins une valeur
        addError("cols ne contient aucune valeur.", check)
      } else if(!is.character(cols)){  # cols doit être une chaine de caractères
        addError("cols doit être de type CHARACTER.", check)
      }
    }
    if(!is.null(select_rows))
      if(!is.wholenumber(select_rows))
        addError("Les valeurs de select_rows doivent être des nombres entiers.", check)
    finishArgCheck(check)

    if(!is.null(cols)){
      for(col in cols){  # vérifier si le nom inscrit est un nom de colonne du dataset
        if(!col %in% names(data)){
          addError(paste0(col," n'est pas le nom d'une colonne."), check)
        }
      }
    }
    if(any(select_rows > nrow(data))){  # supprimer les valeurs de select_rows supérieures au nombre de ligne de data
      select_rows <- select_rows[select_rows <= nrow(data)]
      addMessage(paste0("Les valeurs de select_rows supérieures à ",nrow(data)," ont été supprimées."), check)
    }
    finishArgCheck(check)
  }

# Code --------------------------------------------------------------------

  verif_args(data, cols, select_rows)  # vérifier si les valeurs de cols sont des noms du dataset
  if(!is.data.table(data)) dt <- as.data.table(data) else dt <- copy(data); rm(data)  # dt = dataset d'analyse
  dt_names <- copy(names(dt))  # conserver l'ordre des colonnes
  if(!is.null(select_rows) && !is.integer(select_rows)) select_rows <- as.integer(select_rows)  # convertir integer si nécessaire
  if(!is.null(select_rows)){
    dt <- dt[select_rows]  # sélection des numéros de lignes
    if(!nrow(dt))  stop("dt[select_rows] ne contient aucune données.")  # erreur si aucune données
  }
  if(is.null(cols)) cols <- dt_names  # banaliser toutes les colonnes
  # Pour chaque colonne du dataset qui doivent rester secrète :
  # 1) mélanger les valeurs unique (sans NA).
  # 2) Leur associer une valeur allant de 1 à N où N est le nombre total de valeur unique.
  # 3) Remplacer les valeurs initiales par le nombre créer en 2).
  for(col in cols){
    triv <- data.table(val = sample(sunique(dt[[col]], na.last = NA)))  # mélanger les valeurs unique
    triv[, new_val := 1:.N]  # indiquer un nombre allant de 1 à N
    dt <- merge(  # ajouter la valeur banalisée à dt
      dt, triv,
      by.x = col, by.y = "val",  # nom des colonnes
      all.x = TRUE  # conserver toutes les valeurs de dt
    )
    dt[, paste(col) := new_val]  # convertir la valeur initiale pour la valeur banalisée
    dt[, new_val := NULL]  # supprimer la colonne contenant la valeur banalisée
  }
  setcolorder(dt, dt_names)  # même ordre des colonnes
  setkey(dt)  # tri croissant
  return(dt)

}