1.5-18

alexanderrobitzsch · Mar 21, 2024 · ae95453 · ae95453
1 parent e9db57f
commit ae95453
Show file tree

Hide file tree

Showing 126 changed files with 15,128 additions and 6,443 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: immer
 Type: Package
 Title: Item Response Models for Multiple Ratings
-Version: 1.5-1
-Date: 2022-08-22 19:46:43
+Version: 1.5-10
+Date: 2024-03-21 12:21:24
 Author: 
  Alexander Robitzsch [aut, cre], Jan Steinfeld [aut]
 Maintainer: Alexander Robitzsch <[email protected]>

diff --git a/R/IRT.likelihood.immer_HRM.R b/R/IRT.likelihood.immer_HRM.R
@@ -1,5 +1,5 @@
 ## File Name: IRT.likelihood.immer_hrm.R
-## File Version: 0.08
+## File Version: 0.092
 
 
 
@@ -8,9 +8,9 @@
 IRT.likelihood.immer_hrm <- function( object, ... )
 {
  ll <- object$f.yi.qk
- attr(ll,"theta") <- object$theta_like
- attr(ll,"prob.theta") <- object$pi.k
- attr(ll,"G") <- 1
+ attr(ll,'theta') <- object$theta_like
+ attr(ll,'prob.theta') <- object$pi.k
+ attr(ll,'G') <- 1
  return(ll)
 }
 #############################################################
@@ -21,9 +21,9 @@ IRT.likelihood.immer_hrm <- function( object, ... )
 IRT.posterior.immer_hrm <- function( object, ... )
 {
  ll <- object$f.qk.yi
- attr(ll,"theta") <- object$theta_like
- attr(ll,"prob.theta") <- object$pi.k
- attr(ll,"G") <- 1
+ attr(ll,'theta') <- object$theta_like
+ attr(ll,'prob.theta') <- object$pi.k
+ attr(ll,'G') <- 1
  return(ll)
 }
 #############################################################
diff --git a/R/MHprop_hrm.R b/R/MHprop_hrm.R
@@ -1,5 +1,5 @@
 ## File Name: MHprop_hrm.R
-## File Version: 0.13
+## File Version: 0.142
 
 
 ######################################################################
@@ -14,10 +14,10 @@ MHprop_hrm <- function( MHprop, b, a, phi, theta, iter, burnin )
  # Browne and Draper (2006)
  MHprop$refresh_formula <- TRUE
 
- MHprop$SD <- list( "b"=.4+0*b, "a"=.4 +0*a, "phi"=.2 + 0*phi, "psi"=.4 + 0*psi,
- "theta"=.5 + 0*theta )
- MHprop$accept <- list("b"=0 + 0*b, "a"=0 + 0*a, "phi"=0+0*phi,
- "psi"=0 + 0*psi, "theta"=0 + 0*theta )
+ MHprop$SD <- list( 'b'=.4+0*b, 'a'=.4 +0*a, 'phi'=.2 + 0*phi, 'psi'=.4 + 0*psi,
+ 'theta'=.5 + 0*theta )
+ MHprop$accept <- list('b'=0 + 0*b, 'a'=0 + 0*a, 'phi'=0+0*phi,
+ 'psi'=0 + 0*psi, 'theta'=0 + 0*theta )
 
  MHprop$refresh_count$b <- 0
  MHprop$refresh_count$a <- 0
@@ -39,23 +39,23 @@ MHprop_hrm <- function( MHprop, b, a, phi, theta, iter, burnin )
  MHprop$refresh_SDchange$theta <- .05
 
 
- vars <- c("b","a", "phi", "psi", "theta")
+ vars <- c('b','a', 'phi', 'psi', 'theta')
 
  # compute iterations for which MH updatings must be computed
  refresh_iters <- sort( unique( unlist( MHprop$refresh_iter ) ) )
  RI <- length(refresh_iters)
  v1 <- NULL
