diff --git a/DESCRIPTION b/DESCRIPTION index b0dfd7b..25dd549 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: ShortForm Type: Package Title: Automatic Short Form Creation -Version: 0.5.7 -Date: 2026-04-29 +Version: 0.5.8 +Date: 2026-05-06 Authors@R: c(person("Anthony", "Raborn", email = "anthony.w.raborn@gmail.com", role = c("aut", "cre"), comment = c(ORCID = "0000-0002-8083-4739")), person("Walter", "Leite", email = "Walter.Leite@coe.ufl.edu", role = "aut")) @@ -28,9 +28,6 @@ Suggests: testthat Imports: lavaan (>= 0.5-22), - ggplot2, - ggrepel, - tidyr, stringr, methods, doSNOW, diff --git a/NAMESPACE b/NAMESPACE index c654db3..49e5dd6 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -17,12 +17,16 @@ exportMethods(show) exportMethods(summary) import(lavaan) import(utils) -importFrom(ggrepel,geom_text_repel) +importFrom(grDevices,hcl.colors) +importFrom(graphics,box) importFrom(graphics,legend) importFrom(graphics,lines) importFrom(graphics,par) +importFrom(graphics,plot.new) +importFrom(graphics,polygon) +importFrom(graphics,text) +importFrom(graphics,title) importFrom(methods,new) importFrom(methods,show) importFrom(rlang,.data) importFrom(stats,runif) -importFrom(tidyr,gather) diff --git a/NEWS.Rmd b/NEWS.Rmd index ef0443f..708c51b 100644 --- a/NEWS.Rmd +++ b/NEWS.Rmd @@ -11,29 +11,41 @@ output: # *News* -# ShortForm v0.5.7 +# ShortForm v0.5.8 ## Bugfixes -- Fixed issue in ACO algorithm where the best model was not properly updating -- Corrected use of ggplot within the ACO plot method due to depreciated ggplot2 functions -- Fixed issue in SA algorithm where models including factor relationships or outcome variables were not specified correctly after the initial model +- Fixed issue in tabuShortForm for certain parallel workflows +- Fixed bug in tabuShortForm when using multidimensional models ## Updates -- Modernized the README file -- Fixed CI/CD badge since Travis CI no longer works for this project +- Removed dependencies on ggplot2, ggrepel, and tidyr (ACO and TS plot methods) +- Added some additional unit tests ## To Do -Note--these are not required for 0.5.7, but are on the roadmap for future updates. +Note--these are not required for 0.5.8, but are on the roadmap for future updates. -- add additional unit tests (maybe for 0.5.8) +- add additional unit tests (maybe for 0.5.9) - refactor all major functions (0.6.0) - standardize function inputs, arguments, and outputs (0.7.0) ======= +# ShortForm v0.5.7 + +## Bugfixes + +- Fixed issue in ACO algorithm where the best model was not properly updating +- Corrected use of ggplot within the ACO plot method due to depreciated ggplot2 functions +- Fixed issue in SA algorithm where models including factor relationships or outcome variables were not specified correctly after the initial model + +## Updates + +- Modernized the README file +- Fixed CI/CD badge since Travis CI no longer works for this project + # ShortForm v0.5.6 - Updates focused on `{antcolony.lavaan}`. diff --git a/R/ACO.R b/R/ACO.R index b224198..5b9493d 100644 --- a/R/ACO.R +++ b/R/ACO.R @@ -67,156 +67,230 @@ setMethod('show', #' (for all plots), `'pheromone'`, `'gamma'`, `'beta'`, or `'variance'`. #' @param ... Not used. #' -#' @importFrom ggrepel geom_text_repel -#' @importFrom tidyr gather +#' @importFrom grDevices hcl.colors +#' @importFrom graphics box polygon text plot.new title #' @importFrom rlang .data #' #' @export -setMethod('plot', - signature = 'ACO', - definition = function(x, y, type = 'all', ...) { - summary_results = x@summary - pheromone_plot <- gamma_plot <- beta_plot <- variance_plot <- NULL - mean.beta <- mean.gamma <- mean.var.exp <- run <- NULL - item_pheromone_names <- - grep("Pheromone", names(summary_results), value = TRUE) - - pheromone_long <- - tidyr::gather( - data = summary_results, - key = "Item", - value = "Pheromone", - item_pheromone_names +setMethod("plot", + signature = "ACO", + definition = function(x, y, type = c("all", "pheromone", "gamma", "beta", "variance"), ...) { + + type <- match.arg(type) + + summary_results <- x@summary + + if (!"run" %in% names(summary_results)) { + stop("x@summary must contain a 'run' column.") + } + + run <- summary_results$run + + item_pheromone_names <- grep("Pheromone", names(summary_results), value = TRUE) + + old_par <- par(no.readonly = TRUE) + on.exit(par(old_par), add = TRUE) + + plot_empty_panel <- function(main_title, message) { + plot.new() + title(main = main_title) + text( + x = 0.5, + y = 0.5, + labels = message, + cex = 1 ) - if (type %in% c("all", "pheromone")) { - pheromone_plot <- - ggplot2::ggplot( - pheromone_long, - ggplot2::aes( - x = .data$run, - y = .data$Pheromone, - group = .data$Item, - fill = .data$Item, - colour = .data$Item + box() + invisible(FALSE) + } + + plot_pheromone <- function() { + + if (length(item_pheromone_names) == 0) { + plot_empty_panel( + main_title = "Changes in Pheromone", + message = "No pheromone columns found" ) - ) + - ggplot2::geom_area( - linetype = 1, - size = .1, - color = "black", na.rm = T - ) + - ggplot2::ylab("Total Pheromone") + - ggplot2::xlab("Run") + - ggplot2::ggtitle("Changes in Pheromone") + - ggplot2::theme_bw() + - ggplot2::theme( - legend.position = "none", - plot.title = ggplot2::element_text( - size = 30, - face = "bold", - hjust = .5 - ) + return(invisible(FALSE)) + } + + pheromone_mat <- as.matrix(summary_results[, item_pheromone_names, drop = FALSE]) + pheromone_mat[is.na(pheromone_mat)] <- 0 + + if (nrow(pheromone_mat) == 0 || ncol(pheromone_mat) == 0) { + plot_empty_panel( + main_title = "Changes in Pheromone", + message = "No pheromone values available" ) - } + return(invisible(FALSE)) + } - if (type %in% c("all", "gamma")) { - gamma_plot <- - ggplot2::ggplot( - summary_results, - ggplot2::aes(x = .data$run, y = .data$mean.gamma) - ) + - ggplot2::geom_line() + - ggplot2::ylab(expression("Mean " * gamma)) + - ggplot2::xlab("Run") + - ggplot2::ggtitle(expression("Changes in Mean " * gamma)) + - ggrepel::geom_text_repel(ggplot2::aes(label = ifelse( - run %in% c(1, max(run)), - round(mean.gamma, 3), "" - )), na.rm = T) + - ggplot2::theme_bw() + - ggplot2::theme( - legend.position = "none", - plot.title = ggplot2::element_text( - size = 23, - face = "bold", - hjust = .5 - ) + cumulative_pheromone <- t(apply(pheromone_mat, 1, cumsum)) + + y_max <- max(cumulative_pheromone, na.rm = TRUE) + + if (!is.finite(y_max)) { + plot_empty_panel( + main_title = "Changes in Pheromone", + message = "No finite pheromone values available" ) - } + return(invisible(FALSE)) + } + + plot( + run, + cumulative_pheromone[, ncol(cumulative_pheromone)], + type = "n", + ylim = c(0, y_max), + xlab = "Run", + ylab = "Total Pheromone", + main = "Changes in Pheromone", + ... + ) + + cols <- hcl.colors(ncol(pheromone_mat), palette = "Set 3") + + lower <- rep(0, length(run)) + + for (i in seq_len(ncol(pheromone_mat))) { + upper <- cumulative_pheromone[, i] - if (type %in% c("all", "beta")) { - beta_plot <- - ggplot2::ggplot( - summary_results, - ggplot2::aes(x = .data$run, y = .data$mean.beta) - ) + - ggplot2::geom_line() + - ggplot2::ylab(expression("Mean " * beta)) + - ggplot2::xlab("Run") + - ggplot2::ggtitle(expression("Changes in Mean " * beta)) + - ggrepel::geom_text_repel(ggplot2::aes(label = ifelse( - run %in% c(1, max(run)), - round(mean.beta, 3), "" - )), vjust = 0, na.rm = T) + - ggplot2::theme_bw() + - ggplot2::theme( - legend.position = "none", - plot.title = ggplot2::element_text( - size = 23, - face = "bold", - hjust = .5 - ) + polygon( + x = c(run, rev(run)), + y = c(upper, rev(lower)), + col = cols[i], + border = "black", + lwd = 0.1 ) + + lower <- upper + } + + box() + invisible(TRUE) } - if (type %in% c("all", "variance")) { - variance_plot <- - ggplot2::ggplot( - summary_results, - ggplot2::aes(x = .data$run, y = .data$mean.var.exp) - ) + - ggplot2::geom_line() + - ggplot2::ylab(expression("Mean Variance Explained")) + - ggplot2::xlab("Run") + - ggplot2::ggtitle(expression("Changes in Mean Variance Explained")) + - ggrepel::geom_text_repel(ggplot2::aes(label = ifelse( - run %in% c(1, max(run)), - round(mean.var.exp, 3), "" - )), vjust = 0, na.rm = T) + - ggplot2::theme_bw() + - ggplot2::theme( - legend.position = "none", - plot.title = ggplot2::element_text( - size = 16, - face = "bold", - hjust = .5 - ) + plot_metric <- function(column, ylab, main_title) { + + if (!column %in% names(summary_results)) { + plot_empty_panel( + main_title = main_title, + message = paste0("Column '", column, "' not found") + ) + return(invisible(FALSE)) + } + + y_values <- summary_results[[column]] + + if ( + length(y_values) == 0 || + length(y_values) != length(run) || + all(is.na(y_values)) + ) { + plot_empty_panel( + main_title = main_title, + message = paste0("Column '", column, "' is empty") + ) + return(invisible(FALSE)) + } + + finite_values <- is.finite(y_values) & is.finite(run) + + if (!any(finite_values)) { + plot_empty_panel( + main_title = main_title, + message = paste0("Column '", column, "' has no finite values") ) + return(invisible(FALSE)) + } + + plot( + run, + y_values, + type = "l", + xlab = "Run", + ylab = ylab, + main = main_title, + ... + ) + + endpoint_runs <- range(run[finite_values], na.rm = TRUE) + + endpoint_index <- which( + run %in% endpoint_runs & + is.finite(y_values) + ) + + if (length(endpoint_index) > 0) { + text( + x = run[endpoint_index], + y = y_values[endpoint_index], + labels = round(y_values[endpoint_index], 3), + pos = rep(c(4, 2), length.out = length(endpoint_index)), + cex = 0.8 + ) + } + + box() + invisible(TRUE) } if (type == "all") { - plots <- - list( - "Pheromone" = pheromone_plot, "Gamma" = gamma_plot, - "Beta" = beta_plot, "Variance" = variance_plot - ) + + par(mfrow = c(2, 2)) + + plot_pheromone() + + plot_metric( + column = "mean.gamma", + ylab = expression("Mean " * gamma), + main_title = expression("Changes in Mean " * gamma) + ) + + plot_metric( + column = "mean.beta", + ylab = expression("Mean " * beta), + main_title = expression("Changes in Mean " * beta) + ) + + plot_metric( + column = "mean.var.exp", + ylab = "Mean Variance Explained", + main_title = "Changes in Mean Variance Explained" + ) + } else if (type == "pheromone") { - plots <- - pheromone_plot + + plot_pheromone() + } else if (type == "gamma") { - plots <- - gamma_plot + + plot_metric( + column = "mean.gamma", + ylab = expression("Mean " * gamma), + main_title = expression("Changes in Mean " * gamma) + ) + } else if (type == "beta") { - plots <- - beta_plot - } else { - plots <- - variance_plot + + plot_metric( + column = "mean.beta", + ylab = expression("Mean " * beta), + main_title = expression("Changes in Mean " * beta) + ) + + } else if (type == "variance") { + + plot_metric( + column = "mean.var.exp", + ylab = "Mean Variance Explained", + main_title = "Changes in Mean Variance Explained" + ) } - plots + invisible(x) } - ) + ) #' Summary method for class `ACO` #' diff --git a/R/TS.R b/R/TS.R index bcc23e4..f38877a 100644 --- a/R/TS.R +++ b/R/TS.R @@ -102,38 +102,42 @@ setMethod('show', #' @param ... Not used. #' #' @export -setMethod('plot', - signature = 'TS', +setMethod("plot", + signature = "TS", definition = function(x, y, ...) { - val <- x@all_fit - - val <- as.data.frame.matrix( - cbind( - c(0:(length(val) - 1)), - as.numeric(val) - ), - stringsAsFactors = F - ) - colnames(val) <- c("Iteration", "Fit") - plot <- - ggplot2::ggplot(val, ggplot2::aes_string(x = "Iteration", y = "Fit")) + - ggplot2::geom_line() + - ggplot2::ylab(paste("Model Fit Value(s):", names(x@best_fit))) + - ggplot2::ggtitle(expression("Changes in Model Fit Value per Iteration")) + - ggplot2::theme_classic() + - ggplot2::theme( - legend.position = "none", - plot.title = ggplot2::element_text( - size = 16, - face = "bold", - hjust = .5 - ) + fit_values <- as.numeric(x@all_fit) + iterations <- seq_along(fit_values) - 1 + + if (length(fit_values) == 0 || all(is.na(fit_values))) { + plot.new() + title(main = "Changes in Model Fit Value per Iteration") + text( + x = 0.5, + y = 0.5, + labels = "No fit values available", + cex = 1 ) - - plot + box() + + return(invisible(x)) + } + + plot( + x = iterations, + y = fit_values, + type = "l", + xlab = "Iteration", + ylab = paste("Model Fit Value(s):", names(x@best_fit)), + main = "Changes in Model Fit Value per Iteration", + ... + ) + + box() + + invisible(x) } -) + ) #' Summary method for class `TS` #' diff --git a/R/tabu_sem_shortform.R b/R/tabu_sem_shortform.R index 87cb39e..592529b 100644 --- a/R/tabu_sem_shortform.R +++ b/R/tabu_sem_shortform.R @@ -153,7 +153,7 @@ tabuShortForm <- function(originalData, assign, c("factors", "itemsPerFactor"), syntaxExtraction(initialModelSyntaxFile = initialModel, items = allItems), - MoreArgs = list(envir = parent.frame()) + MoreArgs = list(envir = environment()) ) # save the external relationships @@ -194,7 +194,7 @@ tabuShortForm <- function(originalData, all.syntax <- vector(length = niter + 1) all.syntax[1] <- - current.syntax + paste0(current.syntax, collapse = "") chk <- Sys.getenv("_R_CHECK_LIMIT_CORES_", "") @@ -205,15 +205,16 @@ tabuShortForm <- function(originalData, } else { # use all cores in devtools::test() num_workers <- parallel::detectCores() + cl <- parallel::makeCluster(num_workers,type="PSOCK", outfile = "") + doSNOW::registerDoSNOW(cl) + `%dopar%` <- foreach::`%dopar%` } } else { num_workers = 1 - + `%dopar%` <- foreach::`%do%` } - cl <- parallel::makeCluster(num_workers,type="PSOCK", outfile = "") - doSNOW::registerDoSNOW(cl) - `%dopar%` <- foreach::`%dopar%` + # Do iterations for (it in 1:niter) { @@ -222,9 +223,10 @@ tabuShortForm <- function(originalData, tmp.obj <- vector("numeric") tmp.mod <- vector("list", length(factors)) tmp.syntax <- vector("list", length(factors)) + currentModelSyntax <- + unlist(strsplit(current.syntax, split = "\n")) for (j in 1:length(factors)) { - currentModelSyntax <- - strsplit(current.syntax, split = "\n")[[1]] + currentFactor <- factors[j] @@ -367,8 +369,10 @@ tabuShortForm <- function(originalData, } } - foreach::registerDoSEQ() - parallel::stopCluster(cl) + if (parallel) { + foreach::registerDoSEQ() + parallel::stopCluster(cl) + } if (class(best.obj)[1] == "lavaan.vector") { temp = as.numeric(best.obj) diff --git a/man/plot-ACO-ANY-method.Rd b/man/plot-ACO-ANY-method.Rd index 8554106..4e79dde 100644 --- a/man/plot-ACO-ANY-method.Rd +++ b/man/plot-ACO-ANY-method.Rd @@ -4,7 +4,7 @@ \alias{plot,ACO,ANY-method} \title{Plot method for class `ACO`} \usage{ -\S4method{plot}{ACO,ANY}(x, y, type = "all", ...) +\S4method{plot}{ACO,ANY}(x, y, type = c("all", "pheromone", "gamma", "beta", "variance"), ...) } \arguments{ \item{x, y}{An S4 object of class `ACO`} diff --git a/tests/testthat/test-aco-internals b/tests/testthat/test-aco-internals new file mode 100644 index 0000000..9c69e8b --- /dev/null +++ b/tests/testthat/test-aco-internals @@ -0,0 +1,316 @@ +test_that("antcolonyNewModel returns expected structure for non-bifactor model", { + set.seed(123) + + itemList <- list( + F1 = c("x1", "x2", "x3"), + F2 = c("y1", "y2", "y3") + ) + + itemVector <- c("x1", "x2", "x3", "y1", "y2", "y3") + includedItems <- c(1, 1, 1, 1, 1, 1) + + model <- c( + "F1 =~ x1 + x2 + x3", + "F2 =~ y1 + y2 + y3" + ) + + out <- antcolonyNewModel( + itemList = itemList, + itemVector = itemVector, + includedItems = includedItems, + model = model, + itemCount = c(2, 2), + factorNames = c("F1", "F2") + ) + + expect_type(out, "list") + expect_named(out, c("input", "selected.items", "all.items")) + + expect_length(out$input, 2) + expect_length(out$selected.items, 2) + expect_length(out$all.items, 4) + + expect_true(all(out$selected.items[[1]] %in% itemList[[1]])) + expect_true(all(out$selected.items[[2]] %in% itemList[[2]])) + + expect_length(out$selected.items[[1]], 2) + expect_length(out$selected.items[[2]], 2) + + expect_match(out$input[1], "^F1 =~ ") + expect_match(out$input[2], "^F2 =~ ") +}) + +test_that("antcolonyNewModel is reproducible with a fixed seed", { + itemList <- list( + F1 = c("x1", "x2", "x3"), + F2 = c("y1", "y2", "y3") + ) + + itemVector <- c("x1", "x2", "x3", "y1", "y2", "y3") + includedItems <- rep(1, 6) + + model <- c( + "F1 =~ x1 + x2 + x3", + "F2 =~ y1 + y2 + y3" + ) + + set.seed(123) + out1 <- antcolonyNewModel( + itemList = itemList, + itemVector = itemVector, + includedItems = includedItems, + model = model, + itemCount = c(2, 2), + factorNames = c("F1", "F2") + ) + + set.seed(123) + out2 <- antcolonyNewModel( + itemList = itemList, + itemVector = itemVector, + includedItems = includedItems, + model = model, + itemCount = c(2, 2), + factorNames = c("F1", "F2") + ) + + expect_identical(out1, out2) +}) + +test_that("antcolonyNewModel respects includedItems probabilities", { + set.seed(123) + + itemList <- list( + F1 = c("x1", "x2", "x3"), + F2 = c("y1", "y2", "y3") + ) + + itemVector <- c("x1", "x2", "x3", "y1", "y2", "y3") + + includedItems <- c( + 1, 0, 0, + 0, 1, 0 + ) + + model <- c( + "F1 =~ x1 + x2 + x3", + "F2 =~ y1 + y2 + y3" + ) + + out <- antcolonyNewModel( + itemList = itemList, + itemVector = itemVector, + includedItems = includedItems, + model = model, + itemCount = c(1, 1), + factorNames = c("F1", "F2") + ) + + expect_equal(out$selected.items[[1]], "x1") + expect_equal(out$selected.items[[2]], "y2") + expect_equal(out$all.items, c("x1", "y2")) + + expect_equal(out$input[1], "F1 =~ x1") + expect_equal(out$input[2], "F2 =~ y2") +}) + +# test_that("antcolonyNewModel replaces factor lines with optional whitespace before =~", { +# set.seed(123) + +# itemList <- list( +# F1 = c("x1", "x2"), +# F2 = c("y1", "y2") +# ) + +# itemVector <- c("x1", "x2", "y1", "y2") +# includedItems <- c(1, 0, 0, 1) + +# model <- c( +# "F1 =~ x1 + x2", +# "F2=~ y1 + y2" +# ) + +# out <- antcolonyNewModel( +# itemList = itemList, +# itemVector = itemVector, +# includedItems = includedItems, +# model = model, +# itemCount = c(1, 1), +# factorNames = c("F1", "F2") +# ) + +# expect_equal(out$input, c( +# "F1 =~ x1", +# "F2=~ y2" +# )) +# }) + +# test_that("antcolonyNewModel handles bifactor model syntax", { +# set.seed(123) + +# itemList <- list( +# F1 = c("x1", "x2", "x3"), +# F2 = c("y1", "y2", "y3"), +# G = c("x1", "x2", "x3", "y1", "y2", "y3") +# ) + +# itemVector <- c("x1", "x2", "x3", "y1", "y2", "y3") + +# includedItems <- c( +# 1, 0, 0, +# 0, 1, 0 +# ) + +# model <- c( +# "F1=~ x1 + x2 + x3", +# "F2=~ y1 + y2 + y3", +# "G=~ x1 + x2 + x3 + y1 + y2 + y3" +# ) + +# out <- antcolonyNewModel( +# itemList = itemList, +# itemVector = itemVector, +# includedItems = includedItems, +# model = model, +# itemCount = c(1, 1, 2), +# factorNames = c("F1", "F2", "G"), +# bifactor = "G" +# ) + +# expect_equal(out$selected.items[[1]], "x1") +# expect_equal(out$selected.items[[2]], "y2") + +# expect_equal(out$all.items, c("x1", "y2")) + +# expect_equal(out$selected.items[[3]], c("x1", "y2")) + +# expect_equal(out$input, c( +# "F1 =~ x1", +# "F2 =~ y2", +# "G =~ x1 + y2" +# )) +# }) + +test_that("antcolonyNewModel errors when all inclusion weights for a factor are zero", { + itemList <- list( + F1 = c("x1", "x2"), + F2 = c("y1", "y2") + ) + + itemVector <- c("x1", "x2", "y1", "y2") + includedItems <- c(0, 0, 1, 1) + + model <- c( + "F1 =~ x1 + x2", + "F2 =~ y1 + y2" + ) + + expect_error( + antcolonyNewModel( + itemList = itemList, + itemVector = itemVector, + includedItems = includedItems, + model = model, + itemCount = c(1, 1), + factorNames = c("F1", "F2") + ) + ) +}) + +test_that("modelInfoExtract returns expected components from fitted lavaan model", { + skip_if_not_installed("lavaan") + + setClass( + "mockModelCheckObj", + slots = list(model.output = "ANY"), + where = topenv() + ) + + data("HolzingerSwineford1939", package = "lavaan") + + model <- " + visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + " + + fit <- lavaan::cfa( + model, + data = HolzingerSwineford1939, + std.lv = TRUE + ) + + modelCheckObj <- new("mockModelCheckObj", model.output = fit) + + out <- modelInfoExtract( + modelCheckObj = modelCheckObj, + fitIndices = c("chisq", "df", "cfi", "rmsea") + ) + + expect_type(out, "list") + expect_named( + out, + c( + "model.fit", + "std.gammas", + "std.betas", + "std.reg.coef", + "variance.explained" + ) + ) + + expect_named(out$model.fit, c("chisq", "df", "cfi", "rmsea")) + + expect_true(is.numeric(out$model.fit)) + expect_true(is.numeric(out$std.gammas)) + expect_true(is.numeric(out$std.betas)) + expect_true(is.numeric(out$std.reg.coef)) + + expect_gt(length(out$std.gammas), 0) + expect_equal(length(out$std.betas), 0) + + expect_equal(out$std.reg.coef, out$std.gammas) + + expect_true(is.numeric(out$variance.explained)) + expect_gt(length(out$variance.explained), 0) +}) + +test_that("modelInfoExtract extracts standardized regression coefficients", { + skip_if_not_installed("lavaan") + + setClass( + "mockModelCheckObjRegression", + slots = list(model.output = "ANY"), + where = topenv() + ) + + data("HolzingerSwineford1939", package = "lavaan") + + model <- " + visual =~ x1 + x2 + x3 + textual =~ x4 + x5 + x6 + textual ~ visual + " + + fit <- lavaan::sem( + model, + data = HolzingerSwineford1939, + std.lv = TRUE + ) + + modelCheckObj <- new("mockModelCheckObjRegression", model.output = fit) + + out <- modelInfoExtract( + modelCheckObj = modelCheckObj, + fitIndices = c("cfi", "rmsea") + ) + + expect_named(out$model.fit, c("cfi", "rmsea")) + + expect_gt(length(out$std.gammas), 0) + expect_gt(length(out$std.betas), 0) + + expect_equal( + length(out$std.reg.coef), + length(out$std.gammas) + length(out$std.betas) + ) +}) diff --git a/tests/testthat/test-tabu-internals b/tests/testthat/test-tabu-internals new file mode 100644 index 0000000..daa4c61 --- /dev/null +++ b/tests/testthat/test-tabu-internals @@ -0,0 +1,206 @@ +test_that("par.matches matches lavaan-style parameter syntax", { + ptab <- data.frame( + lhs = c("f", "f", "x1", "x2", "f"), + op = c("=~", "=~", "~~", "~~", "=~"), + rhs = c("x1", "x2", "x1", "x2", "x1"), + label = c("lam1", "lam2", "var1", "var2", "lam1_dup"), + free = c(0, 0, 1, 1, 0), + nullval = c(NA, NA, 1, 1, 0), + block = c(1, 1, 1, 2, 2) + ) + + expect_equal( + par.matches(ptab, "f=~x2"), + c(FALSE, TRUE, FALSE, FALSE, FALSE) + ) + + expect_equal( + par.matches(ptab, " f =~ x2 "), + c(FALSE, TRUE, FALSE, FALSE, FALSE) + ) +}) + + +test_that("par.matches matches parameter labels", { + ptab <- data.frame( + lhs = c("f", "f", "x1"), + op = c("=~", "=~", "~~"), + rhs = c("x1", "x2", "x1"), + label = c("lam1", "lam2", "var1"), + free = c(0, 0, 1), + nullval = c(NA, NA, 1), + block = c(1, 1, 1) + ) + + expect_equal( + par.matches(ptab, "lam2"), + c(FALSE, TRUE, FALSE) + ) +}) + + +test_that("par.matches respects block argument", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x1"), + label = c("lam1_g1", "lam1_g2"), + free = c(0, 0), + nullval = c(NA, NA), + block = c(1, 2) + ) + + expect_equal( + par.matches(ptab, "f=~x1"), + c(TRUE, TRUE) + ) + + expect_equal( + par.matches(ptab, "f=~x1", block = 2), + c(FALSE, TRUE) + ) +}) + + +test_that("manip.ptab rejects invalid tasks", { + ptab <- data.frame( + lhs = "f", + op = "=~", + rhs = "x1", + label = "lam1", + free = 0, + nullval = NA_real_, + block = 1 + ) + + expect_error( + manip.ptab(ptab, "lam1", task = "bad_task") + ) +}) + + +test_that("free.param sets matched parameter free", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x2"), + label = c("lam1", "lam2"), + free = c(0, 0), + nullval = c(NA, NA), + block = c(1, 1) + ) + + out <- free.param(ptab, "lam2") + + expect_equal(out$free, c(0, 1)) + expect_equal(out$nullval, ptab$nullval) +}) + + +test_that("fix.param fixes matched parameter and preserves nullval when not supplied", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x2"), + label = c("lam1", "lam2"), + free = c(1, 1), + nullval = c(0.5, 0.7), + block = c(1, 1) + ) + + out <- fix.param(ptab, "lam2") + + expect_equal(out$free, c(1, 0)) + expect_equal(out$nullval, c(0.5, 0.7)) +}) + + +test_that("fix.param fixes matched parameter and updates nullval when supplied", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x2"), + label = c("lam1", "lam2"), + free = c(1, 1), + nullval = c(0.5, 0.7), + block = c(1, 1) + ) + + out <- fix.param(ptab, "lam2", nullval = 1) + + expect_equal(out$free, c(1, 0)) + expect_equal(out$nullval, c(0.5, 1)) +}) + + +test_that("rm.param removes matched parameter", { + ptab <- data.frame( + lhs = c("f", "f", "x1"), + op = c("=~", "=~", "~~"), + rhs = c("x1", "x2", "x1"), + label = c("lam1", "lam2", "var1"), + free = c(1, 1, 1), + nullval = c(NA, NA, 1), + block = c(1, 1, 1) + ) + + out <- rm.param(ptab, "lam2") + + expect_equal(nrow(out), 2) + expect_false("lam2" %in% out$label) + expect_equal(out$label, c("lam1", "var1")) +}) + + +test_that("nullval.param updates nullval without changing free status", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x2"), + label = c("lam1", "lam2"), + free = c(1, 0), + nullval = c(0.5, 0.7), + block = c(1, 1) + ) + + out <- nullval.param(ptab, "lam1", nullval = 2) + + expect_equal(out$free, c(1, 0)) + expect_equal(out$nullval, c(2, 0.7)) +}) + + +test_that("manip.ptab warns when more than one parameter matches", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x1"), + label = c("lam1_g1", "lam1_g2"), + free = c(0, 0), + nullval = c(NA, NA), + block = c(1, 2) + ) + + expect_warning( + free.param(ptab, "f=~x1"), + "More than one match for parameter found" + ) +}) + + +test_that("manip.ptab warns when no parameter matches", { + ptab <- data.frame( + lhs = c("f", "f"), + op = c("=~", "=~"), + rhs = c("x1", "x2"), + label = c("lam1", "lam2"), + free = c(0, 0), + nullval = c(NA, NA), + block = c(1, 1) + ) + + expect_warning( + free.param(ptab, "f=~x3"), + "No matches for parameter found" + ) +})