Merge pull request #1560 from exploratory-io/fix/issue-26623-diagnostics-robustness

WIP: Factor Analysis: diagnostics section robustness (tam#26623 follow-up)

Author: hidekoji

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: exploratory
 Type: Package
 Title: R package for Exploratory
-Version: 16.0.10
+Version: 16.0.11
 Date: 2026-07-21
 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

R/factanal.R

@@ -428,7 +428,12 @@ exp_factanal <- function(df, ..., nfactors = 2, fm = "minres", scores = "regress
     # Keyed off the REQUESTED family, so a failed polychoric estimation still shows the table with
     # its "Estimation failed" row rather than hiding the only signal the user has.
     fit$cor_diagnostics <- if (identical(requested_family, "pearson")) NULL else {
-      tryCatch(compute_polychoric_diagnostics(encoded_df, cor_result, selection), error = function(e) NULL)
+      # For a categorical correlation the report ALWAYS shows the diagnostics section, so this must
+      # never be NULL -- a NULL would leave the section's heading over an empty table. If the
+      # computation fails, degrade to a 6-row "Not Available" table so the section stays honest and
+      # non-empty. (issue #26623)
+      tryCatch(compute_polychoric_diagnostics(encoded_df, cor_result, selection),
+               error = function(e) unavailable_polychoric_diagnostics())
     }
     class(fit) <- c("fa_exploratory", class(fit))
     fit
@@ -727,19 +732,23 @@ tidy.fa_exploratory <- function(x, type="loadings", n_sample=NULL, pretty.name=F
         if (length(x$n_rows_used) == 1L && !is.na(x$n_rows_used)) as.character(x$n_rows_used) else "N/A"
       ),
       # Hidden columns. The client reads them to bind the report's explanation text; they are not
-      # part of the rendered Item/Value table.
+      # part of the rendered Item/Value table. The booleans are emitted as EXPLICIT "TRUE"/"FALSE"
+      # STRINGS, not R logicals: a logical column can reach the client serialized as "1"/"0" (or a
+      # boolean) depending on the pivot pipeline, and the client's isTrue() only accepts
+      # "TRUE"/"true"/true -- a "1" would read as false and, before the gate was hardened, hide a
+      # real polychoric analysis's diagnostics. Strings remove that ambiguity. (issue #26623)
       correlation_type = cor_type,
-      correlation_is_auto = isTRUE(x$correlation_is_auto),
+      correlation_is_auto = if (isTRUE(x$correlation_is_auto)) "TRUE" else "FALSE",
       # Non-empty when the requested correlation could not be estimated and the fit fell back to
       # Pearson, so the report can say so instead of inventing a rationale.
       degraded_from = if (is.null(x$correlation_degraded_from)) "" else x$correlation_degraded_from,
       # Whether suggesting Polychoric makes sense for this data at all.
-      polychoric_available = isTRUE(x$correlation_polychoric_available),
+      polychoric_available = if (isTRUE(x$correlation_polychoric_available)) "TRUE" else "FALSE",
       # Language-neutral tokens for the selector's warnings; the client renders the localized text.
       warning_tokens = paste(factanal_selection_warning_tokens(x$correlation_selection), collapse = ","),
-      # TRUE also when a polychoric estimation failed and the fit degraded to Pearson, so the
+      # "TRUE" also when a polychoric estimation failed and the fit degraded to Pearson, so the
       # report still shows the diagnostics table that reports the failure.
-      has_diagnostics = !is.null(x$cor_diagnostics) && nrow(x$cor_diagnostics) > 0,
+      has_diagnostics = if (!is.null(x$cor_diagnostics) && nrow(x$cor_diagnostics) > 0) "TRUE" else "FALSE",
       reason = if (is.null(x$correlation_reason)) "" else x$correlation_reason
     )
   }

R/factanal_correlation.R

