From c73b813aa16f874c778490b57606659852a70b4c Mon Sep 17 00:00:00 2001 From: seonghobae <8172694+seonghobae@users.noreply.github.com> Date: Fri, 10 Jul 2026 16:34:20 +0000 Subject: [PATCH 1/3] =?UTF-8?q?=F0=9F=9B=A1=EF=B8=8F=20Sentinel:=20[MEDIUM?= =?UTF-8?q?]=20Fix=20unvalidated=20boolean=20arguments?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - added strict input validation for boolean parameters in autoFIPC - prevented unhandled R condition crashes/unexpected coercions - added comprehensive testthat cases for validation - documented in sentinel journal --- .jules/sentinel.md | 7 +++++++ R/aFIPC.R | 10 ++++++++++ tests/testthat/test-autoFIPC.R | 22 ++++++++++++++++++++++ 3 files changed, 39 insertions(+) diff --git a/.jules/sentinel.md b/.jules/sentinel.md index 891765a..cdac086 100644 --- a/.jules/sentinel.md +++ b/.jules/sentinel.md @@ -39,3 +39,10 @@ **Prevention:** 1. `try()` 블록 외부에서 결과 객체를 사용할 때는 항상 해당 객체가 생성되었는지 확인해야 합니다 (`exists('model')`). 2. 객체의 프로퍼티에 안전하게 접근하려면, 객체가 존재하고 예상되는 타입인지 검증하는 로직을 결합해야 합니다 (예: `(!exists('model') || !isTRUE(model@OptimInfo$secondordertest))`). + +## 2024-07-10 - Unvalidated Boolean Flags Lead to Unhandled Downstream Coercion +**Vulnerability:** Several boolean flags controlling the fundamental algorithmic flow in `autoFIPC` (`tryFitwholeNewItems`, `checkIPD`, `tryEM`, etc.) were used in `if` statements without explicit type validation. If a malicious or unexpected input (e.g., a vector of length > 1, an `NA`, or a character string) was passed to these arguments, R would throw an unhandled `condition has length > 1` exception (crashing the process) or coerce the value unexpectedly (potentially leading to incorrect statistical linking paths or infinite loops). +**Learning:** Control-flow parameters must be strictly verified before usage. R's dynamic typing means `if (flag)` will fail catastrophically if `flag` is `NA` or `length > 1`. +**Prevention:** +1. Always implement explicit, short-circuited runtime type validation for scalar boolean inputs. +2. The standard secure pattern in R is `if (!is.logical(x) || length(x) != 1 || is.na(x)) stop("...")`. The `||` operator correctly avoids evaluating `is.na(x)` if the length is strictly checked first. diff --git a/R/aFIPC.R b/R/aFIPC.R index ba4215b..63c5f97 100644 --- a/R/aFIPC.R +++ b/R/aFIPC.R @@ -84,6 +84,16 @@ autoFIPC <- else if (is.data.frame(oldformYData) || is.matrix(oldformYData)) nItems <- ncol(as.data.frame(oldformYData)) if (!is.na(nItems) && !(length(itemtype) == 1 || length(itemtype) == nItems)) stop(sprintf('Security Error: itemtype must be length 1 or length %d (number of items).', nItems)) + # boolean parameter validation + if (!is.logical(tryFitwholeNewItems) || length(tryFitwholeNewItems) != 1 || is.na(tryFitwholeNewItems)) stop("Security Error: tryFitwholeNewItems must be a single non-NA logical value") + if (!is.logical(tryFitwholeOldItems) || length(tryFitwholeOldItems) != 1 || is.na(tryFitwholeOldItems)) stop("Security Error: tryFitwholeOldItems must be a single non-NA logical value") + if (!is.logical(checkIPD) || length(checkIPD) != 1 || is.na(checkIPD)) stop("Security Error: checkIPD must be a single non-NA logical value") + if (!is.logical(tryEM) || length(tryEM) != 1 || is.na(tryEM)) stop("Security Error: tryEM must be a single non-NA logical value") + if (!is.logical(freeMEAN) || length(freeMEAN) != 1 || is.na(freeMEAN)) stop("Security Error: freeMEAN must be a single non-NA logical value") + if (!is.logical(forceNormalZeroOne) || length(forceNormalZeroOne) != 1 || is.na(forceNormalZeroOne)) stop("Security Error: forceNormalZeroOne must be a single non-NA logical value") + if (!is.logical(parameterOverwrite) || length(parameterOverwrite) != 1 || is.na(parameterOverwrite)) stop("Security Error: parameterOverwrite must be a single non-NA logical value") + if (!is.logical(empiricalhist) || length(empiricalhist) != 1 || is.na(empiricalhist)) stop("Security Error: empiricalhist must be a single non-NA logical value") + # checking configure if (length(newformCommonItemNames) != length(oldformCommonItemNames)) { stop('Common Items are not equal') diff --git a/tests/testthat/test-autoFIPC.R b/tests/testthat/test-autoFIPC.R index 4f96869..13cecd9 100644 --- a/tests/testthat/test-autoFIPC.R +++ b/tests/testthat/test-autoFIPC.R @@ -66,4 +66,26 @@ test_that("autoFIPC validates input types securely", { ), "Security Error: oldformYData must be a data.frame, matrix, or a valid fitted mirt model" ) + + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + tryFitwholeNewItems = "TRUE" + ), + "Security Error: tryFitwholeNewItems must be a single non-NA logical value" + ) + + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + tryEM = NA + ), + "Security Error: tryEM must be a single non-NA logical value" + ) }) From 0104bdee59e8871cb5a16a0dc17536362f995624 Mon Sep 17 00:00:00 2001 From: Seongho Bae Date: Sat, 11 Jul 2026 07:43:39 +0900 Subject: [PATCH 2/3] fix: restore surveyFA fallback implementation --- .Rbuildignore | 4 + DESCRIPTION | 1 + NAMESPACE | 1 - R/aFIPC.R | 14 +- R/surveyFA.R | 233 +++++++++++++++++++++++++++++++-- man/autoFIPC.Rd | 8 +- man/surveyFA.Rd | 23 +++- tests/testthat/test-surveyFA.R | 61 +++++++++ 8 files changed, 326 insertions(+), 19 deletions(-) create mode 100644 tests/testthat/test-surveyFA.R diff --git a/.Rbuildignore b/.Rbuildignore index 81e02e1..232504f 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -5,6 +5,10 @@ ^\.Rprofile$ ^\.github$ ^\.github/.* +^\.codegraph$ +^\.codegraph/.* +^.*\.Rcheck$ +^.*\.tar\.gz$ ^\.yamllint\.yml$ ^AGENTS\.md$ ^ARCHITECTURE\.md$ diff --git a/DESCRIPTION b/DESCRIPTION index 4a69049..f31d3e1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -2,6 +2,7 @@ Package: aFIPC Type: Package Title: Automated Fixed Item Parameter Linking Version: 0.1.0 +Author: Seongho Bae [aut, cre] Maintainer: Seongho Bae Authors@R: person(given = "Seongho", family = "Bae", role = c("aut", "cre"), email = "seongho@kw.ac.kr") diff --git a/NAMESPACE b/NAMESPACE index 9f3114a..8bcfee9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -3,4 +3,3 @@ export(autoFIPC) export(surveyFA) import(mirt) -importFrom(stats,factanal) diff --git a/R/aFIPC.R b/R/aFIPC.R index 63c5f97..1905c64 100644 --- a/R/aFIPC.R +++ b/R/aFIPC.R @@ -25,7 +25,13 @@ #' #' @examples #' \dontrun{ -#' autoFIPC() ## FIXME +#' autoFIPC( +#' newformXData = new_model, +#' oldformYData = old_model, +#' newformCommonItemNames = common_new, +#' oldformCommonItemNames = common_old, +#' confirmCommonItems = TRUE +#' ) #' } autoFIPC <- function( @@ -62,7 +68,7 @@ autoFIPC <- }, error = function(e) FALSE, warning = function(w) FALSE) if (!isTRUE(ok)) return(FALSE) required_slots <- c("OptimInfo", "ParObjects") - return(all(required_slots %in% slotNames(x))) + return(all(required_slots %in% methods::slotNames(x))) } if (!is.data.frame(newformXData) && !is.matrix(newformXData) && !isRealMirtModel(newformXData)) { stop("Security Error: newformXData must be a data.frame, matrix, or a valid fitted mirt model") @@ -763,8 +769,8 @@ autoFIPC <- if ( !is.na(newFormItemName) && !is.na(oldFormItemName) && - (length(na.omit(unique(newFormModel@Data$data[, newFormItemName]))) == - length(na.omit(unique(oldFormModel@Data$data[, oldFormItemName])))) + (length(stats::na.omit(unique(newFormModel@Data$data[, newFormItemName]))) == + length(stats::na.omit(unique(oldFormModel@Data$data[, oldFormItemName])))) ) { message( 'applying ', diff --git a/R/surveyFA.R b/R/surveyFA.R index 9fefee0..b7b471d 100644 --- a/R/surveyFA.R +++ b/R/surveyFA.R @@ -1,11 +1,228 @@ #' @title surveyFA -#' @description Stub for surveyFA -#' @param ... Arguments passed to the function -#' @return NULL -#' @importFrom stats factanal +#' @description Fallback calibration helper used when direct model estimation in +#' `autoFIPC()` fails. +#' @param data A response matrix or data frame. +#' @param autofix When TRUE, remove least-fitting items and retry calibration. +#' @param forceUIRT Kept for legacy compatibility; the fallback is only executed +#' in this mode. +#' @param forceNormalEM Force normal EM/MMLE estimation for the fallback attempt. +#' @param forceMHRM Force MHRM-based estimation when other approaches fail. +#' @param unstable Apply a more permissive retry sequence including QMCEM/MHRM. +#' @param SE Whether to request standard errors from `mirt`. +#' @param itemtype IRT item type for fallback estimation. +#' @param maxItemRemovals Maximum number of items to remove in autofix mode. +#' @param pThreshold p-value cutoff for selecting the first misfit item. +#' @param ... Additional arguments reserved for compatibility. +#' @return A fitted `mirt` model object. #' @export -surveyFA <- function(...) { - # Stub function to satisfy R CMD check until real implementation is provided - message("surveyFA is currently a stub.") - NULL +surveyFA <- function( + data, + autofix = TRUE, + forceUIRT = TRUE, + forceNormalEM = FALSE, + forceMHRM = FALSE, + unstable = FALSE, + SE = TRUE, + itemtype = "2PL", + maxItemRemovals = 3L, + pThreshold = 0.05, + ... +) { + if (!isTRUE(forceUIRT)) { + stop( + "surveyFA requires forceUIRT=TRUE; fallback requires explicit legacy-mode activation.", + call. = FALSE + ) + } + + if (!is.data.frame(data) && !is.matrix(data)) { + stop("surveyFA requires a response matrix or data frame.", call. = FALSE) + } + + response_data <- as.data.frame(data) + response_data <- + response_data[, vapply(response_data, function(column) { + nunique <- length(unique(stats::na.omit(column))) + nunique >= 2L + }, logical(1L))] + + if (nrow(response_data) == 0L || ncol(response_data) < 2L) { + stop("surveyFA needs at least two non-constant response columns.", call. = FALSE) + } + + is_acceptable_model <- function(model) { + if (!inherits(model, "SingleGroupClass")) { + return(FALSE) + } + + converged <- tryCatch(model@OptimInfo$converged, error = function(e) FALSE) + if (!isTRUE(converged)) { + return(FALSE) + } + + log_likelihood <- tryCatch( + model@Fit$logLik[1], + error = function(e) NA_real_ + ) + if (!is.finite(log_likelihood)) { + return(FALSE) + } + + second_order <- tryCatch( + model@OptimInfo$secondordertest, + error = function(e) NA + ) + if (is.logical(second_order) && isFALSE(second_order)) { + return(FALSE) + } + + TRUE + } + + try_fit <- function(response_data, method_name) { + fit_args <- list( + data = response_data, + model = 1, + itemtype = itemtype, + SE = SE, + GenRandomPars = FALSE + ) + + if (method_name == "EM") { + fit_args$method <- "EM" + fit_args$technical <- list(NCYCLES = 1e5) + fit_args$empiricalhist <- TRUE + } else if (method_name == "QMCEM") { + fit_args$method <- "QMCEM" + fit_args$technical <- list(NCYCLES = 1e5) + } else if (method_name == "MHRM") { + fit_args$method <- "MHRM" + fit_args$technical <- list(NCYCLES = 1e5, MHRM_SE_draws = 200000) + } else { + return(NA) + } + + if (method_name == "MHRM") { + fit <- NA + for (attempt in seq_len(3L)) { + fit <- tryCatch( + do.call(mirt::mirt, fit_args), + error = function(err) { + warning( + "fallback surveyFA mirt MHRM attempt #", + attempt, + " failed: ", + err$message, + call. = FALSE + ) + NA + } + ) + if (inherits(fit, "SingleGroupClass")) { + break + } + } + fit + } else { + tryCatch( + do.call(mirt::mirt, fit_args), + error = function(err) { + warning(err$message, call. = FALSE) + NA + } + ) + } + } + + select_bad_item <- function(fitted_model, response_data) { + fit_df <- tryCatch( + suppressWarnings(mirt::itemfit(fitted_model, fit_stats = "S_X2")), + error = function(e) NA, + warning = function(w) { + tryCatch( + mirt::itemfit(fitted_model, fit_stats = "PV_Q1*"), + error = function(err) NA + ) + } + ) + + p_col_candidates <- c("p", "p.value", "pval", "P") + if (!is.data.frame(fit_df)) { + return(NA_character_) + } + + active <- intersect(names(response_data), rownames(fit_df)) + if (length(active) == 0L) { + return(NA_character_) + } + + fit_df <- fit_df[active, , drop = FALSE] + p_col <- intersect(p_col_candidates, colnames(fit_df)) + if (length(p_col) > 0L) { + p_values <- suppressWarnings(as.numeric(fit_df[[p_col[1L]]])) + names(p_values) <- rownames(fit_df) + if (any(!is.na(p_values))) { + p_values[is.na(p_values)] <- 1 + candidate <- names(sort(p_values, decreasing = FALSE))[1L] + if (!is.na(candidate) && p_values[[candidate]] < pThreshold) { + return(candidate) + } + } + } + + v <- vapply( + response_data[active], + function(x) stats::var(as.numeric(x), na.rm = TRUE), + numeric(1L) + ) + names(v) <- active + v[!is.finite(v)] <- -Inf + candidate <- names(which.min(v)) + if (length(candidate) == 0L) NA_character_ else candidate + } + + removed <- character() + methods <- c("QMCEM", "EM", "MHRM") + if (forceNormalEM) { + methods <- c("EM", "QMCEM", "MHRM") + } else if (forceMHRM) { + methods <- c("MHRM", "QMCEM", "EM") + } else if (unstable) { + methods <- c("QMCEM", "MHRM", "EM") + } + + for (removal_round in seq_len(maxItemRemovals + 1L)) { + fitted <- NA + for (method_name in methods) { + fitted <- try_fit(response_data, method_name) + if (is_acceptable_model(fitted)) { + if ( + is.logical(fitted@OptimInfo$secondordertest) && + is.na(fitted@OptimInfo$secondordertest) + ) { + fitted@OptimInfo$secondordertest <- TRUE + } + return(fitted) + } + } + + if (!autofix || ncol(response_data) <= 2L || removal_round > maxItemRemovals) { + break + } + + bad_item <- select_bad_item(fitted, response_data) + if (identical(bad_item, NA_character_) || bad_item %in% removed) { + break + } + + response_data <- response_data[, names(response_data) != bad_item, drop = FALSE] + removed <- c(removed, bad_item) + } + + stop( + "surveyFA fallback could not estimate a valid model after bounded recovery attempts. ", + "Removed items: ", + if (length(removed) == 0L) "none" else paste(removed, collapse = ", "), + call. = FALSE + ) } diff --git a/man/autoFIPC.Rd b/man/autoFIPC.Rd index 2bd6f3f..cc702b2 100644 --- a/man/autoFIPC.Rd +++ b/man/autoFIPC.Rd @@ -67,6 +67,12 @@ automated fixed item parameter linking } \examples{ \dontrun{ -autoFIPC() ## FIXME +autoFIPC( + newformXData = new_model, + oldformYData = old_model, + newformCommonItemNames = common_new, + oldformCommonItemNames = common_old, + confirmCommonItems = TRUE +) } } diff --git a/man/surveyFA.Rd b/man/surveyFA.Rd index 1197693..823089a 100644 --- a/man/surveyFA.Rd +++ b/man/surveyFA.Rd @@ -1,14 +1,27 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/surveyFA.R \name{surveyFA} \alias{surveyFA} \title{surveyFA} \usage{ -surveyFA(...) +surveyFA(data, autofix = TRUE, forceUIRT = TRUE, forceNormalEM = FALSE, + forceMHRM = FALSE, unstable = FALSE, SE = TRUE, itemtype = "2PL", + maxItemRemovals = 3L, pThreshold = 0.05, ...) } \arguments{ -\item{...}{Arguments passed to the function} +\item{data}{A response matrix or data frame.} +\item{autofix}{When TRUE, remove least-fitting items and retry calibration.} +\item{forceUIRT}{Kept for legacy compatibility; fallback requires TRUE.} +\item{forceNormalEM}{Force normal EM/MMLE estimation for fallback attempts.} +\item{forceMHRM}{Force MHRM-based estimation for fallback attempts.} +\item{unstable}{Use a permissive estimator sequence including QMCEM and MHRM.} +\item{SE}{Whether to request standard errors from \code{mirt}.} +\item{itemtype}{IRT item type for fallback estimation.} +\item{maxItemRemovals}{Maximum number of items to remove in autofix mode.} +\item{pThreshold}{p-value cutoff for selecting misfitting items.} +\item{...}{Additional arguments reserved for compatibility.} } \description{ -Stub for surveyFA +Fallback calibration helper used when direct \code{autoFIPC()} estimation fails. +} +\value{ +A fitted \code{mirt} model object. } diff --git a/tests/testthat/test-surveyFA.R b/tests/testthat/test-surveyFA.R new file mode 100644 index 0000000..5a08f88 --- /dev/null +++ b/tests/testthat/test-surveyFA.R @@ -0,0 +1,61 @@ +test_that("surveyFA can recover with bounded autofix for messy response data", { + skip_if_not_installed("mirt") + set.seed(20260702) + + raw <- as.data.frame( + mirt::simdata( + a = matrix(c( + 1.00, 1.20, 0.95, 1.08, 1.12, + 0.90, 1.05, 1.18, 1.22, 0.88 + ), ncol = 1), + d = c(-1.0, -0.45, -0.10, 0.30, 0.70, -0.65, 0.20, 0.55, 0.95, -0.30), + itemtype = rep("2PL", 10), + N = 200 + ) + ) + names(raw) <- paste0("item", seq_len(ncol(raw))) + raw$item11 <- 1 + + fitted <- aFIPC::surveyFA( + data = raw, + autofix = TRUE, + forceUIRT = TRUE, + forceNormalEM = TRUE, + SE = FALSE + ) + + expect_true(inherits(fitted, "SingleGroupClass")) + expect_true(fitted@OptimInfo$secondordertest) +}) + +test_that("surveyFA errors clearly for unsupported input", { + expect_error( + aFIPC::surveyFA(1:10, forceUIRT = TRUE), + "surveyFA requires a response matrix or data frame" + ) +}) + +test_that("surveyFA reports bounded recovery exhaustion when unrecoverable", { + skip_if_not_installed("mirt") + + raw <- as.data.frame( + matrix( + c(rbinom(80, 1, 0.5), rbinom(80, 1, 0.4)), + ncol = 2 + ) + ) + names(raw) <- paste0("item", 1:2) + + expect_error( + suppressWarnings( + aFIPC::surveyFA( + data = raw, + autofix = TRUE, + forceUIRT = TRUE, + itemtype = "not_a_model", + maxItemRemovals = 1 + ) + ), + "could not estimate a valid model after bounded recovery attempts" + ) +}) From b986a82f38cb358b8699764ffca99c956bb294b0 Mon Sep 17 00:00:00 2001 From: Seongho Bae Date: Sat, 11 Jul 2026 08:36:16 +0900 Subject: [PATCH 3/3] Harden surveyFA fallback stability checks --- .jules/sentinel.md | 1 + R/surveyFA.R | 79 ++++++++++++++++++++++++++++++---- man/surveyFA.Rd | 3 +- tests/testthat/test-surveyFA.R | 27 +++++++++++- 4 files changed, 99 insertions(+), 11 deletions(-) diff --git a/.jules/sentinel.md b/.jules/sentinel.md index cdac086..2ab0fb3 100644 --- a/.jules/sentinel.md +++ b/.jules/sentinel.md @@ -46,3 +46,4 @@ **Prevention:** 1. Always implement explicit, short-circuited runtime type validation for scalar boolean inputs. 2. The standard secure pattern in R is `if (!is.logical(x) || length(x) != 1 || is.na(x)) stop("...")`. The `||` operator correctly avoids evaluating `is.na(x)` if the length is strictly checked first. +3. IRT fallback estimators must not convert `secondordertest = NA` into `TRUE`; with `SE = TRUE`, require a passing second-order test and finite covariance estimates before returning a model. diff --git a/R/surveyFA.R b/R/surveyFA.R index b7b471d..f60fffd 100644 --- a/R/surveyFA.R +++ b/R/surveyFA.R @@ -13,7 +13,8 @@ #' @param maxItemRemovals Maximum number of items to remove in autofix mode. #' @param pThreshold p-value cutoff for selecting the first misfit item. #' @param ... Additional arguments reserved for compatibility. -#' @return A fitted `mirt` model object. +#' @return A fitted `mirt` model object with finite log-likelihood and, when +#' `SE = TRUE`, a passing second-order test plus finite covariance estimates. #' @export surveyFA <- function( data, @@ -28,7 +29,23 @@ surveyFA <- function( pThreshold = 0.05, ... ) { - if (!isTRUE(forceUIRT)) { + validate_logical_scalar <- function(value, name) { + if (!is.logical(value) || length(value) != 1L || is.na(value)) { + stop( + sprintf("Security Error: %s must be a single non-NA logical value", name), + call. = FALSE + ) + } + } + + validate_logical_scalar(autofix, "autofix") + validate_logical_scalar(forceUIRT, "forceUIRT") + validate_logical_scalar(forceNormalEM, "forceNormalEM") + validate_logical_scalar(forceMHRM, "forceMHRM") + validate_logical_scalar(unstable, "unstable") + validate_logical_scalar(SE, "SE") + + if (!forceUIRT) { stop( "surveyFA requires forceUIRT=TRUE; fallback requires explicit legacy-mode activation.", call. = FALSE @@ -39,6 +56,30 @@ surveyFA <- function( stop("surveyFA requires a response matrix or data frame.", call. = FALSE) } + if (!is.character(itemtype) || length(itemtype) != 1L || is.na(itemtype)) { + stop("surveyFA requires itemtype to be a single non-NA character value.", call. = FALSE) + } + + if ( + !is.numeric(maxItemRemovals) || + length(maxItemRemovals) != 1L || + is.na(maxItemRemovals) || + maxItemRemovals < 0 + ) { + stop("surveyFA requires maxItemRemovals to be a non-negative numeric scalar.", call. = FALSE) + } + maxItemRemovals <- as.integer(maxItemRemovals) + + if ( + !is.numeric(pThreshold) || + length(pThreshold) != 1L || + is.na(pThreshold) || + pThreshold <= 0 || + pThreshold > 1 + ) { + stop("surveyFA requires pThreshold to be in (0, 1].", call. = FALSE) + } + response_data <- as.data.frame(data) response_data <- response_data[, vapply(response_data, function(column) { @@ -50,6 +91,28 @@ surveyFA <- function( stop("surveyFA needs at least two non-constant response columns.", call. = FALSE) } + has_finite_covariance <- function(model) { + covariance <- tryCatch( + { + direct <- model@vcov + if (is.null(direct) || length(direct) == 0L) { + stats::vcov(model) + } else { + direct + } + }, + error = function(e) { + tryCatch(stats::vcov(model), error = function(err) NA) + } + ) + + covariance <- suppressWarnings(as.matrix(covariance)) + is.numeric(covariance) && + length(covariance) > 0L && + all(dim(covariance) > 0L) && + all(is.finite(covariance)) + } + is_acceptable_model <- function(model) { if (!inherits(model, "SingleGroupClass")) { return(FALSE) @@ -75,6 +138,12 @@ surveyFA <- function( if (is.logical(second_order) && isFALSE(second_order)) { return(FALSE) } + if (SE && !identical(second_order, TRUE)) { + return(FALSE) + } + if (SE && !has_finite_covariance(model)) { + return(FALSE) + } TRUE } @@ -196,12 +265,6 @@ surveyFA <- function( for (method_name in methods) { fitted <- try_fit(response_data, method_name) if (is_acceptable_model(fitted)) { - if ( - is.logical(fitted@OptimInfo$secondordertest) && - is.na(fitted@OptimInfo$secondordertest) - ) { - fitted@OptimInfo$secondordertest <- TRUE - } return(fitted) } } diff --git a/man/surveyFA.Rd b/man/surveyFA.Rd index 823089a..fcc7b45 100644 --- a/man/surveyFA.Rd +++ b/man/surveyFA.Rd @@ -23,5 +23,6 @@ surveyFA(data, autofix = TRUE, forceUIRT = TRUE, forceNormalEM = FALSE, Fallback calibration helper used when direct \code{autoFIPC()} estimation fails. } \value{ -A fitted \code{mirt} model object. +A fitted \code{mirt} model object with finite log-likelihood and, when +\code{SE = TRUE}, a passing second-order test plus finite covariance estimates. } diff --git a/tests/testthat/test-surveyFA.R b/tests/testthat/test-surveyFA.R index 5a08f88..060ae68 100644 --- a/tests/testthat/test-surveyFA.R +++ b/tests/testthat/test-surveyFA.R @@ -21,11 +21,14 @@ test_that("surveyFA can recover with bounded autofix for messy response data", { autofix = TRUE, forceUIRT = TRUE, forceNormalEM = TRUE, - SE = FALSE + SE = TRUE ) + fitted_vcov <- as.matrix(fitted@vcov) expect_true(inherits(fitted, "SingleGroupClass")) - expect_true(fitted@OptimInfo$secondordertest) + expect_gt(nrow(fitted_vcov), 0) + expect_true(all(is.finite(diag(fitted_vcov)))) + expect_true(isTRUE(fitted@OptimInfo$secondordertest)) }) test_that("surveyFA errors clearly for unsupported input", { @@ -35,6 +38,26 @@ test_that("surveyFA errors clearly for unsupported input", { ) }) +test_that("surveyFA validates boolean control flags before estimator dispatch", { + raw <- data.frame( + item1 = c(0, 1, 0, 1), + item2 = c(1, 0, 1, 0) + ) + + expect_error( + aFIPC::surveyFA(raw, autofix = c(TRUE, FALSE)), + "Security Error: autofix must be a single non-NA logical value" + ) + expect_error( + aFIPC::surveyFA(raw, forceNormalEM = NA), + "Security Error: forceNormalEM must be a single non-NA logical value" + ) + expect_error( + aFIPC::surveyFA(raw, SE = "TRUE"), + "Security Error: SE must be a single non-NA logical value" + ) +}) + test_that("surveyFA reports bounded recovery exhaustion when unrecoverable", { skip_if_not_installed("mirt")