Fix supplementary variables not displayed in individual plot for speMCA (#42)

Author: juba

NEWS.md

@@ -2,6 +2,7 @@
 
 - Fix duplicated level names in supplementary variables in speMCA
 - Fix warnings in Font Awesome icon names (#39, thanks @jl5000)
+- Fix supplementary variables not displayed in individual plot for speMCA (thanks @419kfj)
 
 # explor 0.3.9
 

R/prepare_results_speMCA.R

@@ -8,7 +8,6 @@
 ##' @export
 
 prepare_results.speMCA <- function(obj) {
-
     if (!inherits(obj, "speMCA")) stop("obj must be of class speMCA")
 
     ## Extract variable names from results row names
@@ -23,13 +22,13 @@ prepare_results.speMCA <- function(obj) {
     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$rate, 2), length(axes)),"%)"))
+    names(axes) <- paste("Axis", axes, paste0("(", head(round(obj$eig$rate, 2), length(axes)), "%)"))
     ## Eigenvalues
     eig <- data.frame(dim = seq_len(length(obj$eig$rate)), percent = obj$eig$rate)
 
     ## Variables coordinates
-    varnames <- sapply(obj$call$X[,obj$call$quali, drop = FALSE], nlevels)
-    varnames <- rep(names(varnames),varnames)
+    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)
@@ -44,16 +43,22 @@ prepare_results.speMCA <- function(obj) {
         vars <- vars %>% bind_rows(tmp_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))
+    vars <- vars %>%
+        pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("dim.")) %>%
+        mutate(
+            Axis = gsub("dim.", "", Axis, fixed = TRUE),
+            Coord = round(Coord, 3)
+        )
 
     ## Variables contrib
     tmp <- data.frame(obj$var$contrib)
-    tmp <- tmp %>% mutate(modname = rownames(tmp), Type = "Active", Class = "Qualitative") %>%
+    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))
+        mutate(
+            Axis = gsub("dim.", "", Axis, fixed = TRUE),
+            Contrib = round(Contrib, 3)
+        )
 
     vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis"))
 
@@ -71,12 +76,14 @@ prepare_results.speMCA <- function(obj) {
     }
     tmp <- tmp %>%
         pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("dim.")) %>%
-        mutate(Axis = gsub("dim.", "", Axis, fixed = TRUE),
-               Cos2 = round(Cos2, 3))
+        mutate(
+            Axis = gsub("dim.", "", Axis, fixed = TRUE),
+            Cos2 = round(Cos2, 3)
+        )
     vars <- vars %>% left_join(tmp, by = c("modname", "Type", "Class", "Axis"))
 
     vars$modname <- mapply(vars$modname, vars$varname, FUN = function(mod, var) {
-        sub(paste0("^",var,"\\."), "", mod)
+        sub(paste0("^", var, "\\."), "", mod)
     }, USE.NAMES = FALSE)
     vars <- vars %>%
         rename(Variable = varname, Level = modname) %>%
@@ -104,15 +111,20 @@ prepare_results.speMCA <- function(obj) {
     }
     ind <- ind %>%
         pivot_longer(names_to = "Axis", values_to = "Coord", starts_with("dim.")) %>%
-        mutate(Axis = gsub("dim.", "", Axis, fixed = TRUE),
-               Coord = round(Coord, 3))
+        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") %>%
+    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))
+        mutate(
+            Axis = gsub("dim.", "", Axis, fixed = TRUE),
+            Contrib = round(Contrib, 3)
+        )
 
     ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis"))
 
@@ -122,24 +134,25 @@ prepare_results.speMCA <- function(obj) {
         tmp <- tmp %>%
             mutate(Name = rownames(tmp), Type = "Supplementary") %>%
             pivot_longer(names_to = "Axis", values_to = "Cos2", starts_with("dim.")) %>%
-            mutate(Axis = gsub("dim.", "", Axis, fixed = TRUE),
-                   Cos2 = round(Cos2, 3))
+            mutate(
+                Axis = gsub("dim.", "", Axis, fixed = TRUE),
+                Cos2 = round(Cos2, 3)
+            )
         ind <- ind %>% left_join(tmp, by = c("Name", "Type", "Axis"))
     } else {
         ind$Cos2 <- NA
     }
 
     ## 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]
+    if (!is.null(obj$supv)) {
         quali_data <- quali_data %>%
-            bind_cols(obj$call$X[,obj$call$quali.sup, drop = FALSE])
+            bind_cols(obj$supv$tab)
     }
     quali_data$Name <- rownames(obj$call$X)
 
 
     return(
         list(vars = vars, ind = ind, eig = eig, axes = axes, vareta2 = vareta2, quali_data = quali_data)
     )
-
-}
+}

R/utils.R

@@ -24,7 +24,7 @@ speMCA_varsup <- function(mca, df) {
         })
         l
     })
-    Reduce(function(acc, cur) {
+    res <- Reduce(function(acc, cur) {
         for (name in names(acc)) {
             if (name == "weight") next
             acc[[name]] <- dplyr::bind_rows(
@@ -34,4 +34,8 @@ speMCA_varsup <- function(mca, df) {
         }
         acc
     }, res)
-}
+
+    res$tab <- df
+
+    res
+}

tests/testthat/test_prepare_results_speMCA.R

@@ -67,8 +67,10 @@ test_that("Supplementary variables results are equal", {
 
 test_that("Qualitative data are equal", {
   ids <- c("4731", "31", "2489", "4125", "280")
+  tmp <- res$quali_data
+  rownames(tmp) <- tmp$Name
   expect_equal(
-    as.character(res$quali_data[ids, "FrenchPop"]),
+    as.character(tmp[ids, "FrenchPop"]),
     as.character(Music[ids, "FrenchPop"])
   )
 })