R/visualize-CA.R

In nfrerebeau/FactoHelpeR: Extract and Visualize FactoMineR Results

#' @include AllGenerics.R
NULL

# Visualize PCA results ========================================================
#' @export
#' @rdname visualize
visualize.CA <- function(x, axes = c(1, 2),
                          map = c("rows", "columns"),
                          extra = NULL, select = NULL, group = NULL, ...) {
  # Validation
  map <- match.arg(map, several.ok = TRUE)
  if(!is.null(extra)) {
    extra <- match.arg(
      arg = extra,
      choices = c("rows", "columns", "quantitative", "qualitative"),
      several.ok = TRUE)
  } else {
    extra <- FALSE
  }

  row_sup <- ("rows" %in% map & "rows" %in% extra &
                length(x$row.sup) != 0)
  col_sup <- ("columns" %in% map & "columns" %in% extra &
                length(x$col.sup) != 0)
  quanti_sup <- ("columns" %in% map & "quantitative" %in% extra &
                   length(x$quanti.sup) != 0)
  quali_sup <- ("columns" %in% map & "qualitative" %in% extra &
                  length(x$quali.sup) != 0)

  row_data <- col_data <- NULL
  if ("rows" %in% map) {
    row_data <- getIndividuals(x, axes = axes, ind_sup = row_sup,
                               select = select, group = group)
  }
  if ("columns" %in% map) {
    col_data <- getVariables(x, axes = axes, var_sup = col_sup,
                             quanti_sup = quanti_sup, quali_sup = quali_sup,
                             select = select)
  }
  data <- dplyr::bind_rows(row_data, col_data)

  graph <- ggplot2::ggplot(
    data = data,
    ggplot2::aes_string(x = "x", y = "y", label = "label",
                        color = "group", shape = "legend")
  ) +
    ggplot2::geom_point() +
    ggplot2::geom_vline(xintercept = 0, size = 0.5, linetype = "dashed") +
    ggplot2::geom_hline(yintercept = 0, size = 0.5, linetype = "dashed") +
    ggplot2::labs(x = printComponentVar(x, axes[1]),
                  y = printComponentVar(x, axes[2]))
  return(graph)
}

printComponentVar.CA <- function(x, axis = 1) {
  variance <- round(x$eig[axis, 2], 1)
  paste("PC", axis, " (", variance, "%)", sep = "")
}

# Row selection ================================================================
selectRows.CA <- function(x, criterion, axes = c(1, 2),
                           map = c("row", "row.sup", "col", "col.sup",
                                   "quanti.sup", "quali.sup")) {
  map <- match.arg(map, several.ok = FALSE)
  data <- x[[map]]
  n <- nrow(data$coord)

  if (is.numeric(criterion)) {
    index <- criterion
  } else {
    index <- which(rownames(data$coord) %in% criterion)

    if (length(index) == 0) {
      index <- 1:n

      if(length(criterion) == 1) {
        pattern <- "(coord|contrib|cos2|inertia)"
        if (!grepl(pattern, criterion)) {
          stop(paste("Your selection criterion (", dQuote(criterion),
                     ") is invalid.", sep = ""))
        }
        k <- sum(as.numeric(unlist(strsplit(criterion, pattern))), na.rm = TRUE)
        if (grepl("coord", criterion)) {
          coord <- apply(data$coord[, axes]^2, 1, sum)
          index <- rev(order(coord))[1:min(n, k)]
        }
        if (grepl("contrib", criterion)) {
          contrib <- data$contrib[, axes[1], drop = FALSE] * x$eig[axes[1], 1] +
            data$contrib[, axes[2], drop = FALSE] * x$eig[axes[2], 1]
          index <- rev(order(contrib))[1:min(n, k)]
        }
        if (grepl("cos2", criterion)) {
          cos2 <- apply(data$cos2[, axes], 1, sum)
          if (k >= 1) {
            index <- rev(order(cos2))[1:min(n, k)]
          } else {
            index <- which(cos2 > k)
          }
        }
        if (grepl("inertia", criterion)) {
          if (length(data$inertia) != 0)
            index <- rev(order(data$inertia))[1:min(n, k)]
        }
      }
    }
  }

  return(index)
}

