Nothing
tests/testthat/test-efa_schmid_leiman.R
In EFAtools: Fast and Flexible Implementations of Exploratory Factor Analysis Tools
## Use with an output from the EFAtools::EFA function, both with type EFAtools
EFA_mod <- EFA(test_models$baseline$cormat, N = 500, n_factors = 3,
type = "EFAtools", method = "PAF", rotation = "promax")
SL_EFAtools <- efa_schmid_leiman(EFA_mod, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF")
# with type SPSS and method ULS. The second-order fit notes that only PAF is validated
# against SPSS; that note is asserted where it belongs (test-superseded.R) and is muffled
# here so the fixture does not raise a warning outside any test.
SL_SPSS <- suppressWarnings(
efa_schmid_leiman(EFA_mod, estimate_control = estimate_control(type = "SPSS"),
estimator = "ULS"))
## Use with an output from the psych::fa function with type psych
fa_mod <- psych::fa(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "Promax", n.rotations = 1)
SL_psych <- efa_schmid_leiman(fa_mod, estimate_control = estimate_control(type = "psych"), estimator = "PAF")
## Use more flexibly by entering a pattern matrix and phi directly, with method
## ML
SL_flex <- efa_schmid_leiman(EFA_mod$rot_loadings, Phi = EFA_mod$Phi, estimator = "ML",
estimate_control = estimate_control(type = "EFAtools"))
## Use with a second-order lavaan solution
if (requireNamespace("lavaan", quietly = TRUE)) {
lav_mod_ho <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6
F2 =~ V7 + V8 + V9 + V10 + V11 + V12
F3 =~ V13 + V14 + V15 + V16 + V17 + V18
g =~ F1 + F2 + F3'
lav_fit_ho <- suppressWarnings(lavaan::cfa(lav_mod_ho,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
SL_lav <- efa_schmid_leiman(lav_fit_ho, g_name = "g")
}
test_that("output class and dimensions are correct", {
skip_if_not_installed("lavaan")
expect_identical(class(SL_EFAtools), c("efa_schmid_leiman", "SL"))
expect_identical(class(SL_EFAtools$sl), c("efa_sl_loadings", "SLLOADINGS"))
expect_s3_class(SL_SPSS, "efa_schmid_leiman")
expect_s3_class(SL_psych, "efa_schmid_leiman")
expect_s3_class(SL_flex, "efa_schmid_leiman")
expect_s3_class(SL_lav, "efa_schmid_leiman")
expect_output(str(SL_EFAtools), "List of 7")
expect_output(str(SL_SPSS), "List of 7")
expect_output(str(SL_psych), "List of 7")
expect_output(str(SL_flex), "List of 7")
expect_output(str(SL_lav), "List of 7")
})
test_that("non-convergence of the second-order EFA is recorded and surfaced", {
testthat::local_reproducible_output()
# The convergence code of the second-order EFA is carried on the SL object.
expect_equal(SL_SPSS$convergence, 0)
# A non-zero code shows the banner: the optimiser estimators use the generic
# message, PAF the iteration-specific one. Set the code explicitly so the test
# does not depend on the second-order fit's actual convergence.
sl_uls <- SL_SPSS
sl_uls$convergence <- 1L
expect_true(any(grepl("The optimiser did not converge", format(sl_uls), fixed = TRUE)))
sl_paf <- SL_EFAtools
sl_paf$convergence <- 1L
expect_true(any(grepl("Maximum number of iterations reached without convergence",
format(sl_paf), fixed = TRUE)))
# A converged fit shows no banner.
expect_false(any(grepl("did not converge", format(SL_SPSS), fixed = TRUE)))
})
test_that("original correlation is correct", {
skip_if_not_installed("lavaan")
expect_equal(SL_EFAtools$orig_R, test_models$baseline$cormat)
expect_equal(SL_SPSS$orig_R, test_models$baseline$cormat)
expect_equal(SL_psych$orig_R, test_models$baseline$cormat)
expect_equal(SL_flex$orig_R, NA)
expect_equal(SL_lav$orig_R, NA)
})
test_that("sl solution is correct", {
skip_if_not_installed("lavaan")
expect_equal(unname(SL_EFAtools$sl[, "h2"]) + unname(SL_EFAtools$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_SPSS$sl[, "h2"]) + unname(SL_SPSS$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_psych$sl[, "h2"]) + unname(SL_psych$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_flex$sl[, "h2"]) + unname(SL_flex$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_lav$sl[, "h2"]) + unname(SL_lav$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_EFAtools$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_SPSS$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_psych$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_flex$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_lav$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_EFAtools$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_SPSS$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_psych$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_flex$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_lav$sl[1:6, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_EFAtools$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_SPSS$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_psych$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_flex$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_lav$sl[7:18, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_EFAtools$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_SPSS$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_psych$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_flex$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_lav$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_EFAtools$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_SPSS$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_psych$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_flex$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_lav$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_EFAtools$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_SPSS$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_psych$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_flex$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_lav$sl[13:18, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_EFAtools$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_SPSS$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_psych$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_flex$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_lav$sl[1:12, "F3"]) < .20, rep(TRUE, 12))
})
test_that("sl loadings reproduce psych::schmid", {
skip_on_cran()
skip_if_not_installed("psych")
# The Schmid-Leiman transformation of the same psych Promax solution must match
# psych::schmid()'s g and group loadings (its columns are g, F1*, F2*, F3*).
sch <- suppressMessages(suppressWarnings(
psych::schmid(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "Promax")))
expect_equal(unname(SL_psych$sl[, c("g", "F1", "F2", "F3")]),
unname(sch$sl[, c("g", "F1*", "F2*", "F3*")]),
tolerance = 1e-4)
})
test_that("settings are returned correctly", {
skip_if_not_installed("lavaan")
expect_named(SL_EFAtools$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed", "max_iter",
"init_comm", "criterion", "criterion_type",
"abs_eigen"))
expect_named(SL_SPSS$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed"))
expect_named(SL_psych$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed", "max_iter",
"init_comm", "criterion", "criterion_type",
"abs_eigen"))
expect_named(SL_flex$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed", "start_method"))
expect_equal(SL_lav$settings, NA)
expect_equal(SL_EFAtools$settings$estimator, "PAF")
expect_equal(SL_SPSS$settings$estimator, "ULS")
expect_equal(SL_psych$settings$estimator, "PAF")
expect_equal(SL_flex$settings$estimator, "ML")
expect_equal(SL_EFAtools$settings$rotation, "none")
expect_equal(SL_SPSS$settings$rotation, "none")
expect_equal(SL_psych$settings$rotation, "none")
expect_equal(SL_flex$settings$rotation, "none")
expect_equal(SL_EFAtools$settings$type, "EFAtools")
expect_equal(SL_SPSS$settings$type, "SPSS")
expect_equal(SL_psych$settings$type, "psych")
expect_equal(SL_flex$settings$type, "EFAtools")
expect_equal(SL_EFAtools$settings$n_factors, 1)
expect_equal(SL_SPSS$settings$n_factors, 1)
expect_equal(SL_psych$settings$n_factors, 1)
expect_equal(SL_flex$settings$n_factors, 1)
expect_equal(SL_EFAtools$settings$N, 100)
expect_equal(SL_SPSS$settings$N, 100)
expect_equal(SL_psych$settings$N, 100)
expect_equal(SL_flex$settings$N, 100)
expect_equal(SL_EFAtools$settings$use, "pairwise.complete.obs")
expect_equal(SL_SPSS$settings$use, "pairwise.complete.obs")
expect_equal(SL_psych$settings$use, "pairwise.complete.obs")
expect_equal(SL_flex$settings$use, "pairwise.complete.obs")
expect_equal(SL_EFAtools$settings$cor_method, "pearson")
expect_equal(SL_SPSS$settings$cor_method, "pearson")
expect_equal(SL_psych$settings$cor_method, "pearson")
expect_equal(SL_flex$settings$cor_method, "pearson")
expect_equal(SL_EFAtools$settings$max_iter, 300)
expect_equal(SL_psych$settings$max_iter, 50)
expect_equal(SL_EFAtools$settings$init_comm, "smc")
expect_equal(SL_psych$settings$init_comm, "smc")
expect_equal(SL_EFAtools$settings$criterion, 0.001)
expect_equal(SL_psych$settings$criterion, 0.001)
expect_equal(SL_EFAtools$settings$criterion_type, "sum")
expect_equal(SL_psych$settings$criterion_type, "sum")
expect_equal(SL_EFAtools$settings$abs_eigen, TRUE)
expect_equal(SL_psych$settings$abs_eigen, FALSE)
expect_equal(SL_flex$settings$start_method, "psych")
})
EFA_mod_unrot <- EFA(test_models$baseline$cormat, N = 500, n_factors = 3,
type = "EFAtools", method = "PAF", rotation = "none")
EFA_mod_orth <- EFA(test_models$baseline$cormat, N = 500, n_factors = 3,
type = "EFAtools", method = "PAF", rotation = "varimax")
fa_mod_unrot <- psych::fa(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "none")
fa_mod_orth <- psych::fa(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "Varimax", n.rotations = 1)
if (requireNamespace("lavaan", quietly = TRUE)) {
lav_mod_NA <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6 + V17
F2 =~ V7 + V8 + V9 + V10 + V11 + V12 + V2
F3 =~ V13 + V14 + V15 + V16 + V17 + V18 + V10
g =~ V1 + V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9 + V10 + V11 + V12 +
V13 + V14 + V15 + V16 + V17 + V18'
lav_fit_NA <- suppressWarnings(lavaan::cfa(lav_mod_NA,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
lav_mod_ho_inv <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6
F2 =~ V7 + V8 + V9 + V10 + V11 + V12
g =~ F1 + F2 + V13 + V14 + V15 + V16 + V17 + V18'
lav_fit_ho_inv <- suppressWarnings(lavaan::cfa(lav_mod_ho_inv,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
# Improper second-order solution: a first-order factor residual variance turns
# negative while all loadings stay below 1 (a variance Heywood case).
lav_mod_var_hey <- 'F1 =~ V1 + V2
F2 =~ V3 + V4
F3 =~ V5 + V6
g =~ F1 + F2 + F3'
lav_fit_var_hey <- suppressWarnings(lavaan::cfa(lav_mod_var_hey,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
# Bifactor solution (general factor loads on the items, not the first-order
# factors): SL needs a second-order model, so this must abort cleanly.
lav_mod_bifactor <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6
F2 =~ V7 + V8 + V9 + V10 + V11 + V12
F3 =~ V13 + V14 + V15 + V16 + V17 + V18
g =~ V1 + V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9 + V10 + V11 +
V12 + V13 + V14 + V15 + V16 + V17 + V18'
lav_fit_bifactor <- suppressWarnings(lavaan::cfa(lav_mod_bifactor,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml",
orthogonal = TRUE))
}
test_that("errors are thrown correctly", {
skip_if_not_installed("lavaan")
expect_error(efa_schmid_leiman(1:5), class = "efa_sl_bad_input")
expect_warning(efa_schmid_leiman(EFA_mod, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF", Phi = EFA_mod$Phi),
class = "efa_sl_phi_specified")
expect_error(efa_schmid_leiman(EFA_mod_unrot, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_error(efa_schmid_leiman(EFA_mod_orth, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_warning(efa_schmid_leiman(fa_mod, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF", Phi = fa_mod$Phi), class = "efa_sl_phi_specified")
expect_error(efa_schmid_leiman(fa_mod_unrot, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_error(efa_schmid_leiman(fa_mod_orth, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_error(efa_schmid_leiman(lav_fit_NA, g_name = "g"), class = "efa_sl_na_loadings")
expect_error(efa_schmid_leiman(lav_fit_var_hey, g_name = "g"), class = "efa_sl_heywood")
expect_error(efa_schmid_leiman(lav_fit_ho, g_name = "fu"), class = "efa_sl_g_name")
expect_warning(efa_schmid_leiman(lav_fit_ho_inv, g_name = "g"), class = "efa_sl_second_order_loadings")
expect_error(efa_schmid_leiman(EFA_mod$rot_loadings, estimate_control = estimate_control(type = "EFAtools"), estimator = "ML"), class = "efa_sl_phi_missing")
expect_error(efa_schmid_leiman(lav_fit_bifactor, g_name = "g"), class = "efa_sl_not_second_order")
})
test_that("the second-order fit's substantive warnings reach the user", {
# A factor space with an analytic Heywood case: for one factor on three variables
# lambda1^2 = r12 * r13 / r23, so these intercorrelations imply a communality of 1.44.
# PAF and ULS abort on it; ML clamps the communality at the boundary and warns, and
# that warning must not be swallowed -- the residualized loadings it leads to are
# essentially zero and everything computed from them rests on it.
Phi_hey <- matrix(c(1, .9, .8, .9, 1, .5, .8, .5, 1), 3, 3)
L1 <- matrix(0, 9, 3)
L1[1:3, 1] <- L1[4:6, 2] <- L1[7:9, 3] <- .7
colnames(L1) <- c("F1", "F2", "F3")
expect_warning(efa_schmid_leiman(L1, Phi = Phi_hey, estimator = "ML"),
class = "efa_heywood")
# PAF aborts on the same input, after the fit has named the improper first-order
# factor -- the abort says that there is a Heywood case, the warning says where.
expect_warning(
expect_error(efa_schmid_leiman(L1, Phi = Phi_hey, estimator = "PAF"),
class = "efa_sl_heywood"),
class = "efa_heywood")
# The identification warnings of the internal fit are structural -- one factor on a
# k by k matrix of factor intercorrelations is just identified at k = 3 for every
# input -- so a sound three-factor solution stays silent.
expect_no_warning(efa_schmid_leiman(EFA_mod, estimator = "PAF"))
expect_no_warning(efa_schmid_leiman(EFA_mod, estimator = "ML"))
})
test_that("too few first-order factors are reported on the user's solution", {
# One first-order factor leaves nothing to orthogonalize. The diagnostic must name the
# supplied solution rather than the internal one-factor fit on the 1 x 1 matrix of
# factor intercorrelations, which would otherwise abort about a single "variable".
expect_error(
efa_schmid_leiman(matrix(c(.7, .6, .5, .4), 4, 1), Phi = matrix(1, 1, 1),
estimator = "PAF"),
class = "efa_sl_too_few_factors")
# Two first-order factors do not identify the second-order fit either, which is a
# warning and is raised before that fit runs.
L2 <- matrix(0, 4, 2)
L2[1:2, 1] <- 0.7
L2[3:4, 2] <- 0.7
colnames(L2) <- c("F1", "F2")
expect_warning(
efa_schmid_leiman(L2, Phi = matrix(c(1, .5, .5, 1), 2), estimator = "PAF"),
class = "efa_sl_underidentified")
})
test_that("efa_fit()'s inference arguments are refused", {
# They are efa_fit() formals, so they used to ride through the dots into the second-order
# fit -- which runs against a placeholder N and reports none of them, so a standard error
# was computed from a sample size that is not the data's and then thrown away, and `seed`
# governed a fit that draws no random numbers. Only `settings` ever recorded them.
args <- list(EFA_mod, estimate_control = estimate_control(type = "EFAtools"),
estimator = "ML")
expect_error(do.call(efa_schmid_leiman, c(args, list(se = "information"))),
class = "efa_unused_dots")
expect_error(do.call(efa_schmid_leiman, c(args, list(seed = 42))),
class = "efa_unused_dots")
expect_error(do.call(efa_schmid_leiman, c(args, list(b_boot = 10, ci = .90))),
class = "efa_unused_dots")
# the frozen wrapper forwards its dots into the same fit, so the refusal reaches it too
expect_error(SL(EFA_mod, type = "EFAtools", method = "ML", se = "information"),
class = "efa_unused_dots")
# An abbreviation must be refused as well: the dots are spliced into the second-order fit
# with do.call(), where R partial-matches them against efa_fit()'s formals, so `b_b` would
# arrive there as `b_boot` without ever matching the refused name exactly. Only the
# whitelist, which spells every accepted name in full, closes that route.
expect_error(do.call(efa_schmid_leiman, c(args, list(b_b = 10))),
class = "efa_unused_dots")
expect_error(do.call(efa_schmid_leiman, c(args, list(see = 42))),
class = "efa_unused_dots")
expect_error(SL(EFA_mod, type = "EFAtools", method = "ML", b_b = 10),
class = "efa_unused_dots")
# a genuine efa_fit() argument still travels through the dots untouched -- `use` is an
# efa_fit() formal and not one of efa_schmid_leiman()'s, so it really does go through `...`
expect_no_error(suppressWarnings(suppressMessages(
do.call(efa_schmid_leiman, c(args, list(use = "complete.obs"))))))
})
test_that("a second-order Heywood case raises a classed error", {
# A pattern matrix with a highly (and unevenly) intercorrelated factor space
# makes the single second-order factor improper: a second-order communality
# exceeds 1, so the residualized first-order loadings would be undefined.
L1 <- matrix(0, 6, 3)
L1[1:2, 1] <- 0.7
L1[3:4, 2] <- 0.7
L1[5:6, 3] <- 0.7
colnames(L1) <- c("F1", "F2", "F3")
Phi_heywood <- matrix(c(1, 0.8, 0.95,
0.8, 1, 0.7,
0.95, 0.7, 1), nrow = 3)
# The second-order fit names the improper first-order factor before the abort.
expect_warning(
expect_error(efa_schmid_leiman(L1, Phi = Phi_heywood, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"),
class = "efa_sl_heywood"),
class = "efa_heywood")
})
test_that("oblique solutions with unlabelled factor columns keep all factors", {
# A loading matrix whose columns carry no labels leaves the first-order factors to be
# taken in the order they come in. Reordering them by a factor number parsed from
# absent labels used to subset the loadings and Phi down to zero columns, which made
# the second-order EFA see no variables. efa_fit() labels every rotation's columns, so
# strip the labels to reach the path an externally built or bare-matrix input takes.
cormat <- test_models$baseline$cormat
cormat_list <- list(cormat, cormat, cormat)
for (k in c(3L, 4L)) {
fitted <- suppressMessages(efa_fit(cormat, N = 500, n_factors = k,
estimator = "PAF", rotation = "oblimin"))
pooled <- suppressMessages(efa_mi(cormat_list, N = 500, n_factors = k,
estimator = "PAF", rotation = "oblimin"))
# the fixtures only test what they are meant to if the columns are unlabelled
colnames(fitted$rot_loadings) <- NULL
colnames(pooled$rot_loadings) <- NULL
dimnames(fitted$Phi) <- NULL
dimnames(pooled$Phi) <- NULL
for (obj in list(fitted, pooled)) {
sl <- efa_schmid_leiman(obj, estimator = "PAF")
expect_s3_class(sl, "efa_schmid_leiman")
expect_identical(colnames(sl$sl),
c("g", paste0("F", seq_len(k)), "h2", "u2"))
expect_identical(nrow(sl$sl), ncol(cormat))
expect_false(anyNA(sl$sl))
# the second-order EFA saw all k first-order factors: this is what the
# zero-column subset destroyed, so it is the assertion that pins the bug
expect_identical(dim(sl$L2), c(k, 1L))
# loadings are real rather than the all-zero block a collapsed L1 produces
expect_true(all(abs(sl$sl[, "g"]) > 0))
expect_true(all(sl$sl[, "h2"] > 0 & sl$sl[, "h2"] < 1))
}
}
})
test_that("labelled factor columns are still ordered by factor number", {
# The fallback for unlabelled columns must not disable the reordering when the
# labels are present but out of order.
L1 <- EFA_mod$rot_loadings[, c(2, 3, 1)]
Phi_1 <- EFA_mod$Phi[c(2, 3, 1), c(2, 3, 1)]
colnames(L1) <- c("F2", "F3", "F1")
sl_scrambled <- efa_schmid_leiman(L1, Phi = Phi_1, estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools"))
expect_equal(sl_scrambled$sl, SL_EFAtools$sl)
})
test_that("a named Phi is aligned to the loading factors before reordering", {
L1 <- unclass(EFA_mod$rot_loadings)
Phi <- EFA_mod$Phi
base <- efa_schmid_leiman(
L1, Phi = Phi, estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools")
)
perm <- c(3L, 1L, 2L)
aligned <- efa_schmid_leiman(
L1, Phi = Phi[perm, perm], estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools")
)
expect_equal(aligned$sl, base$sl)
expect_equal(aligned$L2, base$L2)
})
test_that("efa_schmid_leiman runs on an oblique fit whose column labels are permuted", {
skip_if_not_installed("GPArotation")
# The first-order columns are reordered by the number in their labels, which the
# oblimin rotation returns permuted (F2, F1, F3). An unguarded reorder empties Phi,
# and the second-order fit then aborts on a model with no variables.
EFA_obl <- efa_fit(test_models$baseline$cormat, N = 500, n_factors = 3,
estimator = "PAF", rotation = "oblimin")
SL_obl <- efa_schmid_leiman(EFA_obl, estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools"))
expect_s3_class(SL_obl, "efa_schmid_leiman")
expect_identical(class(SL_obl$sl), c("efa_sl_loadings", "SLLOADINGS"))
expect_identical(dim(unclass(SL_obl$sl)), dim(unclass(SL_EFAtools$sl)))
expect_true(all(is.finite(SL_obl$L2)))
expect_length(SL_obl$L2, 3)
})
test_that("print output is stable", {
local_reproducible_output()
expect_snapshot(print(SL_EFAtools), transform = scrub_num)
})
test_that("the second-order header follows the console width", {
# Emitted verbatim so the "estimator = 'value'" token is never split, and packed to the
# console around it -- the same treatment the efa_fit() header gets.
header <- function(w) {
out <- withr::with_options(list(cli.width = w, cli.num_colors = 1), format(SL_EFAtools))
wrapped_item(out, "^EFA for second-order")
}
for (w in c(120L, 80L, 60L)) {
lines <- header(w)
expect_true(all(cli::ansi_nchar(lines, type = "width") <= w))
expect_identical(paste(trimws(lines), collapse = " "),
"EFA for second-order loadings performed with estimator = 'PAF'")
}
expect_length(header(60L), 2L)
})
rm(EFA_mod, SL_EFAtools, SL_SPSS, fa_mod, SL_psych, SL_flex, EFA_mod_unrot,
EFA_mod_orth, fa_mod_unrot, fa_mod_orth)
if (requireNamespace("lavaan", quietly = TRUE)) {
rm(lav_mod_ho, lav_fit_ho, SL_lav, lav_mod_NA, lav_fit_NA, lav_mod_ho_inv,
lav_fit_ho_inv, lav_mod_var_hey, lav_fit_var_hey, lav_mod_bifactor,
lav_fit_bifactor)
}
test_that("the input error names the averaged matrix an efa_average object carries", {
# An efa_average object is rejected while "a matrix" is listed as acceptable, and its
# averaged loadings are exactly that. The message now says where they are, together with
# the averaged factor correlations, which this transformation always needs.
avg <- suppressWarnings(suppressMessages(
efa_average(test_models$baseline$cormat, n_factors = 3, N = 500,
estimator = c("PAF", "ULS"), rotation = "promax", type = "EFAtools",
start_method = "psych", show_progress = FALSE)))
e <- tryCatch(efa_schmid_leiman(avg), efa_sl_bad_input = function(e) e)
expect_s3_class(e, "efa_sl_bad_input")
expect_snapshot(cat(conditionMessage(e)))
# The components the message names are accepted.
expect_s3_class(
suppressWarnings(suppressMessages(
efa_schmid_leiman(avg$loadings$average, Phi = avg$Phi$average))),
"efa_schmid_leiman")
})
Try the EFAtools package in your browser
Any scripts or data that you put into this service are public.
EFAtools documentation built on Aug. 21, 2026, 5:16 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
## Use with an output from the EFAtools::EFA function, both with type EFAtools
EFA_mod <- EFA(test_models$baseline$cormat, N = 500, n_factors = 3,
type = "EFAtools", method = "PAF", rotation = "promax")
SL_EFAtools <- efa_schmid_leiman(EFA_mod, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF")
# with type SPSS and method ULS. The second-order fit notes that only PAF is validated
# against SPSS; that note is asserted where it belongs (test-superseded.R) and is muffled
# here so the fixture does not raise a warning outside any test.
SL_SPSS <- suppressWarnings(
efa_schmid_leiman(EFA_mod, estimate_control = estimate_control(type = "SPSS"),
estimator = "ULS"))
## Use with an output from the psych::fa function with type psych
fa_mod <- psych::fa(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "Promax", n.rotations = 1)
SL_psych <- efa_schmid_leiman(fa_mod, estimate_control = estimate_control(type = "psych"), estimator = "PAF")
## Use more flexibly by entering a pattern matrix and phi directly, with method
## ML
SL_flex <- efa_schmid_leiman(EFA_mod$rot_loadings, Phi = EFA_mod$Phi, estimator = "ML",
estimate_control = estimate_control(type = "EFAtools"))
## Use with a second-order lavaan solution
if (requireNamespace("lavaan", quietly = TRUE)) {
lav_mod_ho <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6
F2 =~ V7 + V8 + V9 + V10 + V11 + V12
F3 =~ V13 + V14 + V15 + V16 + V17 + V18
g =~ F1 + F2 + F3'
lav_fit_ho <- suppressWarnings(lavaan::cfa(lav_mod_ho,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
SL_lav <- efa_schmid_leiman(lav_fit_ho, g_name = "g")
}
test_that("output class and dimensions are correct", {
skip_if_not_installed("lavaan")
expect_identical(class(SL_EFAtools), c("efa_schmid_leiman", "SL"))
expect_identical(class(SL_EFAtools$sl), c("efa_sl_loadings", "SLLOADINGS"))
expect_s3_class(SL_SPSS, "efa_schmid_leiman")
expect_s3_class(SL_psych, "efa_schmid_leiman")
expect_s3_class(SL_flex, "efa_schmid_leiman")
expect_s3_class(SL_lav, "efa_schmid_leiman")
expect_output(str(SL_EFAtools), "List of 7")
expect_output(str(SL_SPSS), "List of 7")
expect_output(str(SL_psych), "List of 7")
expect_output(str(SL_flex), "List of 7")
expect_output(str(SL_lav), "List of 7")
})
test_that("non-convergence of the second-order EFA is recorded and surfaced", {
testthat::local_reproducible_output()
# The convergence code of the second-order EFA is carried on the SL object.
expect_equal(SL_SPSS$convergence, 0)
# A non-zero code shows the banner: the optimiser estimators use the generic
# message, PAF the iteration-specific one. Set the code explicitly so the test
# does not depend on the second-order fit's actual convergence.
sl_uls <- SL_SPSS
sl_uls$convergence <- 1L
expect_true(any(grepl("The optimiser did not converge", format(sl_uls), fixed = TRUE)))
sl_paf <- SL_EFAtools
sl_paf$convergence <- 1L
expect_true(any(grepl("Maximum number of iterations reached without convergence",
format(sl_paf), fixed = TRUE)))
# A converged fit shows no banner.
expect_false(any(grepl("did not converge", format(SL_SPSS), fixed = TRUE)))
})
test_that("original correlation is correct", {
skip_if_not_installed("lavaan")
expect_equal(SL_EFAtools$orig_R, test_models$baseline$cormat)
expect_equal(SL_SPSS$orig_R, test_models$baseline$cormat)
expect_equal(SL_psych$orig_R, test_models$baseline$cormat)
expect_equal(SL_flex$orig_R, NA)
expect_equal(SL_lav$orig_R, NA)
})
test_that("sl solution is correct", {
skip_if_not_installed("lavaan")
expect_equal(unname(SL_EFAtools$sl[, "h2"]) + unname(SL_EFAtools$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_SPSS$sl[, "h2"]) + unname(SL_SPSS$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_psych$sl[, "h2"]) + unname(SL_psych$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_flex$sl[, "h2"]) + unname(SL_flex$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_lav$sl[, "h2"]) + unname(SL_lav$sl[, "u2"]),
rep(1, 18))
expect_equal(unname(SL_EFAtools$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_SPSS$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_psych$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_flex$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_lav$sl[, "g"]) >= .20, rep(TRUE, 18))
expect_equal(unname(SL_EFAtools$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_SPSS$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_psych$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_flex$sl[13:18, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_lav$sl[1:6, "F1"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_EFAtools$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_SPSS$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_psych$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_flex$sl[1:12, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_lav$sl[7:18, "F1"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_EFAtools$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_SPSS$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_psych$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_flex$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_lav$sl[7:12, "F2"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_EFAtools$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_SPSS$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_psych$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_flex$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_lav$sl[c(1:6, 13:18), "F2"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_EFAtools$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_SPSS$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_psych$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_flex$sl[1:6, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_lav$sl[13:18, "F3"]) >= .20, rep(TRUE, 6))
expect_equal(unname(SL_EFAtools$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_SPSS$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_psych$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_flex$sl[7:18, "F3"]) < .20, rep(TRUE, 12))
expect_equal(unname(SL_lav$sl[1:12, "F3"]) < .20, rep(TRUE, 12))
})
test_that("sl loadings reproduce psych::schmid", {
skip_on_cran()
skip_if_not_installed("psych")
# The Schmid-Leiman transformation of the same psych Promax solution must match
# psych::schmid()'s g and group loadings (its columns are g, F1*, F2*, F3*).
sch <- suppressMessages(suppressWarnings(
psych::schmid(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "Promax")))
expect_equal(unname(SL_psych$sl[, c("g", "F1", "F2", "F3")]),
unname(sch$sl[, c("g", "F1*", "F2*", "F3*")]),
tolerance = 1e-4)
})
test_that("settings are returned correctly", {
skip_if_not_installed("lavaan")
expect_named(SL_EFAtools$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed", "max_iter",
"init_comm", "criterion", "criterion_type",
"abs_eigen"))
expect_named(SL_SPSS$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed"))
expect_named(SL_psych$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed", "max_iter",
"init_comm", "criterion", "criterion_type",
"abs_eigen"))
expect_named(SL_flex$settings, c("estimator", "method", "rotation", "type", "n_factors",
"N", "use", "cor_method", "input_type",
"cor_method_used", "se", "b_boot", "ci", "seed", "start_method"))
expect_equal(SL_lav$settings, NA)
expect_equal(SL_EFAtools$settings$estimator, "PAF")
expect_equal(SL_SPSS$settings$estimator, "ULS")
expect_equal(SL_psych$settings$estimator, "PAF")
expect_equal(SL_flex$settings$estimator, "ML")
expect_equal(SL_EFAtools$settings$rotation, "none")
expect_equal(SL_SPSS$settings$rotation, "none")
expect_equal(SL_psych$settings$rotation, "none")
expect_equal(SL_flex$settings$rotation, "none")
expect_equal(SL_EFAtools$settings$type, "EFAtools")
expect_equal(SL_SPSS$settings$type, "SPSS")
expect_equal(SL_psych$settings$type, "psych")
expect_equal(SL_flex$settings$type, "EFAtools")
expect_equal(SL_EFAtools$settings$n_factors, 1)
expect_equal(SL_SPSS$settings$n_factors, 1)
expect_equal(SL_psych$settings$n_factors, 1)
expect_equal(SL_flex$settings$n_factors, 1)
expect_equal(SL_EFAtools$settings$N, 100)
expect_equal(SL_SPSS$settings$N, 100)
expect_equal(SL_psych$settings$N, 100)
expect_equal(SL_flex$settings$N, 100)
expect_equal(SL_EFAtools$settings$use, "pairwise.complete.obs")
expect_equal(SL_SPSS$settings$use, "pairwise.complete.obs")
expect_equal(SL_psych$settings$use, "pairwise.complete.obs")
expect_equal(SL_flex$settings$use, "pairwise.complete.obs")
expect_equal(SL_EFAtools$settings$cor_method, "pearson")
expect_equal(SL_SPSS$settings$cor_method, "pearson")
expect_equal(SL_psych$settings$cor_method, "pearson")
expect_equal(SL_flex$settings$cor_method, "pearson")
expect_equal(SL_EFAtools$settings$max_iter, 300)
expect_equal(SL_psych$settings$max_iter, 50)
expect_equal(SL_EFAtools$settings$init_comm, "smc")
expect_equal(SL_psych$settings$init_comm, "smc")
expect_equal(SL_EFAtools$settings$criterion, 0.001)
expect_equal(SL_psych$settings$criterion, 0.001)
expect_equal(SL_EFAtools$settings$criterion_type, "sum")
expect_equal(SL_psych$settings$criterion_type, "sum")
expect_equal(SL_EFAtools$settings$abs_eigen, TRUE)
expect_equal(SL_psych$settings$abs_eigen, FALSE)
expect_equal(SL_flex$settings$start_method, "psych")
})
EFA_mod_unrot <- EFA(test_models$baseline$cormat, N = 500, n_factors = 3,
type = "EFAtools", method = "PAF", rotation = "none")
EFA_mod_orth <- EFA(test_models$baseline$cormat, N = 500, n_factors = 3,
type = "EFAtools", method = "PAF", rotation = "varimax")
fa_mod_unrot <- psych::fa(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "none")
fa_mod_orth <- psych::fa(test_models$baseline$cormat, nfactors = 3, n.obs = 500,
fm = "pa", rotate = "Varimax", n.rotations = 1)
if (requireNamespace("lavaan", quietly = TRUE)) {
lav_mod_NA <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6 + V17
F2 =~ V7 + V8 + V9 + V10 + V11 + V12 + V2
F3 =~ V13 + V14 + V15 + V16 + V17 + V18 + V10
g =~ V1 + V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9 + V10 + V11 + V12 +
V13 + V14 + V15 + V16 + V17 + V18'
lav_fit_NA <- suppressWarnings(lavaan::cfa(lav_mod_NA,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
lav_mod_ho_inv <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6
F2 =~ V7 + V8 + V9 + V10 + V11 + V12
g =~ F1 + F2 + V13 + V14 + V15 + V16 + V17 + V18'
lav_fit_ho_inv <- suppressWarnings(lavaan::cfa(lav_mod_ho_inv,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
# Improper second-order solution: a first-order factor residual variance turns
# negative while all loadings stay below 1 (a variance Heywood case).
lav_mod_var_hey <- 'F1 =~ V1 + V2
F2 =~ V3 + V4
F3 =~ V5 + V6
g =~ F1 + F2 + F3'
lav_fit_var_hey <- suppressWarnings(lavaan::cfa(lav_mod_var_hey,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml"))
# Bifactor solution (general factor loads on the items, not the first-order
# factors): SL needs a second-order model, so this must abort cleanly.
lav_mod_bifactor <- 'F1 =~ V1 + V2 + V3 + V4 + V5 + V6
F2 =~ V7 + V8 + V9 + V10 + V11 + V12
F3 =~ V13 + V14 + V15 + V16 + V17 + V18
g =~ V1 + V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9 + V10 + V11 +
V12 + V13 + V14 + V15 + V16 + V17 + V18'
lav_fit_bifactor <- suppressWarnings(lavaan::cfa(lav_mod_bifactor,
sample.cov = test_models$baseline$cormat,
sample.nobs = 500, estimator = "ml",
orthogonal = TRUE))
}
test_that("errors are thrown correctly", {
skip_if_not_installed("lavaan")
expect_error(efa_schmid_leiman(1:5), class = "efa_sl_bad_input")
expect_warning(efa_schmid_leiman(EFA_mod, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF", Phi = EFA_mod$Phi),
class = "efa_sl_phi_specified")
expect_error(efa_schmid_leiman(EFA_mod_unrot, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_error(efa_schmid_leiman(EFA_mod_orth, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_warning(efa_schmid_leiman(fa_mod, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF", Phi = fa_mod$Phi), class = "efa_sl_phi_specified")
expect_error(efa_schmid_leiman(fa_mod_unrot, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_error(efa_schmid_leiman(fa_mod_orth, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"), class = "efa_sl_not_oblique")
expect_error(efa_schmid_leiman(lav_fit_NA, g_name = "g"), class = "efa_sl_na_loadings")
expect_error(efa_schmid_leiman(lav_fit_var_hey, g_name = "g"), class = "efa_sl_heywood")
expect_error(efa_schmid_leiman(lav_fit_ho, g_name = "fu"), class = "efa_sl_g_name")
expect_warning(efa_schmid_leiman(lav_fit_ho_inv, g_name = "g"), class = "efa_sl_second_order_loadings")
expect_error(efa_schmid_leiman(EFA_mod$rot_loadings, estimate_control = estimate_control(type = "EFAtools"), estimator = "ML"), class = "efa_sl_phi_missing")
expect_error(efa_schmid_leiman(lav_fit_bifactor, g_name = "g"), class = "efa_sl_not_second_order")
})
test_that("the second-order fit's substantive warnings reach the user", {
# A factor space with an analytic Heywood case: for one factor on three variables
# lambda1^2 = r12 * r13 / r23, so these intercorrelations imply a communality of 1.44.
# PAF and ULS abort on it; ML clamps the communality at the boundary and warns, and
# that warning must not be swallowed -- the residualized loadings it leads to are
# essentially zero and everything computed from them rests on it.
Phi_hey <- matrix(c(1, .9, .8, .9, 1, .5, .8, .5, 1), 3, 3)
L1 <- matrix(0, 9, 3)
L1[1:3, 1] <- L1[4:6, 2] <- L1[7:9, 3] <- .7
colnames(L1) <- c("F1", "F2", "F3")
expect_warning(efa_schmid_leiman(L1, Phi = Phi_hey, estimator = "ML"),
class = "efa_heywood")
# PAF aborts on the same input, after the fit has named the improper first-order
# factor -- the abort says that there is a Heywood case, the warning says where.
expect_warning(
expect_error(efa_schmid_leiman(L1, Phi = Phi_hey, estimator = "PAF"),
class = "efa_sl_heywood"),
class = "efa_heywood")
# The identification warnings of the internal fit are structural -- one factor on a
# k by k matrix of factor intercorrelations is just identified at k = 3 for every
# input -- so a sound three-factor solution stays silent.
expect_no_warning(efa_schmid_leiman(EFA_mod, estimator = "PAF"))
expect_no_warning(efa_schmid_leiman(EFA_mod, estimator = "ML"))
})
test_that("too few first-order factors are reported on the user's solution", {
# One first-order factor leaves nothing to orthogonalize. The diagnostic must name the
# supplied solution rather than the internal one-factor fit on the 1 x 1 matrix of
# factor intercorrelations, which would otherwise abort about a single "variable".
expect_error(
efa_schmid_leiman(matrix(c(.7, .6, .5, .4), 4, 1), Phi = matrix(1, 1, 1),
estimator = "PAF"),
class = "efa_sl_too_few_factors")
# Two first-order factors do not identify the second-order fit either, which is a
# warning and is raised before that fit runs.
L2 <- matrix(0, 4, 2)
L2[1:2, 1] <- 0.7
L2[3:4, 2] <- 0.7
colnames(L2) <- c("F1", "F2")
expect_warning(
efa_schmid_leiman(L2, Phi = matrix(c(1, .5, .5, 1), 2), estimator = "PAF"),
class = "efa_sl_underidentified")
})
test_that("efa_fit()'s inference arguments are refused", {
# They are efa_fit() formals, so they used to ride through the dots into the second-order
# fit -- which runs against a placeholder N and reports none of them, so a standard error
# was computed from a sample size that is not the data's and then thrown away, and `seed`
# governed a fit that draws no random numbers. Only `settings` ever recorded them.
args <- list(EFA_mod, estimate_control = estimate_control(type = "EFAtools"),
estimator = "ML")
expect_error(do.call(efa_schmid_leiman, c(args, list(se = "information"))),
class = "efa_unused_dots")
expect_error(do.call(efa_schmid_leiman, c(args, list(seed = 42))),
class = "efa_unused_dots")
expect_error(do.call(efa_schmid_leiman, c(args, list(b_boot = 10, ci = .90))),
class = "efa_unused_dots")
# the frozen wrapper forwards its dots into the same fit, so the refusal reaches it too
expect_error(SL(EFA_mod, type = "EFAtools", method = "ML", se = "information"),
class = "efa_unused_dots")
# An abbreviation must be refused as well: the dots are spliced into the second-order fit
# with do.call(), where R partial-matches them against efa_fit()'s formals, so `b_b` would
# arrive there as `b_boot` without ever matching the refused name exactly. Only the
# whitelist, which spells every accepted name in full, closes that route.
expect_error(do.call(efa_schmid_leiman, c(args, list(b_b = 10))),
class = "efa_unused_dots")
expect_error(do.call(efa_schmid_leiman, c(args, list(see = 42))),
class = "efa_unused_dots")
expect_error(SL(EFA_mod, type = "EFAtools", method = "ML", b_b = 10),
class = "efa_unused_dots")
# a genuine efa_fit() argument still travels through the dots untouched -- `use` is an
# efa_fit() formal and not one of efa_schmid_leiman()'s, so it really does go through `...`
expect_no_error(suppressWarnings(suppressMessages(
do.call(efa_schmid_leiman, c(args, list(use = "complete.obs"))))))
})
test_that("a second-order Heywood case raises a classed error", {
# A pattern matrix with a highly (and unevenly) intercorrelated factor space
# makes the single second-order factor improper: a second-order communality
# exceeds 1, so the residualized first-order loadings would be undefined.
L1 <- matrix(0, 6, 3)
L1[1:2, 1] <- 0.7
L1[3:4, 2] <- 0.7
L1[5:6, 3] <- 0.7
colnames(L1) <- c("F1", "F2", "F3")
Phi_heywood <- matrix(c(1, 0.8, 0.95,
0.8, 1, 0.7,
0.95, 0.7, 1), nrow = 3)
# The second-order fit names the improper first-order factor before the abort.
expect_warning(
expect_error(efa_schmid_leiman(L1, Phi = Phi_heywood, estimate_control = estimate_control(type = "EFAtools"), estimator = "PAF"),
class = "efa_sl_heywood"),
class = "efa_heywood")
})
test_that("oblique solutions with unlabelled factor columns keep all factors", {
# A loading matrix whose columns carry no labels leaves the first-order factors to be
# taken in the order they come in. Reordering them by a factor number parsed from
# absent labels used to subset the loadings and Phi down to zero columns, which made
# the second-order EFA see no variables. efa_fit() labels every rotation's columns, so
# strip the labels to reach the path an externally built or bare-matrix input takes.
cormat <- test_models$baseline$cormat
cormat_list <- list(cormat, cormat, cormat)
for (k in c(3L, 4L)) {
fitted <- suppressMessages(efa_fit(cormat, N = 500, n_factors = k,
estimator = "PAF", rotation = "oblimin"))
pooled <- suppressMessages(efa_mi(cormat_list, N = 500, n_factors = k,
estimator = "PAF", rotation = "oblimin"))
# the fixtures only test what they are meant to if the columns are unlabelled
colnames(fitted$rot_loadings) <- NULL
colnames(pooled$rot_loadings) <- NULL
dimnames(fitted$Phi) <- NULL
dimnames(pooled$Phi) <- NULL
for (obj in list(fitted, pooled)) {
sl <- efa_schmid_leiman(obj, estimator = "PAF")
expect_s3_class(sl, "efa_schmid_leiman")
expect_identical(colnames(sl$sl),
c("g", paste0("F", seq_len(k)), "h2", "u2"))
expect_identical(nrow(sl$sl), ncol(cormat))
expect_false(anyNA(sl$sl))
# the second-order EFA saw all k first-order factors: this is what the
# zero-column subset destroyed, so it is the assertion that pins the bug
expect_identical(dim(sl$L2), c(k, 1L))
# loadings are real rather than the all-zero block a collapsed L1 produces
expect_true(all(abs(sl$sl[, "g"]) > 0))
expect_true(all(sl$sl[, "h2"] > 0 & sl$sl[, "h2"] < 1))
}
}
})
test_that("labelled factor columns are still ordered by factor number", {
# The fallback for unlabelled columns must not disable the reordering when the
# labels are present but out of order.
L1 <- EFA_mod$rot_loadings[, c(2, 3, 1)]
Phi_1 <- EFA_mod$Phi[c(2, 3, 1), c(2, 3, 1)]
colnames(L1) <- c("F2", "F3", "F1")
sl_scrambled <- efa_schmid_leiman(L1, Phi = Phi_1, estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools"))
expect_equal(sl_scrambled$sl, SL_EFAtools$sl)
})
test_that("a named Phi is aligned to the loading factors before reordering", {
L1 <- unclass(EFA_mod$rot_loadings)
Phi <- EFA_mod$Phi
base <- efa_schmid_leiman(
L1, Phi = Phi, estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools")
)
perm <- c(3L, 1L, 2L)
aligned <- efa_schmid_leiman(
L1, Phi = Phi[perm, perm], estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools")
)
expect_equal(aligned$sl, base$sl)
expect_equal(aligned$L2, base$L2)
})
test_that("efa_schmid_leiman runs on an oblique fit whose column labels are permuted", {
skip_if_not_installed("GPArotation")
# The first-order columns are reordered by the number in their labels, which the
# oblimin rotation returns permuted (F2, F1, F3). An unguarded reorder empties Phi,
# and the second-order fit then aborts on a model with no variables.
EFA_obl <- efa_fit(test_models$baseline$cormat, N = 500, n_factors = 3,
estimator = "PAF", rotation = "oblimin")
SL_obl <- efa_schmid_leiman(EFA_obl, estimator = "PAF",
estimate_control = estimate_control(type = "EFAtools"))
expect_s3_class(SL_obl, "efa_schmid_leiman")
expect_identical(class(SL_obl$sl), c("efa_sl_loadings", "SLLOADINGS"))
expect_identical(dim(unclass(SL_obl$sl)), dim(unclass(SL_EFAtools$sl)))
expect_true(all(is.finite(SL_obl$L2)))
expect_length(SL_obl$L2, 3)
})
test_that("print output is stable", {
local_reproducible_output()
expect_snapshot(print(SL_EFAtools), transform = scrub_num)
})
test_that("the second-order header follows the console width", {
# Emitted verbatim so the "estimator = 'value'" token is never split, and packed to the
# console around it -- the same treatment the efa_fit() header gets.
header <- function(w) {
out <- withr::with_options(list(cli.width = w, cli.num_colors = 1), format(SL_EFAtools))
wrapped_item(out, "^EFA for second-order")
}
for (w in c(120L, 80L, 60L)) {
lines <- header(w)
expect_true(all(cli::ansi_nchar(lines, type = "width") <= w))
expect_identical(paste(trimws(lines), collapse = " "),
"EFA for second-order loadings performed with estimator = 'PAF'")
}
expect_length(header(60L), 2L)
})
rm(EFA_mod, SL_EFAtools, SL_SPSS, fa_mod, SL_psych, SL_flex, EFA_mod_unrot,
EFA_mod_orth, fa_mod_unrot, fa_mod_orth)
if (requireNamespace("lavaan", quietly = TRUE)) {
rm(lav_mod_ho, lav_fit_ho, SL_lav, lav_mod_NA, lav_fit_NA, lav_mod_ho_inv,
lav_fit_ho_inv, lav_mod_var_hey, lav_fit_var_hey, lav_mod_bifactor,
lav_fit_bifactor)
}
test_that("the input error names the averaged matrix an efa_average object carries", {
# An efa_average object is rejected while "a matrix" is listed as acceptable, and its
# averaged loadings are exactly that. The message now says where they are, together with
# the averaged factor correlations, which this transformation always needs.
avg <- suppressWarnings(suppressMessages(
efa_average(test_models$baseline$cormat, n_factors = 3, N = 500,
estimator = c("PAF", "ULS"), rotation = "promax", type = "EFAtools",
start_method = "psych", show_progress = FALSE)))
e <- tryCatch(efa_schmid_leiman(avg), efa_sl_bad_input = function(e) e)
expect_s3_class(e, "efa_sl_bad_input")
expect_snapshot(cat(conditionMessage(e)))
# The components the message names are accepted.
expect_s3_class(
suppressWarnings(suppressMessages(
efa_schmid_leiman(avg$loadings$average, Phi = avg$Phi$average))),
"efa_schmid_leiman")
})
Try the EFAtools package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.