Skip to content

Commit

Permalink
use placeholder logic instead
Browse files Browse the repository at this point in the history
  • Loading branch information
@philchalmers
philchalmers committed Nov 6, 2024
1 parent eccd0b8 commit 1408b34
Show file tree
Hide file tree
Showing 5 changed files with 61 additions and 67 deletions.
104 changes: 49 additions & 55 deletions R/06-LoadPars.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -242,10 +242,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
nfixedeffects <- length(betas)
nfact <- nfact + nfixedeffects
for(i in seq_len(J)){
if(mixed.design$has_idesign[i]){
freepars[[i]] <- c(estbetas, freepars[[i]])
startvalues[[i]] <- c(betas, startvalues[[i]])
}
freepars[[i]] <- if(mixed.design$has_idesign[i])
c(estbetas, freepars[[i]]) else c(!estbetas, freepars[[i]])
startvalues[[i]] <- c(betas, startvalues[[i]])
}
valid.ints <- ifelse(any(K > 2), '', 'd')
if(mixed.design$from != 'mixedmirt') # for partcomp
Expand All @@ -262,10 +261,11 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
for(i in seq_len(J))
fixed.design.list[[i]] <- mixed.design$fixed[1L:N + N*(i-1L), , drop = FALSE]
} else { # TODO from mirt(), for now at least
tmp <- matrix(0, 1L, ncol=ncol(fixed.design))
colnames(tmp) <- colnames(fixed.design)
for(i in seq_len(J))
if(mixed.design$has_idesign[i])
fixed.design.list[[i]] <- fixed.design[itemnames[i] == rownames(fixed.design),
, drop = FALSE]
fixed.design.list[[i]] <- if(mixed.design$has_idesign[i])
fixed.design[itemnames[i] == rownames(fixed.design), , drop = FALSE] else tmp
}
}

