3.10-64

alexanderrobitzsch · Aug 29, 2020 · a9f866e · a9f866e
1 parent 6f7804c
commit a9f866e
Show file tree

Hide file tree

Showing 211 changed files with 5,497 additions and 4,192 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 3.10-31
-Date: 2020-04-18 15:20:51
+Version: 3.10-64
+Date: 2020-08-29 14:27:25
 Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
 Maintainer: Alexander Robitzsch <[email protected]>
 Description: 

diff --git a/NAMESPACE b/NAMESPACE
@@ -196,6 +196,7 @@ export(conf.detect)
 export(data.wide2long)
 export(decategorize)
 export(detect.index)
+export(dexppow)
 export(dif.logistic.regression)
 export(dif.strata.variance)
 export(dif.variance)
@@ -240,6 +241,7 @@ export(linking.haberman.lq)
 export(linking.haebara)
 export(linking.robust)
 export(lq_fit)
+export(lq_fit_estimate_power)
 export(lsdm)
 export(lsem.bootstrap)
 export(lsem.estimate)
@@ -321,6 +323,7 @@ export(read.show.regression)
 export(read.show.term)
 export(reliability.nonlinearSEM)
 export(resp_groupwise)
+export(rexppow)
 export(rinvgamma2)
 export(rm.facets)
 export(rm.sdt)
@@ -352,6 +355,7 @@ export(sirt_matrix2)
 export(sirt_optimizer)
 export(sirt_permutations)
 export(sirt_rbind_fill)
+export(sirt_rcpp_discrete_inverse)
 export(sirt_rcpp_polychoric2)
 export(sirt_sum_norm)
 export(sirt_summary_print_call)

diff --git a/R/L0_polish.R b/R/L0_polish.R
@@ -1,13 +1,13 @@
 ## File Name: L0_polish.R
