##' @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))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.