Skip to content

Commit

Permalink
optimize better
Browse files Browse the repository at this point in the history
  • Loading branch information
@philchalmers
philchalmers committed Nov 7, 2024
1 parent 1286c60 commit 1253650
Show file tree
Hide file tree
Showing 3 changed files with 23 additions and 33 deletions.
39 changes: 13 additions & 26 deletions R/02b-item_methods.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1088,14 +1088,14 @@ setMethod(
if(nfact != length(cpow)){
if(cpow[i] == 0) next
pick <- fixed.ind[i]:(fixed.ind[i+1]-1)
# dstar <- sum(a[pick] * t(thetas[,pick,drop=FALSE]))
Pk <- (P.mirt(c(a[factor.ind[i]], d[i],-999,999),
dstar <- sum(a[pick] * thetas[1,pick])
Pk <- (P.mirt(c(a[factor.ind[i]], d[i] + dstar,-999,999),
matrix(thetas[,factor.ind[i]]))[,2L])^cpow[i]
Qk <- 1 - Pk
dd[i] <- sum((1-c)*Pstar*Qk*const1)
da[factor.ind[i]] <- sum((1-c)*Pstar*Qk*thetas[,factor.ind[i]]*const1)
for(j in 1:length(pick))
da[pick[j]] <- dd[i] * thetas[pick[j]]
da[pick[j]] <- dd[i] * thetas[1,pick[j]]
} else {
Pk <- (P.mirt(c(a[i],d[i],-999,999),matrix(thetas[,i]))[,2L])^cpow[i]
Qk <- 1 - Pk
Expand Down Expand Up @@ -1240,33 +1240,20 @@ setMethod(
f <- rowSums(x@dat)
r <- x@dat[ ,2L]
g <- x@par[length(x@par)-1L]
if(x@nfixedeffects > 0){ # TODO temporary
grad <- rep(0, length(x@par))
tmp <- dpars.comp(lambda=ExtractLambdas(x),zeta=ExtractZetas(x),
g=g, r=r, f=f, Thetas=Theta, estHess=estHess && x@nfixedeffects != 0,
factor.ind=x@factor.ind, fixed.ind=x@fixed.ind)
ret <- list(grad=tmp$grad, hess=tmp$hess)
if(x@any.prior) ret <- DerivativePriors(x=x, grad=ret$grad, hess=ret$hess)
if(estHess && x@nfixedeffects > 0){
hess <- matrix(0, length(x@par), length(x@par))
pick <- x@est & c(x@fixed.design != 0, rep(TRUE, 2*length(x@cpow)), TRUE, TRUE)
x@est <- pick
grad[pick] <- numerical_deriv(x@par[pick], EML, obj=x, Theta=Theta)
# print(round(rbind(ret$grad[x@est], grad[x@est]), 3))
pick <- x@est & c(x@fixed.design != 0, rep(TRUE, length(x@cpow)*2), TRUE, TRUE)
if(estHess && any(pick)){
x@est <- pick
hess[pick, pick] <- numerical_deriv(x@par[pick], EML, obj=x,
Theta=Theta, gradient=FALSE)
Theta=Theta, gradient=FALSE)
}
ret <- list(grad=grad, hess=hess)
} else {
tmp <- dpars.comp(lambda=ExtractLambdas(x),zeta=ExtractZetas(x),
g=g, r=r, f=f, Thetas=Theta, estHess=estHess,
factor.ind=x@factor.ind, fixed.ind=x@fixed.ind)
ret <- list(grad=tmp$grad, hess=tmp$hess)
if(x@any.prior) ret <- DerivativePriors(x=x, grad=ret$grad, hess=ret$hess)
# if(FALSE){
# grad <- numeric(length(x@par))
# hess <- matrix(0, length(x@par), length(x@par))
# grad[x@est] <- numerical_deriv(x@par[x@est], EML, obj=x, Theta=Theta)
# # print(round(rbind(ret$grad[x@est], grad[x@est]), 3))
# if(estHess && any(x@est))
# hess[x@est, x@est] <- numerical_deriv(x@par[pick], EML, obj=x,
# Theta=Theta, gradient=FALSE)
# }
ret$hess <- hess
}
return(ret)
}
Expand Down
9 changes: 4 additions & 5 deletions R/03-estimation.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -748,7 +748,7 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
if(opts$plausible.draws != 0) return(ESTIMATE)
if(opts$SE && (ESTIMATE$converge || !opts$info_if_converged)){
if(opts$verbose)
cat('\nCalculating information matrix...\n')
catf('\nCalculating information matrix...\n')
tmp <- MHRM.group(pars=ESTIMATE$pars, constrain=constrain, Ls=Ls, PrepList=PrepList, Data=Data,
list = list(NCYCLES=opts$MHRM_SE_draws, BURNIN=1L,
SEMCYCLES=opts$SEMCYCLES, gain=opts$gain,
Expand Down Expand Up @@ -797,7 +797,7 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
DERIV=DERIV, solnp_args=opts$solnp_args, control=control)
if(opts$SE && (ESTIMATE$converge || !opts$info_if_converged)){
if(opts$verbose)
cat('\nCalculating information matrix...\n')
catf('\nCalculating information matrix...\n')
tmp <- MHRM.group(pars=ESTIMATE$pars, constrain=constrain, Ls=Ls,
PrepList=PrepList, random=mixed.design$random, Data=Data,
lrPars=ESTIMATE$lrPars, lr.random=latent.regression$lr.random,
Expand Down Expand Up @@ -848,7 +848,7 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
if(!opts$NULL.MODEL && opts$SE){
tmp <- ESTIMATE
if(opts$verbose && !(opts$method %in% c('MHRM', 'MIXED', 'SEM')))
cat('\n\nCalculating information matrix...\n')
catf('\n\nCalculating information matrix...\n')
if(opts$SE.type %in% c('complete', 'Oakes') && opts$method %in% c('EM', 'QMCEM')){
opts$times$start.time.SE <- ESTIMATE$start.time.SE
ESTIMATE <- loadESTIMATEinfo(info=-ESTIMATE$hess, ESTIMATE=ESTIMATE, constrain=constrain,
Expand Down Expand Up @@ -1009,8 +1009,7 @@ ESTIMATION <- function(data, model, group, itemtype = NULL, guess = 0, upper = 1
(!opts$logLik_if_converged || !(!ESTIMATE$converge && opts$logLik_if_converged))){
logLik <- G2 <- SElogLik <- 0
if(opts$draws > 0L){
if(opts$verbose) cat("\nCalculating log-likelihood...\n")
flush.console()
if(opts$verbose) catf("\nCalculating log-likelihood...\n")
if(!opts$technical$parallel){
ncores <- .mirtClusterEnv$ncores
.mirtClusterEnv$ncores <- 1L
Expand Down
8 changes: 6 additions & 2 deletions R/utils.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2888,6 +2888,10 @@ mySapply <- function(X, FUN, progress = FALSE, ...){
}

printf <- function(...) {
cat(sprintf(...))
flush.console() # print immediately
catf(sprintf(...))
}

catf <- function(...) {
cat(...)
flush.console()
}

0 comments on commit 1253650

Please sign in to comment.