Implemented Data Summary for EFA / PCA

R/efa.h.R

@@ -12,15 +12,17 @@ efaOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
             minEigen = 0,
             extraction = "minres",
             rotation = "oblimin",
+            countCorrMin = "",
+            countCorrMax = "",
+            kmo = FALSE,
+            bartlett = FALSE,
             hideLoadings = 0.3,
             sortLoadings = FALSE,
             screePlot = FALSE,
             eigen = FALSE,
             factorCor = FALSE,
             factorSummary = FALSE,
             modelFit = FALSE,
-            kmo = FALSE,
-            bartlett = FALSE,
             factorScoreMethod = "Thurstone", ...) {
 
             super$initialize(
@@ -75,6 +77,22 @@ efaOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
                     "oblimin",
                     "simplimax"),
                 default="oblimin")
+            private$..countCorrMin <- jmvcore::OptionString$new(
+                "countCorrMin",
+                countCorrMin,
+                default="")
+            private$..countCorrMax <- jmvcore::OptionString$new(
+                "countCorrMax",
+                countCorrMax,
+                default="")
+            private$..kmo <- jmvcore::OptionBool$new(
+                "kmo",
+                kmo,
+                default=FALSE)
+            private$..bartlett <- jmvcore::OptionBool$new(
+                "bartlett",
+                bartlett,
+                default=FALSE)
             private$..hideLoadings <- jmvcore::OptionNumber$new(
                 "hideLoadings",
                 hideLoadings,
@@ -103,14 +121,6 @@ efaOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
                 "modelFit",
                 modelFit,
                 default=FALSE)
-            private$..kmo <- jmvcore::OptionBool$new(
-                "kmo",
-                kmo,
-                default=FALSE)
-            private$..bartlett <- jmvcore::OptionBool$new(
-                "bartlett",
-                bartlett,
-                default=FALSE)
             private$..factorScoresOV <- jmvcore::OptionOutput$new(
                 "factorScoresOV")
             private$..factorScoreMethod <- jmvcore::OptionList$new(
@@ -130,15 +140,17 @@ efaOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
             self$.addOption(private$..minEigen)
             self$.addOption(private$..extraction)
             self$.addOption(private$..rotation)
+            self$.addOption(private$..countCorrMin)
+            self$.addOption(private$..countCorrMax)
+            self$.addOption(private$..kmo)
+            self$.addOption(private$..bartlett)
             self$.addOption(private$..hideLoadings)
             self$.addOption(private$..sortLoadings)
             self$.addOption(private$..screePlot)
             self$.addOption(private$..eigen)
             self$.addOption(private$..factorCor)
             self$.addOption(private$..factorSummary)
             self$.addOption(private$..modelFit)
-            self$.addOption(private$..kmo)
-            self$.addOption(private$..bartlett)
             self$.addOption(private$..factorScoresOV)
             self$.addOption(private$..factorScoreMethod)
         }),
@@ -149,15 +161,17 @@ efaOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
         minEigen = function() private$..minEigen$value,
         extraction = function() private$..extraction$value,
         rotation = function() private$..rotation$value,
+        countCorrMin = function() private$..countCorrMin$value,
+        countCorrMax = function() private$..countCorrMax$value,
+        kmo = function() private$..kmo$value,
+        bartlett = function() private$..bartlett$value,
         hideLoadings = function() private$..hideLoadings$value,
         sortLoadings = function() private$..sortLoadings$value,
         screePlot = function() private$..screePlot$value,
         eigen = function() private$..eigen$value,
         factorCor = function() private$..factorCor$value,
         factorSummary = function() private$..factorSummary$value,
         modelFit = function() private$..modelFit$value,
-        kmo = function() private$..kmo$value,
-        bartlett = function() private$..bartlett$value,
         factorScoresOV = function() private$..factorScoresOV$value,
         factorScoreMethod = function() private$..factorScoreMethod$value),
     private = list(
@@ -167,15 +181,17 @@ efaOptions <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
         ..minEigen = NA,
         ..extraction = NA,
         ..rotation = NA,
+        ..countCorrMin = NA,
+        ..countCorrMax = NA,
+        ..kmo = NA,
+        ..bartlett = NA,
         ..hideLoadings = NA,
         ..sortLoadings = NA,
         ..screePlot = NA,
         ..eigen = NA,
         ..factorCor = NA,
         ..factorSummary = NA,
         ..modelFit = NA,
-        ..kmo = NA,
-        ..bartlett = NA,
         ..factorScoresOV = NA,
         ..factorScoreMethod = NA)
 )
@@ -263,6 +279,16 @@ efaBase <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
 #' @param rotation \code{'none'}, \code{'varimax'}, \code{'quartimax'},
 #'   \code{'promax'}, \code{'oblimin'} (default), or \code{'simplimax'}, the
 #'   rotation to use in estimation
+#' @param countCorrMin a number (default: NA), returns the number of
+#'   correlations between variables above this minimum (if NA, no output is
+#'   produced)
+#' @param countCorrMax a number (default: NA), returns the number of
+#'   correlations between variables above this maxmimum (if NA, no output is
+#'   produced)
+#' @param kmo \code{TRUE} or \code{FALSE} (default), show Kaiser-Meyer-Olkin
+#'   (KMO) measure of sampling adequacy (MSA) results
+#' @param bartlett \code{TRUE} or \code{FALSE} (default), show Bartlett's test
+#'   of sphericity results
 #' @param hideLoadings a number (default: 0.3), hide factor loadings below
 #'   this value
 #' @param sortLoadings \code{TRUE} or \code{FALSE} (default), sort the factor
