Skip to content

Commit

Permalink
more than enough glue
Browse files Browse the repository at this point in the history
  • Loading branch information
@philchalmers
philchalmers committed Nov 7, 2024
1 parent 91b31b9 commit 59d0f8a
Show file tree
Hide file tree
Showing 5 changed files with 54 additions and 20 deletions.
36 changes: 29 additions & 7 deletions R/SingleGroup-methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1360,8 +1360,13 @@ setMethod(
if(is.null(main))
main <- 'Item Information'
I <- matrix(NA, nrow(Theta), J)
for(i in which.items)
I[,i] <- iteminfo(extract.item(x, i), ThetaFull, degrees=degrees)
for(i in which.items){
ei <- extract.item(x, i)
ThetaFullstar <- ThetaFull
if(ei@nfixedeffects > 0)
ThetaFullstar <- cbind(ei@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], ThetaFull)
I[,i] <- iteminfo(ei, ThetaFullstar, degrees=degrees)
}
I <- t(na.omit(t(I)))
items <- rep(colnames(x@Data$data)[which.items], each=nrow(Theta))
plotobj <- data.frame(I = as.numeric(I), Theta=ThetaFull, item=items)
Expand All @@ -1377,7 +1382,11 @@ setMethod(
names(S) <- colnames(x@Data$data)[which.items]
ind <- 1L
for(i in which.items){
S[[ind]] <- expected.item(extract.item(x, i), ThetaFull, mins[i])
ei <- extract.item(x, i)
ThetaFullstar <- ThetaFull
if(ei@nfixedeffects > 0)
ThetaFullstar <- cbind(ei@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], ThetaFull)
S[[ind]] <- expected.item(ei, ThetaFullstar, mins[i])
ind <- ind + 1L
}
Sstack <- do.call(c, S)
Expand Down Expand Up @@ -1532,7 +1541,11 @@ setMethod(
ind <- 1L
alltwocats <- all(extract.mirt(x, 'K')[which.items] == 2L)
for(i in which.items){
tmp <- probtrace(extract.item(x, i), ThetaFull)
ei <- extract.item(x, i)
ThetaFullstar <- ThetaFull
if(ei@nfixedeffects > 0)
ThetaFullstar <- cbind(ei@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], ThetaFull)
tmp <- probtrace(ei, ThetaFullstar)
if(ncol(tmp) == 2L && (facet_items || (!facet_items && alltwocats)) && drop2)
tmp <- tmp[,2, drop=FALSE]
tmp2 <- data.frame(P=as.numeric(tmp), cat=gl(ncol(tmp), k=nrow(Theta),
Expand Down Expand Up @@ -1565,7 +1578,11 @@ setMethod(
names(S) <- colnames(x@Data$data)[which.items]
ind <- 1L
for(i in which.items){
S[[ind]] <- expected.item(extract.item(x, i), ThetaFull, mins[i])
ei <- extract.item(x, i)
ThetaFullstar <- ThetaFull
if(ei@nfixedeffects > 0)
ThetaFullstar <- cbind(ei@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], ThetaFull)
S[[ind]] <- expected.item(ei, ThetaFullstar, mins[i])
ind <- ind + 1L
}
Sstack <- do.call(c, S)
Expand All @@ -1587,8 +1604,13 @@ setMethod(
if(is.null(main))
main <- 'Item Information'
I <- matrix(NA, nrow(Theta), J)
for(i in which.items)
I[,i] <- iteminfo(extract.item(x, i), ThetaFull)
for(i in which.items){
ei <- extract.item(x, i)
ThetaFullstar <- ThetaFull
if(ei@nfixedeffects > 0)
ThetaFullstar <- cbind(ei@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], ThetaFull)
I[,i] <- iteminfo(ei, ThetaFullstar)
}
I <- t(na.omit(t(I)))
items <- rep(colnames(x@Data$data)[which.items], each=nrow(Theta))
plotobj <- data.frame(I = as.numeric(I), Theta=Theta, item=items)
Expand Down
8 changes: 6 additions & 2 deletions R/itemfit.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -547,8 +547,12 @@ itemfit <- function(x, fit_stats = 'S_X2',
if(Zh){
N <- nrow(Theta)
itemtrace <- matrix(0, ncol=ncol(fulldata), nrow=N)
for (i in which.items)
itemtrace[ ,itemloc[i]:(itemloc[i+1L] - 1L)] <- ProbTrace(x=pars[[i]], Theta=Theta)
for (i in which.items){
Thetastar <- Theta
if(pars[[i]]@nfixedeffects > 0)
Thetastar <- cbind(pars[[i]]@fixed.design[rep(1, nrow(Theta)), , drop=FALSE], Theta)
itemtrace[ ,itemloc[i]:(itemloc[i+1L] - 1L)] <- ProbTrace(x=pars[[i]], Theta=Thetastar)
}
log_itemtrace <- log(itemtrace)
LL <- log_itemtrace * fulldata
Lmatrix <- matrix(LL[as.logical(fulldata)], N, J)
Expand Down
26 changes: 15 additions & 11 deletions R/itemplot.internal.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -168,28 +168,32 @@ itemplot.main <- function(x, item, type, degrees, CE, CEalpha, CEdraws, drop.zer
Theta <- thetaComb(theta, x@Model$nfact)
ThetaFull <- prodterms(Theta,prodlist)
} else Theta <- ThetaFull <- thetaComb(theta, nfact)
ThetaFullstar <- ThetaFull
if(extract.mirt(x, 'nfixedeffects') > 0)
ThetaFullstar <- cbind(x@ParObjects$pars[[item]]@fixed.design[rep(1, nrow(ThetaFull)), , drop=FALSE],
ThetaFull)
if(length(degrees) == 1) degrees <- rep(degrees, ncol(ThetaFull))
if(is(x, 'SingleGroupClass') && x@Options$exploratory){
cfs <- coef(x, ..., verbose=FALSE, rawug=TRUE)
x@ParObjects$pars[[item]]@par <- as.numeric(cfs[[item]][1L,])
}
P <- ProbTrace(x=x@ParObjects$pars[[item]], Theta=ThetaFull)
P <- ProbTrace(x=x@ParObjects$pars[[item]], Theta=ThetaFullstar)
if(type == 'threshold')
P <- 1 - t(apply(P, 1, cumsum))
K <- x@ParObjects$pars[[item]]@ncat
info <- numeric(nrow(ThetaFull))
if(K == 2L) auto.key <- FALSE
if(type %in% c('info', 'SE', 'infoSE', 'infotrace', 'RE', 'infocontour', 'infocat', 'RETURN')){
if(nfact == 1){
info <- iteminfo(x=x@ParObjects$pars[[item]], Theta=ThetaFull, degrees=0)
info <- iteminfo(x=x@ParObjects$pars[[item]], Theta=ThetaFullstar, degrees=0)
} else {
info <- iteminfo(x=x@ParObjects$pars[[item]], Theta=ThetaFull, degrees=degrees)
info <- iteminfo(x=x@ParObjects$pars[[item]], Theta=ThetaFullstar, degrees=degrees)
}
}
if(type == 'infocat'){
stopifnot(nfact == 1L && K > 2L)
type <- 'info'
infocat <- iteminfo(x=x@ParObjects$pars[[item]], Theta=ThetaFull,
infocat <- iteminfo(x=x@ParObjects$pars[[item]], Theta=ThetaFullstar,
degrees=0, total.info = FALSE)
} else infocat <- NULL
CEinfoupper <- CEinfolower <- info
Expand Down Expand Up @@ -217,14 +221,14 @@ itemplot.main <- function(x, item, type, degrees, CE, CEalpha, CEdraws, drop.zer
upper <- sorttmp[ceiling(length(tmp) * (1-CEalpha/2))]
delta <- delta[tmp < upper & tmp > lower, , drop=FALSE]
tmpitem@par[tmpitem@est] <- delta[1, ]
CEinfoupper <- CEinfolower <- iteminfo(tmpitem, ThetaFull, degrees=degrees)
CEprobupper <- CEproblower <- ProbTrace(tmpitem, ThetaFull)
CEscoreupper <- CEscorelower <- expected.item(tmpitem, ThetaFull, min = x@Data$mins[item])
CEinfoupper <- CEinfolower <- iteminfo(tmpitem, ThetaFullstar, degrees=degrees)
CEprobupper <- CEproblower <- ProbTrace(tmpitem, ThetaFullstar)
CEscoreupper <- CEscorelower <- expected.item(tmpitem, ThetaFullstar, min = x@Data$mins[item])
for(i in 2:nrow(delta)){
tmpitem@par[tmpitem@est] <- delta[i, ]
CEinfo <- iteminfo(tmpitem, ThetaFull, degrees=degrees)
CEprob <- ProbTrace(tmpitem, ThetaFull)
CEscore <- expected.item(tmpitem, ThetaFull, min = x@Data$mins[item])
CEinfo <- iteminfo(tmpitem, ThetaFullstar, degrees=degrees)
CEprob <- ProbTrace(tmpitem, ThetaFullstar)
CEscore <- expected.item(tmpitem, ThetaFullstar, min = x@Data$mins[item])
CEinfoupper <- apply(cbind(CEinfoupper, CEinfo), 1, max)
CEinfolower <- apply(cbind(CEinfolower, CEinfo), 1, min)
CEscoreupper <- apply(cbind(CEscoreupper, CEscore), 1, max)
Expand All @@ -236,7 +240,7 @@ itemplot.main <- function(x, item, type, degrees, CE, CEalpha, CEdraws, drop.zer
}
}
if(type == 'RETURN') return(data.frame(P=P, info=info, Theta=Theta))
score <- expected.item(x@ParObjects$pars[[item]], Theta=ThetaFull, min=x@Data$mins[item])
score <- expected.item(x@ParObjects$pars[[item]], Theta=ThetaFullstar, min=x@Data$mins[item])
if(ncol(P) == 2 && type != 'threshold'){
P <- P[ ,-1, drop = FALSE]
CEprobupper <- CEprobupper[ ,-1, drop = FALSE]
Expand Down
2 changes: 2 additions & 0 deletions R/mirt.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1317,6 +1317,8 @@
#'
#' # additional information for LLTM
#' plot(lltm)
#' plot(lltm, type = 'trace')
#' itemplot(lltm, item=1)
#' itemfit(lltm)
#' head(fscores(lltm)) #EAP estimates
#' fscores(lltm, method='EAPsum', full.scores=FALSE)
Expand Down
2 changes: 2 additions & 0 deletions man/mirt.Rd
View file

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit 59d0f8a

Please sign in to comment.