corentinchoisy/SPT
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

corrected theta and residuals computation whith dif in pcm

Browse Source
This commit is contained in:
Corentin Choisy
2025-06-03 16:25:15 +02:00
parent 52252dd5eb
commit de01f2d837
1 changed files with 24 additions and 6 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
R/pcm.R
View File

@ -45,11 +45,11 @@ pcm <- function(df=NULL,items=NULL,grp=NULL,dif.items=NULL,type.dif=NULL,weights
stop('ERROR: no column named id provided') stop('ERROR: no column named id provided')
} }
suppressWarnings( suppressWarnings(
if (!is.null(grp) & any(apply(df[df[,grp]==0,items],2,function(k) max(k,na.rm = T))<max(df[,items],na.rm = T)) | any(apply(df[df[,grp]==1,items],2,function(k) max(k,na.rm = T))<max(df[,items],na.rm=T)) ) { if (!is.null(grp) & any(apply(df[df[,grp]==0,items],2,function(k) max(k,na.rm = T))<max(df[,items],na.rm = T)) | any(apply(df[df[,grp]==1,items],2,function(k) max(k,na.rm = T))<max(df[,items],na.rm=T)) ) {
if (fit=="ucminf") { if (fit=="ucminf") {
fit <- "optim" fit <- "optim"
}
} }
}
) )
##### Analysis ##### Analysis
restab.diftype <- NULL restab.diftype <- NULL
@ -271,6 +271,8 @@ pcm <- function(df=NULL,items=NULL,grp=NULL,dif.items=NULL,type.dif=NULL,weights
} }
} }
if (is.null(dif.items)) {
if (method.theta=="eap") { if (method.theta=="eap") {
theta <- c(-1*ranef(mod,norm=F)+ ifelse(is.null(grpo),0, ifelse(grp==1,beta,0) ) ) theta <- c(-1*ranef(mod,norm=F)+ ifelse(is.null(grpo),0, ifelse(grp==1,beta,0) ) )
} else if (method.theta=="wle") { } else if (method.theta=="wle") {
@ -278,9 +280,25 @@ pcm <- function(df=NULL,items=NULL,grp=NULL,dif.items=NULL,type.dif=NULL,weights
} else if (method.theta=="mle") { } else if (method.theta=="mle") {
theta <- PP::PP_gpcm(as.matrix(df[,items]),t(restab),rep(1,length(items)),type="mle")$resPP$resPP[,1] theta <- PP::PP_gpcm(as.matrix(df[,items]),t(restab),rep(1,length(items)),type="mle")$resPP$resPP[,1]
} }
resid <- apply(matrix(1:nbitems,ncol=length(nbitems)),1, function(k) sapply(1:nrow(df), function(j) resi(theta[j],restab[k,],df[j,items[k]],beta=0)))
} else {
restaba <- restab
restaba[rownames(restab)[dif.items],] <- restaba[rownames(restab)[dif.items],] + restab.dif[paste0("dif.",rownames(restab)[dif.items]),]
theta <- rep(NA,nrow(df))
resid <- matrix(NA,nrow=nrow(df),ncol=nbitems)
if (method.theta=="eap") {
theta <- c(-1*ranef(mod,norm=F)+ ifelse(is.null(grpo),0, ifelse(grp==1,beta,0) ) )
} else if (method.theta=="wle") {
theta[grp==0] <- PP::PP_gpcm(as.matrix(df[grp==0,items]),t(restab),rep(1,length(items)))$resPP$resPP[,1]
theta[grp==1] <- PP::PP_gpcm(as.matrix(df[grp==1,items]),t(restaba),rep(1,length(items)))$resPP$resPP[,1]
} else if (method.theta=="mle") {
theta[grp==0] <- PP::PP_gpcm(as.matrix(df[grp==0,items]),t(restab),rep(1,length(items)),type="mle")$resPP$resPP[,1]
theta[grp==1] <- PP::PP_gpcm(as.matrix(df[grp==1,items]),t(restaba),rep(1,length(items)),type="mle")$resPP$resPP[,1]
}
resid[grp==0,] <- apply(matrix(1:nbitems,ncol=length(nbitems)),1, function(k) sapply(which(grp==0), function(j) resi(theta[j],restab[k,],df[j,items[k]],beta=0)))
resid[grp==1,] <- apply(matrix(1:nbitems,ncol=length(nbitems)),1, function(k) sapply(which(grp==1), function(j) resi(theta[j],restaba[k,],df[j,items[k]],beta=0)))
}
resid <- apply(matrix(1:nbitems,ncol=length(nbitems)),1, function(k) sapply(1:nrow(df), function(j) resi(theta[j],restab[k,],df[j,items[k]],beta=0)))
colnames(resid) <- items_o colnames(resid) <- items_o
##### Output ##### Output