3.10-104

alexanderrobitzsch · May 17, 2021 · 42335ac · 42335ac
1 parent 2763f6e
commit 42335ac
Show file tree

Hide file tree

Showing 12 changed files with 94 additions and 84 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 3.10-102
-Date: 2021-05-12 12:09:50
+Version: 3.10-104
+Date: 2021-05-16 22:30:48
 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: 3.010102
+## File Version: 3.010104
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 

diff --git a/R/rasch.mml.raschtype.R b/R/rasch.mml.raschtype.R
@@ -1,5 +1,5 @@
 ## File Name: rasch.mml.raschtype.R
-## File Version: 2.63
+## File Version: 2.641
 
 
 
@@ -13,68 +13,6 @@ squeeze.mml2 <- function( v1, rgvec ){
 #*******************************************************
 
 
-
-#*************************************************************************************
-# E Step Raschtype Model: multidimensional version
-.e.step.raschtype.mirt <- function( dat1, dat2, dat2.resp, theta.k, pi.k, I,
-                n, b, fixed.a, fixed.c,  fixed.d,
-                alpha1, alpha2, group,  mu,  Sigma.cov, Qmatrix, pseudoll ){
-    #...................................
-    # arrange groups
-# aa0 <- Sys.time()
-    if ( is.null(group) ){ group <- rep( 1, nrow(dat1)) }
-    G <- length( unique( group) )
-    # probabilities of correct item at theta_k
-    pjk <- .prob.raschtype.genlogis( theta.k, b, alpha1, alpha2, fixed.a, Qmatrix )
-    fixed.c.M <- outer( rep(1,nrow(pjk)), fixed.c )
-    fixed.d.M <- outer( rep(1,nrow(pjk)), fixed.d )
-    pjk <- fixed.c.M + ( fixed.d.M - fixed.c.M) * pjk
-    TP <- dim(pjk)[1]
-    #***
-    # array notation of probabilities
-        pjkt <- t(pjk)
-        pjkL <- array( NA, dim=c( I, 2, TP  ) )
-        pjkL[,1,] <- 1 - pjkt
-        pjkL[,2,] <- pjkt
-        probsM <- matrix( aperm( pjkL, c(2,1,3) ), nrow=I*2, ncol=TP )
-# cat("- probs") ; aa1 <- Sys.time(); print(aa1-aa0) ; aa0 <- aa1
-        f.yi.qk <- mml_calc_like( dat2=dat2, dat2resp=dat2.resp,
-                    probs=probsM, pseudoll=pseudoll)$fyiqk
-# cat("- likelihood") ; aa1 <- Sys.time(); print(aa1-aa0) ; aa0 <- aa1
-
-    #******
-    f.qk.yi <- 0 * f.yi.qk
-    if ( G==1 ){
-            pi.k <- matrix( pi.k, ncol=1 )
-                    }
-    for ( gg in 1:G){
-        f.qk.yi[ group==gg, ] <- f.yi.qk[ group==gg, ] * outer( rep( 1, nrow(dat2[ group==gg,]) ), pi.k[,gg] )
-                    }
-    f.qk.yi <- f.qk.yi / rowSums( f.qk.yi )
-# cat("- posterior") ; aa1 <- Sys.time(); print(aa1-aa0) ; aa0 <- aa1
-    # expected counts at theta.k
-    n.k <- matrix( 0, nrow(theta.k), G )
-    r.jk <- n.jk <- array( 0, dim=c( ncol(dat2), nrow(theta.k), G) )
-    ll <- rep(0,G)
-    for (gg in 1:G){
-        ind.gg <- which( group==gg )
-        res <- mml_raschtype_counts( dat2=dat2[ind.gg,], dat2resp=dat2.resp[ind.gg,],
-                    dat1=dat1[ind.gg,2], fqkyi=f.qk.yi[ind.gg,],
-                    pik=pi.k[,gg], fyiqk=f.yi.qk[ind.gg,]  )
-        n.k[,gg] <- res$nk
-        n.jk[,,gg] <- res$njk
-        r.jk[,,gg] <- res$rjk
-        ll[gg] <- res$ll
-        }
-# cat("- counts") ; aa1 <- Sys.time(); print(aa1-aa0) ; aa0 <- aa1
-    res <- list( "n.k"=n.k, "n.jk"=n.jk, "r.jk"=r.jk, "f.qk.yi"=f.qk.yi, "pjk"=pjk,
-            "f.yi.qk"=f.yi.qk, "ll"=sum(ll) )
-    return(res)
-    }
-#*************************************************************************************
-
-
-
 ##################################################
 # estimation of group means in the 1dim IRT model
 .est.mean <- function( dat1.gg, f.yi.qk.gg, X1, pi.k, pi.k0, gg,

diff --git a/R/rasch.mml2.R b/R/rasch.mml2.R
@@ -1,5 +1,5 @@
 ## File Name: rasch.mml2.R
-## File Version: 7.663
+## File Version: 7.671
 
 
 # Semiparametric Maximum Likelihood Estimation in the Rasch type Model
@@ -69,8 +69,12 @@ rasch.mml2 <- function( dat, theta.k=seq(-6,6,len=21), group=NULL, weights=NULL,
                                 }
                 npmodel <- list(1:I)
                 }
-    D <- 1
     dat.resp <- 1 - is.na(dat)
+    if (is.null(Qmatrix)){
+        D <- 1
+    } else {
+        D <- ncol(Qmatrix)
+    }
     if (irtmodel %in% irtmodel_missing){
         D <- 2
         if (is.vector(theta.k)){
@@ -429,17 +433,18 @@ rasch.mml2 <- function( dat, theta.k=seq(-6,6,len=21), group=NULL, weights=NULL,
             e1 <- .e.step.ramsay( dat1, dat2, dat2.resp, theta.k, pi.k, I, n, b,
                             fixed.K, group, pow.qm=pow.qm, ind.ii.list )
         }
-
         if (raschtype & D==1){
             e1 <- rasch_mml2_estep_raschtype( dat1=dat1, dat2=dat2, dat2.resp=dat2.resp,
                         theta.k=theta.k, pi.k=pi.k, I=I, n=n, b=b, fixed.a=fixed.a, fixed.c=fixed.c,
                         fixed.d=fixed.d, alpha1=alpha1, alpha2=alpha2, group=group, pseudoll=pseudoll,
                         weights=weights)
         }
         if (raschtype & D>1){
-            e1 <- .e.step.raschtype.mirt( dat1, dat2, dat2.resp, theta.k, pi.k, I, n, b,
-                            fixed.a, fixed.c, fixed.d,  alpha1, alpha2, group,
-                            mu, Sigma.cov, Qmatrix, pseudoll)
+            e1 <- rasch_mml2_estep_raschtype_mirt( dat1=dat1, dat2=dat2, 
+                        dat2.resp=dat2.resp, theta.k=theta.k, pi.k=pi.k, I=I, n=n, b=b, 
+                        fixed.a=fixed.a, fixed.c=fixed.c, fixed.d=fixed.d, alpha1=alpha1, 
+                        alpha2=alpha2, group=group, mu=mu, Sigma.cov=Sigma.cov, 
+                        Qmatrix=Qmatrix, pseudoll=pseudoll ) 
         }
         if (npirt){
             if (iter==0){
@@ -1184,7 +1189,7 @@ rasch.mml2 <- function( dat, theta.k=seq(-6,6,len=21), group=NULL, weights=NULL,
                 ramsay.qm=ramsay.qm, irtmodel=irtmodel, D=D, mu=mu, Sigma.cov=Sigma.cov,
                 est_parameters=est_parameters, priors=priors,
                 theta.k=theta.k, trait.weights=trait.weights, pi.k=pi.k,
-                dat_implist=dat_implist, CALL=CALL )
+                dat_implist=dat_implist, variance.fixed=variance.fixed, CALL=CALL )
     class(res) <- "rasch.mml"
     res$ic <- ic
     res$est.c <- est.c

diff --git a/R/rasch_mml2_estep_raschtype_mirt.R b/R/rasch_mml2_estep_raschtype_mirt.R
@@ -0,0 +1,67 @@
+## File Name: rasch_mml2_estep_raschtype_mirt.R
+## File Version: 1.071
+
+
+#*** E Step Raschtype Model: multidimensional version
+rasch_mml2_estep_raschtype_mirt <- function( dat1, dat2, dat2.resp, theta.k, pi.k, I,
+                n, b, fixed.a, fixed.c,  fixed.d, alpha1, alpha2, group,  mu,  Sigma.cov, 
+                Qmatrix, pseudoll )
+{
+    aa0 <- Sys.time()
+    if ( is.null(group) ){ 
+        group <- rep( 1, nrow(dat1)) 
+    }
+    G <- length( unique( group) )
+    pjk <- prob_raschtype_genlogis( theta=theta.k, b=b, alpha1=alpha1, 
+                    alpha2=alpha2, fixed.a=fixed.a, Qmatrix=Qmatrix ) 
+    TP <- nrow(pjk)
+# cat("- probs") ; aa1 <- Sys.time(); print(aa1-aa0) ; aa0 <- aa1    
+    fixed.c.M  <- sirt_matrix2(fixed.c, nrow=TP)
+    fixed.d.M  <- sirt_matrix2(fixed.d, nrow=TP)
+    pjk <- fixed.c.M + ( fixed.d.M - fixed.c.M) * pjk
+
+    TP <- dim(pjk)[1]
+    pjkt <- t(pjk)
+    pjkL <- array( NA, dim=c( I, 2, TP))
+    pjkL[,1,] <- 1 - pjkt
+    pjkL[,2,] <- pjkt
+    probsM <- matrix( aperm( pjkL, c(2,1,3) ), nrow=I*2, ncol=TP )
+    f.yi.qk <- mml_calc_like( dat2=dat2, dat2resp=dat2.resp,
+                    probs=probsM, pseudoll=pseudoll)$fyiqk
+
+    f.qk.yi <- 0 * f.yi.qk
+    if ( G==1 ){
+        pi.k <- matrix( pi.k, ncol=1 )
+    }
+    for ( gg in 1:G){
+        f.qk.yi[ group==gg, ] <- f.yi.qk[ group==gg, ] * outer( rep( 1, nrow(dat2[ group==gg,]) ), pi.k[,gg] )
+    }
+    f.qk.yi <- f.qk.yi / rowSums( f.qk.yi )
+
+    # expected counts at theta.k
+    n.k <- matrix( 0, nrow(theta.k), G )
+    r.jk <- n.jk <- array( 0, dim=c( ncol(dat2), nrow(theta.k), G) )
+    ll <- rep(0,G)
+    for (gg in 1:G){
+        ind.gg <- which( group==gg )
+        res <- mml_raschtype_counts( dat2=dat2[ind.gg,], dat2resp=dat2.resp[ind.gg,],
+                    dat1=dat1[ind.gg,2], fqkyi=f.qk.yi[ind.gg,],
+                    pik=pi.k[,gg], fyiqk=f.yi.qk[ind.gg,]  )
+        n.k[,gg] <- res$nk
+        n.jk[,,gg] <- res$njk
+        r.jk[,,gg] <- res$rjk
+        ll[gg] <- res$ll
+    }
+
+    #--- output
+    res <- list( n.k=n.k, n.jk=n.jk, r.jk=r.jk, f.qk.yi=f.qk.yi, pjk=pjk,
+                    f.yi.qk=f.yi.qk, ll=sum(ll) )
+    return(res)
+}
+
+
+
+.e.step.raschtype.mirt <- rasch_mml2_estep_raschtype_mirt
+
+
+# cat("- posterior") ; aa1 <- Sys.time(); print(aa1-aa0) ; aa0 <- aa1
diff --git a/README.md b/README.md
@@ -22,9 +22,9 @@ The CRAN version can be installed from within R using:
 utils::install.packages("sirt")
 ```
 
-#### GitHub version `sirt` 3.10-102 (2021-05-12)
+#### GitHub version `sirt` 3.10-104 (2021-05-16)
 
-[![](https://img.shields.io/badge/github%20version-3.10--102-orange.svg)](https://github.com/alexanderrobitzsch/sirt)&#160;&#160;
+[![](https://img.shields.io/badge/github%20version-3.10--104-orange.svg)](https://github.com/alexanderrobitzsch/sirt)&#160;&#160;
 
 The version hosted [here](https://github.com/alexanderrobitzsch/sirt) is the development version of `sirt`. 
 The GitHub version can be installed using `devtools` as:

diff --git a/docs/404.html b/docs/404.html
diff --git a/docs/authors.html b/docs/authors.html
diff --git a/docs/index.html b/docs/index.html
diff --git a/docs/pkgdown.yml b/docs/pkgdown.yml
@@ -2,5 +2,5 @@ pandoc: 1.13.1
 pkgdown: 1.5.1
 pkgdown_sha: ~
 articles: []
-last_built: 2021-05-12T10:41Z
+last_built: 2021-05-16T20:52Z
 
diff --git a/inst/NEWS b/inst/NEWS
@@ -38,7 +38,7 @@ CHANGELOG sirt
 
 
 ------------------------------------------------------------------------
-VERSIONS sirt 3.10  |  2021-05-12  |  Last: sirt 3.10-102
+VERSIONS sirt 3.10  |  2021-05-16  |  Last: sirt 3.10-104
 ------------------------------------------------------------------------
 
 ADDED * included option for regularization penalties in xxirt()

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