Merge pull request #1572 from exploratory-io/fix/issue-37340-factanal-report-part3

Factor Analysis report part 3: variances_judged tidy type, suitability P-value format, analysis_method order (tam#37340)

Author: hidekoji

DESCRIPTION

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

@@ -799,11 +799,17 @@ tidy.fa_exploratory <- function(x, type="loadings", n_sample=NULL, pretty.name=F
     kj <- judge_kmo(kmo)
     bj <- judge_bartlett(p)
     kmo_val <- if (is.na(kmo)) "N/A" else format(round(kmo, 2), nsmall = 2)
-    bart_val <- if (is.na(p)) "N/A" else if (p < 0.001) "p < 0.001" else paste0("p = ", format(round(p, 3), nsmall = 3))
+    # The Value cell holds the VALUE ONLY -- no "p < " / "p = " prefix, since the Metric name now
+    # says "(P Value)". Small p values are reported as "< 0.0001" (NOT the old 0.001 threshold), so
+    # this is the one place in the report that shows 4 decimals rather than the usual 3: 3 decimals
+    # cannot express the threshold itself. (issue tam#37340)
+    # formatC(format = "f") -- NOT format(nsmall = 4), which switches to scientific notation for a
+    # small-but-above-threshold p (0.0002 rendered as "2e-04").
+    bart_val <- if (is.na(p)) "N/A" else if (p < 0.0001) "< 0.0001" else formatC(p, format = "f", digits = 4)
     rows_used <- if (length(x$n_rows_used) == 1L && !is.na(x$n_rows_used)) as.character(x$n_rows_used) else "N/A"
     variables_used <- if (length(x$n_variables) == 1L && !is.na(x$n_variables)) as.character(x$n_variables) else "N/A"
     res <- tibble::tibble(
-      Metric = c("KMO", "Bartlett's Test of Sphericity", "Rows Used", "Variables Used"),
+      Metric = c("KMO", "Bartlett's Test of Sphericity (P Value)", "Rows Used", "Variables Used"),
       Value = c(kmo_val, bart_val, rows_used, variables_used),
       Judgement = c(kj$label, bj$label, "", ""),
       Description = c(kj$description, bj$description,
@@ -817,19 +823,26 @@ tidy.fa_exploratory <- function(x, type="loadings", n_sample=NULL, pretty.name=F
     cor_type <- if (is.null(x$correlation_type)) "pearson" else x$correlation_type
     rotation <- if (!is.null(x$rotation)) x$rotation else "none"
     res <- tibble::tibble(
-      # NOTE: "Target Variables" / "Data Rows" instead of the shorter "Variables" / "Rows":
-      # the client's shared translation map already binds those two keys to different wordings
-      # for other tables, and a direct-map key can only have one translation. (issue #26623)
-      Item = c("Correlation", "Factor Extraction Method", "Rotation", "Parallel Analysis Method", "Target Variables", "Data Rows"),
+      # The variable / row counts come FIRST (issue tam#37340): the section is now
+      # 「分析条件とデータの確認」, which leads with what data was analyzed. The method rows keep
+      # their own relative order after them, including the Parallel Analysis Method row (tam#37332).
+      # NOTE on the two count keys: they were "Target Variables" / "Data Rows" while the shorter
+      # "Variables" / "Rows" were already bound to other wordings in the client's shared
+      # translation map (#26623). They are now "Number of Variables" / "Row Count" -- keys the map
+      # ALREADY carries with exactly the wanted JA (変数の数 / 行数) from PCA's analysis_conditions
+      # table (#37268), so no new translation key is needed. Do NOT use "Number of Rows": that key
+      # is bound to 行の数 elsewhere in the same map.
+      Item = c("Number of Variables", "Row Count", "Correlation", "Factor Extraction Method",
+               "Rotation", "Parallel Analysis Method"),
       Value = c(
+        if (length(x$n_variables) == 1L && !is.na(x$n_variables)) as.character(x$n_variables) else "N/A",
+        if (length(x$n_rows_used) == 1L && !is.na(x$n_rows_used)) as.character(x$n_rows_used) else "N/A",
         factanal_correlation_label(cor_type),
         factanal_extraction_method_label(x$fm),
         factanal_rotation_label(rotation),
         # issue tam#37332: reported even when parallel analysis itself failed (x$parallel NULL),
         # since x$parallel_method is set independently of whether the computation succeeded.
-        factanal_parallel_method_label(x$parallel_method),
-        if (length(x$n_variables) == 1L && !is.na(x$n_variables)) as.character(x$n_variables) else "N/A",
-        if (length(x$n_rows_used) == 1L && !is.na(x$n_rows_used)) as.character(x$n_rows_used) else "N/A"
+        factanal_parallel_method_label(x$parallel_method)
       ),
       # Hidden columns. The client reads them to bind the report's explanation text; they are not
       # part of the rendered Item/Value table. The booleans are emitted as EXPLICIT "TRUE"/"FALSE"
@@ -888,6 +901,62 @@ tidy.fa_exploratory <- function(x, type="loadings", n_sample=NULL, pretty.name=F
       )
     )
   }
+  else if (type == "variances_judged") {
+    # Per-factor eigenvalue table with the three retention judgments, for the report's
+    # 「因子数の判定」 section (issue tam#37340). Same shape as prcomp.R's "variances_judged" branch
+    # so the client can reuse the PCA table's viz configuration.
+    #
+    # One row per correlation-matrix eigenvalue (i.e. per VARIABLE, not per extracted factor): the
+    # judgments only mean something when every candidate factor is listed, exactly like PCA's
+    # PC1..PCn. Eigenvalue / % Variance / Cummulated % Variance therefore all come off the SAME
+    # eigen(x$correlation) basis the screeplot / parallel_screeplot / factor_count branches use --
+    # NOT psych's Vaccounted "Proportion Var", which only exists for the extracted factors and
+    # would leave the remaining rows empty. So the ratios here are eigenvalue shares and can
+    # legitimately differ from the 「各因子の寄与率」 chart, which is Vaccounted-based.
+    eig <- eigen(x$correlation, symmetric = TRUE, only.values = TRUE)$values
+    n_row <- length(eig)
+    total_variance <- sum(eig)
+    pct_variance <- if (is.finite(total_variance) && total_variance != 0) eig / total_variance * 100 else rep(NA_real_, n_row)
+    par <- x$parallel
+    if (is.null(par)) {
+      parallel_label <- rep("Not Available", n_row)
+      parallel_status <- rep("na", n_row)
+    }
+    else {
+      ptbl <- par$table
+      in_range <- ptbl$factor_number <= n_row
+      actual <- rep(NA_real_, n_row)
+      threshold <- rep(NA_real_, n_row)
+      actual[ptbl$factor_number[in_range]] <- ptbl$actual_eigenvalue[in_range]
+      threshold[ptbl$factor_number[in_range]] <- ptbl$random_eigenvalue_threshold[in_range]
+      adopted <- !is.na(actual) & !is.na(threshold) & actual > threshold
+      parallel_label <- ifelse(adopted, "Adopted", "Not Adopted")
+      parallel_status <- ifelse(adopted, "adopted", "not_adopted")
+    }
+    # Kaiser is always meaningful here: factor analysis always fits a correlation matrix, so the
+    # eigenvalue >= 1 rule applies unconditionally (unlike PCA, where a covariance-scaled fit makes
+    # it "na"). The comparison matches the factor_count branch's kaiser_n (eig > 1).
+    # "Adopted" / "Not Adopted", not PCA's "Adopt" / "Not Adopted": the pair reads as a judgment in
+    # the English report, and both map to the same 採用 / 非採用 in Japanese. (tam#37340)
+    kaiser_adopted <- eig > 1
+    # Adopted = the factors this analysis actually extracted (the nfactors setting).
+    selected_adopted <- seq_len(n_row) <= n_factor
+    res <- tibble::tibble(
+      Factor = as.character(seq_len(n_row)),
+      Eigenvalue = eig,
+      `% Variance` = pct_variance,
+      `Cummulated % Variance` = cumsum(pct_variance),
+      `Parallel Analysis` = parallel_label,
+      `Kaiser Criterion` = ifelse(kaiser_adopted, "Adopted", "Not Adopted"),
+      # Column name "Adoption", not PCA's "Selected": the cells read "Adopted" / "Not Adopted", so a
+      # "Selected" header would not agree with its own values in the English report. Both map to
+      # 採否 / 採用 / 非採用 in Japanese. (tam#37340)
+      Adoption = ifelse(selected_adopted, "Adopted", "Not Adopted"),
+      parallel_status = parallel_status,
+      kaiser_status = ifelse(kaiser_adopted, "adopted", "not_adopted"),
+      selected_status = ifelse(selected_adopted, "adopted", "not_adopted")
+    )
+  }
   else if (type == "parallel_screeplot") {
     par <- x$parallel
     # The actual-data curve MUST be the same kind of eigenvalue the parallel analysis itself used

tests/testthat/test_factanal.R

@@ -51,7 +51,7 @@ test_that("exp_factanal with default orthogonal varimax rotation", {
     # New report tidy types (issue #37018).
     res <- model_df %>% tidy_rowwise(model, type="suitability")
     expect_equal(colnames(res), c("Metric", "Value", "Judgement", "Description", "status"))
-    expect_equal(res$Metric, c("KMO", "Bartlett's Test of Sphericity", "Rows Used", "Variables Used"))
+    expect_equal(res$Metric, c("KMO", "Bartlett's Test of Sphericity (P Value)", "Rows Used", "Variables Used")) # #37340
     res <- model_df %>% tidy_rowwise(model, type="factor_count")
     expect_equal(colnames(res), c("Method", "Recommended Number of Factors", "Description"))
     expect_equal(res$Method, c("Kaiser Criterion", "Parallel Analysis", "Scree Plot"))
@@ -422,12 +422,14 @@ test_that("parallel analysis method: factor_model vs smc (issue #37332)", {
   fc_smc <- smc_model_df %>% tidy_rowwise(model, type = "factor_count")
   expect_equal(fc_smc$Description[[2]], "Number of factors whose SMC-based factor eigenvalue exceeds the random-data threshold.")
 
-  # analysis_method table carries the new row.
+  # analysis_method table carries the new row. Read BY ITEM NAME: #37340 moved the two data counts
+  # to the top of the table, so the row's position is no longer 4.
+  am_value <- function(tbl, item) tbl$Value[[which(tbl$Item == item)]]
   am_factor_model <- model_df %>% tidy_rowwise(model, type = "analysis_method")
-  expect_equal(am_factor_model$Item[[4]], "Parallel Analysis Method")
-  expect_equal(am_factor_model$Value[[4]], "Factor Model")
+  expect_true("Parallel Analysis Method" %in% am_factor_model$Item)
+  expect_equal(am_value(am_factor_model, "Parallel Analysis Method"), "Factor Model")
   am_smc <- smc_model_df %>% tidy_rowwise(model, type = "analysis_method")
-  expect_equal(am_smc$Value[[4]], "Diagonal SMC")
+  expect_equal(am_value(am_smc, "Parallel Analysis Method"), "Diagonal SMC")
 
   # factanal_parallel_method_label: NULL degrades to the factor_model default; unknown -> Not Available.
   expect_equal(factanal_parallel_method_label(NULL), "Factor Model")
@@ -440,5 +442,89 @@ test_that("parallel analysis method: factor_model vs smc (issue #37332)", {
   legacy_fit <- fit
   legacy_fit$parallel_method <- NULL
   legacy_am <- tidy(legacy_fit, type = "analysis_method")
-  expect_equal(legacy_am$Value[[4]], "Factor Model")
+  # #37340 moved the two data counts to the top, so read the row BY NAME rather than by position.
+  expect_equal(legacy_am$Value[[which(legacy_am$Item == "Parallel Analysis Method")]], "Factor Model")
+})
+
+test_that("report part 3: variances_judged, suitability P value format, analysis_method order (issue tam#37340)", {
+  model_df <- mtcars %>%
+    exp_factanal(mpg, cyl, disp, hp, drat, wt, qsec, nfactors = 2, fm = "minres",
+                 rotate = "varimax", cor_type = "pearson", parallel_n_iter = 5)
+  fit <- model_df$model[[1]]
+
+  # --- variances_judged: one row per correlation-matrix eigenvalue (per VARIABLE, like PCA's PCn),
+  # so every candidate factor is judged -- not just the extracted ones.
+  judged <- tidy(fit, type = "variances_judged")
+  expect_equal(colnames(judged),
+               c("Factor", "Eigenvalue", "% Variance", "Cummulated % Variance",
+                 "Parallel Analysis", "Kaiser Criterion", "Adoption",
+                 "parallel_status", "kaiser_status", "selected_status"))
+  n_var <- length(fit$communality)
+  expect_equal(nrow(judged), n_var)
+  expect_equal(judged$Factor, as.character(seq_len(n_var)))
+  # Eigenvalues come off eigen(x$correlation) -- the SAME basis as screeplot / parallel_screeplot,
+  # descending, and the ratios are eigenvalue shares summing to 100%.
+  expect_equal(judged$Eigenvalue, eigen(fit$correlation, symmetric = TRUE, only.values = TRUE)$values)
+  expect_equal(sum(judged$`% Variance`), 100)
+  expect_equal(judged$`Cummulated % Variance`, cumsum(judged$`% Variance`))
+  expect_equal(judged$`Cummulated % Variance`[[n_var]], 100)
+  # Kaiser mirrors the factor_count branch's kaiser_n (eigenvalue > 1) and is ALWAYS judged for
+  # factor analysis (always a correlation matrix) -- never "na" the way covariance-scaled PCA is.
+  expect_equal(sum(judged$kaiser_status == "adopted"), sum(judged$Eigenvalue > 1))
+  expect_false(any(judged$kaiser_status == "na"))
+  # Selected = the factors this analysis actually extracted (nfactors), first rows only.
+  expect_equal(judged$selected_status, ifelse(seq_len(n_var) <= 2, "adopted", "not_adopted"))
+  expect_equal(judged$Adoption, ifelse(seq_len(n_var) <= 2, "Adopted", "Not Adopted"))
+  # Labels stay English-canonical; the client translates them. "Adopted" (not PCA's "Adopt") so the
+  # English report reads as a judgment against "Not Adopted".
+  expect_true(all(judged$`Parallel Analysis` %in% c("Adopted", "Not Adopted", "Not Available")))
+  expect_true(all(judged$`Kaiser Criterion` %in% c("Adopted", "Not Adopted")))
+  expect_true(all(judged$parallel_status %in% c("adopted", "not_adopted", "na")))
+  # Parallel analysis unavailable (old saved model) degrades to Not Available / na, same shape.
+  no_par <- fit
+  no_par$parallel <- NULL
+  judged_no_par <- tidy(no_par, type = "variances_judged")
+  expect_equal(unique(judged_no_par$`Parallel Analysis`), "Not Available")
+  expect_equal(unique(judged_no_par$parallel_status), "na")
+  expect_equal(nrow(judged_no_par), n_var)
+
+  # --- analysis_method: counts first, then the method rows (#37340).
+  method_tbl <- tidy(fit, type = "analysis_method")
+  expect_equal(method_tbl$Item, c("Number of Variables", "Row Count", "Correlation",
+                                  "Factor Extraction Method", "Rotation", "Parallel Analysis Method"))
+  expect_equal(method_tbl$Value[[1]], as.character(n_var))
+  expect_equal(method_tbl$Value[[2]], as.character(nrow(mtcars)))
+  expect_equal(method_tbl$Value[[3]], "Pearson Correlation")
+
+  # --- suitability: Metric names the P value, the Value cell holds the value ONLY, and the
+  # small-p threshold is 0.0001 (was 0.001).
+  suit <- tidy(fit, type = "suitability")
+  expect_equal(suit$Metric[[2]], "Bartlett's Test of Sphericity (P Value)")
+  expect_false(grepl("p", suit$Value[[2]], fixed = TRUE)) # no "p < " / "p = " prefix
+  expect_true(grepl("^(< 0\\.0001|[0-9]+\\.[0-9]{4}|N/A)$", suit$Value[[2]]))
+  fake <- fit
+  fake$bartlett <- list(p.value = 1e-9)
+  expect_equal(tidy(fake, type = "suitability")$Value[[2]], "< 0.0001")
+  fake$bartlett <- list(p.value = 0.00005)
+  expect_equal(tidy(fake, type = "suitability")$Value[[2]], "< 0.0001")
+  # Just ABOVE the threshold: 4 fixed decimals, never scientific notation ("2e-04").
+  fake$bartlett <- list(p.value = 0.0002)
+  expect_equal(tidy(fake, type = "suitability")$Value[[2]], "0.0002")
+  fake$bartlett <- list(p.value = 0.03)
+  expect_equal(tidy(fake, type = "suitability")$Value[[2]], "0.0300")
+  fake$bartlett <- NULL
+  expect_equal(tidy(fake, type = "suitability")$Value[[2]], "N/A")
+})
+
+test_that("report part 3: an over-parameterized fit legitimately has no fit test (issue tam#37340)", {
+  # 4 factors on 7 variables drives the model's degrees of freedom NEGATIVE, so psych::fa returns
+  # no chi-square P value, no RMSEA and no BIC. The report must present that as "not available"
+  # (and must NOT claim a hypothesis-test verdict) -- these blanks are the true output of an
+  # over-parameterized fit, not a serialization bug, so glance is intentionally left as-is.
+  model_df <- mtcars %>%
+    exp_factanal(mpg, cyl, disp, hp, drat, wt, qsec, nfactors = 4, fm = "minres",
+                 rotate = "varimax", cor_type = "pearson", parallel_n_iter = 3)
+  g <- glance(model_df$model[[1]])
+  expect_true(g$DF <= 0)
+  expect_true(is.na(g$`P Value`))
 })