Merge pull request #363 from TDJorgensen/add_h1

lav_test_print() skips $stat.group when NULL
yrosseel · Jun 20, 2024 · 65d1a5c · 65d1a5c
2 parents fbc64df + 5aae5f6
commit 65d1a5c
Show file tree

Hide file tree

Showing 4 changed files with 70 additions and 35 deletions.
diff --git a/R/lav_test.R b/R/lav_test.R
@@ -715,8 +715,8 @@ lav_update_test_custom_h1 <- function(lav_obj_h0, lav_obj_h1) {
   newTEST <- lav_obj_h0@test
 
   ## assemble a call to lavTestLRT()
-  lrtCallTemplate <- list(quote(lavTestLRT), object = quote(lav_obj_h1),
-                          quote(lav_obj_h0)) # in ...
+  lrtCallTemplate <- list(quote(lavTestLRT), object = quote(lav_obj_h0),
+                          quote(lav_obj_h1)) # in ...
 
   ## can only update tests available in both objects
   testNames0 <- names(lav_obj_h0@test)
@@ -769,7 +769,7 @@ lav_update_test_custom_h1 <- function(lav_obj_h0, lav_obj_h1) {
       newTEST[[tn]]$shift.parameter <- attr(ANOVA, "shift")[2] # first row is NA
     } else {
       ## unless scaled.shifted, RMSEA is calculated from $standard$stat and
-      ## df == sum($trace.UGamma).  Reverse-engineer from $scaling factor:
+      ## df == sum($trace.UGamma).  Reverse-engineer from $scaling.factor:
       newTEST[[tn]]$trace.UGamma <- newTEST[[tn]]$df * newTEST[[tn]]$scaling.factor
     }
     ## should not be necessary to replace $trace.UGamma2

diff --git a/R/lav_test_LRT.R b/R/lav_test_LRT.R
@@ -69,7 +69,7 @@ lavTestLRT <- function(object, ..., method = "default", test = "default",
     if (type == "cf") {
       lav_msg_warn(gettext("`type' argument is ignored for a single model"))
     }
-    return(lav_test_lrt_single_model(object))
+    return(lav_test_lrt_single_model(object, method = method, test = test, type = type))
   }
 
   # list of models
@@ -474,43 +474,71 @@ lavTestLRT <- function(object, ..., method = "default", test = "default",
 
 
 # anova table for a single model
-lav_test_lrt_single_model <- function(object) {
+lav_test_lrt_single_model <- function(object, method = "default",
+                                      test = "default", type = "Chisq") {
   estimator <- object@Options$estimator
 
   aic <- bic <- c(NA, NA)
   if (estimator == "ML") {
     aic <- c(NA, AIC(object))
     bic <- c(NA, BIC(object))
   }
-
-  if (length(object@test) > 1L) {
-    val <- data.frame(
-      Df = c(0, object@test[[2L]]$df),
-      AIC = aic,
-      BIC = bic,
-      Chisq = c(0, object@test[[2L]]$stat),
-      "Chisq diff" = c(NA, object@test[[2L]]$stat),
-      "Df diff" = c(NA, object@test[[2L]]$df),
-      "Pr(>Chisq)" = c(NA, object@test[[2L]]$pvalue),
-      row.names = c("Saturated", "Model"),
-      check.names = FALSE
-    )
-    attr(val, "heading") <- "Chi-Squared Test Statistic (scaled)\n"
+
+  ## determine which @test element
+  tn <- names(object@test)
+  if (length(tn) == 1L) {
+    TEST <- 1L # only choice
+
+    ## More than 1.  Cycle through possible user specifications:
+  } else if (method[1] == "standard") {
+    TEST <- 1L
+  } else if (grepl(pattern = "browne", x = type) && type %in% tn) {
+    TEST <- type
+  } else if (test %in% tn) {
+    TEST <- test
   } else {
-    val <- data.frame(
-      Df = c(0, object@test[[1L]]$df),
-      AIC = aic,
-      BIC = bic,
-      Chisq = c(0, object@test[[1L]]$stat),
-      "Chisq diff" = c(NA, object@test[[1L]]$stat),
-      "Df diff" = c(NA, object@test[[1L]]$df),
-      "Pr(>Chisq)" = c(NA, object@test[[1L]]$pvalue),
-      row.names = c("Saturated", "Model"),
-      check.names = FALSE
-    )
-    attr(val, "heading") <- "Chi-Squared Test Statistic (unscaled)\n"
+    ## Nothing explicitly (or validly) requested.
+    ## But there is > 1 test, so take the second element (old default)
+    TEST <- 2L
   }
 
+  ## anova table
+  val <- data.frame(
+    Df = c(0, object@test[[TEST]]$df),
+    AIC = aic,
+    BIC = bic,
+    Chisq = c(0, object@test[[TEST]]$stat),
+    "Chisq diff" = c(NA, object@test[[TEST]]$stat),
+    "Df diff" = c(NA, object@test[[TEST]]$df),
+    "Pr(>Chisq)" = c(NA, object@test[[TEST]]$pvalue),
+    row.names = c("Saturated", "Model"),
+    check.names = FALSE
+  )
+  ## scale/shift attributes
+  if (!is.null(object@test[[TEST]]$scaling.factor)) {
+    attr(val, "scale") <- c(NA, object@test[[TEST]]$scaling.factor)
+  }
+  if (!is.null(object@test[[TEST]]$shift.parameter)) {
+    attr(val, "shift") <- c(NA, object@test[[TEST]]$shift.parameter)
+  }
+
+  ## heading
+  if (grepl(pattern = "browne", x = TEST)) {
+    attr(val, "heading") <- object@test[[TEST]]$label
+
+  } else if (TEST == 1L) {
+    attr(val, "heading") <- "Chi-Squared Test Statistic (unscaled)\n"
+
+  } else {
+    LABEL <- object@test[[TEST]]$label
+    attr(val, "heading") <- paste0("Chi-Squared Test Statistic (scaled",
+                                   ifelse(TEST == "scaled.shifted",
+                                          yes = " and shifted)", no = ")"),
+                                   ifelse(is.null(LABEL),
+                                          yes = "\n", no = paste("\n ", LABEL)),
+                                   "\n")
+  }
+
   class(val) <- c("anova", class(val))
 
   val

diff --git a/R/lav_test_diff.R b/R/lav_test_diff.R
@@ -205,8 +205,15 @@ lav_test_diff_SatorraBentler2001 <- function(m1, m0, test = 2) {
   T1 <- m1@test[[1]]$stat
   r1 <- m1@test[[1]]$df
   c1 <- m1@test[[test]]$scaling.factor
-  if (r1 == 0) { # saturated model
-    c1 <- 1
+
+  ## check for situations when scaling.factor would be NA
+  if (r1 == 0) {
+    ## saturated model
+    c1 <- 1 # canceled out by 0 when calculating "cd"
+
+  } else if (r1 > 0 && isTRUE(all.equal(T1, 0))) {
+    ## perfect fit
+    c1 <- 0 # cancels out r1 when calculating "cd"
   }
 
   T0 <- m0@test[[1]]$stat

diff --git a/R/lav_test_print.R b/R/lav_test_print.R
@@ -271,7 +271,7 @@ lav_test_print <- function(object, nd = 3L) {
 
     # multiple groups?
     ngroups <- ngroups
-    if (ngroups > 1L) {
+    if (ngroups > 1L && !is.null(TEST[[block]]$stat.group)) {
       c1 <- c2 <- c3 <- character(ngroups)
       for (g in 1:ngroups) {
         tmp <- sprintf("  %-40s", group.label[[g]])
@@ -283,7 +283,7 @@ lav_test_print <- function(object, nd = 3L) {
             justify = "right"
           )
         } else {
-          tmp <- sprintf(num.format, TEST[[scaled.idx]]$stat.group[g])
+          tmp <- sprintf(num.format, TEST[[block]]$stat.group[g])
           c2[g] <- format(tmp,
             width = 8L + max(0, (nd - 3L)) * 4L,
             justify = "right"