fix htmt ordinal bug

NEWS.md

@@ -22,6 +22,7 @@
 * EFA: polychoric/tetrachoric correlation matrix errors are now caught and shown as a user-friendly message, including which variables have missing response categories.
 * EFA, PCA: ordinal variables with value labels (e.g., from SPSS) were incorrectly treated as having missing values when computing polychoric correlations; fixed by improving factor/ordered-to-numeric coercion ([jasp-issues#4129](https://github.com/jasp-stats/jasp-issues/issues/4129), [jasp-issues#4224](https://github.com/jasp-stats/jasp-issues/issues/4224)) ([PR #336](https://github.com/jasp-stats/jaspFactor/pull/336)).
 * CFA: Chi-square table footnote now always reports the estimator, test statistic, and standard error method, making it clear which defaults lavaan applied (e.g., Browne.residual.nt when DWLS is used on continuous data) ([jasp-issues#4157](https://github.com/jasp-stats/jasp-issues/issues/4157), [jasp-issues#4171](https://github.com/jasp-stats/jasp-issues/issues/4171)) ([PR #336](https://github.com/jasp-stats/jaspFactor/pull/336)).
+* CFA: the heterotrait-monotrait ratio treated ordinal indicators as continuous, so it was based on Pearson instead of polychoric correlations ([jasp-issues#4434](https://github.com/jasp-stats/jasp-issues/issues/4434)).
 
 ---
 

R/confirmatoryfactoranalysis.R

@@ -1484,10 +1484,13 @@ confirmatoryFactorAnalysisInternal <- function(jaspResults, dataset, options, ..
 }
 
 .cfaTableHtmt <- function(jaspResults, options, cfaResult, dataset) {
-  #### this has an ordering argument that still needs to be implemented once the categorical data stuff is done
 
   if (is.null(cfaResult) || !options[["htmt"]] || !is.null(jaspResults[["resHtmtTable"]])) return()
 
+  # the data extracted from the fitted object is numeric, so the ordered variables have to be named
+  # explicitly, otherwise htmt() falls back to Pearson instead of polychoric correlations
+  orderedVars <- lavaan::lavNames(cfaResult[["lav"]], "ov.ord")
+
   htmtTable <- createJaspTable(gettext("Heterotrait-monotrait ratio"), position = 4.2)
   htmtTable$dependOn(c("factors", "secondOrder", "residualsCovarying", "meanStructure", "modelIdentification", "factorsUncorrelated",
                        "packageMimiced", "estimator", "naAction", "group", "invarianceTesting", "htmt", "interceptsFixedToZero"))
@@ -1513,7 +1516,8 @@ confirmatoryFactorAnalysisInternal <- function(jaspResults, dataset, options, ..
       dataGroup <- as.data.frame(dataList[[gg]])
       colnames(dataGroup) <- cfaResult[["lav"]]@Data@ov.names[[ind]]
       htmt_result <- semTools::htmt(model = cfaResult[["model_simple"]], data = dataGroup,
-                                    missing = cfaResult[["lav"]]@Options[["missing"]])
+                                    missing = cfaResult[["lav"]]@Options[["missing"]],
+                                    ordered = orderedVars)
       htmt_result[upper.tri(htmt_result)] <- NA
       tmp_dat[tmp_dat$group == gg, facNames] <- htmt_result
     }
@@ -1533,10 +1537,12 @@ confirmatoryFactorAnalysisInternal <- function(jaspResults, dataset, options, ..
 
     if (is.null(cfaResult[["spec"]][["soIndics"]])) {
       htmt_result <- semTools::htmt(model = cfaResult[["model"]], data = dataset, sample.cov = sampCov,
-                                    missing = cfaResult[["lav"]]@Options[["missing"]])
+                                    missing = cfaResult[["lav"]]@Options[["missing"]],
+                                    ordered = orderedVars)
     } else { # the htmt does not allow a second order factor, so we take the model syntax without the seco
       htmt_result <- semTools::htmt(model = cfaResult[["model_simple"]], data = dataset, sample.cov = sampCov,
-                                    missing = cfaResult[["lav"]]@Options[["missing"]])
+                                    missing = cfaResult[["lav"]]@Options[["missing"]],
+                                    ordered = orderedVars)
     }
 
     htmt_result[upper.tri(htmt_result)] <- NA

tests/testthat/test-confirmatoryfactoranalysis.R

@@ -427,6 +427,7 @@ options$naAction <- "pairwise"
 options$thresholds <- TRUE
 options$group <- "gender"
 options$fitMeasures <- TRUE
+options$htmt <- TRUE
 dt <- read.csv("cavalini_group.csv")
 dt[, c("V1", "V5", "V8")] <- lapply(dt[, c("V1", "V5", "V8")], ordered)
 
@@ -501,6 +502,14 @@ test_that("Chi-square test table results match", {
                                       38, "Factor model", 0))
 })
 
+# htmt must use polychoric correlations for the ordinal indicators, see jasp-issues #4434
+test_that("Heterotrait-monotrait ratio table results match for ordinal data", {
+  table <- results[["results"]][["resHtmtTable"]][["data"]]
+  jaspTools::expect_equal_tables(table,
+                                 list(1, "", "Factor 1", "f", 0.934652527995396, 1, "Factor 2", "f",
+                                      1, "", "Factor 1", "m", 0.977492107173945, 1, "Factor 2", "m"))
+})
+
 
 # scalar invariance with ordinal data: thresholds must be constrained (equal) across groups
 options <- jaspTools::analysisOptions("confirmatoryFactorAnalysis")