# Individuals factor map =======================================================
getIndividuals.CA <- function(x, axes = c(1, 2), ind_sup = FALSE,
                              select = NULL, group = NULL) {
  # Get individual coordinates
  ind_coords <- as.data.frame(x$row$coord)
  ind_index <- NULL
  if (!is.null(select)) {
    ind_index <- selectRows(x, select, axes, map = "row")
    ind_coords <- ind_coords[ind_index, ]
  }
  # Get row names
  ind_names <- rownames(ind_coords)
  ind_rows <- nrow(ind_coords)
  # Set column names
  dim_names <- paste("Dim", 1:ncol(ind_coords), sep = "")
  colnames(ind_coords) <- dim_names

  # Supplementary informations
  sup_coords <- sup_names <- NULL
  sup_rows <- 0
  if (ind_sup) {
    # Get supplementary individual coordinates
    sup_coords <- as.data.frame(x$row.sup$coord)
    if (length(sup_coords) != 0) colnames(sup_coords) <- dim_names
    if (!is.null(select)) {
      sup_index <- selectRows(x, select, axes, map = "row.sup")
      sup_coords <- sup_coords[sup_index, ]
    }
    # Get row names
    sup_names <- rownames(sup_coords)
    sup_rows <- nrow(sup_coords)
  }

  levels <- c("Row", "Row sup.")
  extra <- rep(levels, times = c(ind_rows, sup_rows))
  if (!is.null(group)) {
    k <- length(group)
    if (k != 1 & k != ind_rows + sup_rows) {
      stop(paste("Argument", dQuote("group"), "must be length",
                 ind_rows + sup_rows, "or one, not", k))
    }
    if (k == 1) {
      group <- x$call$Xtot[, group]
    }
    group <- as.character(group)[1:max(ind_rows, ind_rows + sup_rows)]
  } else {
    group <- extra
  }

  data <- dplyr::bind_rows(ind_coords, sup_coords) %>%
    dplyr::select(axes) %>%
    dplyr::rename(x = 1, y = 2) %>%
    dplyr::mutate(label = c(ind_names, sup_names),
                  group = group,
                  legend = extra)
  return(data)
}

# Variables factor map =========================================================
getVariables.CA <- function(x, axes = c(1, 2), var_sup = FALSE,
                            quanti_sup = FALSE, quali_sup = FALSE,
                            select = NULL) {
  # Get variables coordinates
  var_coords <- as.data.frame(x$col$coord)
  var_index <- NULL
  if (!is.null(select)) {
    var_index <- selectRows(x, select, axes, map = "col")
    var_coords <- var_coords[var_index, ]
  }
  # Get row names
  var_names <- rownames(var_coords)
  # Set column names
  dim_names <- paste("Dim", 1:ncol(var_coords), sep = "")
  colnames(var_coords) <- dim_names

  # Supplementary informations
  col_coords <- col_names <- NULL
  quanti_coords <- quanti_names <- NULL
  quali_coords <- quali_names <- NULL
  extra <- rep("Col.", nrow(var_coords))
  if (var_sup) {
    # Get supplementary columns coordinates
    col_coords <- as.data.frame(x$col.sup$coord)
    if (length(col_coords) != 0) colnames(col_coords) <- dim_names
    if (!is.null(select)) {
      col_index <- selectRows(x, select, axes, map = "col.sup")
      col_coords <- col_coords[col_index, ]
    }
    # Get row names
    col_names <- rownames(col_coords)
    extra <- c(extra, rep("Col. sup.", nrow(col_coords)))
  }
  if (quanti_sup) {
    # Get quantitative supplementary variable coordinates
    quanti_coords <- as.data.frame(x$quanti.sup$coord)
    if (length(quanti_coords) != 0) colnames(quanti_coords) <- dim_names
    # Get row names
    quanti_names <- rownames(quanti_coords)
    extra <- c(extra, rep("Quanti. sup.", nrow(quanti_coords)))
  }
  if (quali_sup) {
    # Get categorical supplementary variable coordinates
    quali_coords <- as.data.frame(x$quali.sup$coord)
    if (length(quali_coords) != 0) colnames(quali_coords) <- dim_names
    # Get row names
    quali_names <- rownames(quali_coords)
    extra <- c(extra, rep("Quali. sup.", nrow(quali_coords)))
  }

  # Bind coordinates
  data <- dplyr::bind_rows(var_coords, col_coords,
                           quanti_coords, quali_coords) %>%
    dplyr::select(axes) %>%
    dplyr::rename(x = 1, y = 2) %>%
    dplyr::mutate(label = c(var_names, col_names, quanti_names, quali_names),
                  group = extra,
                  legend = extra)
  return(data)
}

# Eigenvalues and cumulative variance ==========================================
plotEigenvalues.CA <- function(x, variance = TRUE) {
  # Eigenvalues
  data <- as.data.frame(x$eig) %>%
    dplyr::mutate(PC = factor(1:nrow(.), levels = 1:nrow(.)))
  k <- max(data[, 1]) / max(data[, 3])

  if (variance) {
    gg_var <- list(
      ggplot2::geom_line(
        mapping = ggplot2::aes_string(
          y = "`cumulative percentage of variance` * k"
        ), group = 1
      ),
      ggplot2::geom_point(
        mapping = ggplot2::aes_string(
          y = "`cumulative percentage of variance` * k"
        )
      ),
      ggplot2::scale_y_continuous(
        sec.axis = ggplot2::sec_axis(
          ~ . / k, name = "Cumulative percentage of variance"
        )
      )
    )
  } else {
    gg_var <- NULL
  }

  graph <- ggplot2::ggplot(data = data,
                           mapping = ggplot2::aes_string(x = "PC")) +
    ggplot2::geom_col(mapping = ggplot2::aes_string(y = "eigenvalue")) +
    gg_var +
    ggplot2::labs(x = "PC", y = "Eigenvalue")
    ggplot2::scale_x_continuous(breaks = 1:nrow(data))

  return(graph)
}