R/prepare_results_MCA.R

In explor: Interactive Interfaces for Results Exploration

##' @rdname prepare_results
##' @aliases prepare_results.MCA
##' @seealso \code{\link[FactoMineR]{MCA}}
##' @import dplyr
##' @importFrom tidyr pivot_longer
##' @importFrom utils head
##' @importFrom stats pnorm
##' @export

prepare_results.MCA <- function(obj) {

    if (!inherits(obj, "MCA")) stop("obj must be of class MCA")

    vars <- data.frame(obj$var$coord)
    ## Axes names and inertia
    axes <- seq_len(ncol(obj$var$coord))
    names(axes) <- paste("Axis", axes, paste0("(", head(round(obj$eig[, 2], 2), length(axes)), "%)"))
    ## Eigenvalues
    eig <- data.frame(dim = seq_len(nrow(obj$eig)), percent = obj$eig[, 2])

    ## Variables coordinates
    varnames <- sapply(obj$call$X[, obj$call$quali, drop = FALSE], nlevels)
    varnames <- rep(names(varnames), varnames)
    if (!is.null(obj$call$excl)) varnames <- varnames[-obj$call$excl]
    vars$varname <- varnames
    vars$modname <- rownames(vars)
    vars$Type <- "Active"
    vars$Class <- "Qualitative"

    ## Variables count
    quali.mods <- rownames(obj$var$coord)
    # Remove supplementary individuals from counts
    if (is.null(obj$call$ind.sup)) counts.tab <- obj$call$Xtot
    else counts.tab <- obj$call$Xtot[- (obj$call$ind.sup), ]
    # Fix when MCA called with tab.disj, see #37
    names(counts.tab) <- make.unique(names(counts.tab))
    counts <- sapply(counts.tab[, quali.mods, drop = FALSE], sum)
    vars$Count <- counts

    ## Supplementary variables coordinates
    if (!is.null(obj$quali.sup)) {
        vars.quali.sup <- data.frame(obj$quali.sup$coord)
        if ("tab.disj" %in% names(as.list(obj$call$call))) {
            varnames <- rownames(obj$quali.sup$coord)
            vars.quali.sup$varname <- gsub("[._][^._]+?$", "", varnames)
        } else {
            varnames <- sapply(obj$call$X[, obj$call$quali.sup, drop = FALSE], nlevels)
            vars.quali.sup$varname <- rep(names(varnames), varnames)
        }
        vars.quali.sup$modname <- rownames(vars.quali.sup)
        vars.quali.sup$Type <- "Supplementary"
        vars.quali.sup$Class <- "Qualitative"
        quali.sup.mods <- rownames(obj$quali.sup$coord)
        counts <- sapply(counts.tab[, quali.sup.mods, drop = FALSE], sum)
        vars.quali.sup$Count <- counts
        vars <- rbind(vars, vars.quali.sup)
    }

    ## Quantitative supplementary variables coordinates
    if (!is.null(obj$quanti.sup)) {
        vars.quanti.sup <- data.frame(obj$quanti.sup$coord)
        vars.quanti.sup$varname <- rownames(obj$quanti.sup$coord)
        vars.quanti.sup$modname <- rownames(obj$quanti.sup$coord)
        vars.quanti.sup$Type <- "Supplementary"
        vars.quanti.sup$Class <- "Quantitative"
        vars.quanti.sup$Count <- NA
        vars <- rbind(vars, vars.quanti.sup)
    }

    vars <- vars %>%
        pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
               Coord = round(Coord, 3))

    ## Contributions
    tmp <- data.frame(obj$var$contrib)
    tmp <- tmp %>%
        mutate(modname = rownames(tmp), Type = "Active", Class = "Qualitative") %>%
        pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
               Contrib = round(Contrib, 3))

    vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis"))

    ## Cos2
    tmp <- data.frame(obj$var$cos2)
    tmp$modname <- rownames(tmp)
    tmp$Type <- "Active"
    tmp$Class <- "Qualitative"
    if (!is.null(obj$quali.sup)) {
        tmp_sup <- data.frame(obj$quali.sup$cos2)
        tmp_sup$modname <- rownames(tmp_sup)
        tmp_sup$Type <- "Supplementary"
        tmp_sup$Class <- "Qualitative"
        tmp <- tmp %>% bind_rows(tmp_sup)
    }
    tmp <- tmp %>%
        pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
               Cos2 = round(Cos2, 3))

    vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis"))

    ## V.test for supplementary qualitative variables
    if (!is.null(obj$quali.sup)) {
        tmp <- data.frame(obj$quali.sup$v.test)
        tmp$modname <- rownames(tmp)
        tmp$Type <- "Supplementary"
        tmp$Class <- "Qualitative"
        tmp <- tmp %>%
            pivot_longer(names_to = "Axis", values_to = "V.test", starts_with("Dim.")) %>%
            mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
                   P.value = round(ifelse(V.test >= 0, 2 * (1 - pnorm(V.test)), 2 * pnorm(V.test)), 3),
                   V.test = round(V.test, 2))

        vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis"))
    }

    vars <- vars %>%
        rename(Variable = varname, Level = modname) %>%
        as.data.frame()

    ## Variables eta2
    vareta2 <- data.frame(obj$var$eta2)
    vareta2$Variable <- rownames(vareta2)
    vareta2$Type <- "Active"
    vareta2$Class <- "Qualitative"
    if (!is.null(obj$quali.sup)) {
        vareta2_sup <- data.frame(obj$quali.sup$eta2)
        vareta2_sup$Variable <- rownames(vareta2_sup)
        vareta2_sup$Type <- "Supplementary"
        vareta2_sup$Class <- "Qualitative"
        vareta2 <- vareta2 %>% bind_rows(vareta2_sup)
    }
    vareta2 <- vareta2 %>%
        pivot_longer(names_to = "Axis", values_to = "eta2", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE))

    ## Individuals coordinates
    ind <- data.frame(obj$ind$coord)
    ind$Name <- rownames(ind)
    ind$Type <- "Active"
    if (!is.null(obj$ind.sup)) {
        tmp_sup <- data.frame(obj$ind.sup$coord)
        tmp_sup$Name <- rownames(tmp_sup)
        tmp_sup$Type <- "Supplementary"
        ind <- ind %>% bind_rows(tmp_sup)
    }
    ind <- ind %>%
        pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
               Coord = round(Coord, 3))

    ## Individuals contrib
    tmp <- data.frame(obj$ind$contrib)
    tmp <- tmp %>%
        mutate(Name = rownames(tmp), Type = "Active") %>%
        pivot_longer(names_to = "Axis", values_to = "Contrib", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
               Contrib = round(Contrib, 3))

    ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis"))

    ## Individuals Cos2
    tmp <- data.frame(obj$ind$cos2)
    tmp$Name <- rownames(tmp)
    tmp$Type <- "Active"
    if (!is.null(obj$ind.sup)) {
        tmp_sup <- data.frame(obj$ind.sup$cos2)
        tmp_sup$Name <- rownames(tmp_sup)
        tmp_sup$Type <- "Supplementary"
        tmp <- tmp %>% bind_rows(tmp_sup)
    }
    tmp <- tmp %>%
        pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("Dim.")) %>%
        mutate(Axis = gsub("Dim.", "", Axis, fixed = TRUE),
               Cos2 = round(Cos2, 3))

    ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis"))

    ## Qualitative data for individuals plot color mapping
    quali_data <- obj$call$X[, obj$call$quali]
    if (!is.null(obj$quali.sup)) {
        quali_data <- obj$call$X[, obj$call$quali.sup, drop = FALSE] %>% bind_cols(quali_data)
    }
    quali_data$Name <- rownames(obj$call$X)


    return(list(vars = vars, ind = ind, eig = eig, axes = axes, vareta2 = vareta2, quali_data = quali_data))

}