diff --git a/R/aFIPC.R b/R/aFIPC.R index 62546519..c8bdc58a 100644 --- a/R/aFIPC.R +++ b/R/aFIPC.R @@ -770,8 +770,8 @@ autoFIPC <- if ( !is.na(newFormItemName) && !is.na(oldFormItemName) && - (length(stats::na.omit(unique(newFormModel@Data$data[, newFormItemName]))) == - length(stats::na.omit(unique(oldFormModel@Data$data[, oldFormItemName])))) + (sum(!is.na(unique(newFormModel@Data$data[, newFormItemName]))) == + sum(!is.na(unique(oldFormModel@Data$data[, oldFormItemName])))) ) { message( 'applying ', diff --git a/R/surveyFA.R b/R/surveyFA.R index f60fffd8..787c1cc9 100644 --- a/R/surveyFA.R +++ b/R/surveyFA.R @@ -83,7 +83,7 @@ surveyFA <- function( response_data <- as.data.frame(data) response_data <- response_data[, vapply(response_data, function(column) { - nunique <- length(unique(stats::na.omit(column))) + nunique <- sum(!is.na(unique(column))) nunique >= 2L }, logical(1L))] diff --git a/tests/testthat/test-optimization-equivalence.R b/tests/testthat/test-optimization-equivalence.R index 02ce2f74..9a7ab62b 100644 --- a/tests/testthat/test-optimization-equivalence.R +++ b/tests/testthat/test-optimization-equivalence.R @@ -1,74 +1,64 @@ # Formula-integrity regression guards for performance refactors. # -# These tests pin the two formula-bearing expressions that recent "Bolt" -# performance refactors rewrote, so any future re-optimization that silently -# changes their meaning is caught. Values below are hand-computed references, -# not a re-encoding of the current implementation. -# -# Audited refactors: -# * #56 (fc8bbfb): response-category count guard rewritten from -# length(levels(as.factor(x))) -> length(na.omit(unique(x))) -# Both count DISTINCT NON-MISSING response categories. This guard decides -# whether an old/new common-item pair may be linked (Kim, 2006: an anchor -# item must share the same response structure on both forms). -# * #99 (d73adbd): IPD common-item extraction rewritten from a per-column -# for-loop over IPDItemList[cols][row, i] -# to a vectorized -# as.character(unlist(IPDItemList[row, cols])). -# Row 1 = old-form anchor names, row 2 = new-form anchor names, restricted -# to the columns that survived IPD screening (CommonItemList_NOIPD). +# These tests pin formula-bearing expressions that performance refactors rewrite. +# Expected values are hand-computed references rather than copies of production +# implementation, and legacy expressions remain only as compatibility oracles. -test_that("category-count guard counts distinct non-missing categories (#56)", { +test_that("category-count guard counts distinct non-missing categories", { vecs <- list( - dichotomous = c(0, 1, 0, 1, 1, 0), + dichotomous = c(0, 1, 0, 1, 1, 0), trichotomous_w_na = c(0, 1, 2, NA, 2, 1, 0), - constant = c(0, 0, 0, 0), - four_category_w_na = c(0, 1, 2, 3, 3, NA, 1) + numeric_w_nan = c(1, NaN, 2, NA, 2, 1), + character_w_na = c("A", "B", NA, "A", "C"), + factor_w_na = factor(c("A", "B", NA, "A", "C"), levels = c("A", "B", "C", "unused")), + constant = c(0, 0, 0, 0) ) - # Independent hand-computed reference (distinct non-missing categories). expected <- c( - dichotomous = 2L, - trichotomous_w_na = 3L, - constant = 1L, - four_category_w_na = 4L + dichotomous = 2L, + trichotomous_w_na = 3L, + numeric_w_nan = 2L, + character_w_na = 3L, + factor_w_na = 3L, + constant = 1L ) - new_idiom <- vapply( + candidate <- vapply( + vecs, + function(x) as.integer(sum(!is.na(unique(x)))), + integer(1) + ) + legacy_unique_then_omit <- vapply( vecs, - function(x) length(na.omit(unique(x))), + function(x) length(stats::na.omit(unique(x))), integer(1) ) - legacy_idiom <- vapply( + legacy_omit_then_unique <- vapply( vecs, - function(x) length(levels(as.factor(x))), + function(x) length(unique(stats::na.omit(x))), integer(1) ) - expect_equal(new_idiom, expected) - # The refactor must remain equivalent to the pre-#56 expression. - expect_equal(unname(new_idiom), unname(legacy_idiom)) + expect_equal(candidate, expected) + expect_identical(candidate, legacy_unique_then_omit) + expect_identical(candidate, legacy_omit_then_unique) }) test_that("IPD anchor extraction keeps old/new rows and screened columns (#99)", { old_anchor_names <- c("old_1", "old_2", "old_3") new_anchor_names <- c("new_1", "new_2", "new_3") - # Mirror how autoFIPC() builds IPDItemList and names its columns. IPDItemList <- data.frame(rbind(old_anchor_names, new_anchor_names)) colnames(IPDItemList) <- paste0("X", seq_along(old_anchor_names)) - # Item X2 is flagged as showing drift and dropped from the anchor set. CommonItemList_NOIPD <- c("X1", "X3") actual_old <- as.character(unlist(IPDItemList[1, CommonItemList_NOIPD])) actual_new <- as.character(unlist(IPDItemList[2, CommonItemList_NOIPD])) - # Independent hand-computed reference. expect_equal(actual_old, c("old_1", "old_3")) expect_equal(actual_new, c("new_1", "new_3")) - # The vectorized refactor must match the pre-#99 element-wise loop. legacy_old <- character(length(CommonItemList_NOIPD)) legacy_new <- character(length(CommonItemList_NOIPD)) for (i in seq_along(CommonItemList_NOIPD)) {