3.13-162

alexanderrobitzsch · Jun 11, 2023 · 6ac4978 · 6ac4978
1 parent 05c9006
commit 6ac4978
Show file tree

Hide file tree

Showing 18 changed files with 102 additions and 35 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,8 +1,8 @@
 Package: sirt
 Type: Package
 Title: Supplementary Item Response Theory Models
-Version: 3.13-151
-Date: 2023-04-23 09:53:29
+Version: 3.13-162
+Date: 2023-06-11 18:07:59
 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.013151
+## File Version: 3.013162
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 

diff --git a/R/mgsem.R b/R/mgsem.R
@@ -1,9 +1,9 @@
 ## File Name: mgsem.R
-## File Version: 0.539
+## File Version: 0.545
 
 mgsem <- function(suffstat, model, data=NULL, group=NULL, weights=NULL,
         estimator="ML", p_me=2, p_pen=1, pen_type="scad",
-        diffpar_pen=NULL, a_scad=3.7, eps_approx=1e-3, comp_se=TRUE,
+        diffpar_pen=NULL, pen_sample_size=TRUE, a_scad=3.7, eps_approx=1e-3, comp_se=TRUE,
         se_delta_formula=FALSE, prior_list=NULL, hessian=TRUE,
         fixed_parms=FALSE, cd=FALSE,
         cd_control=list(maxiter=20, tol=5*1e-4, interval_length=0.05, method="exact"),
@@ -72,7 +72,8 @@ mgsem <- function(suffstat, model, data=NULL, group=NULL, weights=NULL,
     res <- mgsem_proc_model(model=model, G=G, prior_list=prior_list,
                     technical=technical, N_group=N_group, random_sd=random_sd,
                     pen_type=pen_type, fixed_parms=fixed_parms,
-                    partable_start=partable_start, diffpar_pen=diffpar_pen)
+                    partable_start=partable_start, diffpar_pen=diffpar_pen,
+                    pen_sample_size=pen_sample_size)
     model <- res$model
     partable <- res$partable
     NP <- res$NP
@@ -154,6 +155,7 @@ mgsem <- function(suffstat, model, data=NULL, group=NULL, weights=NULL,
     opt_fun_args$partable <- partable
     opt_fun_args$model <- model
     opt_fun_output <- mgsem_opt_fun(x=coef, opt_fun_args=opt_fun_args, output_all=TRUE)
+
     implied <- opt_fun_output$implied
     est_tot <- opt_fun_output$est_tot
     grad_fun_output <- mgsem_grad_fun(x=coef, opt_fun_args=opt_fun_args, output_all=TRUE)

diff --git a/R/mgsem_L0_approx_ot.R b/R/mgsem_L0_approx_ot.R
@@ -0,0 +1,9 @@
+## File Name: mgsem_L0_approx_ot.R
+## File Version: 0.01
+
+
+mgsem_L0_approx_ot <- function(x, gamma, eps)
+{
+    y <- 2/(1+exp(-gamma*(x^2+eps)^1/2) )-1
+    return(y)
+}
diff --git a/R/mgsem_L0_penalty.R b/R/mgsem_L0_penalty.R
@@ -0,0 +1,14 @@
+## File Name: mgsem_L0_penalty.R
+## File Version: 0.03
+
+mgsem_L0_penalty <- function(x=x, eps, gamma, deriv=FALSE, h=min(1e-4,eps/10) )
+{
+    if (deriv){
+        y1 <- mgsem_L0_approx_ot(x=x+h, gamma=gamma, eps=eps)
+        y2 <- mgsem_L0_approx_ot(x=x-h, gamma=gamma, eps=eps)
+        y <- (y1-y2)/(2*h)
+    } else {
+        y <- mgsem_L0_approx_ot(x=x, gamma=gamma, eps=eps)
+    }
+    return(y)
+}
diff --git a/R/mgsem_eval_lp_penalty_vector.R b/R/mgsem_eval_lp_penalty_vector.R
@@ -1,10 +1,23 @@
 ## File Name: mgsem_eval_lp_penalty_vector.R
-## File Version: 0.199
+## File Version: 0.211
 
 
 mgsem_eval_lp_penalty_vector <- function(x, fac, n, p, eps_approx, deriv, h, a=3.7,
     pen_type="lasso")
 {
+    # smoothic penalty
+    if (pen_type=='smoothic'){
+        val <- mgsem_smoothic_penalty(x=x, eps=eps_approx, deriv=deriv)
+        val <- fac*val
+    }
+
+    # L0 penalty
+    if (pen_type=='L0'){
+        h <- 1e-4
+        gamma <- 50
+        val <- mgsem_L0_penalty(x=x, eps=eps_approx, gamma=gamma, deriv=deriv, h=h)
+        val <- n*fac*val
+    }
 
     # Lasso penalty
     if (pen_type=='lasso'){
@@ -30,5 +43,6 @@ mgsem_eval_lp_penalty_vector <- function(x, fac, n, p, eps_approx, deriv, h, a=3
         }
     }
 
+    #--- output
     return(val)
 }
diff --git a/R/mgsem_evaluate_penalties.R b/R/mgsem_evaluate_penalties.R
@@ -1,5 +1,5 @@
 ## File Name: mgsem_evaluate_penalties.R
-## File Version: 0.332
+## File Version: 0.345
 
 
 mgsem_evaluate_penalties <- function(x, partable, prior_list, technical,
@@ -33,6 +33,9 @@ mgsem_evaluate_penalties <- function(x, partable, prior_list, technical,
 
     partable2 <- partable[ loop_parms, ]
     n <- partable2$N_group
+    if (partable$ss[1]==0){
+        n <- 1+0*n
+    }
 
     #*** L2 penalty
     if (technical$is_pen_l2){
@@ -53,7 +56,7 @@ mgsem_evaluate_penalties <- function(x, partable, prior_list, technical,
         args_pen <- list(x=x, p=p, n=n, fac=fac, eps=eps_approx, deriv=deriv,
                         pen_type=pen_type, a=a_scad, h=h)
 
-        if (!use_rcpp_penalty){
+        if (!use_rcpp_penalty | (pen_type%in%c('smoothic','L0')) ){
             fun_pen <- 'mgsem_eval_lp_penalty_vector'
         } else {
             fun_pen <- 'sirt_rcpp_mgsem_eval_lp_penalty'

diff --git a/R/mgsem_opt_fun.R b/R/mgsem_opt_fun.R
@@ -1,5 +1,5 @@
 ## File Name: mgsem_opt_fun.R
-## File Version: 0.266
+## File Version: 0.272
 
 
 mgsem_opt_fun <- function(x, opt_fun_args, output_all=FALSE)
@@ -34,7 +34,7 @@ mgsem_opt_fun <- function(x, opt_fun_args, output_all=FALSE)
         }
         S_gg <- suffstat[[gg]]$S
         p <- nrow(S_gg)
-        
+
         #- function evaluation
         eval_args <- list(suffstat=opt_fun_args$suffstat[[gg]],
                             Mu=implied$Mu, Sigma=implied$Sigma,
@@ -86,7 +86,7 @@ mgsem_opt_fun <- function(x, opt_fun_args, output_all=FALSE)
         # chi square statistic and RMSEA
         p_mu <- 0
         for (gg in 1:G){
-            mu1 <- suffstat[[gg]]$mu
+            mu1 <- suffstat[[gg]]$M
             p_mu <- p_mu + sum(abs(mu1)>1e-14)
         }
         chisq_df <- p_mu + G*p*(p+1)/2 - max(partable$index)

diff --git a/R/mgsem_power_fun_differentiable_approx.R b/R/mgsem_power_fun_differentiable_approx.R
@@ -1,27 +1,35 @@
 ## File Name: mgsem_power_fun_differentiable_approx.R
-## File Version: 0.091
+## File Version: 0.096
 
 mgsem_power_fun_differentiable_approx <- function(x, p, eps, deriv=FALSE,
         approx_method="lp")
 {
     # logcomp <- TRUE
     logcomp <- FALSE
-    if (deriv){
+    if (deriv){  ## derivative
         if (approx_method=='lp'){
-            if (!logcomp){
-                res <- p*((x^2+eps)^(p/2-1))*x
-            } else {
-                logp <- log(p)
-                p2 <- (p/2-1)
-                res <- x*exp( p2*log(x^2+eps) + logp )
+            if (p>0){
+                if (!logcomp){
+                    res <- p*((x^2+eps)^(p/2-1))*x
+                } else {
+                    logp <- log(p)
+                    p2 <- (p/2-1)
+                    res <- x*exp( p2*log(x^2+eps) + logp )
+                }
+            } else { # p=0
+                res <- 2*x*eps/(x^2+eps)^2
             }
         }
         if (approx_method=='l2'){
             res <- 2*x
         }
-    } else {
+    } else {  # no derivative
         if (approx_method=='lp'){
-            res <- (x^2+eps)^(p/2)
+            if (p>0){
+                res <- (x^2+eps)^(p/2)
+            } else { # p=0
+                res <- x^2 / (x^2 + eps)
+            }
         }
         if (approx_method=='l2'){
             res <- x^2

diff --git a/R/mgsem_proc_model.R b/R/mgsem_proc_model.R
@@ -1,9 +1,9 @@
 ## File Name: mgsem_proc_model.R
-## File Version: 0.298
+## File Version: 0.306
 
 mgsem_proc_model <- function(model, G=G, random_sd=1e-1, technical, N_group,
         prior_list=NULL, pen_type="lasso", fixed_parms=FALSE,
-        partable_start=NULL, diffpar_pen=NULL)
+        partable_start=NULL, diffpar_pen=NULL, pen_sample_size=TRUE)
 {
 
     dfr <- NULL
@@ -94,6 +94,7 @@ mgsem_proc_model <- function(model, G=G, random_sd=1e-1, technical, N_group,
                                             pen_type=pen_type)
                             dfr1$unique <- 0
                             dfr1$recycle <- 0
+
                             #- append to previous parameters
                             dfr <- rbind(dfr, dfr1)
                         }
@@ -104,6 +105,8 @@ mgsem_proc_model <- function(model, G=G, random_sd=1e-1, technical, N_group,
 
     }    # end gg
 
+    dfr$ss <- 1*pen_sample_size
+
     if (any(duplicated(dfr$name))){
         dfr$name <- dfr$name2
     }

diff --git a/R/mgsem_smoothic_penalty.R b/R/mgsem_smoothic_penalty.R
@@ -0,0 +1,14 @@
+## File Name: mgsem_smoothic_penalty.R
+## File Version: 0.04
+
+
+mgsem_smoothic_penalty <- function(x, eps, deriv=FALSE)
+{
+    if (deriv){  ## derivative
+        res <- 2*x*eps / (x^2+eps)^2
+        # 2*x*(x^2+eps) - x^2*(2*x)
+    } else {  # no derivative
+        res <- x^2 / (x^2 + eps)
+    }
+    return(res)
+}
diff --git a/README.md b/README.md
@@ -25,9 +25,9 @@ The CRAN version can be installed from within R using:
 utils::install.packages("sirt")
 ```
 
-#### GitHub version `sirt` 3.13-151 (2023-04-23)
+#### GitHub version `sirt` 3.13-162 (2023-06-11)
 
-[![](https://img.shields.io/badge/github%20version-3.13--151-orange.svg)](https://github.com/alexanderrobitzsch/sirt)&#160;&#160;
+[![](https://img.shields.io/badge/github%20version-3.13--162-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: 2023-04-23T08:14Z
+last_built: 2023-06-11T16:26Z
 
diff --git a/inst/NEWS b/inst/NEWS
@@ -35,7 +35,7 @@ CHANGELOG sirt
 
 
 ------------------------------------------------------------------------
-VERSIONS sirt 3.13  |  2023-04-23  |  Last: sirt 3.13-151
+VERSIONS sirt 3.13  |  2023-06-11  |  Last: sirt 3.13-162
 ------------------------------------------------------------------------
 
 NOTE  * included arguments 'pw_linear', 'pw_quadratic' that allow 

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