@@ -596,6 +596,27 @@ factanal_polychoric_available <- function(selection, data = NULL) {
 # in prose ("less than 5% of the responses" / 「回答が全体の5%未満」) in
 # tam/src/js/components/analysis/templates/markdown/exp_factanal{,_ja}.js. Changing the default here
 # means updating that wording too. (issue #26623)
+# A 6-row "Not Available" diagnostics table, matching compute_polychoric_diagnostics' shape. Used
+# when the real computation fails, so a categorical analysis's diagnostics section never renders as
+# an empty table under its heading. (issue #26623)
+unavailable_polychoric_diagnostics <- function() {
+  tibble::tibble(
+    Diagnostic = c("Number of Categories", "Sparse Categories", "Empty Category Combinations",
+                   "Correlation Estimation Failures", "Positive Definiteness of the Correlation Matrix",
+                   "Smoothing Applied"),
+    Judgement = rep("Not Available", 6),
+    Description = c(
+      "Number of categories in the categorical variables used for the correlation.",
+      "Categorical variables that have a category holding a very small share of the responses. Correlations estimated from categories may become unstable when categories are sparse.",
+      "Variable pairs that have a category combination with no observations.",
+      "Variable pairs whose correlation could not be estimated.",
+      "Whether the estimated correlation matrix was positive definite, which factor analysis assumes, before any smoothing.",
+      "Whether the correlation matrix had to be smoothed to become positive definite."
+    ),
+    status = rep("na", 6)
+  )
+}
+
 compute_polychoric_diagnostics <- function(data, cor_result, selection,
                                            rare_category_prop_cutoff = 0.05) {
   data <- as.data.frame(data)

tests/testthat/test_factanal_correlation.R

@@ -176,7 +176,7 @@ test_that("analysis_method and cor_diagnostics tidy types (issue #26623)", {
   expect_equal(method_tbl$Value[[5]], as.character(nrow(df)))
   # Hidden columns the client binds the report explanation from.
   expect_equal(unique(method_tbl$correlation_type), "polychoric")
-  expect_true(all(method_tbl$correlation_is_auto))
+  expect_true(all(method_tbl$correlation_is_auto == "TRUE"))
   expect_true(nchar(method_tbl$reason[[1]]) > 0)
 
   diagnostics <- tidy(poly, type = "cor_diagnostics")
@@ -283,8 +283,8 @@ test_that("verification pass 1 findings (issue #26623)", {
   expect_equal(rotated$correlation_reason, "Polychoric Correlation was selected manually.")
   expect_false(rotated$correlation_is_auto)
   method_tbl <- tidy(rotated, type = "analysis_method")
-  expect_false(method_tbl$correlation_is_auto[[1]])
-  expect_true(method_tbl$has_diagnostics[[1]])
+  expect_equal(method_tbl$correlation_is_auto[[1]], "FALSE")
+  expect_equal(method_tbl$has_diagnostics[[1]], "TRUE")
 
   # An unsupported variable combination stays unsupported when the correlation is chosen manually:
   # picking Pearson must not smuggle a nominal column in as arbitrary integer codes.
@@ -332,7 +332,7 @@ test_that("verification pass 2 findings (issue #26623)", {
   # Whether Polychoric is worth suggesting is data-dependent.
   expect_true(factanal_polychoric_available(select_factor_correlation_type(df)))
   expect_false(factanal_polychoric_available(select_factor_correlation_type(mtcars[, c("mpg", "hp", "drat", "wt")])))
-  expect_true(method_tbl$polychoric_available[[1]])
+  expect_equal(method_tbl$polychoric_available[[1]], "TRUE")
   expect_equal(method_tbl$degraded_from[[1]], "")
 
   # The category-count row says "categorical variables": in a mixed analysis the continuous
@@ -535,7 +535,7 @@ test_that("a failed estimation degrades to Pearson end to end (issue #26623)", {
   method_tbl <- tidy(fit, type = "analysis_method")
   expect_equal(method_tbl$Value[[1]], "Pearson Correlation")
   expect_equal(method_tbl$degraded_from[[1]], "polychoric")
-  expect_true(method_tbl$has_diagnostics[[1]])
+  expect_equal(method_tbl$has_diagnostics[[1]], "TRUE")
   diagnostics <- tidy(fit, type = "cor_diagnostics")
   expect_equal(diagnostics$Judgement[[4]], "Estimation failed")
   # The Pearson fallback matrix says nothing about the correlation that failed.
@@ -604,3 +604,26 @@ test_that("an unsupported facet is skipped, not fatal, under Repeat By (issue #2
   expect_error(exp_factanal(dplyr::select(bad, q1, q2, q3), q1, q2, q3, nfactors = 1, parallel_n_iter = 3),
                "EXP-ANA-35")
 })
+
+test_that("a categorical correlation always yields a non-empty diagnostics table (issue #26623)", {
+  # The report ALWAYS shows the diagnostics section for a categorical correlation, so cor_diagnostics
+  # must never be NULL there -- otherwise the section renders a heading over an empty table, or (with
+  # the old has_diagnostics-only gate) vanishes entirely on a real polychoric analysis.
+  df <- factanal_ordinal_fixture()
+  poly <- exp_factanal(df, q1, q2, q3, q4, q5, q6, nfactors = 2, rotate = "varimax",
+                       cor_type = "polychoric", parallel_n_iter = 3)$model[[1]]
+  expect_false(is.null(poly$cor_diagnostics))
+  expect_equal(nrow(poly$cor_diagnostics), 6)
+  # The analysis_method table reports it as available, as an explicit "TRUE" string (not a logical
+  # that could serialize as "1"/"0" and read falsy on the client).
+  method_tbl <- tidy(poly, type = "analysis_method")
+  expect_equal(method_tbl$has_diagnostics[[1]], "TRUE")
+  expect_true(method_tbl$has_diagnostics[[1]] %in% c("TRUE", "FALSE"))
+
+  # If the diagnostics computation itself fails, the fallback keeps the section non-empty rather
+  # than returning NULL.
+  fallback <- unavailable_polychoric_diagnostics()
+  expect_equal(nrow(fallback), 6)
+  expect_true(all(fallback$Judgement == "Not Available"))
+  expect_equal(fallback$Diagnostic, poly$cor_diagnostics$Diagnostic)
+})