Add support for EFA/PCA from {psych} package (#822)

Co-authored-by: gemini-code-assist[bot] <176961590+gemini-code-assist[bot]@users.noreply.github.com>

Author: strengejacke

DESCRIPTION

@@ -1,7 +1,7 @@
 Type: Package
 Package: performance
 Title: Assessment of Regression Models Performance
-Version: 0.14.0.2
+Version: 0.14.0.3
 Authors@R:
     c(person(given = "Daniel",
              family = "Lüdecke",
@@ -71,7 +71,7 @@ License: GPL-3
 URL: https://easystats.github.io/performance/
 BugReports: https://github.com/easystats/performance/issues
 Depends:
-    R (>= 3.6)
+    R (>= 4.0)
 Imports:
     bayestestR (>= 0.16.0),
     insight (>= 1.3.0),
@@ -98,6 +98,7 @@ Suggests:
     dagitty,
     dbscan,
     DHARMa (>= 0.4.7),
+    discovr,
     estimatr,
     fixest,
     flextable,
@@ -137,6 +138,7 @@ Suggests:
     patchwork,
     pscl,
     psych,
+    psychTools,
     quantreg,
     qqplotr (>= 0.0.6),
     randomForest,
@@ -165,3 +167,4 @@ Config/Needs/website:
     r-lib/pkgdown,
     easystats/easystatstemplate
 Config/rcmdcheck/ignore-inconsequential-notes: true
+Remotes: easystats/insight, easystats/parameters

NAMESPACE

@@ -65,13 +65,16 @@ S3method(check_multimodal,numeric)
 S3method(check_normality,BFBayesFactor)
 S3method(check_normality,afex_aov)
 S3method(check_normality,default)
+S3method(check_normality,fa)
 S3method(check_normality,glm)
 S3method(check_normality,glmmTMB)
 S3method(check_normality,htest)
 S3method(check_normality,lmerModLmerTest)
 S3method(check_normality,merMod)
 S3method(check_normality,numeric)
+S3method(check_normality,parameters_efa)
 S3method(check_normality,performance_simres)
+S3method(check_normality,principal)
 S3method(check_outliers,BFBayesFactor)
 S3method(check_outliers,DHARMa)
 S3method(check_outliers,character)
@@ -118,7 +121,10 @@ S3method(check_predictions,lme)
 S3method(check_predictions,stanreg)
 S3method(check_residuals,DHARMa)
 S3method(check_residuals,default)
+S3method(check_residuals,fa)
+S3method(check_residuals,parameters_efa)
 S3method(check_residuals,performance_simres)
+S3method(check_residuals,principal)
 S3method(check_singularity,MixMod)
 S3method(check_singularity,clmm)
 S3method(check_singularity,cpglmm)
@@ -173,6 +179,7 @@ S3method(model_performance,clm2)
 S3method(model_performance,coxph)
 S3method(model_performance,coxph_weightit)
 S3method(model_performance,default)
+S3method(model_performance,fa)
 S3method(model_performance,felm)
 S3method(model_performance,fixest)
 S3method(model_performance,fixest_multi)
@@ -205,10 +212,12 @@ S3method(model_performance,negbinirr)
 S3method(model_performance,negbinmfx)
 S3method(model_performance,nestedLogit)
 S3method(model_performance,ordinal_weightit)
+S3method(model_performance,parameters_efa)
 S3method(model_performance,plm)
 S3method(model_performance,poissonirr)
 S3method(model_performance,poissonmfx)
 S3method(model_performance,polr)
+S3method(model_performance,principal)
 S3method(model_performance,probitmfx)
 S3method(model_performance,rlmerMod)
 S3method(model_performance,rma)

NEWS.md

@@ -5,6 +5,9 @@
 * Formatting of p-values in `test_likelihoodratio()` is now consistent with
   formatted p-values from other functions.
 
+* Added following methods for `psych::fa()`, `psych::principal()` and
+ `parameters::factor_analysis()`: `check_normality()`, `check_residuals()`, and `model_performance()`.
+
 # performance 0.14.0
 
 ## Breaking Changes

R/check_normality.R

@@ -75,6 +75,28 @@ check_normality.default <- function(x, ...) {
   p.val
 }
 
+# PCA / FA ---------------
+
+#' @export
+check_normality.parameters_efa <- function(x, ...) {
+  # check for normality of residuals
+  p.val <- .check_normality(insight::get_residuals(x), x)
+
+  attr(p.val, "data") <- x
+  attr(p.val, "object_name") <- insight::safe_deparse_symbol(substitute(x))
+  attr(p.val, "effects") <- "fixed"
+  attr(p.val, "is_fa") <- TRUE
+  class(p.val) <- unique(c("check_normality", "see_check_normality", class(p.val)))
+
+  p.val
+}
+
+#' @export
+check_normality.fa <- check_normality.parameters_efa
+
+#' @export
+check_normality.principal <- check_normality.parameters_efa
+
 # glm ---------------
 
 #' @export
@@ -180,6 +202,21 @@ print.check_normality <- function(x, ...) {
       }
     }
   }
+
+  # add FA / PCA information
+  if (isTRUE(attributes(x)$is_fa)) {
+    res <- insight::get_residuals(attributes(x)$data)
+    lge_resid_tot <- sum(abs(res) > 0.05)
+    lge_resid_pct <- lge_resid_tot / length(res)
+    cat(paste0(
+      "\nAbsolute residuals > 0.05 = ",
+      lge_resid_tot,
+      " (",
+      insight::format_percent(lge_resid_pct),
+      ")\n"
+    ))
+  }
+
   invisible(x)
 }
 