@@ -275,10 +301,6 @@ efaBase <- if (requireNamespace("jmvcore", quietly=TRUE)) R6::R6Class(
 #'   summary
 #' @param modelFit \code{TRUE} or \code{FALSE} (default), show model fit
 #'   measures and test
-#' @param kmo \code{TRUE} or \code{FALSE} (default), show Kaiser-Meyer-Olkin
-#'   (KMO) measure of sampling adequacy (MSA) results
-#' @param bartlett \code{TRUE} or \code{FALSE} (default), show Bartlett's test
-#'   of sphericity results
 #' @param factorScoreMethod \code{'Thurstone'} (default), \code{'Bartlett'},
 #'   \code{'tenBerge'}, \code{'Anderson'}, or \code{'Harman'} use respectively
 #'   'Thurstone', 'Bartlett', 'ten Berge', 'Anderson & Rubin', or 'Harman'
@@ -297,15 +319,17 @@ efa <- function(
     minEigen = 0,
     extraction = "minres",
     rotation = "oblimin",
+    countCorrMin = "",
+    countCorrMax = "",
+    kmo = FALSE,
+    bartlett = FALSE,
     hideLoadings = 0.3,
     sortLoadings = FALSE,
     screePlot = FALSE,
     eigen = FALSE,
     factorCor = FALSE,
     factorSummary = FALSE,
     modelFit = FALSE,
-    kmo = FALSE,
-    bartlett = FALSE,
     factorScoreMethod = "Thurstone") {
 
     if ( ! requireNamespace("jmvcore", quietly=TRUE))
@@ -326,15 +350,17 @@ efa <- function(
         minEigen = minEigen,
         extraction = extraction,
         rotation = rotation,
+        countCorrMin = countCorrMin,
+        countCorrMax = countCorrMax,
+        kmo = kmo,
+        bartlett = bartlett,
         hideLoadings = hideLoadings,
         sortLoadings = sortLoadings,
         screePlot = screePlot,
         eigen = eigen,
         factorCor = factorCor,
         factorSummary = factorSummary,
         modelFit = modelFit,
-        kmo = kmo,
-        bartlett = bartlett,
         factorScoreMethod = factorScoreMethod)
 
     analysis <- efaClass$new(

R/pca.b.R

@@ -110,6 +110,7 @@ pcaClass <- R6::R6Class(
             private$.initLoadingsTable()
             private$.initModelFitTable()
             private$.initEigenTable()
+            private$.initCorrCountTable()
             private$.initKMOTable()
             private$.initFactorCor()
         },
@@ -124,6 +125,7 @@ pcaClass <- R6::R6Class(
             private$.populateFactorSummaryTable()
             private$.populateFactorCorTable()
             private$.populateModelFitTable()
+            private$.populateCorrCountTable()
             private$.populateKMOTable()
             private$.populateBartlettTable()
             private$.prepareScreePlot()
@@ -250,6 +252,21 @@ pcaClass <- R6::R6Class(
             for (i in seq_along(self$options$vars))
                 table$addRow(rowKey=i, values=list(comp = as.character(i)))
         },
+        .initCorrCountTable = function() {
+            group <- self$results$dataSummary
+            vars <- self$options$vars
+
+            for (t in c("Min", "Max")) {
+                table <- group[[paste0("corrAbove", t)]]
+                title <- jmvcore::format(.("Correlations Above {} Threshold ({})"),
+                                         ifelse(t == "Min", .("Minimum"), .("Maximum")),
+                                         self$options[[paste0("countCorr", t)]])
+                table$setTitle(title)
+                for (i in seq_along(vars)) {
+                    table$addColumn(name = sprintf("c%d", i), title = "", type = 'integer')
+                }
+            }
+        },
         .initKMOTable = function() {
             table <- self$results$assump$kmo
             vars <- self$options$vars
@@ -413,6 +430,30 @@ pcaClass <- R6::R6Class(
                 table$setRow(rowNo=1, values=row)
             }
         },
+        .populateCorrCountTable = function() {
+            group <- self$results$dataSummary
+            vars <- self$options$vars
+            if (length(vars) >= 1) {
+                corrMatrix = abs(cor(sapply(self$data[, vars], jmvcore::toNumeric), use = "pairwise"))
+                diag(corrMatrix) <- NA
+
+                for (t in c("Min", "Max")) {
+                    thresh <- as.numeric(self$options[[paste0("countCorr", t)]])
+                    if (is.na(thresh)) next
+                    if (thresh <= 0 || thresh >= 1)
+                        jmvcore::reject(.("Values for the Correlation Min. / Max. need to be Numeric and Between 0 and 1"))
+                    table  <- group[[paste0("corrAbove", t)]]
+                    # sort the columns by the number of correlations above threshold (increasing for min: lower counts
+                    # on the left, decreasing for max: higher counts on the left)
+                    counts <- sort(colSums(corrMatrix > thresh, na.rm = TRUE), decreasing = (t == "Max"))
+                    cnames <- names(counts)
+                    table$setRow(rowNo = 1, setNames(as.list(counts), sprintf("c%d", seq_along(vars))))
+                    for (i in seq_along(cnames)) {
+                         table$columns[[i + 1]]$setTitle(cnames[i])
+                    }
+                }
+            }
+        },
         .populateKMOTable = function() {
             if (! self$options$kmo)
                 return()