From 2929566a7d4e1684a2a02a8caa1d6e779ded55ee Mon Sep 17 00:00:00 2001 From: "Hok Chio (Mark) Lai" Date: Thu, 14 Mar 2024 10:06:43 -0700 Subject: [PATCH 01/18] `lavaan_rerun()` failed when using listwise deletion Fixes #110 --- R/lavaan_rerun.R | 2 +- tests/testthat/test-lavaan_rerun.R | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index 8a53595..447c2e8 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -254,7 +254,7 @@ lavaan_rerun <- function(fit, } } } else { - to_rerun <- sort(unlist(case_ids, use.names = FALSE)) + to_rerun <- order(unlist(case_ids, use.names = FALSE)) } if (!missing(md_top)) { diff --git a/tests/testthat/test-lavaan_rerun.R b/tests/testthat/test-lavaan_rerun.R index f06a6ba..a9a688f 100644 --- a/tests/testthat/test-lavaan_rerun.R +++ b/tests/testthat/test-lavaan_rerun.R @@ -26,3 +26,10 @@ test_that("Compare parameter estimates of omitting an arbitrary case", { ) }) +datm <- dat[1:20, ] +datm[1, 2] <- datm[2, 3] <- datm[3, 4] <- datm[4, ] <- NA +fitm <- lavaan::sem(mod, datm) + +test_that("Works for missing data", { + expect_no_error(lavaan_rerun(fitm)) + }) \ No newline at end of file From b8159d27859784b9fc2d0b0fcb1962e1031203cf Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 02:37:39 +0800 Subject: [PATCH 02/18] More fixes on listwise missing --- R/lavaan_rerun.R | 16 +++++++++++----- tests/testthat/test-lavaan_rerun.R | 12 +++++++++--- tests/testthat/test-lavaan_rerun_multi.R | 12 ++++++++++++ 3 files changed, 32 insertions(+), 8 deletions(-) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index 447c2e8..deeddeb 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -311,12 +311,15 @@ lavaan_rerun <- function(fit, id_to_rerun <- tmp[to_rerun] } fit_total_time <- lavaan::lavInspect(fit, "timing")$total + lav_case_idx <- sort(unlist(lavaan::lavInspect(fit, "case.idx", + drop.list.single.group = FALSE), + use.names = FALSE)) if (rerun_method == "lavaan") { - rerun_i <- gen_fct_use_lavaan(fit) + rerun_i <- gen_fct_use_lavaan(fit, lav_case_idx = lav_case_idx) } if (rerun_method == "update") { environment(gen_fct_use_update) <- parent.frame() - rerun_i <- gen_fct_use_update(fit) + rerun_i <- gen_fct_use_update(fit, lav_case_idx = lav_case_idx) } rerun_test <- suppressWarnings(rerun_i(NULL)) if (!isTRUE(all.equal(unclass(coef(fit)), @@ -393,7 +396,8 @@ lavaan_rerun <- function(fit, out } -gen_fct_use_lavaan <- function(fit) { +gen_fct_use_lavaan <- function(fit, + lav_case_idx) { slot_opt <- fit@Options slot_pat <- data.frame(fit@ParTable) slot_pat$est <- NULL @@ -410,7 +414,8 @@ gen_fct_use_lavaan <- function(fit) { group = gp_var, slotOptions = slot_opt)) } else { - return(lavaan::lavaan(data = data_full[-i, ], + i1 <- match(i, lav_case_idx) + return(lavaan::lavaan(data = data_full[-i1, ], model = slot_pat, group = gp_var, slotOptions = slot_opt)) @@ -423,7 +428,8 @@ gen_fct_use_lavaan <- function(fit) { model = slot_pat, slotOptions = slot_opt)) } else { - return(lavaan::lavaan(data = data_full[-i, ], + i1 <- match(i, lav_case_idx) + return(lavaan::lavaan(data = data_full[-i1, ], model = slot_pat, slotOptions = slot_opt)) } diff --git a/tests/testthat/test-lavaan_rerun.R b/tests/testthat/test-lavaan_rerun.R index a9a688f..ae6b56d 100644 --- a/tests/testthat/test-lavaan_rerun.R +++ b/tests/testthat/test-lavaan_rerun.R @@ -4,7 +4,7 @@ library(semfindr) #context("Test lavaan_rerun") -mod <- +mod <- ' iv1 ~~ iv2 m1 ~ iv1 + iv2 @@ -31,5 +31,11 @@ datm[1, 2] <- datm[2, 3] <- datm[3, 4] <- datm[4, ] <- NA fitm <- lavaan::sem(mod, datm) test_that("Works for missing data", { - expect_no_error(lavaan_rerun(fitm)) - }) \ No newline at end of file + expect_no_error(rerunm_out <- lavaan_rerun(fitm)) + fitm_10 <- lavaan::sem(mod, datm[-10, ]) + rerunm_10 <- rerunm_out$rerun[["10"]] + expect_equal(ignore_attr = TRUE, + parameterEstimates(fitm_10), parameterEstimates(rerunm_10) + ) + }) + diff --git a/tests/testthat/test-lavaan_rerun_multi.R b/tests/testthat/test-lavaan_rerun_multi.R index bd7f4ed..3b7910e 100644 --- a/tests/testthat/test-lavaan_rerun_multi.R +++ b/tests/testthat/test-lavaan_rerun_multi.R @@ -33,3 +33,15 @@ test_that("Compare parameter estimates of omitting an arbitrary case", { ) }) +datm <- dat0[1:25, ] +datm[1, 2] <- datm[2, 3] <- datm[3, 4] <- datm[4, 1:4] <- NA +fitm <- lavaan::sem(mod, datm, group = "gp") + +test_that("Works for missing data", { + expect_no_error(rerunm_out <- lavaan_rerun(fitm)) + fitm_10 <- lavaan::sem(mod, datm[-10, ], group = "gp") + rerunm_10 <- rerunm_out$rerun[["10"]] + expect_equal(ignore_attr = TRUE, + parameterEstimates(fitm_10), parameterEstimates(rerunm_10) + ) + }) From 7b107e29967c836fe563334e99f24cb185a40df3 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 03:26:19 +0800 Subject: [PATCH 03/18] Check to_rerun with listwise deletion --- R/lavaan_rerun.R | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index deeddeb..f2a0da5 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -252,6 +252,11 @@ lavaan_rerun <- function(fit, if (!all(to_rerun %in% seq_len(n))) { stop("Some elements in to_rerun is not valid row numbers.") } + if (!all(to_rerun %in% case_ids)) { + stop("Some cases in to_rerun is not used in lavaan output. Probably due to listwise deletion.") + } + to_reun_org <- to_rerun + to_rerun <- match(to_rerun, case_ids) } } else { to_rerun <- order(unlist(case_ids, use.names = FALSE)) From d2ab255225f78a8666df65b286df0b3ba3a8dcbf Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 03:26:40 +0800 Subject: [PATCH 04/18] Update a test to handle missing --- tests/testthat/test-mahalanobis_exo_multi_select_md.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-mahalanobis_exo_multi_select_md.R b/tests/testthat/test-mahalanobis_exo_multi_select_md.R index 4255b1d..7f7dac5 100644 --- a/tests/testthat/test-mahalanobis_exo_multi_select_md.R +++ b/tests/testthat/test-mahalanobis_exo_multi_select_md.R @@ -64,7 +64,7 @@ head(dat0) fit0 <- lavaan::cfa(mod, dat0, group = "gp", group.equal = "loadings") -rerun_out <- lavaan_rerun(fit0, parallel = FALSE, to_rerun = c(5, 3, 4, 1)) +rerun_out <- lavaan_rerun(fit0, parallel = FALSE, to_rerun = c(5, 8, 7, 9)) test_that("No exogenous observed variables", { expect_warning( From 1f6ba2c2f21be74602b06983b315cea6bf810084 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 03:52:47 +0800 Subject: [PATCH 05/18] Handle case_ids with listwise deletion --- R/lavaan_rerun.R | 6 ++- .../test-lavaan_rerun_multi_select_by_id.R | 23 +++++++++++ .../test-lavaan_rerun_single_select_by_id.R | 39 ++++++++++++++++++- 3 files changed, 65 insertions(+), 3 deletions(-) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index f2a0da5..5f73d21 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -212,6 +212,7 @@ lavaan_rerun <- function(fit, n <- nrow(lavaan::lavInspect(fit, "data")) n_j <- n } + n_orig <- sum(lavaan::lavInspect(fit, "norig")) if (is.null(case_id)) { case_ids <- lavaan::lavInspect(fit, "case.idx", @@ -220,10 +221,11 @@ lavaan_rerun <- function(fit, } else { case_ids <- lavaan::lavInspect(fit, "case.idx", drop.list.single.group = FALSE) - if (length(case_id) != n) { + case_ids <- sort(unlist(case_ids, use.names = FALSE)) + if (length(case_id) != n_orig) { stop("The length of case_id is not equal to the number of cases.") } else { - case_ids <- case_id + case_ids <- case_id[case_ids] } } diff --git a/tests/testthat/test-lavaan_rerun_multi_select_by_id.R b/tests/testthat/test-lavaan_rerun_multi_select_by_id.R index 3b833e0..c2842f1 100644 --- a/tests/testthat/test-lavaan_rerun_multi_select_by_id.R +++ b/tests/testthat/test-lavaan_rerun_multi_select_by_id.R @@ -80,3 +80,26 @@ test_that("Check selected", { expect_equal(case_id_test[rerun_out$selected], case_id_to_rerun) }) +dat0 <- dat[1:60, ] +set.seed(856041) +dat0$gp <- sample(c("gp2", "gp1"), size = nrow(dat0), replace = TRUE) + +dat0[1, 2] <- dat0[2, 3] <- dat0[3, 4] <- dat0[5, 1:4] <- NA +fit0 <- lavaan::sem(mod, dat0, group = "gp") + +set.seed(4345) +case_id_test <- paste0(sample(letters, nrow(dat0), replace = TRUE), + sample(letters, nrow(dat0), replace = TRUE)) +case_id_to_rerun <- case_id_test[c(6, 4, 7)] +rerun_out <- lavaan_rerun(fit0, case_id = case_id_test, + to_rerun = case_id_to_rerun, parallel = FALSE) +id_test <- which(case_id_test %in% case_id_to_rerun)[3] +fit0_test <- lavaan::sem(mod, dat0[-id_test, ], group = "gp") + +rerun_test <- rerun_out$rerun[[case_id_test[id_test]]] + +test_that("Compare parameter estimates of omitting an arbitrary case", { + expect_equal(ignore_attr = TRUE, + parameterEstimates(fit0_test), parameterEstimates(rerun_test) + ) + }) \ No newline at end of file diff --git a/tests/testthat/test-lavaan_rerun_single_select_by_id.R b/tests/testthat/test-lavaan_rerun_single_select_by_id.R index 5f9de12..9df976b 100644 --- a/tests/testthat/test-lavaan_rerun_single_select_by_id.R +++ b/tests/testthat/test-lavaan_rerun_single_select_by_id.R @@ -2,7 +2,7 @@ library(testthat) library(lavaan) library(semfindr) -mod <- +mod <- ' iv1 ~~ iv2 m1 ~ iv1 + iv2 @@ -36,6 +36,20 @@ test_that("Check selected", { expect_equal(rerun_out$selected, c(1, 3, 9, 15, 50)) }) +datm <- dat[1:20, ] +datm[1, 2] <- datm[2, 3] <- datm[3, 4] <- datm[5, ] <- NA +fitm <- lavaan::sem(mod, datm) +fitm_7 <- lavaan::sem(mod, datm[-7, ]) + +rerun_out <- lavaan_rerun(fitm, to_rerun = c(4, 7, 6), parallel = FALSE) +rerun_7 <- rerun_out$rerun[["7"]] + +test_that("Compare parameter estimates of omitting an arbitrary case", { + expect_equal(ignore_attr = TRUE, + parameterEstimates(fitm_7), parameterEstimates(rerun_7) + ) + }) + # With case_id dat <- pa_dat @@ -72,3 +86,26 @@ test_that("Check the names of reruns", { test_that("Check selected", { expect_equal(case_id_test[rerun_out$selected], case_id_to_rerun) }) + +dat <- pa_dat + +dat0 <- dat[1:20, ] +dat0[1, 2] <- dat0[2, 3] <- dat0[3, 4] <- dat0[5, ] <- NA +fit0 <- lavaan::sem(mod, dat0) + +set.seed(4345) +case_id_test <- paste0(sample(letters, nrow(dat0), replace = TRUE), + sample(letters, nrow(dat0), replace = TRUE)) +case_id_to_rerun <- case_id_test[c(6, 4, 7)] +rerun_out <- lavaan_rerun(fit0, case_id = case_id_test, + to_rerun = case_id_to_rerun, parallel = FALSE) +id_test <- which(case_id_test %in% case_id_to_rerun)[3] +fit0_test <- lavaan::sem(mod, dat0[-id_test, ]) + +rerun_test <- rerun_out$rerun[[case_id_test[id_test]]] + +test_that("Compare parameter estimates of omitting an arbitrary case", { + expect_equal(ignore_attr = TRUE, + parameterEstimates(fit0_test), parameterEstimates(rerun_test) + ) + }) From 9507d82263da2dc6c4e4809030e70947e69f336b Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 08:32:36 +0800 Subject: [PATCH 06/18] Fix one more bug in listwise, and update test-lavaan_rerun_single_nonconvergence tests passed. --- R/lavaan_rerun.R | 2 +- .../test-lavaan_rerun_single_nonconvergence.R | 38 +++++++++++++++++++ 2 files changed, 39 insertions(+), 1 deletion(-) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index 5f73d21..04f14eb 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -251,7 +251,7 @@ lavaan_rerun <- function(fit, stop("Some elements in to_rerun is not in the case_id vectors.") } } else { - if (!all(to_rerun %in% seq_len(n))) { + if (!all(to_rerun %in% seq_len(n_orig))) { stop("Some elements in to_rerun is not valid row numbers.") } if (!all(to_rerun %in% case_ids)) { diff --git a/tests/testthat/test-lavaan_rerun_single_nonconvergence.R b/tests/testthat/test-lavaan_rerun_single_nonconvergence.R index a1926ea..bd94989 100644 --- a/tests/testthat/test-lavaan_rerun_single_nonconvergence.R +++ b/tests/testthat/test-lavaan_rerun_single_nonconvergence.R @@ -70,3 +70,41 @@ test_that("fit_measures_change", { nc_check0) }) +# With Listwise + +datm <- dat[1:30, ] +datm[1, 2] <- datm[2, 3] <- datm[3, 4] <- datm[5, ] <- NA +fitm <- lavaan::cfa(mod, datm, control = list(iter.max = 40)) +lavInspect(fitm, "iterations") +# rerun_out <- lavaan_rerun(fitm, parallel = FALSE) + +# This rerun has both runs that failed to converge and runs that failed post.check. +j <- c(16, 17, 20, 30) +fit_rerun <- lavaan_rerun(fitm, to_rerun = j, skip_all_checks = TRUE) +# table(sapply(fit_rerun$rerun, lavInspect, what = "converged")) +# suppressWarnings(table(sapply(fit_rerun$rerun, lavInspect, what = "post.check"))) + +tmp <- sapply(j, function(x) suppressWarnings(lavaan::cfa(mod, datm[-x, ], control = list(iter.max = 40)))) +nc_check0 <- sapply(tmp, lavInspect, what = "converged") +nc_check1 <- sum(nc_check0) +pc_check0 <- suppressWarnings(sapply(tmp, lavInspect, what = "post.check")) +pc_check1 <- sum(!pc_check0) + +test_that("Convergence", { + expect_equal(sum(sapply(fit_rerun$rerun, lavInspect, + what = "converged")), + nc_check1) + expect_equal(fit_rerun$converged, + nc_check0, + ignore_attr = TRUE) + }) + +test_that("Warnings", { + expect_equal(sum(sapply(fit_rerun$post_check, inherits, + what = "simpleWarning")), + pc_check1) + expect_equal(which(sapply(fit_rerun$post_check, inherits, + what = "simpleWarning")), + which(!pc_check0), + ignore_attr = TRUE) + }) From 43e7be9932ae3d3a6bdb5caedfedd006b9866f2c Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 08:52:41 +0800 Subject: [PATCH 07/18] Update test-lavaan_rerun_single_heywood.R Include a listwise deletion case. Tests passed. --- .../test-lavaan_rerun_single_heywood.R | 40 ++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/tests/testthat/test-lavaan_rerun_single_heywood.R b/tests/testthat/test-lavaan_rerun_single_heywood.R index 8992baa..39d4f83 100644 --- a/tests/testthat/test-lavaan_rerun_single_heywood.R +++ b/tests/testthat/test-lavaan_rerun_single_heywood.R @@ -2,7 +2,7 @@ library(testthat) library(lavaan) library(semfindr) -mod <- +mod <- ' f1 =~ x1 + x2 + x3 f2 =~ x4 + x5 + x6 @@ -33,3 +33,41 @@ test_that("Warnings", { what = "simpleWarning")), 0) }) + +# With Listwise + +n <- 20 +sigma <- matrix(.3, 3, 3) +diag(sigma) <- 1 +sigma <- sigma * (n - 1) / n +set.seed(1234) +dat0 <- MASS::mvrnorm(n, rep(0, 3), sigma, empirical = TRUE) +dat0 <- as.data.frame(dat0) +colnames(dat0) <- paste0("x", 1:3) +cov(dat0) + +dat0[1, 2] <- dat0[2, 3] <- dat0[4, ] <- NA +dat0[6, 1] <- -10 +dat0[6, 2] <- 10 +cov(dat0, use = "complete.obs") +cfa_dat_heywood <- dat0 + +mod <- +" +f1 =~ x1 + x2 + x3 +" +suppressWarnings(fit <- lavaan::cfa(mod, cfa_dat_heywood)) + +attr(lavaan_rerun_check(fit), "info") + +test_that("Reject inadmissible solution", { + expect_error(lavaan_rerun(fit)) + }) + +fit_rerun <- lavaan_rerun(fit, allow_inadmissible = TRUE) + +test_that("Warnings", { + expect_equal(sum(sapply(fit_rerun$post_check, inherits, + what = "simpleWarning")), + 14) + }) From 407af7c71ea20ac54d0a380b70d76b084d94ce1f Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 19:18:03 +0800 Subject: [PATCH 08/18] Update test-lavaan_rerun_multi_select_by_id.R Annotate the listwise section --- tests/testthat/test-lavaan_rerun_multi_select_by_id.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-lavaan_rerun_multi_select_by_id.R b/tests/testthat/test-lavaan_rerun_multi_select_by_id.R index c2842f1..ff3b6e1 100644 --- a/tests/testthat/test-lavaan_rerun_multi_select_by_id.R +++ b/tests/testthat/test-lavaan_rerun_multi_select_by_id.R @@ -80,6 +80,8 @@ test_that("Check selected", { expect_equal(case_id_test[rerun_out$selected], case_id_to_rerun) }) +# Listwise + dat0 <- dat[1:60, ] set.seed(856041) dat0$gp <- sample(c("gp2", "gp1"), size = nrow(dat0), replace = TRUE) From 9b749fd513752658f97ad01b78519ec8199456a9 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 19:19:12 +0800 Subject: [PATCH 09/18] Update test-lavaan_rerun_single_select_by_id.R Annotate the listwise section --- tests/testthat/test-lavaan_rerun_single_select_by_id.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/tests/testthat/test-lavaan_rerun_single_select_by_id.R b/tests/testthat/test-lavaan_rerun_single_select_by_id.R index 9df976b..94e1911 100644 --- a/tests/testthat/test-lavaan_rerun_single_select_by_id.R +++ b/tests/testthat/test-lavaan_rerun_single_select_by_id.R @@ -87,6 +87,8 @@ test_that("Check selected", { expect_equal(case_id_test[rerun_out$selected], case_id_to_rerun) }) +# Listwise + dat <- pa_dat dat0 <- dat[1:20, ] From 96829358ecfa5fcf0d925034b8577a8e702adcec Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 19:34:02 +0800 Subject: [PATCH 10/18] Update test-lavaan_rerun_single_select_by_md.R Confirmed that it works with listwise. --- tests/testthat/test-lavaan_rerun_single_select_by_md.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/testthat/test-lavaan_rerun_single_select_by_md.R b/tests/testthat/test-lavaan_rerun_single_select_by_md.R index 3b837d1..2490c96 100644 --- a/tests/testthat/test-lavaan_rerun_single_select_by_md.R +++ b/tests/testthat/test-lavaan_rerun_single_select_by_md.R @@ -43,6 +43,13 @@ test_that("Check selected", { expect_equal(rerun_out$selected, md_selected) }) +# For listwise + +fit0_case_ids <- lavInspect(fit0, "case.idx") +test_that("Check case ids", { + expect_equal(sort(as.numeric(rownames(md_fit0))), + sort(fit0_case_ids)) + }) # With Case ID From c7e1f8b2f54f2d437a2e6de9efaa538c1cd0e498 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 20:25:40 +0800 Subject: [PATCH 11/18] Fix listwise for select_by_residual tests passed. --- R/lavaan_rerun.R | 11 ++++- ...avaan_rerun_single_select_by_residual_md.R | 41 +++++++++++++++++++ 2 files changed, 50 insertions(+), 2 deletions(-) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index 04f14eb..731fbe5 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -304,9 +304,16 @@ lavaan_rerun <- function(fit, fit_resid_md_ordered <- fit_resid_md_ordered[!is.na(fit_resid_md_ordered)] fit_resid_md_selected <- fit_resid_md_ordered[seq_len(resid_md_top)] fit_resid_md_selected <- fit_resid_md_selected[!is.na(fit_resid_md_selected)] - to_rerun <- case_ids[fit_resid_md_selected] + if (!is.null(case_id)) { + to_rerun <- case_ids[fit_resid_md_selected] + } else { + to_rerun <- fit_resid_md_selected + } } - + # listwise: + # to_rerun: + # no case_id: The positions in the *listwise* dataset + # case_id: The case id to rerun if (!is.null(case_id)) { case_ids <- to_rerun id_to_rerun <- match(to_rerun, case_id) diff --git a/tests/testthat/test-lavaan_rerun_single_select_by_residual_md.R b/tests/testthat/test-lavaan_rerun_single_select_by_residual_md.R index 0672d02..fbc7555 100644 --- a/tests/testthat/test-lavaan_rerun_single_select_by_residual_md.R +++ b/tests/testthat/test-lavaan_rerun_single_select_by_residual_md.R @@ -63,3 +63,44 @@ test_that("Check the names of reruns", { test_that("Check selected", { expect_equal(case_id_test[rerun_out$selected], case_id_test[resid_md_selected]) }) + +# Listwise + +dat <- pa_dat + +dat0 <- dat[1:20, ] +dat0[1, 2] <- dat0[2, 3] <- dat0[3, 4] <- dat0[5, ] <- NA +fit0 <- lavaan::sem(mod, dat0) + +suppressWarnings(fit0 <- lavaan::sem(mod, dat0, meanstructure = TRUE)) + +fit0_data <- lavInspect(fit0, "data") +colnames(fit0_data) <- lavNames(fit0) +head(fit0_data) + +fit0_implied <- implied_scores(fit0) +fit0_observed <- fit0_data[, colnames(fit0_implied)] +fit0_residual <- fit0_implied - fit0_observed +fit0_resid_md <- mahalanobis(fit0_residual, colMeans(fit0_residual), + cov(fit0_residual)) + +resid_md_ordered <- order(fit0_resid_md, decreasing = TRUE, na.last = NA) + +resid_md_top <- 4 +resid_md_selected <- resid_md_ordered[seq_len(resid_md_top)] +resid_md_selected <- resid_md_selected[!is.na(resid_md_selected)] +resid_md_selected <- as.numeric(names(fit0_resid_md)[resid_md_selected]) +rerun_md_top <- suppressWarnings(lavaan_rerun(fit0, to_rerun = resid_md_selected, parallel = FALSE)) +rerun_out <- suppressWarnings(lavaan_rerun(fit0, resid_md_top = 4, parallel = FALSE)) + +test_that("Check the number of reruns", { + expect_equal(length(rerun_out$rerun), resid_md_top) + }) + +test_that("Check the names of reruns", { + expect_equal(names(rerun_out$rerun), as.character(resid_md_selected)) + }) + +test_that("Check selected", { + expect_equal(rerun_out$selected, resid_md_selected) + }) From 98aef7fba6e761dd1b62d3e31fe6e84180bf7ebb Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 21:01:01 +0800 Subject: [PATCH 12/18] Fix listwise issue in multisample tests passed. --- R/lavaan_rerun.R | 4 ++ .../test-lavaan_rerun_multi_heywood.R | 52 +++++++++++++++++++ 2 files changed, 56 insertions(+) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index 731fbe5..0a12228 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -421,17 +421,21 @@ gen_fct_use_lavaan <- function(fit, ngroups <- lavaan::lavInspect(fit, "ngroups") if (ngroups > 1) { gp_var <- lavaan::lavInspect(fit, "group") + gp_label <- lavaan::lavInspect(fit, "group.label") + slot_opt$group.label <- gp_label out <- function(i = NULL) { if (is.null(i)) { return(lavaan::lavaan(data = data_full, model = slot_pat, group = gp_var, + group.label = gp_label, slotOptions = slot_opt)) } else { i1 <- match(i, lav_case_idx) return(lavaan::lavaan(data = data_full[-i1, ], model = slot_pat, group = gp_var, + group.label = gp_label, slotOptions = slot_opt)) } } diff --git a/tests/testthat/test-lavaan_rerun_multi_heywood.R b/tests/testthat/test-lavaan_rerun_multi_heywood.R index a401294..46d0173 100644 --- a/tests/testthat/test-lavaan_rerun_multi_heywood.R +++ b/tests/testthat/test-lavaan_rerun_multi_heywood.R @@ -40,3 +40,55 @@ test_that("Warnings", { what = "simpleWarning")), 0) }) + +# With Listwise + +n <- 50 +sigma <- matrix(.3, 3, 3) +diag(sigma) <- 1 +sigma <- sigma * (n - 1) / n +set.seed(12345) +dat0 <- MASS::mvrnorm(n, rep(0, 3), sigma, empirical = TRUE) +dat0 <- as.data.frame(dat0) +colnames(dat0) <- paste0("x", 1:3) +cov(dat0) + +dat1 <- dat0 +dat1[1, 2] <- dat1[2, 3] <- dat1[4, ] <- NA +dat1[6, 1] <- -3 +dat1[6, 2] <- 3 +set.seed(856041) +dat1$gp <- sample(c("gp2", "gp1"), size = nrow(dat1), replace = TRUE) +cov(dat1[dat1$gp == "gp1", -4], use = "complete.obs") +cov(dat1[dat1$gp == "gp2", -4], use = "complete.obs") + +cfa_dat_heywood <- dat1 + +mod <- +" +f1 =~ x1 + x2 + x3 +" +suppressWarnings(fit <- lavaan::cfa(mod, cfa_dat_heywood, group = "gp")) + +attr(lavaan_rerun_check(fit), "info") + +test_that("Reject inadmissible solution", { + expect_error(lavaan_rerun(fit)) + }) + +tmp <- c(3, 6, 5) +fit_rerun <- lavaan_rerun(fit, to_rerun = tmp, allow_inadmissible = TRUE) +suppressWarnings(fit1 <- lavaan::cfa(mod, cfa_dat_heywood[-3, ], group = "gp", se = "none")) +suppressWarnings(fit2 <- lavaan::cfa(mod, cfa_dat_heywood[-6, ], group = "gp", se = "none")) +suppressWarnings(fit3 <- lavaan::cfa(mod, cfa_dat_heywood[-5, ], group = "gp", se = "none")) +chk <- sum(sapply(list(fit1, fit2, fit3), function(x) { + inherits(tryCatch(lavInspect(x, "post.check"), + warning = function(w) w), + "simpleWarning") + })) + +test_that("Warnings", { + expect_equal(sum(sapply(fit_rerun$post_check, inherits, + what = "simpleWarning")), + chk) + }) From 85a84d23fb3167dc4b63854b99c1d5e616f90844 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 21:08:50 +0800 Subject: [PATCH 13/18] Update test-lavaan_rerun_multi_nonconvergence.R Add a test for listwise deletion. tests passed. --- .../test-lavaan_rerun_multi_nonconvergence.R | 53 +++++++++++++++++++ 1 file changed, 53 insertions(+) diff --git a/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R b/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R index 92e2533..57946ce 100644 --- a/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R +++ b/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R @@ -75,3 +75,56 @@ test_that("fit_measures_change", { expect_equal(as.vector(!is.na(tmp)), nc_check0) }) + + +# With Listwise + +n <- 50 +sigma <- matrix(.3, 3, 3) +diag(sigma) <- 1 +sigma <- sigma * (n - 1) / n +set.seed(12345) +dat0 <- MASS::mvrnorm(n, rep(0, 3), sigma, empirical = TRUE) +dat0 <- as.data.frame(dat0) +colnames(dat0) <- paste0("x", 1:3) +cov(dat0) + +dat1 <- dat0 +dat1[1, 2] <- dat1[2, 3] <- dat1[4, ] <- NA +dat1[6, 1] <- -10 +dat1[6, 2] <- 10 +set.seed(856041) +dat1$gp <- sample(c("gp2", "gp1"), size = nrow(dat1), replace = TRUE) +cor(dat1[dat1$gp == "gp1", -4], use = "complete.obs") +cor(dat1[dat1$gp == "gp2", -4], use = "complete.obs") + +cfa_dat_heywood <- dat1 + +mod <- +" +f1 =~ x1 + x2 + x3 +" +suppressWarnings(fit <- lavaan::cfa(mod, cfa_dat_heywood, group = "gp", control = list(iter.max = 10))) + +attr(lavaan_rerun_check(fit), "info") + +test_that("Reject inadmissible solution", { + expect_error(lavaan_rerun(fit)) + }) + +j <- c(3, 7, 5) +fit_rerun <- lavaan_rerun(fit, to_rerun = j, skip_all_checks = TRUE) +tmp <- sapply(j, function(x) {suppressWarnings(lavaan::cfa(mod, dat[-x, ], control = list(iter.max = 10), group = "gp"))}) +nc_check0 <- sapply(tmp, lavInspect, what = "converged") +nc_check1 <- sum(nc_check0) +pc_check0 <- suppressWarnings(sapply(tmp, lavInspect, what = "post.check")) +pc_check1 <- sum(!pc_check0) + +test_that("Convergence", { + expect_equal(sum(sapply(fit_rerun$rerun, lavInspect, + what = "converged")), + nc_check1) + expect_equal(fit_rerun$converged, + nc_check0, + ignore_attr = TRUE) + }) From da5e22d87849a5db203b93ba8d46c9d8564f69c8 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 21:44:23 +0800 Subject: [PATCH 14/18] Add a test for listwise deletion tests passed --- tests/testthat/test-lavaan_rerun_multi_select_by_md.R | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/tests/testthat/test-lavaan_rerun_multi_select_by_md.R b/tests/testthat/test-lavaan_rerun_multi_select_by_md.R index 32c52d8..24761e6 100644 --- a/tests/testthat/test-lavaan_rerun_multi_select_by_md.R +++ b/tests/testthat/test-lavaan_rerun_multi_select_by_md.R @@ -44,6 +44,13 @@ test_that("Check selected", { expect_equal(rerun_out$selected, md_selected) }) +# For listwise + +fit0_case_ids <- unlist(lavInspect(fit0, "case.idx"), use.names = FALSE) +test_that("Check case ids", { + expect_equal(sort(as.numeric(rownames(md_fit0))), + sort(fit0_case_ids)) + }) # With Case ID From 0882b3501f8b5dba12401cbfa5b1c2b226558998 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 22:57:35 +0800 Subject: [PATCH 15/18] Fix listwise for test-lavaan_rerun_multi_select_by_residual_md tess pased --- R/lavaan_rerun.R | 6 +- ...lavaan_rerun_multi_select_by_residual_md.R | 56 +++++++++++++++++++ 2 files changed, 61 insertions(+), 1 deletion(-) diff --git a/R/lavaan_rerun.R b/R/lavaan_rerun.R index 0a12228..8266540 100644 --- a/R/lavaan_rerun.R +++ b/R/lavaan_rerun.R @@ -298,7 +298,11 @@ lavaan_rerun <- function(fit, fit_resid_md <- unlist(fit_resid_md, use.names = FALSE) tmp1 <- lavaan::lavInspect(fit, "case.idx", drop.list.single.group = FALSE) - tmp2 <- unlist(tmp1, use.names = FALSE) + tmp2 <- sort(unlist(tmp1, use.names = FALSE)) + if (ngroups > 1) { + tmp <- order(unlist(tmp1, use.names = FALSE)) + fit_resid_md <- fit_resid_md[tmp] + } names(fit_resid_md) <- tmp2 fit_resid_md_ordered <- order(fit_resid_md, decreasing = TRUE, na.last = NA) fit_resid_md_ordered <- fit_resid_md_ordered[!is.na(fit_resid_md_ordered)] diff --git a/tests/testthat/test-lavaan_rerun_multi_select_by_residual_md.R b/tests/testthat/test-lavaan_rerun_multi_select_by_residual_md.R index 685c060..a019408 100644 --- a/tests/testthat/test-lavaan_rerun_multi_select_by_residual_md.R +++ b/tests/testthat/test-lavaan_rerun_multi_select_by_residual_md.R @@ -45,6 +45,7 @@ resid_md_ordered <- order(fit0_resid_md, decreasing = TRUE, na.last = NA) resid_md_top <- 4 resid_md_selected <- resid_md_ordered[seq_len(resid_md_top)] resid_md_selected <- resid_md_selected[!is.na(resid_md_selected)] +resid_md_selected <- case_idx_full[resid_md_selected] rerun_md_top <- suppressWarnings(lavaan_rerun(fit0, to_rerun = resid_md_selected, parallel = FALSE)) rerun_out <- suppressWarnings(lavaan_rerun(fit0, resid_md_top = 4, parallel = FALSE)) @@ -80,3 +81,58 @@ test_that("Check the names of reruns", { test_that("Check selected", { expect_equal(case_id_test[rerun_out$selected], case_id_test[resid_md_selected]) }) + +# Listwise + +dat <- pa_dat + +dat0 <- dat[1:40, ] +dat0[1, 2] <- dat0[2, 3] <- dat0[3, 4] <- dat0[5, ] <- NA +set.seed(856041) +dat0$gp <- sample(c("gp2", "gp1"), size = nrow(dat0), replace = TRUE) + +suppressWarnings(fit0 <- lavaan::sem(mod, dat0, group = "gp")) + +fit0_data <- lavInspect(fit0, "data") +head(fit0_data[[1]]) +head(fit0_data[[2]]) + +fit0_implied <- implied_scores(fit0, output = "list") +y_names <- colnames(fit0_implied[[1]]) +fit0_observed <- lapply(lavInspect(fit0, "data"), function(x) x[, y_names]) +fit0_residual <- mapply(function(x1, x2) {x1 - x2}, + x1 = fit0_implied, + x2 = fit0_observed, + SIMPLIFY = FALSE) +fit0_resid_md <- lapply(fit0_residual, + function(x) { + mahalanobis(x, + colMeans(x), + cov(x)) + }) +fit0_resid_md <- unlist(fit0_resid_md, use.names = FALSE) +tmp1 <- lavaan::lavInspect(fit0, "case.idx", + drop.list.single.group = FALSE) +tmp2 <- order(unlist(tmp1, use.names = FALSE)) +tmp3 <- sort(unlist(tmp1, use.names = FALSE)) +fit0_resid_md <- fit0_resid_md[tmp2] +resid_md_ordered <- order(fit0_resid_md, decreasing = TRUE, na.last = NA) +resid_md_ordered <- tmp3[resid_md_ordered] + +resid_md_top <- 4 +resid_md_selected <- resid_md_ordered[seq_len(resid_md_top)] +resid_md_selected <- resid_md_selected[!is.na(resid_md_selected)] +# Should be: 16 40 26 25 +rerun_md_top <- suppressWarnings(lavaan_rerun(fit0, to_rerun = resid_md_selected, parallel = FALSE)) +rerun_out <- suppressWarnings(lavaan_rerun(fit0, resid_md_top = 4, parallel = FALSE)) +test_that("Check the number of reruns", { + expect_equal(length(rerun_out$rerun), resid_md_top) + }) + +test_that("Check the names of reruns", { + expect_equal(names(rerun_out$rerun), as.character(resid_md_selected)) + }) + +test_that("Check selected", { + expect_equal(rerun_out$selected, resid_md_selected) + }) From 95a82b50bd8522307c8a9da53a52bbd7ce82b04d Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 23:02:30 +0800 Subject: [PATCH 16/18] Roxygen -> 7.3.1 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 209a8e2..5b4d0b5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -25,7 +25,7 @@ License: GPL-3 Encoding: UTF-8 LazyData: true Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.3 +RoxygenNote: 7.3.1 Suggests: testthat (>= 3.0.0), parallel, From c4b2846a912e241c5aa5424b378cda2dee2665ad Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 23:10:06 +0800 Subject: [PATCH 17/18] Add MASS to Suggets, for tests --- DESCRIPTION | 3 ++- tests/testthat/test-lavaan_rerun_multi_heywood.R | 1 + tests/testthat/test-lavaan_rerun_multi_nonconvergence.R | 1 + tests/testthat/test-lavaan_rerun_single_heywood.R | 1 + 4 files changed, 5 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5b4d0b5..e1d4aa2 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,7 +31,8 @@ Suggests: parallel, knitr, rmarkdown, - modi + modi, + MASS Imports: lavaan, ggplot2, diff --git a/tests/testthat/test-lavaan_rerun_multi_heywood.R b/tests/testthat/test-lavaan_rerun_multi_heywood.R index 46d0173..df18b75 100644 --- a/tests/testthat/test-lavaan_rerun_multi_heywood.R +++ b/tests/testthat/test-lavaan_rerun_multi_heywood.R @@ -1,3 +1,4 @@ +skip_if_not_installed("MASS") library(testthat) library(lavaan) library(semfindr) diff --git a/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R b/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R index 57946ce..dae1f51 100644 --- a/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R +++ b/tests/testthat/test-lavaan_rerun_multi_nonconvergence.R @@ -1,5 +1,6 @@ skip_on_cran() # "Essential but may be machine dependent" +skip_if_not_installed("MASS") library(testthat) library(lavaan) diff --git a/tests/testthat/test-lavaan_rerun_single_heywood.R b/tests/testthat/test-lavaan_rerun_single_heywood.R index 39d4f83..6d8b7e3 100644 --- a/tests/testthat/test-lavaan_rerun_single_heywood.R +++ b/tests/testthat/test-lavaan_rerun_single_heywood.R @@ -1,3 +1,4 @@ +skip_if_not_installed("MASS") library(testthat) library(lavaan) library(semfindr) From 512733f27972377acbb3591e48fdbad18fcfa259 Mon Sep 17 00:00:00 2001 From: Shu Fai Cheung Date: Fri, 15 Mar 2024 23:16:43 +0800 Subject: [PATCH 18/18] Update to 0.1.6.2 tests and checks. passed. --- DESCRIPTION | 2 +- NEWS.md | 9 ++++++++- README.md | 2 +- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index e1d4aa2..6af8b8f 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: semfindr Title: Influential Cases in Structural Equation Modeling -Version: 0.1.6.1 +Version: 0.1.6.2 Authors@R: c( person(given = "Shu Fai", family = "Cheung", diff --git a/NEWS.md b/NEWS.md index d9af911..35ded6d 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,10 +1,17 @@ -# semfindr 0.1.6.1 +# semfindr 0.1.6.2 + +## Others - Updated the two tests for nonconvergence. Will check against results generated by directly calling `lavaan` functions. (0.1.6.1) +## Bug Fixes + +- Fixed a bug with listwise deletion + in `lavaan_rerun()`. (0.1.6.2) + # semfindr 0.1.6 ## New Features diff --git a/README.md b/README.md index fffbfae..f2934d8 100644 --- a/README.md +++ b/README.md @@ -9,7 +9,7 @@ [![R-CMD-check](https://github.com/sfcheung/semfindr/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/sfcheung/semfindr/actions/workflows/R-CMD-check.yaml) -(Version 0.1.6.1, updated on 2024-01-03, [release history](https://sfcheung.github.io/semfindr/news/index.html)) +(Version 0.1.6.2, updated on 2024-03-15, [release history](https://sfcheung.github.io/semfindr/news/index.html)) # semfindr: Finding influential cases in SEM