R/check_residuals.R

@@ -66,6 +66,19 @@ check_residuals.default <- function(x, alternative = "two.sided",
   }
 }
 
+
+#' @export
+check_residuals.fa <- function(x, ...) {
+  check_normality(x, ...)
+}
+
+#' @export
+check_residuals.principal <- check_residuals.fa
+
+#' @export
+check_residuals.parameters_efa <- check_residuals.fa
+
+
 #' @export
 check_residuals.performance_simres <- function(x, alternative = "two.sided",
                                                distribution = "punif", ...) {

R/model_performance.psych.R

@@ -0,0 +1,55 @@
+#' Performance of FA / PCA models
+#'
+#' Compute indices of model performance for models from the **psych** package,
+#' and for `parameters::factor_analysis()`.
+#'
+#' @param model A model object of class `fa` (e.g., from `psych::fa()`),
+#' `principal` (e.g., from `psych::principal()`), or from
+#' `parameters::factor_analysis()`.
+#' @param metrics Can be `"all"` or a character vector of metrics to be computed
+#' (some of `"Chi2"`, `"Chi2_df"`, `"p_Chi2"`, `"RMSA"`, `"RMSA_corrected"`,
+#' `"TLI"`, `"RMSEA"`, `"RMSEA_CI_low"`, `"RMSEA_CI_high"`, and `"BIC"`.
+#' @param verbose Toggle off warnings.
+#' @param ... Arguments passed to or from other methods.
+#'
+#' @return A data frame (with one row) and one column per "index" (see
+#' `metrics`).
+#'
+#' @examplesIf all(insight::check_if_installed(c("psych", "GPArotation", "psychTools"), quietly = TRUE))
+#' out <- psych::fa(psychTools::bfi[, 1:25], 5)
+#' model_performance(out)
+#' @export
+model_performance.fa <- function(model, metrics = "all", verbose = TRUE, ...) {
+  out <- data.frame(
+    Chi2 = ifelse(is.null(model$STATISTIC), NA_real_, model$STATISTIC),
+    Chi2_df = ifelse(is.null(model$dof), NA_real_, model$dof),
+    p_Chi2 = ifelse(is.null(model$PVAL), NA_real_, model$PVAL),
+    RMSA = ifelse(is.null(model$rms), NA_real_, model$rms),
+    RMSA_corrected = ifelse(is.null(model$crms), NA_real_, model$crms),
+    TLI = ifelse(is.null(model$TLI), NA_real_, model$TLI),
+    RMSEA = ifelse(is.null(model$RMSEA), NA_real_, model$RMSEA[1]),
+    RMSEA_CI = ifelse(is.null(model$RMSEA), NA_real_, 0.9),
+    RMSEA_CI_low = ifelse(is.null(model$RMSEA), NA_real_, model$RMSEA[2]),
+    RMSEA_CI_high = ifelse(is.null(model$RMSEA), NA_real_, model$RMSEA[3]),
+    BIC = ifelse(is.null(model$BIC), NA_real_, model$BIC)
+  )
+
+  if (all(metrics == "all")) {
+    metrics <- names(out)
+  }
+
+  # clean up
+  out <- out[, metrics]
+  out <- datawizard::remove_empty_columns(out)
+
+  class(out) <- c("performance_fa", "performance_model", class(out))
+  out
+}
+
+#' @export
+model_performance.principal <- model_performance.fa
+
+#' @export
+model_performance.parameters_efa <- function(model, metrics = "all", verbose = TRUE, ...) {
+  model_performance(attributes(model)$model, metrics = metrics, verbose = verbose, ...)
+}

R/test_likelihoodratio.R

@@ -73,7 +73,7 @@ print.test_likelihoodratio <- function(x, digits = 2, ...) {
 
 
 #' @export
-format.test_likelihoodratio <- function(x, digits = 2, p_digits = 3, ...) {
+format.test_likelihoodratio <- function(x, digits = 2, p_digits = 3, format = "text", ...) {
   # Footer
   if ("LogLik" %in% names(x)) {
     best <- which.max(x$LogLik)
@@ -91,21 +91,27 @@ format.test_likelihoodratio <- function(x, digits = 2, p_digits = 3, ...) {
     estimator_string <- sprintf(" (%s-estimator)", toupper(attributes(x)$estimator))
   }
 
+  if (format == "text") {
+    caption <- c(paste0("# Likelihood-Ratio-Test (LRT) for Model Comparison", estimator_string), "blue")
+  } else {
+    caption <- paste0("Likelihood-Ratio-Test (LRT) for Model Comparison", estimator_string)
+  }
+
   attr(x, "table_footer") <- footer
-  attr(x, "table_caption") <- c(paste0("# Likelihood-Ratio-Test (LRT) for Model Comparison", estimator_string), "blue")
+  attr(x, "table_caption") <- caption
   x
 }
 
 
 #' @export
 print_md.test_likelihoodratio <- function(x, digits = 2, ...) {
-  insight::export_table(format(x, digits = digits, ...), format = "markdown", ...)
+  insight::export_table(format(x, digits = digits, format = "markdown", ...), format = "markdown", ...)
 }
 
 
 #' @export
 print_html.test_likelihoodratio <- function(x, digits = 2, ...) {
-  insight::export_table(format(x, digits = digits, ...), format = "html", ...)
+  insight::export_table(format(x, digits = digits, format = "html", ...), format = "html", ...)
 }