4.2-57

alexanderrobitzsch · Apr 20, 2024 · 532bc4a · 532bc4a
1 parent b096061
commit 532bc4a
Show file tree

Hide file tree

Showing 40 changed files with 220 additions and 199 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 4.2-52
-Date: 2024-04-15 16:45:37
+Version: 4.2-57
+Date: 2024-04-20 17:32:32
 Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
 Maintainer: Alexander Robitzsch <[email protected]>
 Description: 

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

diff --git a/R/invariance_alignment_cfa_config_estimate.R b/R/invariance_alignment_cfa_config_estimate.R
@@ -1,5 +1,5 @@
 ## File Name: invariance_alignment_cfa_config_estimate.R
-## File Version: 0.199
+## File Version: 0.202
 
 invariance_alignment_cfa_config_estimate <- function(dat_gg, N, weights_gg=NULL,
     model="2PM", ...)
@@ -16,7 +16,7 @@ invariance_alignment_cfa_config_estimate <- function(dat_gg, N, weights_gg=NULL,
         I_gg <- length(mu)
         items_gg <- names(mu)
         if (is.null(items_gg)){
-            items_gg <- paste0('I',1:I)
+            items_gg <- paste0('I',1L:I)
         }
         names(mu) <- items_gg
         rownames(Sigma) <- items_gg
@@ -44,12 +44,12 @@ invariance_alignment_cfa_config_estimate <- function(dat_gg, N, weights_gg=NULL,
     mod <- do.call(what='sirt_import_lavaan_cfa', args=args)
     partable <- sirt_import_lavaan_parameterTable(object=mod)
     lambda <- partable[ partable$op=='=~', 'est']
-    nu <- partable[ partable$op=='~1', 'est'][1:I_gg]
-    err_var <- partable[ partable$op=='~~', 'est'][1:I_gg]
+    nu <- partable[ partable$op=='~1', 'est'][1L:I_gg]
+    err_var <- partable[ partable$op=='~~', 'est'][1L:I_gg]
     nobs <- mod@Data@nobs[[1]]
     # vcov <- lavaan::lavInspect(object=mod, what='information')
     vcov <- mod@vcov$vcov
-    ind <- c(1:I_gg, 2*I_gg+1:I_gg)
+    ind <- c(1L:I_gg, 2*I_gg+1L:I_gg)
     vcov <- vcov[ ind, ind ]
 
     #--- output

diff --git a/R/invariance_alignment_proc_labels.R b/R/invariance_alignment_proc_labels.R
@@ -1,15 +1,15 @@
 ## File Name: invariance_alignment_proc_labels.R
-## File Version: 0.05
+## File Version: 0.06
 
 invariance_alignment_proc_labels <- function(x)
 {
     G <- nrow(x)
     I <- ncol(x)
     if (is.null(colnames(x))){
-        colnames(x) <- paste0('I', 1:I)
+        colnames(x) <- paste0('I', 1L:I)
     }
     if (is.null(rownames(x))){
-        rownames(x) <- paste0('G', 1:G)
+        rownames(x) <- paste0('G', 1L:G)
     }
     return(x)
 }
diff --git a/R/invariance_alignment_simulate.R b/R/invariance_alignment_simulate.R
@@ -1,5 +1,5 @@
 ## File Name: invariance_alignment_simulate.R
-## File Version: 0.122
+## File Version: 0.123
 
 invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N,
     output="data", groupwise=FALSE, exact=FALSE)
@@ -15,22 +15,22 @@ invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N,
     I <- ncol(nu)
     items <- colnames(nu)
     if (is.null(items)){
-        items <- paste0('I',1:I)
+        items <- paste0('I',1L:I)
     }
     n_end <- cumsum(N)
     n_start <- c(1,n_end+1)[-c(G+1)]
     #* simulate data
     if (N[1]<Inf){
-        group <- rep(1:G, N)
+        group <- rep(1L:G, N)
         dat <- matrix(NA, nrow=N_tot, ncol=I+1)
         colnames(dat) <- c('group',items)
         dat <- as.data.frame(dat)
         dat$group <- group
-        for (gg in 1:G){
+        for (gg in 1L:G){
             N_gg <- N[gg]
             ind_gg <- seq(n_start[gg], n_end[gg])
             fac <- ruvn(N=N_gg, mean=mu[gg], sd=sigma[gg], exact=FALSE)
-            for (ii in 1:I){
+            for (ii in 1L:I){
                 err_ii <- ruvn(N=N_gg, mean=0, sd=sqrt(err_var[gg,ii]), exact=FALSE )
                 dat[ind_gg, ii+1] <- nu[gg,ii] + lambda[gg,ii]*fac + err_ii
             }
@@ -47,7 +47,7 @@ invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N,
         res <- dat
         if (output=='suffstat'){
             res <- list(mu=list(), Sigma=list(), N=list() )
-            for (gg in 1:G){
+            for (gg in 1L:G){
                 ind_gg <- which(dat$group==gg)
                 res$mu[[gg]] <- colMeans(dat[ ind_gg, -1])
                 res$Sigma[[gg]] <- stats::cov.wt(dat[ ind_gg, -1], method='ML')$cov
@@ -58,7 +58,7 @@ invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N,
     #*** only compute covariance matrices
     if (N[1]==Inf){
         res <- list(mu=list(), Sigma=list(), N=list() )
-        for (gg in 1:G){
+        for (gg in 1L:G){
             lam_gg <- lambda[gg,]
             sig2_gg <- sigma[gg]^2
             res$mu[[gg]] <- nu[gg,] + lam_gg*mu[gg]
@@ -71,8 +71,8 @@ invariance_alignment_simulate <- function(nu, lambda, err_var, mu, sigma, N,
     #*** group-wise output
     if ( (output=='suffstat') & groupwise ){
         res1 <- res
-        res <- as.list(1:G)
-        for (gg in 1:G){
+        res <- as.list(1L:G)
+        for (gg in 1L:G){
             res[[gg]] <- list(mu=res1$mu[[gg]], Sigma=res1$Sigma[[gg]], N=res1$N[[gg]])
         }
     }

diff --git a/R/likelihood_adjustment.R b/R/likelihood_adjustment.R
@@ -1,46 +1,42 @@
 ## File Name: likelihood_adjustment.R
-## File Version: 0.17
+## File Version: 0.182
 
 
-####################################################################
-# likelihood adjustment
+#*** likelihood adjustment
 likelihood.adjustment <- function( likelihood, theta=NULL, prob.theta=NULL,
             adjfac=rep(1,nrow(likelihood)), extreme.item=5,
             target.EAP.rel=NULL, min_tuning=.2, max_tuning=3,
-            maxiter=100, conv=.0001, trait.normal=TRUE ){
+            maxiter=100, conv=.0001, trait.normal=TRUE )
+{
 
     like0 <- likelihood
     eps <- 1E-30
     normal_approx <- trait.normal
 
     if ( is.null(theta) ){
-        theta <- attr( likelihood, "theta" )[,1]
-                        }
+        theta <- attr( likelihood, 'theta' )[,1]
+    }
 
     if ( is.null(prob.theta) ){
-        prob.theta <- attr( likelihood, "prob.theta" )
-                        }
+        prob.theta <- attr( likelihood, 'prob.theta' )
+    }
 
 
-    attr(likelihood,"prob.theta") <- NULL
-    attr(likelihood,"theta") <- NULL
-    attr(likelihood,"G") <- NULL
+    attr(likelihood,'prob.theta') <- NULL
+    attr(likelihood,'theta') <- NULL
+    attr(likelihood,'G') <- NULL
 
-    #**********************
-    # add extreme item
+    #-- add extreme item
     N <- nrow(like0)
     TP <- length(theta)
     thetaM <- matrix( theta, nrow=N, ncol=TP, byrow=TRUE)
     S1 <- stats::plogis( thetaM + extreme.item ) *
                 ( 1 - stats::plogis( thetaM - extreme.item ) )
     likelihood <- likelihood * S1
 
-# Revalpr( "mean(abs( like0 - likelihood) )")
-
     # likelihood adjustment
     like2 <- likelihood_adjustment_compute( likelihood, theta, thetaM, adjfac )
 
-
     #*** compute posterior given likelihood and empirical prior
     if ( ! is.null( target.EAP.rel ) ){
         probs <- prob.theta
@@ -64,21 +60,21 @@ likelihood.adjustment <- function( likelihood, theta=NULL, prob.theta=NULL,
             EAP_rel0 <- res1$EAP.rel
             like2 <- res1$likelihood
             if ( EAP_rel0 < target.EAP.rel ){
-                    tuning2 <- tuning0
-                        } else {
-                    tuning1 <- tuning0
-                                }
+                tuning2 <- tuning0
+            } else {
+                tuning1 <- tuning0
+            }
             iter <- iter + 1
             change <- abs( EAP_rel0 - target.EAP.rel )
-            cat("Iteration ", iter, " | EAP reliability=", round( EAP_rel0, 4 ), "\n")
+            cat('Iteration ', iter, ' | EAP reliability=', round( EAP_rel0, 4 ), '\n')
             flush.console()
         }
-            }
+    }
     res <- like2
-    attr( res, "theta" ) <- matrix( theta, ncol=1)
-    attr(like0,"prob.theta") -> attr( res, "prob.theta")
-    attr(like0,"G") -> attr(res, "G")
+    attr( res, 'theta' ) <- matrix( theta, ncol=1)
+    attr(like0,'prob.theta') -> attr( res, 'prob.theta')
+    attr(like0,'G') -> attr(res, 'G')
     return(res)
-    }
-####################################################################
+}
+
 
diff --git a/R/likelihood_adjustment_aux.R b/R/likelihood_adjustment_aux.R
@@ -1,5 +1,5 @@
 ## File Name: likelihood_adjustment_aux.R
-## File Version: 0.19
+## File Version: 0.201
 
 
 #######################################################
@@ -15,7 +15,7 @@ likelihood_adjustment_compute <- function( likelihood, theta,
     w1 <- rowSums(likelihood)
     # compute adjusted likelihood
     like2 <- 0*likelihood
-    for (tt in 1:TP){
+    for (tt in 1L:TP){
         like2[,tt] <- sirt_dnorm( theta[tt], mean=M1, sd=SD1*adjfac*tuningfac )
     }
     like2 <- like2 / rowSums(like2) * w1
@@ -59,7 +59,7 @@ likelihood_adjustment_tuning <- function( likelihood, theta, thetaM, adjfac,
 
     res0 <- likelihood_moments( likelihood=like2 * probsM, theta=theta  )
     EAP.rel <- like_adj_EAP_reliability( res0$M, res0$SD )
-    res <- list( "likelihood"=like2, "EAP.rel"=EAP.rel )
+    res <- list( likelihood=like2, EAP.rel=EAP.rel )
     return(res)
 }
 

diff --git a/R/linking.haberman.R b/R/linking.haberman.R
@@ -1,5 +1,5 @@
 ## File Name: linking.haberman.R
-## File Version: 2.653
+## File Version: 2.654
 
 
 #**** Linking Haberman: ETS Research Report 2009
@@ -109,7 +109,7 @@ linking.haberman <- function( itempars, personpars=NULL,
     #****
     # transform person parameters
     if ( ! is.null( personpars) ){
-        for (ll in 1:NS){
+        for (ll in 1L:NS){
             pp0 <- pp1 <- personpars[[ll]]
             pp1 <- transf.personpars$A_theta[ll] * pp1 + transf.personpars$B_theta[ll]
             ind <- which( substring( colnames(pp0),1,2) %in% c('se', 'SE') )

diff --git a/R/linking.haberman.lq.R b/R/linking.haberman.lq.R
@@ -1,5 +1,5 @@
 ## File Name: linking.haberman.lq.R
-## File Version: 0.199
+## File Version: 0.201
 
 linking.haberman.lq <- function(itempars, pow=2, eps=1e-3, a_log=TRUE,
     use_nu=FALSE, est_pow=FALSE, lower_pow=.1, upper_pow=3)
@@ -43,10 +43,10 @@ linking.haberman.lq <- function(itempars, pow=2, eps=1e-3, a_log=TRUE,
         y <- log(y)
     }
     X <- X0
-    for (gg in 2:G){
+    for (gg in 2L:G){
         X[ ind_studies==gg, gg-1] <- 1
     }
-    for (ii in 1:I){
+    for (ii in 1L:I){
         X[ ind_items==ii, ii+G-1] <- 1
     }
     #- fit
@@ -55,7 +55,7 @@ linking.haberman.lq <- function(itempars, pow=2, eps=1e-3, a_log=TRUE,
                 upper_pow=upper_pow)
     coef0 <- mod0$coefficients
     pow_slopes <- mod0$pow
-    ind_groups <- 1:(G-1)
+    ind_groups <- 1L:(G-1)
     coef0_A <- coef0[ind_groups]
     a_joint <- coef0[-c(ind_groups)]
     ar <- y - X %*% coef0

diff --git a/R/linking.haebara.R b/R/linking.haebara.R
@@ -1,5 +1,5 @@
 ## File Name: linking.haebara.R
-## File Version: 0.432
+## File Version: 0.434
 
 linking.haebara <- function(itempars, dist="L2", theta=seq(-4,4, length=61),
         optimizer="optim", center=FALSE, eps=1e-3, par_init=NULL,
@@ -30,10 +30,10 @@ linking.haebara <- function(itempars, dist="L2", theta=seq(-4,4, length=61),
     parnames <- c( paste0('a_',items), paste0('b_',items), paste0('mu_',studies[-1]),
                     paste0('sigma_',studies[-1]) )
     names(par) <- parnames
-    index_a <- 1:NI
-    index_b <- NI + 1:NI
-    index_mu <- 2*NI + 1:(NS-1)
-    index_sigma <- 2*NI + NS - 1 + 1:(NS-1)
+    index_a <- 1L:NI
+    index_b <- NI + 1L:NI
+    index_mu <- 2*NI + 1L:(NS-1)
+    index_sigma <- 2*NI + NS - 1 + 1L:(NS-1)
     NP <- length(par)
 
     #-- initial values

diff --git a/R/linking.robust.R b/R/linking.robust.R
@@ -1,5 +1,5 @@
 ## File Name: linking.robust.R
-## File Version: 1.261
+## File Version: 1.263
 
 
 #*** Robust linking
@@ -16,7 +16,7 @@ linking.robust <- function(  itempars )
     KK <- length(kvec)
     se <- meanpars <- rep(NA, KK )
     # define trimming factor
-    for (kk in 1:KK){
+    for (kk in 1L:KK){
         # arrange calculations
         N <- length(x)
         k <- kk

diff --git a/R/linking_haberman_als.R b/R/linking_haberman_als.R
@@ -1,5 +1,5 @@
 ## File Name: linking_haberman_als.R
-## File Version: 0.658
+## File Version: 0.659
 
 
 
@@ -60,7 +60,7 @@ linking_haberman_als <- function(logaM, wgtM, maxiter, conv,
             logaj <- weighted_rowMeans( mat=logaM_adj1, wgt=wgtM )
         }
         if (estimation %in% c('MED')){
-            for (ii in 1:I){
+            for (ii in 1L:I){
                 logaj[ii] <- linking_haberman_compute_median(x=logaM_adj1[ii,],
                                             w=wgtM[ii,])
             }
@@ -74,7 +74,7 @@ linking_haberman_als <- function(logaM, wgtM, maxiter, conv,
             logaAt <- res1$col
         }
         if (estimation %in% c('LTS')){
-            for (ii in 1:I){
+            for (ii in 1L:I){
                 logaj[ii] <- linking_haberman_compute_lts_mean(x=logaM_adj1[ii,],
                                         w=wgtM[ii,], lts_prop=lts_prop)
             }
@@ -96,7 +96,7 @@ linking_haberman_als <- function(logaM, wgtM, maxiter, conv,
             logaAt <- weighted_colMeans( mat=logaMadj, wgt=wgtM )
         }
         if (estimation %in% c('MED')){
-            for (ss in 1:NS){
+            for (ss in 1L:NS){
                 logaAt[ss] <- linking_haberman_compute_median(x=logaMadj[,ss],
                                             w=wgtM[,ss])
             }

diff --git a/R/linking_haberman_als_residual_weights.R b/R/linking_haberman_als_residual_weights.R
@@ -1,5 +1,5 @@
 ## File Name: linking_haberman_als_residual_weights.R
-## File Version: 0.372
+## File Version: 0.373
 
 
 linking_haberman_als_residual_weights <- function( logaj, logaAt,
@@ -42,17 +42,17 @@ linking_haberman_als_residual_weights <- function( logaj, logaAt,
     }
     #-- estimation LTS
     if (estimation=='LTS'){
-        for (ss in 1:NS){
+        for (ss in 1L:NS){
             e <- loga_resid[,ss]
             e <- e - median(e, na.rm=TRUE)
-            dfr_resid <- data.frame(item=1:NI, e=e )
+            dfr_resid <- data.frame(item=1L:NI, e=e )
             dfr_resid <- na.omit(dfr_resid)
             dfr_resid <- dfr_resid[ order(abs(dfr_resid$e), decreasing=TRUE), ]
             wgt_adj[ is.na(loga_resid[,ss]), ss ] <- 0
             n <- nrow(dfr_resid)
             n_del <- floor( (1-lts_prop)*n)
-            m1 <- dfr_resid[ 1:n_del, c(2,1) ]
-            wgt_adj[ dfr_resid[ 1:n_del, 1 ], ss ] <- 0
+            m1 <- dfr_resid[ 1L:n_del, c(2,1) ]
+            wgt_adj[ dfr_resid[ 1L:n_del, 1 ], ss ] <- 0
         }
     }