Merge pull request #1561 from exploratory-io/fix/cronbach-alpha-factor-polychoric

fix: harden polychoric for Cronbach Alpha and Factor Analysis

Author: hidekoji

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: exploratory
 Type: Package
 Title: R package for Exploratory
-Version: 16.0.11
-Date: 2026-07-21
+Version: 16.0.12
+Date: 2026-07-23
 Authors@R: c(person("Hideaki", "Hayashi", email = "hideaki@exploratory.io", role = c("aut", "cre")), person("Hide", "Kojima", email = "hide@exploratory.io", role = c("aut")), person("Kan", "Nishida", email = "kan@exploratory.io", role = c("aut")), person("Kei", "Saito", email = "kei@exploratory.io", role = c("aut")), person("Yosuke", "Yasuda", email = "double.y.919.quick@gmail.com", role = c("aut")))
 URL: https://github.com/exploratory-io/exploratory_func
 Description: Functions for Exploratory

R/factanal_correlation.R

@@ -432,23 +432,44 @@ build_factor_correlation <- function(data, correlation_type = c("pearson", "poly
                 type = "pearson", smoothed = FALSE, warnings = character(), failed = FALSE))
   }
 
+  # psych::polychoric / tetrachoric / mixedCor can fail on sparse contingency tables when the
+  # continuity correction (default correct=0.5) produces empty pairwise results. psych itself
+  # suggests retrying with correct=0; without that retry we used to degrade straight to Pearson
+  # even though the polychoric-family estimate was recoverable (same root cause as the
+  # Cronbach's Alpha fix).
   captured <- character()