Expand All @@ -274,19 +274,13 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
K <- as.integer(K)
for(i in seq_len(J)){
tmp <- c(itemloc[i]:(itemloc[i+1L] - 1L)) #item location
item_nfi <- ifelse(!is.null(mixed.design) &&
mixed.design$has_idesign[i], nfixedeffects, 0)
item_nfact <- nfact
if(!is.null(mixed.design) && !mixed.design$has_idesign[i])
item_nfact <- nfact - nfixedeffects


if(any(itemtype[i] == c('Rasch')) && K[i] == 2L){
pars[[i]] <- new('dich', par=startvalues[[i]], est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=2L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=1L,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -305,9 +299,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('gpcm',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=3L,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -330,9 +324,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
par=startvalues[[i]],
est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
itemclass=1L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
ncat=2L,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -352,9 +346,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
par=startvalues[[i]],
est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
itemclass=9L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
ncat=2L,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -374,9 +368,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
par=startvalues[[i]],
est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
itemclass=9L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
ncat=2L,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -396,9 +390,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
par=startvalues[[i]],
est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
itemclass=8L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
ncat=K[i],
correctcat=key[i],
any.prior=FALSE,
Expand All @@ -418,9 +412,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('rating',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=5L,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -440,10 +434,10 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('graded',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
itemclass=2L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
fixed.design=fixed.design.list[[i]],
Expand All @@ -462,10 +456,10 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('ull',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
itemclass=9L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
fixed.design=fixed.design.list[[i]],
Expand All @@ -484,10 +478,10 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('sequential',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
itemclass=9L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
fixed.design=fixed.design.list[[i]],
Expand All @@ -506,9 +500,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('gpcm',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=3L,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -529,10 +523,10 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('gpcmIRT',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
itemclass=6L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
fixed.design=fixed.design.list[[i]],
Expand All @@ -551,11 +545,11 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('monopoly',
par=startvalues[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
k=as.integer(monopoly.k[i]),
itemclass=12L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
fixed.design=fixed.design.list[[i]],
Expand All @@ -576,10 +570,10 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
parnames=names(freepars[[i]]),
est=freepars[[i]],
mat=FALSE,
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
itemclass=4L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
prior.type=rep(0L, length(startvalues[[i]])),
fixed.design=fixed.design.list[[i]],
Expand Down Expand Up @@ -618,11 +612,11 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
par=startvalues[[i]],
parnames=names(freepars[[i]]),
est=freepars[[i]],
nfact=item_nfact,
nfact=nfact,
ncat=2L,
itemclass=7L,
cpow=cpow,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
fixed.ind=fixed.ind,
factor.ind=factor.ind,
any.prior=FALSE,
Expand All @@ -641,9 +635,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
if(any(itemtype[i] == c('ideal'))){
pars[[i]] <- new('ideal', par=startvalues[[i]], est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=2L,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=9L,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -661,9 +655,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
if(any(itemtype[i] == 'lca')){
pars[[i]] <- new('lca', par=startvalues[[i]], est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=10L,
item.Q=item.Q[[i]],
Expand Down Expand Up @@ -704,13 +698,13 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new('spline', par=p,
parnames=names(est),
est=est,
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
stype=stype,
item.Q=matrix(1, K[i], length(p)),
Theta_prime=matrix(0),
sargs=sargs,
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=11L,
prior.type=rep(0L, length(p)),
Expand All @@ -731,9 +725,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
par=startvalues[[i]],
est=freepars[[i]],
parnames=names(freepars[[i]]),
nfact=item_nfact,
nfact=nfact,
ncat=K[i],
nfixedeffects=item_nfi,
nfixedeffects=nfixedeffects,
any.prior=FALSE,
itemclass=11L,
prior.type=rep(0L, length(startvalues[[i]])),
Expand All @@ -753,9 +747,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,
pars[[i]] <- new(itemtype[i], nfact=nfact, ncat=K[i])
names(pars[[i]]@est) <- names(pars[[i]]@par)
pars[[i]]@parnames <- names(pars[[i]]@est)
pars[[i]]@nfact <- item_nfact
pars[[i]]@nfact <- nfact
pars[[i]]@ncat <- K[i]
pars[[i]]@nfixedeffects <- item_nfi
pars[[i]]@nfixedeffects <- nfixedeffects
pars[[i]]@any.prior <- FALSE
pars[[i]]@itemclass <- 9L
pars[[i]]@prior.type <- rep(0L, length(pars[[i]]@par))
Expand All @@ -770,9 +764,9 @@ LoadPars <- function(itemtype, itemloc, lambdas, zetas, guess, upper, fulldata,

if(all(itemtype[i] != valid.items)){
pars[[i]] <- customItems[[which(itemtype[i] == names(customItems))]]
pars[[i]]@nfact <- item_nfact
pars[[i]]@nfact <- nfact
pars[[i]]@ncat <- K[i]
pars[[i]]@nfixedeffects <- item_nfi
pars[[i]]@nfixedeffects <- nfixedeffects
pars[[i]]@any.prior <- FALSE
pars[[i]]@itemclass <- 9L
pars[[i]]@prior.type <- rep(0L, length(pars[[i]]@par))
Expand Down
12 changes: 3 additions & 9 deletions R/SingleGroup-methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -314,15 +314,9 @@ setMethod(
J <- object@Data$nitems
nfe <- max(sapply(1:J, \(i) object@ParObjects$pars[[i]]@nfixedeffects))
nfact <- object@Model$nfact + length(object@Model$prodlist) + nfe
a <- vector('list', J)
for(i in 1:J){
tmp <- ExtractLambdas(object@ParObjects$pars[[i]])
names(tmp) <- names(object@ParObjects$pars[[i]]@est)[1:length(tmp)]
if(nfe > 0 && length(tmp) < nfact)
tmp <- c(rep(NA, nfact - length(tmp)), tmp)
a[[i]] <- tmp
}
a <- do.call(rbind, a)
a <- matrix(0, J, nfact)
for(i in 1:J)
a[i, ] <- ExtractLambdas(object@ParObjects$pars[[i]])
if (object@Options$exploratory && rotate != 'none'){
if(verbose) cat("\nRotation: ", rotate, "\n\n")
so <- summary(object, rotate=rotate, Target=Target, verbose=FALSE, ...)
Expand Down
4 changes: 3 additions & 1 deletion R/mirt.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1321,14 +1321,16 @@
#' # intercept across items also possible by removing ~ 0 portion, just interpreted differently
#' lltm.int <- mirt(dat, itemtype = 'Rasch',
#' item.formula = ~ difficulty, itemdesign=itemdesign)
#' anova(lltm, lltm.int) # same
#' coef(lltm.int, simplify=TRUE)
#'
#' # using unconditional modeling for first four items
#' itemdesign.sub <- itemdesign[5:nrow(itemdesign), , drop=FALSE]
#' itemdesign.sub # note that rownames are required in this case
#' lltm.4 <- mirt(dat, itemtype = 'Rasch',
#' item.formula = ~ difficulty, itemdesign=itemdesign.sub)
#' item.formula = ~ 0 + difficulty, itemdesign=itemdesign.sub)
#' coef(lltm.4, simplify=TRUE) # first four items are the standard Rasch
#' anova(lltm, lltm.4) # similar fit, hence more constrained model preferred
#'
#' # LLTM with mixedmirt() (more flexible in general, but slower)
#' LLTM <- mixedmirt(dat, model=1, fixed = ~ 0 + difficulty,
Expand Down
4 changes: 3 additions & 1 deletion R/utils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -821,7 +821,9 @@ UpdateConstrain <- function(pars, constrain, invariance, nfact, nLambdas, J, ngr
for(i in which(mixed.design$has_idesign))
if(pars[[g]][[i]]@est[p])
constr[i] <- pars[[g]][[i]]@parnum[p]
constrain[[length(constrain) + 1L]] <- na.omit(constr)
constr <- na.omit(constr)
if(length(constr))
constrain[[length(constrain) + 1L]] <- constr
}
}
}
Expand Down
4 changes: 3 additions & 1 deletion 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 1408b34

Please sign in to comment.