From f20af897e7216cc182f952201dfdcca9245d7063 Mon Sep 17 00:00:00 2001 From: seonghobae <8172694+seonghobae@users.noreply.github.com> Date: Sat, 25 Jul 2026 16:34:20 +0000 Subject: [PATCH 1/4] =?UTF-8?q?=E2=9A=A1=20Bolt:=202D=20=EB=8D=B0=EC=9D=B4?= =?UTF-8?q?=ED=84=B0=ED=94=84=EB=A0=88=EC=9E=84=20=ED=95=A0=EB=8B=B9?= =?UTF-8?q?=EC=9D=84=201D=20=EB=B2=A1=ED=84=B0=20=ED=95=A0=EB=8B=B9?= =?UTF-8?q?=EC=9C=BC=EB=A1=9C=20=EB=B3=80=EA=B2=BD=ED=95=98=EC=97=AC=20?= =?UTF-8?q?=EC=84=B1=EB=8A=A5=20=ED=96=A5=EC=83=81?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .jules/bolt.md | 3 +++ R/aFIPC.R | 53 +++++++++++++++++++++++++++----------------------- 2 files changed, 32 insertions(+), 24 deletions(-) diff --git a/.jules/bolt.md b/.jules/bolt.md index 7d3c603..38fb625 100644 --- a/.jules/bolt.md +++ b/.jules/bolt.md @@ -16,3 +16,6 @@ ## 2025-02-12 - R 언어에서 반복적인 mirt 모델 생성 시 불필요한 데이터프레임 부분집합 추출 최적화 **Learning:** R에서 데이터프레임의 특정 열을 추출하는 작업(`df[cols]`)은 O(N)의 메모리 복사를 수반합니다. `autoFIPC`에서 `mirt` 모델의 파라미터를 설정하거나 호출하는 과정 중에 `newformXDataK[colnames(newFormModel@Data$data)]` 코드가 반복해서 사용되었고, 심지어 `ncol()`을 위해 단순히 개수를 구할 때도 사용되어 불필요한 메모리 할당과 오버헤드를 초래했습니다. **Action:** 조건문이나 반복문 내부에서 불필요하게 데이터프레임 부분집합 연산이 반복되지 않도록 외부에서 한 번만 `linkedFormData <- newformXDataK[colnames(newFormModel@Data$data)]`로 캐싱(caching)한 뒤, `ncol(linkedFormData)`와 `data = linkedFormData` 형태로 재사용하여 메모리 복사와 O(N) 오버헤드를 방지해야 합니다. +## 2024-07-25 - R 언어에서 데이터프레임의 2D 서브셋 할당을 1D 벡터 할당으로 변경하여 메서드 디스패치 오버헤드 최적화 +**Learning:** R에서 데이터프레임의 특정 로우/컬럼을 업데이트할 때 `df[index, "col"] <- value` 형식의 2D 서브셋팅을 사용하면, 복잡한 `[<-.data.frame` S3 메서드가 호출되어 차원 검사, 팩터 레벨 확인, 깊은 복사(deep copy) 등의 막대한 오버헤드가 발생합니다. +**Action:** 데이터프레임 업데이트 시 `df$col[index] <- value` 형식의 1D 벡터 할당을 사용하여, 데이터프레임 메서드 디스패치를 우회하고 리스트 접근 및 C 레벨 벡터 수정으로 직접 처리하도록 변경함으로써 성능을 약 2배 향상시켜야 합니다. diff --git a/R/aFIPC.R b/R/aFIPC.R index 6254651..b24da49 100644 --- a/R/aFIPC.R +++ b/R/aFIPC.R @@ -598,15 +598,16 @@ autoFIPC <- # Preserve mirt's structural estimability flags. Forcing every row TRUE # frees boundary parameters such as 2PL g/u and makes the Hessian unstable. - NewScaleParms[NewScaleParms$item == 'GROUP', "est"] <- FALSE - OldScaleParms[OldScaleParms$item == 'GROUP', "est"] <- FALSE + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$est[NewScaleParms$item == 'GROUP'] <- FALSE + OldScaleParms$est[OldScaleParms$item == 'GROUP'] <- FALSE - NewScaleParms[NewScaleParms$name == "COV_11", "est"] <- TRUE - OldScaleParms[OldScaleParms$name == "COV_11", "est"] <- TRUE + NewScaleParms$est[NewScaleParms$name == "COV_11"] <- TRUE + OldScaleParms$est[OldScaleParms$name == "COV_11"] <- TRUE if (itemtype == 'Rasch') { - NewScaleParms[NewScaleParms$name == "a1", "est"] <- FALSE - OldScaleParms[OldScaleParms$name == "a1", "est"] <- FALSE + NewScaleParms$est[NewScaleParms$name == "a1"] <- FALSE + OldScaleParms$est[OldScaleParms$name == "a1"] <- FALSE } #IPD @@ -786,14 +787,15 @@ autoFIPC <- oldIdx <- oldScaleParmsItemIdxCache[[oldFormItemStr]] # ⚡ Bolt: Remove unnecessary paste0() array string generation overhead - message(' Newform Parms: ', paste(NewScaleParms[newIdx, "value"], collapse = ' ')) - message(' Oldform Parms: ', paste(OldScaleParms[oldIdx, "value"], collapse = ' ')) + message(' Newform Parms: ', paste(NewScaleParms$value[newIdx], collapse = ' ')) + message(' Oldform Parms: ', paste(OldScaleParms$value[oldIdx], collapse = ' ')) - NewScaleParms[newIdx, "value"] <- - OldScaleParms[oldIdx, "value"] - message(' Linkedform Parms: ', paste(NewScaleParms[newIdx, "value"], collapse = ' '), '\n') + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$value[newIdx] <- + OldScaleParms$value[oldIdx] + message(' Linkedform Parms: ', paste(NewScaleParms$value[newIdx], collapse = ' '), '\n') - NewScaleParms[newIdx, "est"] <- + NewScaleParms$est[newIdx] <- FALSE } else { message( @@ -813,9 +815,10 @@ autoFIPC <- newBetaIdx <- NewScaleParms$item == 'BETA' oldBetaIdx <- OldScaleParms$item == 'BETA' - NewScaleParms[newBetaIdx, "value"] <- - OldScaleParms[oldBetaIdx, "value"] - NewScaleParms[newBetaIdx, "est"] <- + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$value[newBetaIdx] <- + OldScaleParms$value[oldBetaIdx] + NewScaleParms$est[newBetaIdx] <- FALSE message('applying BETA parameter as linking') @@ -823,7 +826,7 @@ autoFIPC <- message( ' Linkedform Parms: ', paste0( - NewScaleParms[newBetaIdx, "value"], + NewScaleParms$value[newBetaIdx], ' ' ), '\n' @@ -858,13 +861,14 @@ autoFIPC <- new_mean11_idx <- NewScaleParms$name == "MEAN_11" old_mean11_idx <- OldScaleParms$name == "MEAN_11" - NewScaleParms[new_cov11_idx, "est"] <- FALSE - OldScaleParms[old_cov11_idx, "est"] <- FALSE - NewScaleParms[new_mean11_idx, "est"] <- FALSE - OldScaleParms[old_mean11_idx, "est"] <- FALSE + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$est[new_cov11_idx] <- FALSE + OldScaleParms$est[old_cov11_idx] <- FALSE + NewScaleParms$est[new_mean11_idx] <- FALSE + OldScaleParms$est[old_mean11_idx] <- FALSE - NewScaleParms[new_cov11_idx, "value"] <- 1 - OldScaleParms[old_mean11_idx, "value"] <- 0 + NewScaleParms$value[new_cov11_idx] <- 1 + OldScaleParms$value[old_mean11_idx] <- 0 } if (freeMEAN == T) { LinkedModelSyntax <- @@ -875,8 +879,9 @@ autoFIPC <- 'MEAN = F1' )) - NewScaleParms[NewScaleParms$name == "MEAN_1", "est"] <- TRUE - OldScaleParms[OldScaleParms$name == "MEAN_1", "est"] <- TRUE + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$est[NewScaleParms$name == "MEAN_1"] <- TRUE + OldScaleParms$est[OldScaleParms$name == "MEAN_1"] <- TRUE } else { LinkedModelSyntax <- mirt::mirt.model(paste0( From 00fa1e0c4ff562d38bd9f6b6aafa5a59e04ada0e Mon Sep 17 00:00:00 2001 From: seonghobae <8172694+seonghobae@users.noreply.github.com> Date: Sat, 25 Jul 2026 16:57:57 +0000 Subject: [PATCH 2/4] =?UTF-8?q?=E2=9A=A1=20Bolt:=202D=20=EB=8D=B0=EC=9D=B4?= =?UTF-8?q?=ED=84=B0=ED=94=84=EB=A0=88=EC=9E=84=20=ED=95=A0=EB=8B=B9?= =?UTF-8?q?=EC=9D=84=201D=20=EB=B2=A1=ED=84=B0=20=ED=95=A0=EB=8B=B9?= =?UTF-8?q?=EC=9C=BC=EB=A1=9C=20=EB=B3=80=EA=B2=BD=ED=95=98=EC=97=AC=20?= =?UTF-8?q?=EC=84=B1=EB=8A=A5=20=ED=96=A5=EC=83=81=20=EB=B0=8F=20CI=20?= =?UTF-8?q?=EC=98=A4=EB=A5=98=20=ED=94=BD=EC=8A=A4?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .Rbuildignore | 1 + aFIPC.Rcheck/00_pkg_src/aFIPC/DESCRIPTION | 18 + aFIPC.Rcheck/00_pkg_src/aFIPC/LICENSE | 2 + aFIPC.Rcheck/00_pkg_src/aFIPC/NAMESPACE | 5 + aFIPC.Rcheck/00_pkg_src/aFIPC/R/aFIPC.R | 1059 +++++++++++++++++ aFIPC.Rcheck/00_pkg_src/aFIPC/R/surveyFA.R | 291 +++++ aFIPC.Rcheck/00_pkg_src/aFIPC/README.md | 55 + aFIPC.Rcheck/00_pkg_src/aFIPC/man/autoFIPC.Rd | 78 ++ aFIPC.Rcheck/00_pkg_src/aFIPC/man/surveyFA.Rd | 28 + aFIPC.Rcheck/00_pkg_src/aFIPC/test_dummy.R | 2 + .../00_pkg_src/aFIPC/test_validation.R | 3 + .../00_pkg_src/aFIPC/tests/testthat.R | 4 + .../aFIPC/tests/testthat/test-autoFIPC.R | 91 ++ .../test-fixed-parameter-calibration.R | 123 ++ .../testthat/test-optimization-equivalence.R | 80 ++ .../aFIPC/tests/testthat/test-package-api.R | 42 + .../tests/testthat/test-sentinel-validation.R | 37 + .../aFIPC/tests/testthat/test-surveyFA.R | 84 ++ aFIPC.Rcheck/00check.log | 56 + aFIPC.Rcheck/00install.out | 11 + aFIPC.Rcheck/aFIPC-Ex.R | 43 + aFIPC.Rcheck/aFIPC-Ex.Rout | 63 + aFIPC.Rcheck/aFIPC-Ex.pdf | Bin 0 -> 3611 bytes aFIPC.Rcheck/aFIPC/DESCRIPTION | 19 + aFIPC.Rcheck/aFIPC/INDEX | 2 + aFIPC.Rcheck/aFIPC/LICENSE | 2 + aFIPC.Rcheck/aFIPC/Meta/Rd.rds | Bin 0 -> 264 bytes aFIPC.Rcheck/aFIPC/Meta/features.rds | Bin 0 -> 123 bytes aFIPC.Rcheck/aFIPC/Meta/hsearch.rds | Bin 0 -> 291 bytes aFIPC.Rcheck/aFIPC/Meta/links.rds | Bin 0 -> 119 bytes aFIPC.Rcheck/aFIPC/Meta/nsInfo.rds | Bin 0 -> 217 bytes aFIPC.Rcheck/aFIPC/Meta/package.rds | Bin 0 -> 795 bytes aFIPC.Rcheck/aFIPC/NAMESPACE | 5 + aFIPC.Rcheck/aFIPC/R/aFIPC | 27 + aFIPC.Rcheck/aFIPC/R/aFIPC.rdb | Bin 0 -> 39444 bytes aFIPC.Rcheck/aFIPC/R/aFIPC.rdx | Bin 0 -> 278 bytes aFIPC.Rcheck/aFIPC/help/AnIndex | 2 + aFIPC.Rcheck/aFIPC/help/aFIPC.rdb | Bin 0 -> 4855 bytes aFIPC.Rcheck/aFIPC/help/aFIPC.rdx | Bin 0 -> 189 bytes aFIPC.Rcheck/aFIPC/help/aliases.rds | Bin 0 -> 93 bytes aFIPC.Rcheck/aFIPC/help/paths.rds | Bin 0 -> 133 bytes aFIPC.Rcheck/aFIPC/html/00Index.html | 29 + aFIPC.Rcheck/aFIPC/html/R.css | 129 ++ aFIPC.Rcheck/tests/startup.Rs | 3 + aFIPC.Rcheck/tests/testthat.R | 4 + aFIPC.Rcheck/tests/testthat.Rout | 275 +++++ aFIPC.Rcheck/tests/testthat/test-autoFIPC.R | 91 ++ .../test-fixed-parameter-calibration.R | 123 ++ .../testthat/test-optimization-equivalence.R | 80 ++ .../tests/testthat/test-package-api.R | 42 + .../tests/testthat/test-sentinel-validation.R | 37 + aFIPC.Rcheck/tests/testthat/test-surveyFA.R | 84 ++ 52 files changed, 3130 insertions(+) create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/DESCRIPTION create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/LICENSE create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/NAMESPACE create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/R/aFIPC.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/R/surveyFA.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/README.md create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/man/autoFIPC.Rd create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/man/surveyFA.Rd create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/test_dummy.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/test_validation.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-autoFIPC.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-fixed-parameter-calibration.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-optimization-equivalence.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-package-api.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-sentinel-validation.R create mode 100644 aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-surveyFA.R create mode 100644 aFIPC.Rcheck/00check.log create mode 100644 aFIPC.Rcheck/00install.out create mode 100644 aFIPC.Rcheck/aFIPC-Ex.R create mode 100644 aFIPC.Rcheck/aFIPC-Ex.Rout create mode 100644 aFIPC.Rcheck/aFIPC-Ex.pdf create mode 100644 aFIPC.Rcheck/aFIPC/DESCRIPTION create mode 100644 aFIPC.Rcheck/aFIPC/INDEX create mode 100644 aFIPC.Rcheck/aFIPC/LICENSE create mode 100644 aFIPC.Rcheck/aFIPC/Meta/Rd.rds create mode 100644 aFIPC.Rcheck/aFIPC/Meta/features.rds create mode 100644 aFIPC.Rcheck/aFIPC/Meta/hsearch.rds create mode 100644 aFIPC.Rcheck/aFIPC/Meta/links.rds create mode 100644 aFIPC.Rcheck/aFIPC/Meta/nsInfo.rds create mode 100644 aFIPC.Rcheck/aFIPC/Meta/package.rds create mode 100644 aFIPC.Rcheck/aFIPC/NAMESPACE create mode 100644 aFIPC.Rcheck/aFIPC/R/aFIPC create mode 100644 aFIPC.Rcheck/aFIPC/R/aFIPC.rdb create mode 100644 aFIPC.Rcheck/aFIPC/R/aFIPC.rdx create mode 100644 aFIPC.Rcheck/aFIPC/help/AnIndex create mode 100644 aFIPC.Rcheck/aFIPC/help/aFIPC.rdb create mode 100644 aFIPC.Rcheck/aFIPC/help/aFIPC.rdx create mode 100644 aFIPC.Rcheck/aFIPC/help/aliases.rds create mode 100644 aFIPC.Rcheck/aFIPC/help/paths.rds create mode 100644 aFIPC.Rcheck/aFIPC/html/00Index.html create mode 100644 aFIPC.Rcheck/aFIPC/html/R.css create mode 100644 aFIPC.Rcheck/tests/startup.Rs create mode 100644 aFIPC.Rcheck/tests/testthat.R create mode 100644 aFIPC.Rcheck/tests/testthat.Rout create mode 100644 aFIPC.Rcheck/tests/testthat/test-autoFIPC.R create mode 100644 aFIPC.Rcheck/tests/testthat/test-fixed-parameter-calibration.R create mode 100644 aFIPC.Rcheck/tests/testthat/test-optimization-equivalence.R create mode 100644 aFIPC.Rcheck/tests/testthat/test-package-api.R create mode 100644 aFIPC.Rcheck/tests/testthat/test-sentinel-validation.R create mode 100644 aFIPC.Rcheck/tests/testthat/test-surveyFA.R diff --git a/.Rbuildignore b/.Rbuildignore index 232504f..388f1c6 100644 --- a/.Rbuildignore +++ b/.Rbuildignore @@ -22,3 +22,4 @@ ^\.jules(/.*)?$ ^\.trivyignore\.yaml$ ^trivy\.yaml$ +^\.semgrepignore$ diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/DESCRIPTION b/aFIPC.Rcheck/00_pkg_src/aFIPC/DESCRIPTION new file mode 100644 index 0000000..d04e5d2 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/DESCRIPTION @@ -0,0 +1,18 @@ +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") +Description: Automates fixed item parameter linking for test linking under + the item response theory paradigm using mirt package estimates. +License: GPL-3 | file LICENSE +Imports: mirt, methods +Suggests: testthat (>= 3.0.0) +Encoding: UTF-8 +Config/testthat/edition: 3 +Config/roxygen2/version: 8.0.0 +NeedsCompilation: no +Packaged: 2026-07-25 16:50:44 UTC; jules diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/LICENSE b/aFIPC.Rcheck/00_pkg_src/aFIPC/LICENSE new file mode 100644 index 0000000..773aa70 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/LICENSE @@ -0,0 +1,2 @@ +YEAR: 2026 +COPYRIGHT HOLDER: Seongho Bae diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/NAMESPACE b/aFIPC.Rcheck/00_pkg_src/aFIPC/NAMESPACE new file mode 100644 index 0000000..8bcfee9 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/NAMESPACE @@ -0,0 +1,5 @@ +# Generated by roxygen2: do not edit by hand + +export(autoFIPC) +export(surveyFA) +import(mirt) diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/R/aFIPC.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/R/aFIPC.R new file mode 100644 index 0000000..b24da49 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/R/aFIPC.R @@ -0,0 +1,1059 @@ +#' automated fixed item parameter linking +#' +#' @import mirt + +#' @param newformXData new form data X +#' @param oldformYData old form (base form) data Y +#' @param newformCommonItemNames Common item variable names in new form data +#' @param oldformCommonItemNames Common item variable names in old (base) form data +#' @param itemtype itemtype of calibration +#' @param newformBILOGprior using BILOG-MG prior when try to calibrate 3PL model? if you want, set the this to TRUE +#' @param oldformBILOGprior using BILOG-MG prior when try to calibrate 3PL model? if you want, set the this to TRUE +#' @param tryFitwholeNewItems do you want to try calibrate new form data? default is TRUE +#' @param tryFitwholeOldItems do you want to try calibrate base form data? default is TRUE +#' @param checkIPD do you want to check item parameter drift? default is TRUE +#' @param tryEM do you want to try EM algorithm when you calibrate model? defalut is TRUE +#' @param freeMEAN allow freely mean estimation, default is TRUE +#' @param forceNormalZeroOne set the prior distribution follows N(0,1) distribution. default is FALSE +#' @param parameterOverwrite don't touch it +#' @param empiricalhist do you want to use empirical histogram method when tryEM = TRUE? default is FALSE +#' @param confirmCommonItems set TRUE to accept the supplied common-item pairs without an interactive prompt. Default NULL: in interactive sessions the user will be prompted; set FALSE to explicitly reject (function will stop). +#' @param ... Additional arguments reserved for future extensions. +#' +#' @return the model list of the base form, new form, linked form +#' @export +#' +#' @examples +#' \dontrun{ +#' autoFIPC( +#' newformXData = new_model, +#' oldformYData = old_model, +#' newformCommonItemNames = common_new, +#' oldformCommonItemNames = common_old, +#' confirmCommonItems = TRUE +#' ) +#' } +autoFIPC <- + function( + newformXData, + oldformYData, + newformCommonItemNames, + oldformCommonItemNames, + itemtype = '3PL', + newformBILOGprior = NULL, + oldformBILOGprior = NULL, + tryFitwholeNewItems = T, + tryFitwholeOldItems = T, + checkIPD = T, + tryEM = T, + freeMEAN = T, + forceNormalZeroOne = F, + parameterOverwrite = F, + empiricalhist = F, + confirmCommonItems = NULL, + ... + ) { + # print credits + message('automated Fixed Item Parameter Calibration: aFIPC 0.2') + message('Seongho Bae (seongho@kw.ac.kr)\n') + try(invisible(gc()), silent = T) + # garbage cleaning + + # Input validation - Security Enhancement + isRealMirtModel <- function(x) { + if (!isS4(x) || !methods::is(x, "SingleGroupClass")) return(FALSE) + ok <- tryCatch({ + vals <- mirt::mod2values(x) + is.data.frame(vals) || is.matrix(vals) + }, error = function(e) FALSE, warning = function(w) FALSE) + if (!isTRUE(ok)) return(FALSE) + required_slots <- c("OptimInfo", "ParObjects") + 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") + } + if (!is.data.frame(oldformYData) && !is.matrix(oldformYData) && !isRealMirtModel(oldformYData)) { + stop("Security Error: oldformYData must be a data.frame, matrix, or a valid fitted mirt model") + } + + if (!is.character(newformCommonItemNames) && !is.factor(newformCommonItemNames)) { + stop("Security Error: newformCommonItemNames must be a character vector") + } + if (!is.character(oldformCommonItemNames) && !is.factor(oldformCommonItemNames)) { + stop("Security Error: oldformCommonItemNames must be a character vector") + } + + if (!is.character(itemtype)) stop('Security Error: itemtype must be a character vector') + nItems <- NA_integer_ + if (is.data.frame(newformXData) || is.matrix(newformXData)) nItems <- ncol(as.data.frame(newformXData)) + 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.null(newformBILOGprior) && (!is.logical(newformBILOGprior) || length(newformBILOGprior) != 1 || is.na(newformBILOGprior))) stop("Security Error: newformBILOGprior must be a single non-NA logical value or NULL") + if (!is.null(oldformBILOGprior) && (!is.logical(oldformBILOGprior) || length(oldformBILOGprior) != 1 || is.na(oldformBILOGprior))) stop("Security Error: oldformBILOGprior must be a single non-NA logical value or NULL") + if (!is.null(confirmCommonItems) && (!is.logical(confirmCommonItems) || length(confirmCommonItems) != 1 || is.na(confirmCommonItems))) stop("Security Error: confirmCommonItems must be a single non-NA logical value or NULL") + 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') + } + + if ( + length(newformCommonItemNames) == 0 | + length(oldformCommonItemNames) == 0 + ) { + stop('Please provide common item names') + } + + # checking common items + message('Checking correspond common item names') + to <- rep("<<<", length(newformCommonItemNames)) + print(data.frame(cbind( + newformCommonItemNames, + to, + oldformCommonItemNames + ))) + correspondItems <- + data.frame(cbind(newformCommonItemNames, oldformCommonItemNames)) + + checkCorrect <- function() { + if (isTRUE(confirmCommonItems)) { + return(1L) + } + if (identical(confirmCommonItems, FALSE)) { + return(2L) + } + if (!interactive()) { + stop( + 'Common item confirmation requires an interactive session; ', + 'set confirmCommonItems = TRUE to accept the supplied pairs.' + ) + } + for (attempt in seq_len(3)) { + n <- readline(prompt = "Is it correct? (1: Yes 2: No) : ") + if (grepl("^[0-9]+$", n)) { + return(as.integer(n)) + } + } + stop("Too many invalid common item confirmation attempts") + } + confirm <- checkCorrect() + if (confirm != 1) { + stop('Please write down pairs correctly') + } + + # estimate models for calibration + if ( + !is.data.frame(oldformYData) && + !is.matrix(oldformYData) + ) { + # if Data is mirt model + oldFormModel <- oldformYData + oldformYDataK <- data.frame(oldFormModel@Data$data) + } else { + # if Data is data.frame + oldformYDataK <- oldformYData + if (itemtype == '3PL' && length(oldformBILOGprior) == 0) { + checkoldformBILOGprior <- function() { + if (!interactive()) stop("Interactive session required for oldform BILOG prior") + for (attempt in seq_len(3)) { + n <- + readline( + prompt = "Do you want to use default BILOG-MG priors for oldform Data? (1: Yes 2: No) : " + ) + if (grepl("^[0-9]+$", n)) { + return(as.integer(n)) + } + } + stop("Too many invalid oldform BILOG prior attempts") + } + oldformBILOGprior <- checkoldformBILOGprior() + if (oldformBILOGprior == 1) { + oldformBILOGprior <- TRUE + } else { + oldformBILOGprior <- FALSE + } + } + + message('\nestimating oldForm (Y) parameters') + if (itemtype == '3PL' && oldformBILOGprior == T) { + message('with traditional MMLE/EM approach') + oldFormModelSyntax <- + mirt::mirt.model( + paste0( + 'F1 = 1-', + ncol(oldformYData), + '\n', + 'PRIOR = (1-', + ncol(oldformYData), + ', a1, lnorm, 1, 1.6487), ', + '(1-', + ncol(oldformYData), + ', g, norm, .22, .08)' + ) + ) + try( + oldFormModel <- + mirt::mirt( + data = oldformYData, + model = oldFormModelSyntax, + itemtype = itemtype, + SE = T, + accelerate = 'squarem' + ) + ) + } else { + # try to search priors automatically. if it fail, try to bayesian approaches + message( + 'with estimate prior distribution using an empirical histogram approach. please be patient.' + ) + try( + oldFormModel <- + mirt::mirt( + data = oldformYData, + model = 1, + itemtype = itemtype, + SE = T, + accelerate = 'squarem', + empiricalhist = T, + technical = list(NCYCLES = 1e+5), + GenRandomPars = F + ) + ) + } + + if (!exists("oldFormModel", inherits = FALSE)) { + stop("Security Error: Initial estimation of oldFormModel completely failed") + } + + if (tryFitwholeOldItems == T) { + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. estimating new parameters with no prior distribution using quasi-Monte Carlo EM estimation. please be patient.' + ) + + try(rm(oldFormModel)) + try( + oldFormModel <- + mirt::mirt( + data = oldformYDataK, + 1, + itemtype = itemtype, + SE = T, + method = 'QMCEM', + accelerate = 'squarem', + technical = list(NCYCLES = 1e+5), + GenRandomPars = F + ) + ) + } + + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. estimating new parameters with no prior distribution using Cai\'s (2010) Metropolis-Hastings Robbins-Monro (MHRM) algorithm. please be patient.' + ) + + try(rm(oldFormModel), silent = TRUE) + for (attempt in seq_len(3)) { + try( + oldFormModel <- + mirt::mirt( + data = oldformYDataK, + 1, + itemtype = itemtype, + SE = T, + method = 'MHRM', + accelerate = 'squarem', + technical = list(NCYCLES = 1e+5, MHRM_SE_draws = 200000), + GenRandomPars = F + ) + ) + if (exists('oldFormModel', inherits = FALSE)) break + } + if (!exists('oldFormModel', inherits = FALSE)) stop('Failed to estimate oldFormModel with MHRM after 3 attempts') + } + } + + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics' + ) + try(rm(oldFormModel)) + + oldFormModel <- + surveyFA( + oldformYData, + autofix = F, + SE = T, + forceUIRT = T + ) + } + + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics by normal MMLE/EM' + ) + try(rm(oldFormModel)) + + oldFormModel <- + surveyFA( + oldformYData, + autofix = F, + SE = T, + forceUIRT = T, + forceNormalEM = T + ) + } + + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics by MMLE/QMCEM' + ) + try(rm(oldFormModel)) + + oldFormModel <- + surveyFA( + oldformYData, + autofix = F, + SE = T, + forceUIRT = T, + unstable = T + ) + } + + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics by MMLE/MHRM' + ) + try(rm(oldFormModel)) + + oldFormModel <- + surveyFA( + oldformYData, + autofix = F, + SE = T, + forceUIRT = T, + forceMHRM = T + ) + } + + if ( + (!exists("oldFormModel", inherits = FALSE)) || (!isTRUE(oldFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + stop('Estimation failed. Please check test quality.') + } + } + + if ( + !is.data.frame(newformXData) && + !is.matrix(newformXData) + ) { + # if Data is mirt model + newFormModel <- newformXData + newformXDataK <- data.frame(newFormModel@Data$data) + } else { + newformXDataK <- newformXData + if (itemtype == '3PL' && length(newformBILOGprior) == 0) { + checknewformBILOGprior <- function() { + if (!interactive()) stop("Interactive session required for newform BILOG prior") + for (attempt in seq_len(3)) { + n <- + readline( + prompt = "Do you want to use default BILOG-MG priors for newform Data? (1: Yes 2: No) : " + ) + if (grepl("^[0-9]+$", n)) { + return(as.integer(n)) + } + } + stop("Too many invalid newform BILOG prior attempts") + } + newformBILOGprior <- checknewformBILOGprior() + if (newformBILOGprior == 1) { + newformBILOGprior <- TRUE + } else { + newformBILOGprior <- FALSE + } + } + + message('\nestimating newForm (X) parameters') + if (itemtype == '3PL' && newformBILOGprior == T) { + message('with traditional MMLE/EM approach') + newFormModelSyntax <- + mirt::mirt.model( + paste0( + 'F1 = 1-', + ncol(newformXData), + '\n', + 'PRIOR = (1-', + ncol(newformXData), + ', a1, lnorm, 1, 1.6487), ', + '(1-', + ncol(newformXData), + ', g, norm, .22, .08)' + ) + ) + try( + newFormModel <- + mirt::mirt( + data = newformXData, + model = newFormModelSyntax, + itemtype = itemtype, + SE = T, + accelerate = 'squarem' + ) + ) + } else { + message( + 'with estimate prior distribution using an empirical histogram approach. please be patient.' + ) + try( + newFormModel <- + mirt::mirt( + data = newformXDataK, + 1, + itemtype = itemtype, + SE = T, + empiricalhist = T, + accelerate = 'squarem', + technical = list(NCYCLES = 1e+5), + GenRandomPars = F + ) + ) + } + + if (!exists("newFormModel", inherits = FALSE)) { + stop("Security Error: Initial estimation of newFormModel completely failed") + } + + if (tryFitwholeNewItems) { + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. estimating new parameters with no prior distribution using quasi-Monte Carlo EM estimation. please be patient.' + ) + + try(rm(newFormModel)) + try( + newFormModel <- + mirt::mirt( + data = newformXDataK, + 1, + itemtype = itemtype, + SE = T, + method = 'QMCEM', + accelerate = 'squarem', + technical = list(NCYCLES = 1e+5), + GenRandomPars = F + ) + ) + } + + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. estimating new parameters with no prior distribution using Cai\'s (2010) Metropolis-Hastings Robbins-Monro (MHRM) algorithm. please be patient.' + ) + + try(rm(newFormModel), silent = TRUE) + for (attempt in seq_len(3)) { + try( + newFormModel <- + mirt::mirt( + data = newformXDataK, + 1, + itemtype = itemtype, + SE = T, + method = 'MHRM', + accelerate = 'squarem', + technical = list(NCYCLES = 1e+5, MHRM_SE_draws = 200000), + GenRandomPars = F + ) + ) + if (exists('newFormModel', inherits = FALSE)) break + } + if (!exists('newFormModel', inherits = FALSE)) stop('Failed to estimate newFormModel with MHRM after 3 attempts') + } + } + + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics' + ) + try(rm(newFormModel)) + + newFormModel <- + surveyFA( + newformXData, + autofix = F, + SE = T, + forceUIRT = T + ) + } + + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics again by normal MMLE/EM' + ) + try(rm(newFormModel)) + + newFormModel <- + surveyFA( + newformXData, + autofix = F, + SE = T, + forceUIRT = T, + forceNormalEM = T + ) + } + + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics again by MMLE/QMCEM' + ) + try(rm(newFormModel)) + + newFormModel <- + surveyFA( + newformXData, + autofix = F, + SE = T, + forceUIRT = T, + unstable = T + ) + } + + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + message( + 'Estimation failed. trying to remove weird items by itemfit statistics again by MMLE/MHRM' + ) + try(rm(newFormModel)) + + newFormModel <- + surveyFA( + newformXData, + autofix = F, + SE = T, + forceUIRT = T, + forceMHRM = T + ) + } + + if ( + (!exists("newFormModel", inherits = FALSE)) || (!isTRUE(newFormModel@OptimInfo$secondordertest) && + itemtype != 'ideal') + ) { + stop('Estimation failed. Please check test quality.') + } + } + + # do FIPC + NewScaleParms <- mirt::mod2values(newFormModel) + OldScaleParms <- mirt::mod2values(oldFormModel) + + # Preserve mirt's structural estimability flags. Forcing every row TRUE + # frees boundary parameters such as 2PL g/u and makes the Hessian unstable. + + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$est[NewScaleParms$item == 'GROUP'] <- FALSE + OldScaleParms$est[OldScaleParms$item == 'GROUP'] <- FALSE + + NewScaleParms$est[NewScaleParms$name == "COV_11"] <- TRUE + OldScaleParms$est[OldScaleParms$name == "COV_11"] <- TRUE + + if (itemtype == 'Rasch') { + NewScaleParms$est[NewScaleParms$name == "a1"] <- FALSE + OldScaleParms$est[OldScaleParms$name == "a1"] <- FALSE + } + + #IPD + if (checkIPD == T) { + # config + IPDgroup <- + as.factor(c( + rep('oldForm', nrow(oldformYDataK)), + rep('newForm', nrow(newformXDataK)) + )) + IPDItemCount <- 0 + + # IPD target item checking + newFormColNames <- colnames(newformXDataK[colnames(newFormModel@Data$data)]) + oldFormColNames <- colnames(oldformYDataK[colnames(oldFormModel@Data$data)]) + + # ⚡ Bolt: Vectorized match() to avoid dynamic array growth overhead inside a for loop + idxNew <- match(newformCommonItemNames, newFormColNames) + idxOld <- match(oldformCommonItemNames, oldFormColNames) + valid_idx <- !is.na(idxNew) & !is.na(idxOld) + + IPDItemNamesNewForm <- newFormColNames[idxNew[valid_idx]] + IPDItemNamesOldForm <- oldFormColNames[idxOld[valid_idx]] + IPDItemCount <- length(IPDItemNamesNewForm) + + # IPD Data generation + IPDItemList <- + data.frame(rbind(IPDItemNamesOldForm, IPDItemNamesNewForm)) + + IPDData <- + data.frame(matrix(nrow = length(IPDgroup), ncol = IPDItemCount)) + colnames(IPDData) <- paste0('X', 1:IPDItemCount) + print(IPDItemNamesOldForm) + print(IPDItemNamesNewForm) + IPDData[1:nrow(oldformYDataK), ] <- + oldformYDataK[, IPDItemNamesOldForm] + IPDData[nrow(oldformYDataK) + 1:nrow(newformXDataK), ] <- + newformXDataK[, IPDItemNamesNewForm] + + # IPD estimation + IPDParmNames <- OldScaleParms$name + IPDParmNames <- IPDParmNames[!duplicated(IPDParmNames)] + IPDParmNames <- IPDParmNames[!grepl("^(MEAN|COV|ak|d0$)", IPDParmNames)] + IPDParmNames <- as.character(IPDParmNames) + + mirt::mirtCluster() + message('Discovering IPD') + if (itemtype == 'nominal' | tryEM == T) { + if (empiricalhist == T) { + modIPD_MG <- mirt::multipleGroup( + IPDData, + model = 1, + group = IPDgroup, + itemtype = itemtype, + method = 'EM', + invariance = c(names(IPDData), 'free_means', 'free_var'), + empiricalhist = T, + technical = list(NCYCLES = 1e+5, removeEmptyRows = TRUE) + ) + try( + modIPD_DIF <- + mirt::DIF( + modIPD_MG, + IPDParmNames, + scheme = 'drop_sequential', + method = 'EM', + empiricalhist = T, + technical = list(NCYCLES = 1e+5) + ) + ) + } else { + modIPD_MG <- mirt::multipleGroup( + IPDData, + model = 1, + group = IPDgroup, + itemtype = itemtype, + method = 'EM', + invariance = c(names(IPDData), 'free_means', 'free_var'), + empiricalhist = F, + technical = list(NCYCLES = 1e+5, removeEmptyRows = TRUE) + ) + try( + modIPD_DIF <- + mirt::DIF( + modIPD_MG, + IPDParmNames, + scheme = 'drop_sequential', + method = 'EM', + empiricalhist = F, + technical = list(NCYCLES = 1e+5) + ) + ) + } + } else { + modIPD_MG <- mirt::multipleGroup( + IPDData, + model = 1, + group = IPDgroup, + itemtype = itemtype, + method = 'MHRM', + invariance = c(names(IPDData), 'free_means', 'free_var'), + technical = list(NCYCLES = 1e+5, removeEmptyRows = TRUE) + ) + try( + modIPD_DIF <- + mirt::DIF( + modIPD_MG, + IPDParmNames, + scheme = 'drop_sequential', + method = 'MHRM', + technical = list(NCYCLES = 1e+5) + ) + ) + } + mirt::mirtCluster(remove = T) + + if (exists('modIPD_DIF', inherits = FALSE)) { + modIPD_IPDItem <- names(modIPD_DIF) + CommonItemList_NOIPD <- + colnames(IPDData)[!colnames(IPDData) %in% modIPD_IPDItem] + print(modIPD_DIF) + print(CommonItemList_NOIPD) + + # ⚡ Bolt: 루프 내에서 데이터 프레임을 서브셋팅(subsetting)하는 O(N) 연산을 + # unlist()를 활용한 벡터화된(vectorized) O(1) 연산으로 대체하여 성능 향상 + ActualoldFormCommonItem <- + as.character(unlist(IPDItemList[1, CommonItemList_NOIPD])) + ActualnewFormCommonItem <- + as.character(unlist(IPDItemList[2, CommonItemList_NOIPD])) + + message('ActualoldFormCommonItem: ', ActualoldFormCommonItem) + message('ActualnewFormCommonItem: ', ActualnewFormCommonItem) + + oldformCommonItemNames <- ActualoldFormCommonItem + newformCommonItemNames <- ActualnewFormCommonItem + message('oldformCommonItemNames: ', ActualoldFormCommonItem) + message('newformCommonItemNames: ', ActualnewFormCommonItem) + } else { + message('No IPD detected') + } + } + + newFormColNames <- colnames(newformXDataK[colnames(newFormModel@Data$data)]) + oldFormColNames <- colnames(oldformYDataK[colnames(oldFormModel@Data$data)]) + + # ⚡ Bolt: Cache parameter indices to avoid O(N) linear search inside loop + newScaleParmsItemIdxCache <- split(seq_len(nrow(NewScaleParms)), NewScaleParms$item) + oldScaleParmsItemIdxCache <- split(seq_len(nrow(OldScaleParms)), OldScaleParms$item) + + # ⚡ Bolt: Vectorize match() outside the loop to avoid repeated array scanning overhead + idxNew_all <- match(newformCommonItemNames, newFormColNames) + idxOld_all <- match(oldformCommonItemNames, oldFormColNames) + + for (i in seq_along(oldformCommonItemNames)) { + newFormItemStr <- newformCommonItemNames[i] + oldFormItemStr <- oldformCommonItemNames[i] + + newFormItemName <- newFormColNames[idxNew_all[i]] + oldFormItemName <- oldFormColNames[idxOld_all[i]] + + 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])))) + ) { + message( + 'applying ', + newFormItemStr, + ' <<< ', + oldFormItemStr, + ' as common item use' + ) + + # ⚡ Bolt: Use cached O(1) dictionary lookups instead of O(N) which() scans + newIdx <- newScaleParmsItemIdxCache[[newFormItemStr]] + oldIdx <- oldScaleParmsItemIdxCache[[oldFormItemStr]] + + # ⚡ Bolt: Remove unnecessary paste0() array string generation overhead + message(' Newform Parms: ', paste(NewScaleParms$value[newIdx], collapse = ' ')) + message(' Oldform Parms: ', paste(OldScaleParms$value[oldIdx], collapse = ' ')) + + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$value[newIdx] <- + OldScaleParms$value[oldIdx] + message(' Linkedform Parms: ', paste(NewScaleParms$value[newIdx], collapse = ' '), '\n') + + NewScaleParms$est[newIdx] <- + FALSE + } else { + message( + 'skipping ', + newFormItemStr, + ' <<< ', + oldFormItemStr, + ' as common item use' + ) + } + } + + if ( + length(attr(newFormModel@ParObjects$lrPars, 'parnum')) != 0 && + length(attr(oldFormModel@ParObjects$lrPars, 'parnum')) != 0 + ) { + newBetaIdx <- NewScaleParms$item == 'BETA' + oldBetaIdx <- OldScaleParms$item == 'BETA' + + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$value[newBetaIdx] <- + OldScaleParms$value[oldBetaIdx] + NewScaleParms$est[newBetaIdx] <- + FALSE + + message('applying BETA parameter as linking') + + message( + ' Linkedform Parms: ', + paste0( + NewScaleParms$value[newBetaIdx], + ' ' + ), + '\n' + ) + betaFormula <- + attr(newFormModel@ParObjects$lrPars, 'formula')[[1]] + betaCOVdata <- attr(newFormModel@ParObjects$lrPars, 'df') + betaSE <- FALSE + betaEmpiricalhist <- FALSE + } else if (empiricalhist == F) { + betaFormula <- NULL + betaCOVdata <- NULL + betaSE <- TRUE + betaEmpiricalhist <- FALSE + } else { + betaFormula <- NULL + betaCOVdata <- NULL + betaSE <- TRUE + betaEmpiricalhist <- TRUE + } + + message('\nestimating Linked Form Eq(X) parameters') + + # ⚡ Bolt: Cache subsetted dataframe to avoid repeated O(N) memory copies during mirt model setup + linkedFormData <- newformXDataK[colnames(newFormModel@Data$data)] + + if (forceNormalZeroOne) { + freeMEAN <- F + + new_cov11_idx <- NewScaleParms$name == "COV_11" + old_cov11_idx <- OldScaleParms$name == "COV_11" + new_mean11_idx <- NewScaleParms$name == "MEAN_11" + old_mean11_idx <- OldScaleParms$name == "MEAN_11" + + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$est[new_cov11_idx] <- FALSE + OldScaleParms$est[old_cov11_idx] <- FALSE + NewScaleParms$est[new_mean11_idx] <- FALSE + OldScaleParms$est[old_mean11_idx] <- FALSE + + NewScaleParms$value[new_cov11_idx] <- 1 + OldScaleParms$value[old_mean11_idx] <- 0 + } + if (freeMEAN == T) { + LinkedModelSyntax <- + mirt::mirt.model(paste0( + 'F1 = 1-', + ncol(linkedFormData), + '\n', + 'MEAN = F1' + )) + + # ⚡ Bolt: Update dataframe columns using 1D vector assignment instead of 2D subsetting to bypass method dispatch overhead + NewScaleParms$est[NewScaleParms$name == "MEAN_1"] <- TRUE + OldScaleParms$est[OldScaleParms$name == "MEAN_1"] <- TRUE + } else { + LinkedModelSyntax <- + mirt::mirt.model(paste0( + 'F1 = 1-', + ncol(linkedFormData), + '\n' + )) + } + + print(NewScaleParms) + + if (itemtype == 'nominal' | tryEM == T) { + if (betaEmpiricalhist) { + message( + 'with MMLE/EM + empirical histogram approach. please be patient.' + ) + } else { + message('with MMLE/EM approach. please be patient.') + } + if (sum(NewScaleParms$est) == 0) { + # LinkedModel <- oldFormModel + + LinkedModel <- + mirt::mirt( + data = linkedFormData, + LinkedModelSyntax, + itemtype = newFormModel@Model$itemtype, + method = 'EM', + SE = F, + accelerate = 'squarem', + empiricalhist = betaEmpiricalhist, + technical = list( + NCYCLES = 1e+6, + SEtol = 1e-4, + MHRM_SE_draws = 1e+5 + ), + pars = NewScaleParms, + GenRandomPars = F, + covdata = betaCOVdata, + formula = betaFormula + ) + } else { + LinkedModel <- + mirt::mirt( + data = linkedFormData, + LinkedModelSyntax, + itemtype = newFormModel@Model$itemtype, + method = 'EM', + SE = betaSE, + accelerate = 'squarem', + empiricalhist = betaEmpiricalhist, + technical = list( + NCYCLES = 1e+6, + SEtol = 1e-4, + MHRM_SE_draws = 1e+5 + ), + pars = NewScaleParms, + GenRandomPars = F, + covdata = betaCOVdata, + formula = betaFormula + ) + } + } else { + message( + 'with Cai\'s (2010) Metropolis-Hastings Robbins-Monro (MHRM) approach. please be patient.' + ) + + if (sum(NewScaleParms$est) == 0) { + # LinkedModel <- oldFormModel + LinkedModel <- + mirt::mirt( + data = linkedFormData, + LinkedModelSyntax, + itemtype = newFormModel@Model$itemtype, + method = 'MHRM', + SE = F, + accelerate = 'squarem', + TOL = .0005, + technical = list( + NCYCLES = 1e+6, + SEtol = 1e-4, + MHRM_SE_draws = 1e+5 + ), + pars = NewScaleParms, + GenRandomPars = F, + covdata = betaCOVdata, + formula = betaFormula + ) + } else { + LinkedModel <- + mirt::mirt( + data = linkedFormData, + LinkedModelSyntax, + itemtype = newFormModel@Model$itemtype, + method = 'MHRM', + SE = betaSE, + accelerate = 'squarem', + TOL = .0005, + technical = list( + NCYCLES = 1e+6, + SEtol = 1e-4, + MHRM_SE_draws = 1e+5 + ), + pars = NewScaleParms, + GenRandomPars = F, + covdata = betaCOVdata, + formula = betaFormula + ) + } + } + + # if(!LinkedModel@OptimInfo$secondordertest){ + # message('Estimation failed. estimating new parameters with no prior distribution using quasi-Monte Carlo EM estimation. please be patient.') + # + # rm(LinkedModel) + # try(LinkedModel <- mirt::mirt(data = linkedFormData, LinkedModelSyntax, itemtype = newFormModel@Model$itemtype, SE = T, method = 'QMCEM', accelerate = 'squarem', technical = list(NCYCLES = 1e+5), pars = NewScaleParms, GenRandomPars = F)) + # } + # + # if(!LinkedModel@OptimInfo$secondordertest){ + # message('Estimation failed. estimating new parameters with no prior distribution using Cai\'s (2010) Metropolis-Hastings Robbins-Monro (MHRM) algorithm. please be patient.') + # + # try(rm(LinkedModel), silent = TRUE) + # for (attempt in seq_len(3)) { + # try(LinkedModel <- mirt::mirt(data = linkedFormData, LinkedModelSyntax, itemtype = newFormModel@Model$itemtype, SE = T, method = 'MHRM', accelerate = 'squarem', technical = list(NCYCLES = 1e+5, MHRM_SE_draws = 200000), pars = NewScaleParms, GenRandomPars = T)) + # if (exists('LinkedModel')) break + # } + # if (!exists('LinkedModel')) stop('Failed to estimate LinkedModel with MHRM after 3 attempts') + # } + + # if(!LinkedModel@OptimInfo$secondordertest){ + # stop('Estimation failed. Please check test quality.') + # } + + # calculate theta + ThetaOldform <- mirt::fscores(oldFormModel, method = 'MAP') + ThetaLinkedform <- mirt::fscores(LinkedModel, method = 'MAP') + ThetaNewform <- mirt::fscores(newFormModel, method = 'MAP') + + # calculate expected score + ExpectedScoreOldform <- + mirt::expected.test( + x = oldFormModel, + Theta = ThetaOldform + ) + ExpectedScoreLinkedform <- + mirt::expected.test( + x = LinkedModel, + Theta = ThetaLinkedform + ) + ExpectedScoreNewform <- + mirt::expected.test( + x = newFormModel, + Theta = ThetaNewform + ) + + # save results as object + modelReturn <- new.env() + modelReturn$oldFormModel <- oldFormModel + modelReturn$newFormModel <- newFormModel + modelReturn$LinkedModel <- LinkedModel + modelReturn$ExpectedScoreOldform <- ExpectedScoreOldform + modelReturn$ExpectedScoreLinkedform <- ExpectedScoreLinkedform + modelReturn$ExpectedScoreNewform <- ExpectedScoreNewform + modelReturn$ThetaOldform <- ThetaOldform + modelReturn$ThetaNewform <- ThetaNewform + modelReturn$ThetaLinkedform <- ThetaLinkedform + if (checkIPD) { + modelReturn$IPDData <- data.frame(IPDData, IPDgroup) + if (exists('CommonItemList_NOIPD', inherits = FALSE)) { + modelReturn$IPDCommonItemList <- IPDItemList[CommonItemList_NOIPD] + } + } + + return(as.list(modelReturn)) + } diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/R/surveyFA.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/R/surveyFA.R new file mode 100644 index 0000000..f60fffd --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/R/surveyFA.R @@ -0,0 +1,291 @@ +#' @title surveyFA +#' @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 with finite log-likelihood and, when +#' `SE = TRUE`, a passing second-order test plus finite covariance estimates. +#' @export +surveyFA <- function( + data, + autofix = TRUE, + forceUIRT = TRUE, + forceNormalEM = FALSE, + forceMHRM = FALSE, + unstable = FALSE, + SE = TRUE, + itemtype = "2PL", + maxItemRemovals = 3L, + pThreshold = 0.05, + ... +) { + 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 + ) + } + + if (!is.data.frame(data) && !is.matrix(data)) { + 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) { + 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) + } + + 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) + } + + 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) + } + if (SE && !identical(second_order, TRUE)) { + return(FALSE) + } + if (SE && !has_finite_covariance(model)) { + 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)) { + 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/aFIPC.Rcheck/00_pkg_src/aFIPC/README.md b/aFIPC.Rcheck/00_pkg_src/aFIPC/README.md new file mode 100644 index 0000000..7e5816f --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/README.md @@ -0,0 +1,55 @@ +# aFIPC + +Automated Fixed Item Parameter Calibration (FIPC) for IRT test linking. + +This package contains the original graduate-school implementation used to +produce accurate fixed-item linking results. The current maintenance goal is to +preserve numerical behavior while modernizing repository operations +(documentation, CI, and dependency hygiene). + +## What this repository contains + +- `R/aFIPC.R`: core `autoFIPC()` implementation +- `DESCRIPTION`, `NAMESPACE`, `man/`: package metadata and generated docs +- `packrat/`: historical dependency lock/vendor directory +- `.github/workflows/`: CI/security automation + +## Development status + +- Algorithmic core is legacy but trusted for historical outputs. +- Operational guardrails are now maintained via GitHub Actions and Dependabot. +- Legacy `packrat` bootstrap is opt-in via `AFIPC_ENABLE_PACKRAT=true`. +- Broken host-specific `packrat/lib-R` symlinks were removed for portable builds. +- Architectural and agent operation docs are available in: + - `ARCHITECTURE.md` + - `AGENTS.md` + - `CLAUDE.md` + - `CONTRIBUTING.md` + - `.github/SECURITY.md` + +## Collaboration workflow + +- Pull request template: `.github/PULL_REQUEST_TEMPLATE.md` +- Issue templates: `.github/ISSUE_TEMPLATE/` +- Code ownership: `.github/CODEOWNERS` +- Code quality checks: `.github/workflows/code-quality.yml` +- Security checks (private-safe): `.github/workflows/security-audit.yml` +- Secret-scan policy config: `.gitleaks.toml` +- CodeRabbit command reference: `docs/coderabbit/review-commands.md` +- Maintainer operations runbook: `docs/operations/maintenance-runbook.md` + +## Local package check + +```bash +R_PROFILE_USER=/dev/null Rscript -e \ +'install.packages(c("rcmdcheck"), repos="https://cloud.r-project.org")' +R_PROFILE_USER=/dev/null Rscript -e \ +'rcmdcheck::rcmdcheck(args = c("--no-manual", "--as-cran"), error_on = "warning")' +``` + +## Maintenance policy + +- Prefer preserving equation/calibration behavior over refactoring. +- Avoid silent behavioral changes in `autoFIPC()` without explicit regression + evidence. +- Keep CI green on supported runners and keep Actions pinned/updated. diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/man/autoFIPC.Rd b/aFIPC.Rcheck/00_pkg_src/aFIPC/man/autoFIPC.Rd new file mode 100644 index 0000000..cc702b2 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/man/autoFIPC.Rd @@ -0,0 +1,78 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/aFIPC.R +\name{autoFIPC} +\alias{autoFIPC} +\title{automated fixed item parameter linking} +\usage{ +autoFIPC( + newformXData, + oldformYData, + newformCommonItemNames, + oldformCommonItemNames, + itemtype = "3PL", + newformBILOGprior = NULL, + oldformBILOGprior = NULL, + tryFitwholeNewItems = T, + tryFitwholeOldItems = T, + checkIPD = T, + tryEM = T, + freeMEAN = T, + forceNormalZeroOne = F, + parameterOverwrite = F, + empiricalhist = F, + confirmCommonItems = NULL, + ... +) +} +\arguments{ +\item{newformXData}{new form data X} + +\item{oldformYData}{old form (base form) data Y} + +\item{newformCommonItemNames}{Common item variable names in new form data} + +\item{oldformCommonItemNames}{Common item variable names in old (base) form data} + +\item{itemtype}{itemtype of calibration} + +\item{newformBILOGprior}{using BILOG-MG prior when try to calibrate 3PL model? if you want, set the this to TRUE} + +\item{oldformBILOGprior}{using BILOG-MG prior when try to calibrate 3PL model? if you want, set the this to TRUE} + +\item{tryFitwholeNewItems}{do you want to try calibrate new form data? default is TRUE} + +\item{tryFitwholeOldItems}{do you want to try calibrate base form data? default is TRUE} + +\item{checkIPD}{do you want to check item parameter drift? default is TRUE} + +\item{tryEM}{do you want to try EM algorithm when you calibrate model? defalut is TRUE} + +\item{freeMEAN}{allow freely mean estimation, default is TRUE} + +\item{forceNormalZeroOne}{set the prior distribution follows N(0,1) distribution. default is FALSE} + +\item{parameterOverwrite}{don't touch it} + +\item{empiricalhist}{do you want to use empirical histogram method when tryEM = TRUE? default is FALSE} + +\item{confirmCommonItems}{set TRUE to accept the supplied common-item pairs without an interactive prompt. Default NULL: in interactive sessions the user will be prompted; set FALSE to explicitly reject (function will stop).} + +\item{...}{Additional arguments reserved for future extensions.} +} +\value{ +the model list of the base form, new form, linked form +} +\description{ +automated fixed item parameter linking +} +\examples{ +\dontrun{ +autoFIPC( + newformXData = new_model, + oldformYData = old_model, + newformCommonItemNames = common_new, + oldformCommonItemNames = common_old, + confirmCommonItems = TRUE +) +} +} diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/man/surveyFA.Rd b/aFIPC.Rcheck/00_pkg_src/aFIPC/man/surveyFA.Rd new file mode 100644 index 0000000..fcc7b45 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/man/surveyFA.Rd @@ -0,0 +1,28 @@ +\name{surveyFA} +\alias{surveyFA} +\title{surveyFA} +\usage{ +surveyFA(data, autofix = TRUE, forceUIRT = TRUE, forceNormalEM = FALSE, + forceMHRM = FALSE, unstable = FALSE, SE = TRUE, itemtype = "2PL", + maxItemRemovals = 3L, pThreshold = 0.05, ...) +} +\arguments{ +\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{ +Fallback calibration helper used when direct \code{autoFIPC()} estimation fails. +} +\value{ +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/aFIPC.Rcheck/00_pkg_src/aFIPC/test_dummy.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/test_dummy.R new file mode 100644 index 0000000..e6f7019 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/test_dummy.R @@ -0,0 +1,2 @@ +source("R/aFIPC.R") +source("R/surveyFA.R") diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/test_validation.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/test_validation.R new file mode 100644 index 0000000..f084116 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/test_validation.R @@ -0,0 +1,3 @@ +source("R/aFIPC.R") +source("R/surveyFA.R") +print("Syntax check passed") diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat.R new file mode 100644 index 0000000..0405a84 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat.R @@ -0,0 +1,4 @@ +library(testthat) +library(aFIPC) + +test_check("aFIPC") diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-autoFIPC.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-autoFIPC.R new file mode 100644 index 0000000..13cecd9 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-autoFIPC.R @@ -0,0 +1,91 @@ +test_that("autoFIPC raises error in non-interactive session for inputs", { + # interactive() should be FALSE by default in testthat environments + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A') + ), + "Common item confirmation requires an interactive session" + ) +}) + +test_that("autoFIPC does not implicitly approve supplied common items", { + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + confirmCommonItems = FALSE + ), + "Please write down pairs correctly" + ) +}) + +test_that("autoFIPC validates input types securely", { + expect_error( + aFIPC::autoFIPC( + newformXData = 1, + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A') + ), + "Security Error: newformXData 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 = 123, + oldformCommonItemNames = c('A') + ), + "Security Error: newformCommonItemNames must be a character vector" + ) + + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + itemtype = c("3PL", "2PL") + ), + "Security Error: itemtype must be length 1 or length 1 \\(number of items\\)." + ) + + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = structure(list(), class = "SingleGroupClass"), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + confirmCommonItems = TRUE + ), + "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" + ) +}) diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-fixed-parameter-calibration.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-fixed-parameter-calibration.R new file mode 100644 index 0000000..71808da --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-fixed-parameter-calibration.R @@ -0,0 +1,123 @@ +test_that("autoFIPC fixes common-item parameters on the old-form scale", { + skip_if_not_installed("mirt") + + set.seed(20260629) + old_item_names <- paste0("old_item_", 1:6) + new_item_names <- paste0("new_item_", 1:6) + old_common_items <- old_item_names[1:4] + new_common_items <- new_item_names[1:4] + old_a <- matrix(c(0.82, 1.05, 1.28, 0.96, 1.15, 0.74), ncol = 1) + old_d <- c(-1.05, -0.35, 0.15, 0.85, -0.65, 0.45) + new_a <- matrix(c(0.82, 1.05, 1.28, 0.96, 0.88, 1.36), ncol = 1) + new_d <- c(-1.05, -0.35, 0.15, 0.85, -0.05, 0.95) + + old_data <- as.data.frame(mirt::simdata( + a = old_a, + d = old_d, + itemtype = rep("2PL", length(old_item_names)), + N = 1600 + )) + new_data <- as.data.frame(mirt::simdata( + a = new_a, + d = new_d, + itemtype = rep("2PL", length(new_item_names)), + N = 1600 + )) + names(old_data) <- old_item_names + names(new_data) <- new_item_names + old_data[1, ] <- 0 + old_data[2, ] <- 1 + new_data[1, ] <- 0 + new_data[2, ] <- 1 + old_data[3, old_common_items[1]] <- NA + new_data[3, new_common_items[1]] <- NA + + old_model <- mirt::mirt( + old_data, + 1, + itemtype = "2PL", + method = "EM", + SE = TRUE, + verbose = FALSE, + technical = list(NCYCLES = 500) + ) + new_model <- mirt::mirt( + new_data, + 1, + itemtype = "2PL", + method = "EM", + SE = TRUE, + verbose = FALSE, + technical = list(NCYCLES = 500) + ) + + old_vcov <- as.matrix(old_model@vcov) + new_vcov <- as.matrix(new_model@vcov) + expect_gt(nrow(old_vcov), 0) + expect_gt(nrow(new_vcov), 0) + expect_true(all(is.finite(diag(old_vcov)))) + expect_true(all(is.finite(diag(new_vcov)))) + expect_true(isTRUE(old_model@OptimInfo$secondordertest)) + expect_true(isTRUE(new_model@OptimInfo$secondordertest)) + + linked <- aFIPC::autoFIPC( + newformXData = new_model, + oldformYData = old_model, + newformCommonItemNames = new_common_items, + oldformCommonItemNames = old_common_items, + itemtype = "2PL", + checkIPD = FALSE, + tryEM = TRUE, + freeMEAN = FALSE, + forceNormalZeroOne = TRUE, + confirmCommonItems = TRUE + ) + + linked_vcov <- as.matrix(linked$LinkedModel@vcov) + expect_gt(nrow(linked_vcov), 0) + expect_true(all(is.finite(diag(linked_vcov)))) + expect_true(isTRUE(linked$LinkedModel@OptimInfo$secondordertest)) + + old_values <- mirt::mod2values(old_model) + linked_values <- mirt::mod2values(linked$LinkedModel) + linked_structural <- linked_values[ + linked_values$item %in% new_item_names[5:6] & + linked_values$name %in% c("g", "u"), + "est" + ] + expect_false(any(linked_structural)) + + for (i in seq_along(old_common_items)) { + old_item <- old_common_items[i] + new_item <- new_common_items[i] + old_fixed <- old_values[ + old_values$item == old_item & old_values$name %in% c("a1", "d"), + c("name", "value") + ] + linked_fixed <- linked_values[ + linked_values$item == new_item & linked_values$name %in% c("a1", "d"), + c("name", "value", "est") + ] + + expect_equal(linked_fixed$name, old_fixed$name) + expect_equal(linked_fixed$value, old_fixed$value, tolerance = 1e-6) + expect_false(any(linked_fixed$est)) + } + + # Kim (2006) invariant, second half: parameters of the NON-common new-form + # items must stay free (estimated) so they move onto the fixed base scale, + # rather than being frozen along with the anchors. + new_unique_items <- setdiff(new_item_names, new_common_items) + free_new <- linked_values[ + linked_values$item %in% new_unique_items & linked_values$name %in% c("a1", "d"), + "est" + ] + expect_true(all(free_new)) + + old_estimates <- old_values[ + old_values$item %in% old_common_items & old_values$name %in% c("a1", "d"), + "value" + ] + true_parameters <- c(rbind(old_a[1:4, 1], old_d[1:4])) + expect_lt(mean(abs(old_estimates - true_parameters)), 0.35) +}) diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-optimization-equivalence.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-optimization-equivalence.R new file mode 100644 index 0000000..02ce2f7 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-optimization-equivalence.R @@ -0,0 +1,80 @@ +# 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). + +test_that("category-count guard counts distinct non-missing categories (#56)", { + vecs <- list( + 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) + ) + + # Independent hand-computed reference (distinct non-missing categories). + expected <- c( + dichotomous = 2L, + trichotomous_w_na = 3L, + constant = 1L, + four_category_w_na = 4L + ) + + new_idiom <- vapply( + vecs, + function(x) length(na.omit(unique(x))), + integer(1) + ) + legacy_idiom <- vapply( + vecs, + function(x) length(levels(as.factor(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)) +}) + +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)) { + legacy_old[i] <- as.character(IPDItemList[CommonItemList_NOIPD][1, i]) + legacy_new[i] <- as.character(IPDItemList[CommonItemList_NOIPD][2, i]) + } + expect_identical(actual_old, legacy_old) + expect_identical(actual_new, legacy_new) +}) diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-package-api.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-package-api.R new file mode 100644 index 0000000..7f0ecf5 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-package-api.R @@ -0,0 +1,42 @@ +test_that("autoFIPC is exported", { + expect_true("autoFIPC" %in% getNamespaceExports("aFIPC")) + expect_true(is.function(aFIPC::autoFIPC)) +}) + +test_that("autoFIPC executes without errors in non-interactive environment", { + skip_if_not_installed("mirt") + + set.seed(123) + dat_old <- mirt::simdata( + a = matrix(runif(10, 0.8, 2)), + d = matrix(rnorm(10)), + N = 100, + itemtype = "2PL" + ) + dat_new <- mirt::simdata( + a = matrix(runif(10, 0.8, 2)), + d = matrix(rnorm(10)), + N = 100, + itemtype = "2PL" + ) + + colnames(dat_old) <- paste0("Item", 1:10) + colnames(dat_new) <- c(paste0("Item", 1:5), paste0("NewItem", 6:10)) + + old_mod <- mirt::mirt(dat_old, 1, itemtype = "2PL", SE = FALSE, verbose = FALSE) + new_mod <- mirt::mirt(dat_new, 1, itemtype = "2PL", SE = FALSE, verbose = FALSE) + + res <- aFIPC::autoFIPC( + newformXData = new_mod, + oldformYData = old_mod, + newformCommonItemNames = paste0("Item", 1:5), + oldformCommonItemNames = paste0("Item", 1:5), + itemtype = "2PL", + checkIPD = FALSE, + confirmCommonItems = TRUE + ) + + expect_type(res, "list") + expect_true("ExpectedScoreOldform" %in% names(res)) + expect_true("ThetaOldform" %in% names(res)) +}) diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-sentinel-validation.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-sentinel-validation.R new file mode 100644 index 0000000..900f0ee --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-sentinel-validation.R @@ -0,0 +1,37 @@ +test_that("autoFIPC validates boolean flags for newformBILOGprior, oldformBILOGprior, and confirmCommonItems", { + # newformBILOGprior + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + newformBILOGprior = "TRUE" + ), + "Security Error: newformBILOGprior must be a single non-NA logical value or NULL" + ) + + # oldformBILOGprior + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + oldformBILOGprior = c(TRUE, FALSE) + ), + "Security Error: oldformBILOGprior must be a single non-NA logical value or NULL" + ) + + # confirmCommonItems + expect_error( + aFIPC::autoFIPC( + newformXData = data.frame(A=1), + oldformYData = data.frame(A=2), + newformCommonItemNames = c('A'), + oldformCommonItemNames = c('A'), + confirmCommonItems = NA + ), + "Security Error: confirmCommonItems must be a single non-NA logical value or NULL" + ) +}) diff --git a/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-surveyFA.R b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-surveyFA.R new file mode 100644 index 0000000..060ae68 --- /dev/null +++ b/aFIPC.Rcheck/00_pkg_src/aFIPC/tests/testthat/test-surveyFA.R @@ -0,0 +1,84 @@ +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 = TRUE + ) + + fitted_vcov <- as.matrix(fitted@vcov) + expect_true(inherits(fitted, "SingleGroupClass")) + 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", { + expect_error( + aFIPC::surveyFA(1:10, forceUIRT = TRUE), + "surveyFA requires a response matrix or data frame" + ) +}) + +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") + + 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" + ) +}) diff --git a/aFIPC.Rcheck/00check.log b/aFIPC.Rcheck/00check.log new file mode 100644 index 0000000..a35b349 --- /dev/null +++ b/aFIPC.Rcheck/00check.log @@ -0,0 +1,56 @@ +* using log directory ‘/app/aFIPC.Rcheck’ +* using R version 4.3.3 (2024-02-29) +* using platform: x86_64-pc-linux-gnu (64-bit) +* R was compiled by + gcc (Ubuntu 13.2.0-23ubuntu3) 13.2.0 + GNU Fortran (Ubuntu 13.2.0-23ubuntu3) 13.2.0 +* running under: Ubuntu 24.04.4 LTS +* using session charset: UTF-8 +* using option ‘--no-manual’ +* checking for file ‘aFIPC/DESCRIPTION’ ... OK +* checking extension type ... Package +* this is package ‘aFIPC’ version ‘0.1.0’ +* package encoding: UTF-8 +* checking package namespace information ... OK +* checking package dependencies ... OK +* checking if this is a source package ... OK +* checking if there is a namespace ... OK +* checking for executable files ... OK +* checking for hidden files and directories ... OK +* checking for portable file names ... OK +* checking for sufficient/correct file permissions ... OK +* checking whether package ‘aFIPC’ can be installed ... OK +* checking installed package size ... OK +* checking package directory ... OK +* checking DESCRIPTION meta-information ... OK +* checking top-level files ... OK +* checking for left-over files ... OK +* checking index information ... OK +* checking package subdirectories ... OK +* checking R files for non-ASCII characters ... OK +* checking R files for syntax errors ... OK +* checking whether the package can be loaded ... OK +* checking whether the package can be loaded with stated dependencies ... OK +* checking whether the package can be unloaded cleanly ... OK +* checking whether the namespace can be loaded with stated dependencies ... OK +* checking whether the namespace can be unloaded cleanly ... OK +* checking loading without being on the library search path ... OK +* checking dependencies in R code ... OK +* checking S3 generic/method consistency ... OK +* checking replacement functions ... OK +* checking foreign function calls ... OK +* checking R code for possible problems ... OK +* checking Rd files ... OK +* checking Rd metadata ... OK +* checking Rd cross-references ... OK +* checking for missing documentation entries ... OK +* checking for code/documentation mismatches ... OK +* checking Rd \usage sections ... OK +* checking Rd contents ... OK +* checking for unstated dependencies in examples ... OK +* checking examples ... OK +* checking for unstated dependencies in ‘tests’ ... OK +* checking tests ... OK + Running ‘testthat.R’ +* DONE +Status: OK diff --git a/aFIPC.Rcheck/00install.out b/aFIPC.Rcheck/00install.out new file mode 100644 index 0000000..36caa27 --- /dev/null +++ b/aFIPC.Rcheck/00install.out @@ -0,0 +1,11 @@ +* installing *source* package ‘aFIPC’ ... +** using staged installation +** R +** byte-compile and prepare package for lazy loading +** help +*** installing help indices +** building package indices +** testing if installed package can be loaded from temporary location +** testing if installed package can be loaded from final location +** testing if installed package keeps a record of temporary installation path +* DONE (aFIPC) diff --git a/aFIPC.Rcheck/aFIPC-Ex.R b/aFIPC.Rcheck/aFIPC-Ex.R new file mode 100644 index 0000000..5e6b5ed --- /dev/null +++ b/aFIPC.Rcheck/aFIPC-Ex.R @@ -0,0 +1,43 @@ +pkgname <- "aFIPC" +source(file.path(R.home("share"), "R", "examples-header.R")) +options(warn = 1) +library('aFIPC') + +base::assign(".oldSearch", base::search(), pos = 'CheckExEnv') +base::assign(".old_wd", base::getwd(), pos = 'CheckExEnv') +cleanEx() +nameEx("autoFIPC") +### * autoFIPC + +flush(stderr()); flush(stdout()) + +### Name: autoFIPC +### Title: automated fixed item parameter linking +### Aliases: autoFIPC + +### ** Examples + +## Not run: +##D autoFIPC( +##D newformXData = new_model, +##D oldformYData = old_model, +##D newformCommonItemNames = common_new, +##D oldformCommonItemNames = common_old, +##D confirmCommonItems = TRUE +##D ) +## End(Not run) + + + +### *