-  result <- withCallingHandlers(
-    tryCatch({
-      switch(correlation_type,
-        polychoric = psych::polychoric(data, correct = correct),
-        tetrachoric = psych::tetrachoric(data, correct = correct),
-        mixed = psych::mixedCor(data))
-    }, error = function(e) {
-      captured <<- c(captured, conditionMessage(e))
-      NULL
-    }),
-    warning = function(w) {
-      captured <<- c(captured, conditionMessage(w))
-      invokeRestart("muffleWarning")
-    })
-
-  if (is.null(result) || is.null(result$rho) || anyNA(result$rho)) {
+  run_psych_correlation <- function(corr) {
+    withCallingHandlers(
+      tryCatch({
+        switch(correlation_type,
+          polychoric = psych::polychoric(data, correct = corr),
+          tetrachoric = psych::tetrachoric(data, correct = corr),
+          mixed = psych::mixedCor(data, correct = corr))
+      }, error = function(e) {
+        captured <<- c(captured, conditionMessage(e))
+        NULL
+      }),
+      warning = function(w) {
+        captured <<- c(captured, conditionMessage(w))
+        invokeRestart("muffleWarning")
+      })
+  }
+  correlation_ok <- function(obj) {
+    !is.null(obj) && !is.null(obj$rho) && !anyNA(obj$rho)
+  }
+
+  result <- run_psych_correlation(correct)
+  if (!correlation_ok(result) && correct != 0) {
+    result <- run_psych_correlation(0)
+    if (correlation_ok(result)) {
+      captured <- c(
+        captured,
+        sprintf("%s used continuity correction of 0 because the default correction failed.",
+                factanal_correlation_label(correlation_type)))
+    }
+  }
+
+  if (!correlation_ok(result)) {
     # Degrade to Pearson rather than aborting the whole analysis. A partially-NA matrix counts as a
     # failure too: psych::fa() refuses to run on one ("missing values (NAs) in the correlation
     # matrix do not allow me to continue"), so keeping it would abort with a raw psych error.

R/reliability.R

@@ -165,6 +165,75 @@ reliability_prepare_correlation_data <- function(data, item_types) {
 # Correlation matrix builder
 # ------------------------------------------------------------
 
+# psych::polychoric / mixedCor can fail on sparse contingency tables when the
+# continuity correction (default correct=0.5) produces empty pairwise results.
+# psych itself suggests retrying with correct=0; without that retry the failure
+# surfaces as cryptic errors like "attempt to set 'rownames' on an object with
+# no dimensions" or "supply both 'x' and 'y' or a matrix-like 'x'".
+reliability_valid_rho <- function(rho, expected_n = NULL) {
+  rho <- tryCatch(as.matrix(rho), error = function(e) NULL)
+  if (is.null(rho) || is.null(dim(rho)) || any(dim(rho) == 0)) {
+    return(FALSE)
+  }
+  if (!is.null(expected_n) && (nrow(rho) != expected_n || ncol(rho) != expected_n)) {
+    return(FALSE)
+  }
+  TRUE
+}
+
+reliability_estimate_polychoric_rho <- function(prepared_data, correct = 0.5) {
+  expected_n <- ncol(prepared_data)
+  run <- function(corr) {
+    obj <- suppressWarnings(psych::polychoric(prepared_data, correct = corr,
+                                              smooth = FALSE, global = FALSE))
+    obj$rho
+  }
+  warnings_list <- character()
+  rho <- tryCatch(run(correct), error = function(e) NULL)
+  if (!reliability_valid_rho(rho, expected_n) && correct != 0) {
+    rho <- tryCatch(run(0), error = function(e) NULL)
+    if (reliability_valid_rho(rho, expected_n)) {
+      warnings_list <- c(
+        warnings_list,
+        "Polychoric correlation used continuity correction of 0 because the default correction failed.")
+    }
+  }
+  if (!reliability_valid_rho(rho, expected_n)) {
+    stop("Failed to estimate polychoric correlations. Check that items are ordinal ",
+         "with enough responses across categories.")
+  }
+  list(rho = rho, warnings = warnings_list)
+}
+
+reliability_estimate_mixed_rho <- function(prepared_data, item_types, correct = 0.5) {
+  expected_n <- ncol(prepared_data)
+  continuous_index <- match(names(item_types)[item_types == "continuous"], names(prepared_data))
+  polytomous_index <- match(names(item_types)[item_types == "ordinal"], names(prepared_data))
+  dichotomous_index <- match(names(item_types)[item_types == "dichotomous"], names(prepared_data))
+  run <- function(corr) {
+    obj <- suppressWarnings(psych::mixedCor(
+      prepared_data,
+      c = continuous_index, p = polytomous_index, d = dichotomous_index,
+      correct = corr, global = FALSE))
+    obj$rho
+  }
+  warnings_list <- character()
+  rho <- tryCatch(run(correct), error = function(e) NULL)
+  if (!reliability_valid_rho(rho, expected_n) && correct != 0) {
+    rho <- tryCatch(run(0), error = function(e) NULL)
+    if (reliability_valid_rho(rho, expected_n)) {
+      warnings_list <- c(
+        warnings_list,
+        "Mixed correlation used continuity correction of 0 because the default correction failed.")
+    }
+  }
+  if (!reliability_valid_rho(rho, expected_n)) {
+    stop("Failed to estimate mixed correlations. Check that items have enough ",
+         "responses across categories.")
+  }
+  list(rho = rho, warnings = warnings_list)
+}
+
 reliability_build_correlation <- function(data, item_types, method,
                                           smooth = TRUE, correct = 0.5) {
   prepared_data <- reliability_prepare_correlation_data(data, item_types)
@@ -174,17 +243,14 @@ reliability_build_correlation <- function(data, item_types, method,
     correlation_matrix <- stats::cor(prepared_data, use = "pairwise.complete.obs",
                                      method = "pearson")
   } else if (method == "polychoric") {
-    obj <- suppressWarnings(psych::polychoric(prepared_data, correct = correct,
-                                              smooth = FALSE, global = FALSE))
-    correlation_matrix <- obj$rho
+    poly_result <- reliability_estimate_polychoric_rho(prepared_data, correct = correct)
+    correlation_matrix <- poly_result$rho
+    warnings_list <- c(warnings_list, poly_result$warnings)
   } else if (method == "mixed") {
-    continuous_index <- match(names(item_types)[item_types == "continuous"], names(prepared_data))
-    polytomous_index <- match(names(item_types)[item_types == "ordinal"], names(prepared_data))
-    dichotomous_index <- match(names(item_types)[item_types == "dichotomous"], names(prepared_data))
-    obj <- suppressWarnings(psych::mixedCor(prepared_data,
-                           c = continuous_index, p = polytomous_index, d = dichotomous_index,
-                           correct = correct, global = FALSE))
-    correlation_matrix <- obj$rho
+    mixed_result <- reliability_estimate_mixed_rho(prepared_data, item_types,
+                                                   correct = correct)
+    correlation_matrix <- mixed_result$rho
+    warnings_list <- c(warnings_list, mixed_result$warnings)
   } else {
     stop("Unsupported correlation method: ", method)
   }
@@ -467,6 +533,16 @@ exp_cronbach_alpha <- function(df, ..., correlation_method = "auto", check_keys
     item_types <- vapply(cleaned_df, reliability_detect_item_type, character(1))
     names(item_types) <- colnames(cleaned_df)
 
+    # Exploratory often stores Likert items as unordered factors. Treat those as
+    # ordinal when the user asks for polychoric/mixed, or when every selected
+    # item is categorical (auto -> Ordinal Alpha). Keep rejecting nominal when
+    # mixed with continuous items under auto/pearson.
+    if (correlation_method %in% c("polychoric", "mixed") ||
+        (correlation_method == "auto" &&
+         all(item_types %in% c("nominal", "ordinal", "dichotomous")))) {
+      item_types[item_types == "nominal"] <- "ordinal"
+    }
+
     unsupported <- names(item_types)[item_types %in% c("nominal", "unsupported")]
     if (length(unsupported) > 0) {
       stop("These variables cannot be used for reliability analysis (nominal/unsupported): ",

tests/testthat/test_factanal_correlation.R

@@ -507,6 +507,33 @@ test_that("verification pass 4 findings (issue #26623)", {
   expect_equal(zero_diagnostics$Judgement[[2]], "Detected in 1 variable")
 })
 
+test_that("build_factor_correlation retries with correct=0 before degrading", {
+  # Same sparse contingency pattern that makes psych::polychoric(correct=0.5) throw
+  # "attempt to set 'rownames' on an object with no dimensions", while correct=0 succeeds.
+  set.seed(1)
+  df <- data.frame(lapply(1:8, function(i) as.integer(sample(1:5, 12, replace = TRUE))))
+  names(df) <- paste0("q", 1:8)
+
+  expect_true(inherits(
+    suppressWarnings(tryCatch(psych::polychoric(df, correct = 0.5), error = function(e) e)),
+    "error"))
+  expect_false(inherits(
+    suppressWarnings(tryCatch(psych::polychoric(df, correct = 0), error = function(e) e)),
+    "error"))
+
+  result <- build_factor_correlation(df, "polychoric")
+  expect_equal(result$type, "polychoric")
+  expect_false(result$failed)
+  expect_equal(dim(result$correlation), c(8L, 8L))
+  expect_true(any(grepl("continuity correction of 0", result$warnings)))
+
+  # End-to-end: exp_factanal must keep polychoric rather than degrade to Pearson.
+  fit <- exp_factanal(df, q1, q2, q3, q4, q5, q6, q7, q8, nfactors = 2, rotate = "varimax",
+                      cor_type = "polychoric", parallel_n_iter = 3)$model[[1]]
+  expect_equal(fit$correlation_type, "polychoric")
+  expect_equal(fit$correlation_degraded_from, "")
+})
+
 test_that("a failed estimation degrades to Pearson end to end (issue #26623)", {
   # The degrade path mutates `resolved` after construction and re-points the diagnostics and the
   # parallel analysis; exercise it through exp_factanal, not just the helper.

tests/testthat/test_reliability.R

@@ -233,6 +233,41 @@ test_that("exp_cronbach_alpha rejects nominal (unordered, 3+ level) factor colum
                "nominal")
 })
 
+test_that("exp_cronbach_alpha treats all-factor Likert columns as ordinal under auto/polychoric", {
+  df <- make_reliability_df() %>%
+    dplyr::mutate(dplyr::across(dplyr::everything(), ~ factor(.x)))
+
+  model_df <- exp_cronbach_alpha(df, dplyr::everything(), correlation_method = "auto")
+  expect_equal(model_df$model[[1]]$selected_method, "polychoric")
+  res <- model_df %>% glance_rowwise(model, pretty.name = TRUE)
+  expect_equal(res$Coefficient, "Ordinal Alpha")
+  expect_false(is.na(res$Alpha))
+
+  model_df <- exp_cronbach_alpha(df, dplyr::everything(), correlation_method = "polychoric")
+  expect_equal(model_df$model[[1]]$selected_method, "polychoric")
+})
+
+test_that("exp_cronbach_alpha retries polychoric with correct=0 on sparse tables", {
+  set.seed(1)
+  df <- tibble::tibble(
+    a = ordered(sample(1:5, 12, replace = TRUE)),
+    b = ordered(sample(1:5, 12, replace = TRUE)),
+    c = ordered(sample(1:5, 12, replace = TRUE)),
+    d = ordered(sample(1:5, 12, replace = TRUE)),
+    e = ordered(sample(1:5, 12, replace = TRUE)),
+    f = ordered(sample(1:5, 12, replace = TRUE)),
+    g = ordered(sample(1:5, 12, replace = TRUE)),
+    h = ordered(sample(1:5, 12, replace = TRUE))
+  )
+
+  # Default psych::polychoric(correct=0.5) fails on this sparse case with
+  # "attempt to set 'rownames' on an object with no dimensions".
+  model_df <- exp_cronbach_alpha(df, dplyr::everything(), correlation_method = "polychoric")
+  expect_equal(model_df$model[[1]]$selected_method, "polychoric")
+  expect_false(is.na(model_df$model[[1]]$alpha))
+  expect_true(any(grepl("continuity correction of 0", model_df$model[[1]]$warnings)))
+})
+
 test_that("exp_cronbach_alpha drops constant columns and errors when fewer than 2 remain", {
   # One constant column is dropped; 3 valid items remain -> report still builds.
   df <- make_reliability_df() %>% dplyr::mutate(`定数` = 3L)