From ebf0f871a9d726b23425c259fe00de3bb837aa5d Mon Sep 17 00:00:00 2001 From: philchalmers Date: Thu, 7 Nov 2024 11:22:13 -0500 Subject: [PATCH] attach MLTM to M2() --- R/M2.R | 29 ++++++++++++++++------------- tests/tests/test-18-LLTM.R | 4 ++++ 2 files changed, 20 insertions(+), 13 deletions(-) diff --git a/R/M2.R b/R/M2.R index cf521e5b..6707d884 100644 --- a/R/M2.R +++ b/R/M2.R @@ -90,7 +90,6 @@ #' } M2 <- function(obj, type="M2*", calcNull = TRUE, na.rm=FALSE, quadpts = NULL, theta_lim = c(-6, 6), CI = .9, residmat = FALSE, QMC = FALSE, suppress = 1, ...){ - impute <- 0 if(is(obj, 'MixtureModel')) stop('Mixture IRT models not yet supported', call.=FALSE) @@ -173,11 +172,6 @@ M2 <- function(obj, type="M2*", calcNull = TRUE, na.rm=FALSE, quadpts = NULL, th } if(length(prodlist) > 0L) Theta <- prodterms(Theta, prodlist) - if(extract.mirt(obj, 'nfixedeffects') > 0){ - warning('M2() not fully tested for itemdesign effects') - if(nrow(extract.mirt(obj, "fixed.design")) == 1) - Theta <- cbind(extract.mirt(obj, "fixed.design")[rep(1, nrow(Theta)), , drop=FALSE], Theta) - } } else { Theta <- obj@Model$Theta prior <- bfactorlist$prior[[group]]; Priorbetween <- bfactorlist$Priorbetween[[group]] @@ -198,13 +192,16 @@ M2 <- function(obj, type="M2*", calcNull = TRUE, na.rm=FALSE, quadpts = NULL, th for(i in seq_len(nitems)){ x <- extract.item(obj, i) scs <- 1L:x@ncat - 1L - EIs[,i] <- expected.item(x, Theta, min=0L) - prob <- ProbTrace(x, Theta) + Thetastar <- Theta + if(x@nfixedeffects > 0) + Thetastar <- cbind(x@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], Theta) + EIs[,i] <- expected.item(x, Thetastar, min=0L) + prob <- ProbTrace(x, Thetastar) E11s[,i] <- colSums((1L:ncol(prob)-1L)^2 * t(prob)) cfs <- scs * scs EIs2[,i] <- t(cfs %*% t(prob)) tmp <- length(x@parnum) - DP[ ,ind:(ind+tmp-1L)] <- dP(x, Theta) + DP[ ,ind:(ind+tmp-1L)] <- dP(x, Thetastar) ind <- ind + tmp wherepar[i+1L] <- ind } @@ -264,14 +261,17 @@ M2 <- function(obj, type="M2*", calcNull = TRUE, na.rm=FALSE, quadpts = NULL, th for(i in seq_len(nitems)){ x <- extract.item(obj, i) scs <- 1L:x@ncat - 1L - EIs[,i] <- expected.item(x, Theta, min=0L) - prob <- ProbTrace(x, Theta) + Thetastar <- Theta + if(x@nfixedeffects > 0) + Thetastar <- cbind(x@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], Theta) + EIs[,i] <- expected.item(x, Thetastar, min=0L) + prob <- ProbTrace(x, Thetastar) PIs[,pind:(pind+ncol(prob)-2L)] <- prob[,-1L] E11s[,i] <- colSums((1L:ncol(prob)-1L)^2 * t(prob)) cfs <- scs * scs EIs2[,i] <- t(cfs %*% t(prob)) tmp <- length(x@parnum) - DP[ ,ind:(ind+tmp-1L)] <- dP(x, Theta) + DP[ ,ind:(ind+tmp-1L)] <- dP(x, Thetastar) pind <- pind + K[i] - 1L ind <- ind + tmp wherepar[i+1L] <- ind @@ -303,7 +303,10 @@ M2 <- function(obj, type="M2*", calcNull = TRUE, na.rm=FALSE, quadpts = NULL, th offset <- pars[[1L]]@parnum[1L] - 1L for(i in seq_len(nitems)){ x <- extract.item(obj, i) - tmp <- lapply(numDeriv_dP2(x, Theta), function(x) colSums(x * Prior)) + Thetastar <- Theta + if(x@nfixedeffects > 0) + Thetastar <- cbind(x@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], Theta) + tmp <- lapply(numDeriv_dP2(x, Thetastar), function(x) colSums(x * Prior)) dp <- if(length(tmp) == 1L) matrix(tmp[[1L]], nrow=1L) else do.call(rbind, tmp) delta1[pind1:(pind1+nrow(dp)-1L), pars[[i]]@parnum - offset] <- dp pind1 <- pind1 + nrow(dp) diff --git a/tests/tests/test-18-LLTM.R b/tests/tests/test-18-LLTM.R index e49a6787..708c14fb 100644 --- a/tests/tests/test-18-LLTM.R +++ b/tests/tests/test-18-LLTM.R @@ -30,6 +30,8 @@ test_that('LLTM', { cfs <- coef(lltm.4, simplify=TRUE)$items expect_equal(as.vector(cfs[c(1,5), 1:3]), c(0, .9063842, numeric(4)), tol=1e-2) expect_equal(anova(lltm, lltm.4)$p[2], 0.04288353, tol=1e-2) + m2 <- M2(lltm.4) + expect_equal(m2$TLI, 1.001862, tol=1e-2) }) @@ -73,6 +75,8 @@ test_that('MLTM', { fs <- fscores(mltm) expect_equal(as.vector(fs[1:3,]), c(-2.0019607,1.138449,0.149316, -0.4814751,0.3697978,1.7928627), tol=1e-2) + m2 <- M2(mltm) + expect_equal(m2$CFI, 0.9758302, tol=1e-2) })