-## File Version: 0.10
+## File Version: 0.12
 
 
-L0_polish <- function(x, tol, eps=0.01, maxiter=30, type=1, verbose=TRUE)
+L0_polish <- function(x, tol, conv=0.01, maxiter=30, type=1, verbose=TRUE)
 {
     res <- list(x_update=x, iterate_further=TRUE)
     #-- iterate
     while(res$iterate_further){
-        res <- L0_polish_one_iteration(x=res$x_update, tol=tol, type=type)
+        res <- L0_polish_one_iteration(x=res$x_update, tol=tol, type=type, eps=conv)
         if (verbose){
             v1 <- paste0("Interactions detected: ", res$N_elim)
             v2 <- paste0(" | Absolute value residual: ", round(res$max_resid,3) )

diff --git a/R/RcppExports.R b/R/RcppExports.R
@@ -1,5 +1,5 @@
 ## File Name: RcppExports.R
-## File Version: 3.010031
+## File Version: 3.010064
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
@@ -107,6 +107,14 @@ MML2_CALCPOST_V3 <- function(DAT2, DAT2RESP, PROBS) {
     .Call('_sirt_MML2_CALCPOST_V3', PACKAGE='sirt', DAT2, DAT2RESP, PROBS)
 }
 
+sirt_rcpp_ccov_np_compute_ccov_sum_score <- function(index, NS, data) {
+    .Call('_sirt_sirt_rcpp_ccov_np_compute_ccov_sum_score', PACKAGE='sirt', index, NS, data)
+}
+
+sirt_rcpp_discrete_inverse <- function(x0, y0, y) {
+    .Call('_sirt_sirt_rcpp_discrete_inverse', PACKAGE='sirt', x0, y0, y)
+}
+
 sirt_rcpp_first_eigenvalue <- function(X, maxit, conv, K) {
     .Call('_sirt_sirt_rcpp_first_eigenvalue', PACKAGE='sirt', X, maxit, conv, K)
 }
@@ -187,6 +195,22 @@ sirt_rcpp_linking_haebara_grad_optim <- function(NI, NS, dist, aM, bM, theta, pr
     .Call('_sirt_sirt_rcpp_linking_haebara_grad_optim', PACKAGE='sirt', NI, NS, dist, aM, bM, theta, prob_theta, est_pars, wgtM, a, b, mu, sigma, eps, index_a, index_b, index_mu, index_sigma, parnames, NP, pow)
 }
 
+sirt_rcpp_lq_fit_analyze_matrix <- function(X) {
+    .Call('_sirt_sirt_rcpp_lq_fit_analyze_matrix', PACKAGE='sirt', X)
+}
+
+sirt_rcpp_lq_fit_sparse_matrix_derivative <- function(Z, h1, px) {
+    .Call('_sirt_sirt_rcpp_lq_fit_sparse_matrix_derivative', PACKAGE='sirt', Z, h1, px)
+}
+
+sirt_rcpp_lq_fit_matrix_mult <- function(Z, y, beta) {
+    .Call('_sirt_sirt_rcpp_lq_fit_matrix_mult', PACKAGE='sirt', Z, y, beta)
+}
+
+sirt_rcpp_lq_fit_fct_optim <- function(Z, y, beta, pow, w, eps) {
+    .Call('_sirt_sirt_rcpp_lq_fit_fct_optim', PACKAGE='sirt', Z, y, beta, pow, w, eps)
+}
+
 sirt_rcpp_monoreg_rowwise <- function(YM, WM) {
     .Call('_sirt_sirt_rcpp_monoreg_rowwise', PACKAGE='sirt', YM, WM)
 }

diff --git a/R/btm.R b/R/btm.R
@@ -1,5 +1,5 @@
 ## File Name: btm.R
-## File Version: 1.532
+## File Version: 1.535
 
 
 #--- Bradley-Terry model in sirt
@@ -243,6 +243,7 @@ btm <- function( data, judge=NULL, ignore.ties=FALSE, fix.eta=NULL, fix.delta=NU
 
     # log-likelihood
     NObs <- nrow(dat0)
+    dat0$result <- dat0[,3]
     ll <- rep(0,NObs)
     ll <- ll+log(probs[,1])*(dat0$result==1)
     ll <- ll+log(probs[,2])*(dat0$result==0)

diff --git a/R/ccov.np.R b/R/ccov.np.R
@@ -1,13 +1,18 @@
 ## File Name: ccov.np.R
-## File Version: 1.190
+## File Version: 1.208
 
 
 #---- nonparametric estimation of conditional covariance
 ccov.np <- function( data, score, bwscale=1.1, thetagrid=seq( -3,3,len=200),
-        progress=TRUE, scale_score=TRUE, adjust_thetagrid=TRUE, smooth=TRUE )
+        progress=TRUE, scale_score=TRUE, adjust_thetagrid=TRUE, smooth=TRUE,
+        use_sum_score=FALSE)
 {
     # number of Items I
     I <- ncol(data)
+    if (use_sum_score){
+        smooth <- FALSE
+        score <- rowSums(data)
+    }
     # z-standardization of score
     if (scale_score){
         score <- scale(score)[,1]
@@ -67,8 +72,9 @@ ccov.np <- function( data, score, bwscale=1.1, thetagrid=seq( -3,3,len=200),
     # smoothing all item pairs
     # calculate conditional covariances
     FF <- nrow(ccov.table)
-    ccov.matrix <- prod.matrix <- matrix( 0, nrow=length(thetagrid ), ncol=FF )
+    ccov.matrix <- prod.matrix <- matrix( 0, nrow=length(thetagrid), ncol=FF )
     ii <- 1
+    ccov_sum_score <- rep(NA, FF)
     for (ff in 1:FF){
         if (FF>20){
             display <- seq( 1, FF, floor( FF/20 ) )[ 2:20 ]
@@ -78,19 +84,35 @@ ccov.np <- function( data, score, bwscale=1.1, thetagrid=seq( -3,3,len=200),
         data.ff <- data[, c( ccov.table[ff,1], ccov.table[ff,2] ) ]
         which.ff <- which( rowSums( is.na(data.ff) )==0  )
         data.ff <- data.ff[ which.ff, ]
-        prod.matrix[,ff] <- ccov_np_regression(x=score[ which.ff], y=data.ff[,1]*data.ff[,2],
+        score.ff <- score[which.ff]
+        prod.matrix[,ff] <- ccov_np_regression(x=score.ff, y=data.ff[,1]*data.ff[,2],
                         xgrid=thetagrid, bwscale=bwscale, smooth=smooth, score=score)
         m12 <- icc_items[, ccov.table[ff,1] ]*icc_items[, ccov.table[ff,2] ]
         ccov.matrix[,ff] <- prod.matrix[,ff] - m12
+
+        #- computations based on sum score
+        if (use_sum_score){
+            res1 <- ccov_np_compute_ccov_sum_score(score=score.ff, data=data.ff)
+            score_ff2 <- score.ff - data.ff[,1] - data.ff[,2]
+            res2 <- ccov_np_compute_ccov_sum_score(score=score_ff2, data=data.ff)
+            ccov_sum_score[ff] <- ( res1$ccov_aggr + res2$ccov_aggr ) / 2
+        }
+
         # print progress
         ii <- ccov_np_print_progress(progress=progress, i=ii, ii=ff, display=display)
     }
     # remove NAs from ccov.matrix
     ccov.matrix[ is.na(ccov.matrix) ] <- 0
     sirt_progress_cat(progress=progress)
+
     # calculate (weighted) conditional covariance
     ccov.table$ccov <- apply( ccov.matrix, 2, FUN=function(sp){
                         stats::weighted.mean( x=sp, w=wgt_thetagrid ) } )
+    if (use_sum_score){
+        ccov_sum_score[ is.na(ccov_sum_score) ] <- 0
+        ccov.table$ccov <- ccov_sum_score
+    }
+
     #--- output
     res <- list( ccov.table=ccov.table, ccov.matrix=ccov.matrix,
                     data=data, score=score, icc.items=icc_items,

diff --git a/R/ccov_np_compute_ccov_sum_score.R b/R/ccov_np_compute_ccov_sum_score.R
@@ -0,0 +1,24 @@
+## File Name: ccov_np_compute_ccov_sum_score.R
+## File Version: 0.10
+
+ccov_np_compute_ccov_sum_score <- function(score, data, use_rcpp=TRUE)
+{
+    scores <- sort(unique(score))
+    wgt_score <- sirt_sum_norm(table(score))
+    NS <- length(scores)
+    ccov_ff <- rep(NA,NS)
+    if (!use_rcpp){
+        for (ss in 1:NS){
+            i1 <- which(score==scores[ss])
+            s1 <- stats::cov.wt(x=data[i1,], method="ML")
+            ccov_ff[ss] <- s1$cov[1,2]
+        }
+    } else {
+        index <- match(score, scores)-1
+        ccov_ff <- sirt_rcpp_ccov_np_compute_ccov_sum_score( index=index,
+                            NS=NS, data=as.matrix(data) )
+    }
+    ccov_aggr <- sum(wgt_score*ccov_ff)
+    res <- list(ccov_ff=ccov_ff, scores=scores, ccov_aggr=ccov_aggr)
+    return(res)
+}
diff --git a/R/ccov_np_regression.R b/R/ccov_np_regression.R
@@ -1,5 +1,5 @@
 ## File Name: ccov_np_regression.R
-## File Version: 0.07
+## File Version: 0.12
 
 ccov_np_regression <- function(x, y, xgrid, bwscale=1.1, smooth=TRUE, score=NULL)
 {

diff --git a/R/conf.detect.R b/R/conf.detect.R
@@ -1,10 +1,10 @@
 ## File Name: conf.detect.R
-## File Version: 1.16
+## File Version: 1.198
 
 
 # Confirmatory DETECT analysis
 conf.detect <- function( data, score, itemcluster, bwscale=1.1, progress=TRUE,
-                        thetagrid=seq( -3,3,len=200))
+                thetagrid=seq( -3,3,len=200), smooth=TRUE, use_sum_score=FALSE)
 {
     CALL <- match.call()
     cat("-----------------------------------------------------------\n" )
@@ -15,7 +15,7 @@ conf.detect <- function( data, score, itemcluster, bwscale=1.1, progress=TRUE,
         PP <- ncol(score)
     }
     is_one_score <- TRUE
-    if (! h1  ){
+    if (! h1 ){
         cat("Conditioning on 1 Score\n" )
     } else {
         cat(paste("Conditioning on ",PP, " Scores\n", sep="") )
@@ -24,26 +24,32 @@ conf.detect <- function( data, score, itemcluster, bwscale=1.1, progress=TRUE,
     cat(paste("Bandwidth Scale:", bwscale, "\n" ) )
     utils::flush.console()
     if ( ! h1 ){
-        ccovtable <- ccov.np( data, score=score, bwscale=bwscale,
-                            progress=progress, thetagrid=thetagrid )
-        res <- detect.index( ccovtable, itemcluster=itemcluster )
+        scale_score <- TRUE
+        if (!smooth){
+            scale_score <- FALSE
+        }
+        ccovtable <- ccov.np( data=data, score=score, bwscale=bwscale,
+                            progress=progress, thetagrid=thetagrid, smooth=smooth,
+                            scale_score=scale_score, use_sum_score=use_sum_score)
+        res <- detect.index( ccovtable=ccovtable, itemcluster=itemcluster )
     } else {
         ccovtable.list <- list()
         for (pp in 1:PP){
             cat( paste( "DETECT Calculation Score ", pp, "\n", sep="") ) ;
             utils::flush.console()
-            ccovtable.list[[pp]] <- ccov.np( data, score=score[,pp],
-                                        bwscale=bwscale, progress=FALSE )
+            ccovtable.list[[pp]] <- ccov.np( data=data, score=score[,pp],
+                                    bwscale=bwscale, smooth=smooth, progress=FALSE,
+                                    scale_score=scale_score, thetagrid=thetagrid,
+                                    use_sum_score=use_sum_score)
         }
-        detect.list <- lapply( ccovtable.list, FUN=function( ccovtable ){
+        detect.list <- lapply( ccovtable.list, FUN=function(ccovtable){
                     detect.index( ccovtable, itemcluster=itemcluster ) } )
         detect.matrix <- matrix( unlist( lapply( detect.list, FUN=function( ll){
                                 c( ll[1,], ll[2,], ll[3,] ) } ) ), nrow=PP, byrow=TRUE)
         detect.summary <- data.frame( "NScores"=PP, "Mean"=colMeans( detect.matrix ),
                                 "SD"=apply( detect.matrix, 2, stats::sd ),
                                 "Min"=apply( detect.matrix, 2, min ),
-                                "Max"=apply( detect.matrix, 2, max )
-                )
+                                "Max"=apply( detect.matrix, 2, max ) )
         rownames(detect.summary) <- c("DETECT Unweighted", "DETECT Weighted", "ASSI Unweighted", "ASSI Weighted",
                     "RATIO Unweighted", "RATIO Weighted" )
     }
@@ -59,6 +65,7 @@ conf.detect <- function( data, score, itemcluster, bwscale=1.1, progress=TRUE,
     res$CALL <- CALL
     res$bwscale <- bwscale
     res$itemcluster <- itemcluster
+    res$smooth <- smooth
     #--- print
     print(round(res$detect.summary,3))
     #--- return

diff --git a/R/detect.index.R b/R/detect.index.R
@@ -1,5 +1,5 @@
 ## File Name: detect.index.R
-## File Version: 0.30
+## File Version: 0.34
 
 
 
@@ -15,7 +15,7 @@ detect.index <- function( ccovtable, itemcluster )
     N <- ccovtable$N
     sqrt_N <- sqrt(N)
     sign_ccov <- sign(ccov)
-    abs_ccov <- abs( ccov )
+    abs_ccov <- abs(ccov)
     # number of parameters
     np <- 5
     parnames <- weighted.indizes <- indizes <- rep(NA,np)

diff --git a/R/dexppow.R b/R/dexppow.R
@@ -0,0 +1,15 @@
+## File Name: dexppow.R
+## File Version: 0.04
+
+
+## copied from normalp::dnormp
+dexppow <- function (x, mu=0, sigmap=1, pow=2, log=FALSE)
+{
+    p <- pow
+    cost <- 2 * p^(1/p) * gamma(1 + 1/p) * sigmap
+    expon1 <- (abs(x - mu))^p
+    expon2 <- p * sigmap^p
+    dsty <- (1/cost) * exp(-expon1/expon2)
+    if (log){ dsty <- log(dsty) }
+    return(dsty)
+}
diff --git a/R/expl.detect.R b/R/expl.detect.R
@@ -1,15 +1,21 @@
 ## File Name: expl.detect.R
-## File Version: 1.20
+## File Version: 1.24
 
 
 #**** Exploratory DETECT analysis
-expl.detect <- function( data, score, nclusters, N.est=NULL, seed=NULL, bwscale=1.1 )
+expl.detect <- function( data, score, nclusters, N.est=NULL, seed=NULL,
+        bwscale=1.1, use_sum_score=FALSE )
 {
     if ( ! is.null(seed) ){
         set.seed(seed)
     }
+    smooth <- TRUE
     # number of items
     I <- ncol(data)
+    if (use_sum_score){
+        smooth <- FALSE
+        score <- rowSums(data)
+    }
     # sample for estimation
     N <- nrow(data)
     if ( is.null( N.est ) ){
@@ -22,7 +28,8 @@ expl.detect <- function( data, score, nclusters, N.est=NULL, seed=NULL, bwscale=
     # Maximizing DETECT index
     #**********************************
     # nonparametric estimation of conditional covariance
-    cc <- ccov.np( data=data[ estsample,], score=score[estsample], bwscale=bwscale )
+    cc <- ccov.np( data=data[ estsample,], score=score[estsample], bwscale=bwscale,
+                smooth=smooth, use_sum_score=use_sum_score)
     ccov.matrix <- create.ccov( cc=cc, data=data[ estsample,]  )
     # create distance matrix
     cc1 <- max(ccov.matrix) - ccov.matrix
@@ -56,7 +63,8 @@ expl.detect <- function( data, score, nclusters, N.est=NULL, seed=NULL, bwscale=
     # Validating DETECT index
     #************************************
     if ( length(valsample) > 0 ){
-        cc <- ccov.np( data=data[ valsample,], score=score[valsample], bwscale=bwscale )
+        cc <- ccov.np( data=data[ valsample,], score=score[valsample],
+                    bwscale=bwscale, smooth=smooth, use_sum_score=use_sum_score )
         detect.unweighted <- detect.weighted <- NULL
         for (k in 2:nclusters){
             h1 <- detect.index( ccovtable=cc, itemcluster=itemcluster[,k] )

diff --git a/R/linking.haberman.R b/R/linking.haberman.R
@@ -1,11 +1,12 @@
 ## File Name: linking.haberman.R
-## File Version: 2.637
+## File Version: 2.639
 
 
 #**** Linking Haberman: ETS Research Report 2009
 linking.haberman <- function( itempars, personpars=NULL,
         estimation="OLS", a_trim=Inf, b_trim=Inf, lts_prop=.5,
-        a_log=TRUE, conv=.00001, maxiter=1000, progress=TRUE, adjust_main_effects=TRUE)
+        a_log=TRUE, conv=.00001, maxiter=1000, progress=TRUE,
+        adjust_main_effects=TRUE)
 {
     CALL <- match.call()
     s1 <- Sys.time()