- for (rr in 1:RI){
- l1 <- ( 1:iter %% refresh_iters[rr] )==0
- l1 <- (1:iter)[l1]
+ for (rr in 1L:RI){
+ l1 <- (1L:iter %% refresh_iters[rr] )==0
+ l1 <- (1L:iter)[l1]
  v1 <- c( v1, l1 )
  }
  v2 <- sort( unique(v1) )
  v2 <- v2[ v2 <=burnin ]
  MHprop$ITER_refreshing <- v2
 
  # refreshing variables
- MHprop$VARS_refreshing <- c("b", "phi", "psi", "theta")
+ MHprop$VARS_refreshing <- c('b', 'phi', 'psi', 'theta')
 
  # boundaries for acceptance rates
  MHprop$accept_bounds <- c( .4, .6 )

diff --git a/R/MHprop_refresh.R b/R/MHprop_refresh.R
@@ -1,12 +1,12 @@
 ## File Name: MHprop_refresh.R
-## File Version: 0.16
+## File Version: 0.171
 
 
 MHprop_refresh <- function( MHprop )
 {
  vars <- MHprop$VARS_refreshing
  V <- length(vars)
- for (vv in 1:V){
+ for (vv in 1L:V){
  var.vv <- vars[vv]
  ri <- MHprop$refresh_iter[[ var.vv ]]
  accept <- MHprop$accept[[ var.vv ]] / MHprop$refresh_iter[[ var.vv ]]

diff --git a/R/MHprop_refresh_pars.R b/R/MHprop_refresh_pars.R
@@ -1,13 +1,15 @@
 ## File Name: MHprop_refresh_pars.R
-## File Version: 0.04
+## File Version: 0.052
 
 
 MHprop_refresh_pars <- function( acc, SD.pp, MHprop, SDchange )
 {
  target <- mean( MHprop$accept_bounds )
  if (MHprop$refresh_formula){
- SD.pp <- ifelse( acc < MHprop$accept_bounds[1], SD.pp / ( 2 - acc / target ), SD.pp )
- SD.pp <- ifelse( acc > MHprop$accept_bounds[2], SD.pp * ( 2 - (1-acc)/(1-target) ), SD.pp )
+ SD.pp <- ifelse( acc < MHprop$accept_bounds[1],
+ SD.pp / ( 2 - acc / target ), SD.pp )
+ SD.pp <- ifelse( acc > MHprop$accept_bounds[2],
+ SD.pp * ( 2 - (1-acc)/(1-target) ), SD.pp )
  } else {
  SD.pp <- ifelse( acc < MHprop$accept_bounds[1], SD.pp - SDchange, SD.pp )
  SD.pp <- ifelse( acc > MHprop$accept_bounds[2], SD.pp + SDchange, SD.pp )

diff --git a/R/MHprop_refresh_parstype.R b/R/MHprop_refresh_parstype.R
@@ -1,16 +1,17 @@
 ## File Name: MHprop_refresh_parstype.R
-## File Version: 0.07
+## File Version: 0.09
 
 MHprop_refresh_parstype <- function( accept, SD, MHprop, SDchange )
 {
  #--- vector
  if ( is.vector(accept) ){
- SD <- MHprop_refresh_pars( acc=accept, SD.pp=SD, MHprop=MHprop, SDchange=SDchange )
+ SD <- MHprop_refresh_pars( acc=accept, SD.pp=SD, MHprop=MHprop,
+ SDchange=SDchange )
  }
  #--- matrix
  if ( is.matrix(accept) ){
  NP <- ncol(accept)
- for (pp in 1:NP){
+ for (pp in 1L:NP){
  SD[,pp] <- MHprop_refresh_pars( acc=accept[,pp], SD.pp=SD[,pp],
  MHprop=MHprop, SDchange=SDchange)
  }

diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -1,5 +1,5 @@
 ## File Name: RcppExports.R
-## File Version: 1.005001
+## File Version: 1.005010
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 

diff --git a/R/agree_aicken.R b/R/agree_aicken.R
@@ -1,8 +1,8 @@
 ## File Name: agree_aicken.R
-## File Version: 0.09
+## File Version: 0.102
 
-#################################
-# algorithm for Aicken's statistic
+
+#--- algorithm for Aicken's statistic
 agree_aicken <- function( PAk, PBk, Pa )
 {
  PAH <- PAk
@@ -26,7 +26,6 @@ agree_aicken <- function( PAk, PBk, Pa )
  # chance agreement
  Pe <- pet
  # output
- res <- list( "alpha"=alpha, "PAH"=PAH,
- "PBH"=PBH, "Pe"=Pe )
+ res <- list( alpha=alpha, PAH=PAH, PBH=PBH, Pe=Pe )
  return(res)
 }
diff --git a/R/anova_immer.R b/R/anova_immer.R
@@ -1,13 +1,13 @@
 ## File Name: anova_immer.R
-## File Version: 0.22
+## File Version: 0.232
 
 ##############################################################
 # anova method immer_cml
 anova_immer <- function( object, ... )
 {
  cl2 <- paste(match.call())[-1]
  if (length(list(object, ...)) !=2){
- stop("anova method can only be applied for comparison of two models.\n")
+ stop('anova method can only be applied for comparison of two models.\n')
  }
  objects <- list(object, ...)
  model1 <- objects[[1]]
@@ -19,22 +19,22 @@ anova_immer <- function( object, ... )
  model2$loglike <- model2$loglike
  model2$Npars <- model2$npars
  # test
- dfr1 <- data.frame( "Model"=cl2[1],
- "loglike"=model1$loglike,
- "Deviance"=-2*model1$loglike )
+ dfr1 <- data.frame( 'Model'=cl2[1],
+ 'loglike'=model1$loglike,
+ 'Deviance'=-2*model1$loglike )
  dfr1$Npars <- sum(model1$Npars)
- dfr2 <- data.frame( "Model"=cl2[2],
- "loglike"=model2$loglike, "Deviance"=-2*model2$loglike )
+ dfr2 <- data.frame( 'Model'=cl2[2],
+ 'loglike'=model2$loglike, 'Deviance'=-2*model2$loglike )
  dfr2$Npars <- sum(model2$Npars)
  dfr <- rbind( dfr1, dfr2 )
  dfr <- dfr[ order( dfr$Npars ), ]
  dfr$Chisq <- NA
  dfr$df <- NA
  dfr$p <- NA
- dfr[1,"Chisq"] <- dfr[1,"Deviance"] - dfr[2,"Deviance"]
- dfr[1,"df"] <- abs( dfr[1,"Npars"] - dfr[2,"Npars"] )
- dfr[ 1, "p" ] <- round( 1 - stats::pchisq( dfr[1,"Chisq"], df=dfr[1,"df"] ), 5 )
- for ( vv in 2:( ncol(dfr))){ dfr[,vv] <- round( dfr[,vv], 5 ) }
+ dfr[1,'Chisq'] <- dfr[1,'Deviance'] - dfr[2,'Deviance']
+ dfr[1,'df'] <- abs( dfr[1,'Npars'] - dfr[2,'Npars'] )
+ dfr[1, 'p' ] <- round( 1 - stats::pchisq( dfr[1,'Chisq'], df=dfr[1,'df'] ), 5 )
+ for ( vv in 2L:( ncol(dfr))){ dfr[,vv] <- round( dfr[,vv], 5 ) }
  print( dfr )
  invisible(dfr)
 }

diff --git a/R/immer_FACETS.R b/R/immer_FACETS.R
@@ -1,5 +1,5 @@
 ## File Name: immer_FACETS.R
-## File Version: 0.46
+## File Version: 0.475
 
 #--- Wrapper to FACDOS (Linacre, 1999)
 immer_FACETS <- function(
@@ -76,7 +76,7 @@ immer_FACETS <- function(
 
 
  models <- rbind("models=",matrix(models,ncol=1),"*")
- labels <- tapply(labels,rep(1:(length(labels)/2),each=2),function(x) c(x,"*"))
+ labels <- tapply(labels,rep(1L:(length(labels)/2),each=2),function(x) c(x,"*"))
  labels <- unlist(labels)
  labels <- rbind("Labels=",matrix(labels,ncol=1))
  # "ISFILE"="Category.txt",
@@ -109,7 +109,7 @@ immer_FACETS <- function(
  }else{
  inputfile <-fileinput
  }
- # ------------------------------------------------------------------------------------------------
+ # --------------------------------------------------------------------------
  # Checks START
  # Check length of specified modelname
  if(!is.null(path.dosbox)){ model.name <- bit8(model.name)}
@@ -127,7 +127,8 @@ immer_FACETS <- function(
  woScor <- grep("Scorefile",inputfile,ignore.case=TRUE)
  Scor <- inputfile[woScor] ; Scor <- grepInput(Scor)
  if(!is.null(path.dosbox)){
- inputfile[woScor] <- paste0("Scorefile=",bit8(Scor)[1],"; Name of Scorefile file")
+ inputfile[woScor] <- paste0("Scorefile=",bit8(Scor)[1],
+ "; Name of Scorefile file")
  filenames <- c(filenames,"Scorefile"=bit8(Scor)[1])
  } else {
  filenames <- c(filenames,"Scorefile"=Scor)
@@ -137,7 +138,8 @@ immer_FACETS <- function(
  woResid <- grep("Residualfile",inputfile,ignore.case=TRUE)
  Resid <- inputfile[woResid] ; Resid <- grepInput(Resid)
  if(!is.null(path.dosbox)){
- inputfile[woResid] <- paste0("Residualfile=",bit8(Resid)[1],"; Name of Residualfile file")
+ inputfile[woResid] <- paste0("Residualfile=",bit8(Resid)[1],
+ "; Name of Residualfile file")
  filenames <- c(filenames,"Residualfile"=bit8(Resid)[1])
  } else {
  filenames <- c(filenames,"Residualfile"=Resid)
@@ -162,27 +164,27 @@ immer_FACETS <- function(
  # filenames <- c(filenames,Out)
  #}else{
  # c(
- # inputfile[c(1:5),1],
+ # inputfile[c(1L:5),1],
  # c("Xfile=XFILE.txt; Name of Xfile file"),
  # inputfile[c(5:nrow(inputfile)),1],
  # filenames <- c(filenames,"Xfile"="XFILE.txt")
  # )
  #}
 
  # Checks END
- # ------------------------------------------------------------------------------------------------
+ # --------------------------------------------------------------------
  # Check if CSV is specified
  csv <- grep("CSV",inputfile,ignore.case=TRUE)
  if(length(csv)==0){
  c(
- inputfile[c(1:6),1],
+ inputfile[c(1L:6),1],
  c("CSV=Commas ;"),
  inputfile[c(6:nrow(inputfile)),1]
  )
  }
  # END Check if CSV is specified
 
- # ---------------------------------------------------------------------------------------------------
+ # ---------------------------------------------------------------------
 
  cat(paste0("writing the inputfile to \n --> ",path.facets,"/",model.name," <-- \n"))
  writeLines(inputfile,file.path(path.facets,model.name))
@@ -196,7 +198,9 @@ immer_FACETS <- function(
  # it is very important to quote the first path to the DOSbox (" \" ")
  if(!is.null(path.dosbox)){
  # start.dosbox <- c( paste0( "echo start the DOSbox: ", Sys.time() ),
- # paste0( paste0("start /w \"\" ", file.path(path.dosbox,"DOSBoxPortable.exe")), " -c mount ", paste0(gsub("/","\\\\", path.facets),"\\mymodel.bat")),
+ # paste0( paste0("start /w \"\" ",
+ # file.path(path.dosbox,"DOSBoxPortable.exe")), " -c mount ",
+ # paste0(gsub("/","\\\\", path.facets),"\\mymodel.bat")),
  # c("@ECHO OFF"),
  # c("TASKKILL DosBox\n"),
  # c(":LOOP"),
@@ -212,7 +216,11 @@ immer_FACETS <- function(
  # c("exit")
  # )
  start.dosbox <- c( paste0( "echo start the DOSbox: ", Sys.time() ),
- paste0( paste0("start /w \"\" ", file.path(path.dosbox,"DOSBoxPortable.exe")), " -c mount ", paste0(gsub("/","\\\\", path.facets),"\\mymodel.bat"))
+ paste0( paste0("start /w \"\" ",
+ file.path(path.dosbox,"DOSBoxPortable.exe")),
+ " -c mount ",
+ paste0(gsub("/","\\\\", path.facets),
+ "\\mymodel.bat"))
  )
 
 
@@ -221,8 +229,8 @@ immer_FACETS <- function(
  # KEINE BLANKS IN DEN INPUT_FILE (Dateinamen)beim FACDOS!!
 
 
- start.facets <- c( paste( "echo change directory in DOSbox", Sys.time(),sep=" " ),
- # paste( "cd", paste(path.facets,"/",sep="",collapse=""), sep=" "),
+ start.facets <- c( paste( "echo change directory in DOSbox",
+  Sys.time(),sep=" " ),
  paste0( "FACETS BATCH=YES ",model.name),
  paste0( "echo shutdown DOSbox"),
  c("del STARTDOS.BAT"),
@@ -235,7 +243,8 @@ immer_FACETS <- function(
  while (file.exists(file.path(path.facets,"startDOS.bat"))) {
  Sys.sleep(1)
  }
- # invisible(file.remove(paste0("C:\\Users\\",user,"\\AppData\\Local\\Temp\\startDOSbox.bat")))
+ # invisible(file.remove(paste0("C:\\Users\\",user,
+ # "\\AppData\\Local\\Temp\\startDOSbox.bat")))
  }else{
  if(!is.null(facetsEXE)){
  Exe <- facetsEXE
@@ -254,7 +263,8 @@ immer_FACETS <- function(
  writeLines( start.facets, paste0(path.facets,"\\mymodel.bat") )
 
  shell(paste0(path.facets,"\\mymodel.bat"),wait=TRUE,translate=TRUE)
- # system2(paste0(path.facets,"\\mymodel_",time,".bat"),wait=TRUE,invisible=TRUE)
+ # system2(paste0(path.facets,"\\mymodel_",time,".bat"),
+ # wait=TRUE,invisible=TRUE)
  }
  cat("removing temp-files \n")
  invisible(file.remove(paste0(path.facets,"\\mymodel.bat")))
@@ -274,7 +284,9 @@ immer_FACETS <- function(
  }
  )
  # output on screen: saved files by FACDOS:
- # cat(paste0("\n The estimation in FACETS is finished, the results ['",inputfile[[grep("Output",inputfile)]],"''] are stored here:\n --> ",path.facets," <-- \n"))
+ # cat(paste0("\n The estimation in FACETS is finished,
+ # the results ['",inputfile[[grep("Output",inputfile)]],"'']
+ # are stored here:\n --> ",path.facets," <-- \n"))
 # cat("Outputs are:\n",
 # paste0(
 # "\n", grep("Output",inputfile,ignore.case=TRUE,value=TRUE),
@@ -290,7 +302,9 @@ immer_FACETS <- function(
  fileListe <- sapply(filenames,function(x) grep(x,files,value=TRUE))
 
  # lapply(fileListe,FUN=function(x) sapply(x,function(x)readLines(x,skipNul=TRUE,)))
- # namScorefile <- c("T.Score","T.Count","Obs.Avge","Fair.Avge","Measure","S.E.","InfitMS","InfitZ","OutfitMS","OutfitZ","PtMea","PtMeExp","Discrim","Displace","Status","Group","Weight","Lable","Teams","F-Number","F-Label" )
+ # namScorefile<-c("T.Score","T.Count","Obs.Avge","Fair.Avge","Measure","S.E.","InfitMS",
+ # "InfitZ","OutfitMS","OutfitZ","PtMea","PtMeExp","Discrim","Displace","Status","Group",
+ # "Weight","Lable","Teams","F-Number","F-Label" )
  score <- try(
  lapply(fileListe$Scorefile,function(x){
  all_content=readLines(file.path(path.facets,x))
@@ -324,12 +338,14 @@ immer_FACETS <- function(
 
  output <- list(
  "Inputfile"=try(readLines(paste0(path.facets,"/",model.name),skipNul=TRUE)),
- "Outputfile"=try(readLines(paste0(path.facets,"/",fileListe$Outputfile),skipNul=TRUE)),
+ "Outputfile"=try(readLines(paste0(path.facets,"/",fileListe$Outputfile),
+ skipNul=TRUE)),
  "Scorefile"=score,
  "Residualfile"=residualfile[[1]]
  )
  # "Categoryfile"=categoryfile
- invisible( try( file.remove( paste0(path.facets,"/",c(unlist(fileListe),model.name))),silent=TRUE ) )
+ invisible( try( file.remove( paste0(path.facets,"/",
+ c(unlist(fileListe),model.name))),silent=TRUE ) )
 
  return(output)
 }