diff --git a/R/lav_test.R b/R/lav_test.R index 3a797514..bf9de45d 100644 --- 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 index 750fa568..415fa30c 100644 --- 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,7 +474,8 @@ 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) @@ -482,35 +483,62 @@ lav_test_lrt_single_model <- function(object) { 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 index a3d57ad1..acb4fcf5 100644 --- 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 index 4e141e6c..d167c534 100644 --- 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"