R/preprocess.R

In BiGaRx: Unified Classical and Canonical Biplots

#' Transformaciones disponibles para la matriz de datos
#'
#' Nombres aceptados por el argumento `transform` de [bigarx()]:
#'
#' * `"standardize"`: resta la media y divide por la desviación típica de
#'   cada columna (denominador n - 1). Equivale a trabajar con la estructura
#'   de correlaciones. Es la opción por defecto y la que se usa cuando las
#'   variables tienen escalas distintas.
#' * `"center"`: resta la media de cada columna. Conserva las varianzas
#'   originales (estructura de covarianzas), como en el biplot de componentes
#'   principales de Gabriel (1971, sección 3).
#' * `"double"`: doble centrado; resta medias de fila y de columna y suma la
#'   media global. Útil para estudiar interacciones (Gabriel, 1971, sección 2).
#' * `"grand"`: resta la media global de toda la matriz.
#' * `"none"`: usa los datos tal como vienen.
#'
#' @name transformaciones
#' @keywords internal
NULL

.transforms <- c("standardize", "center", "double", "grand", "none")

# Prepara la matriz numérica y valida la entrada.
.as_data_matrix <- function(X, arg = "X", allow_na = FALSE) {
  if (is.data.frame(X)) {
    num <- vapply(X, is.numeric, logical(1))
    if (!all(num)) {
      stop(sprintf(
        "`%s` tiene columnas no num\u00E9ricas: %s. Qu\u00EDtalas o p\u00E1salas como `groups`.",
        arg, paste(names(X)[!num], collapse = ", ")), call. = FALSE)
    }
    X <- as.matrix(X)
  }
  if (!is.matrix(X) || !is.numeric(X)) {
    stop(sprintf("`%s` debe ser una matriz o un data.frame num\u00E9rico.", arg),
         call. = FALSE)
  }
  if (anyNA(X) && !allow_na) {
    stop(sprintf(paste0("`%s` contiene valores NA. Usa `na_action = \"impute\"` para ",
                        "imputarlos con SVD iterativa, o elim\u00EDnalos antes del an\u00E1lisis."), arg),
         call. = FALSE)
  }
  if (is.null(rownames(X))) rownames(X) <- paste0("F", seq_len(nrow(X)))
  if (is.null(colnames(X))) colnames(X) <- paste0("V", seq_len(ncol(X)))
  X
}

# Aplica la transformación a la matriz activa y guarda los parámetros
# necesarios para transformar después filas o columnas suplementarias.
.preprocess <- function(X, transform) {
  transform <- match.arg(transform, .transforms)
  n <- nrow(X)
  info <- list(transform = transform, col_center = NULL, col_scale = NULL,
               row_center = NULL, grand = NULL)
  Z <- X
  if (transform %in% c("standardize", "center")) {
    m <- colMeans(X)
    Z <- sweep(X, 2, m, "-")
    info$col_center <- m
    if (transform == "standardize") {
      s <- sqrt(colSums(Z^2) / (n - 1))
      if (any(s == 0)) {
        stop("Hay columnas constantes (desviaci\u00F3n t\u00EDpica 0): ",
             paste(colnames(X)[s == 0], collapse = ", "), call. = FALSE)
      }
      Z <- sweep(Z, 2, s, "/")
      info$col_scale <- s
    }
  } else if (transform == "double") {
    g <- mean(X)
    rm <- rowMeans(X)
    cm <- colMeans(X)
    Z <- X - outer(rm, rep(1, ncol(X))) - outer(rep(1, n), cm) + g
    info$col_center <- cm
    info$row_center <- rm
    info$grand <- g
  } else if (transform == "grand") {
    g <- mean(X)
    Z <- X - g
    info$grand <- g
  }
  list(Z = Z, info = info)
}

# Transforma filas suplementarias con los parámetros de la matriz activa.
.transform_sup_rows <- function(Xs, info) {
  switch(info$transform,
    standardize = sweep(sweep(Xs, 2, info$col_center, "-"), 2, info$col_scale, "/"),
    center = sweep(Xs, 2, info$col_center, "-"),
    grand = Xs - info$grand,
    none = Xs,
    double = {
      # Cada fila suplementaria se centra con su propia media y con las
      # medias de columna de la matriz activa.
      Xs - outer(rowMeans(Xs), rep(1, ncol(Xs))) -
        outer(rep(1, nrow(Xs)), info$col_center) + info$grand
    })
}

# Transforma columnas suplementarias: cada columna se centra (y escala)
# con sus propios parámetros, como es habitual en el análisis factorial.
.transform_sup_cols <- function(Xs, info) {
  n <- nrow(Xs)
  switch(info$transform,
    standardize = {
      Zs <- sweep(Xs, 2, colMeans(Xs), "-")
      sweep(Zs, 2, sqrt(colSums(Zs^2) / (n - 1)), "/")
    },
    center = sweep(Xs, 2, colMeans(Xs), "-"),
    grand = Xs - info$grand,
    none = Xs,
    double = {
      Xs - outer(info$row_center, rep(1, ncol(Xs))) -
        outer(rep(1, n), colMeans(Xs)) + info$grand
    })
}

# Deshace la transformacion: lleva una matriz del espacio preprocesado a la
# escala original, con los parametros guardados en `info`.
.unpreprocess <- function(Z, info) {
  n <- nrow(Z); p <- ncol(Z)
  switch(info$transform,
    standardize = sweep(sweep(Z, 2, info$col_scale, "*"), 2, info$col_center, "+"),
    center = sweep(Z, 2, info$col_center, "+"),
    grand = Z + info$grand,
    none = Z,
    double = Z + outer(info$row_center, rep(1, p)) +
      outer(rep(1, n), info$col_center) - info$grand)
}