Skip to content

Commit

Permalink
Showing 141 changed files with 891 additions and 647 deletions.
4 changes: 2 additions & 2 deletions DESCRIPTION
Original file line number Diff line number Diff line change
@@ -1,8 +1,8 @@
Package: sirt
Type: Package
Title: Supplementary Item Response Theory Models
Version: 3.13-24
Date: 2022-11-28 16:03:25
Version: 3.13-35
Date: 2023-02-10 15:14:59
Author: Alexander Robitzsch [aut,cre] (<https://orcid.org/0000-0002-8226-3132>)
Maintainer: Alexander Robitzsch <robitzsch@ipn.uni-kiel.de>
Description:
1 change: 1 addition & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
@@ -278,6 +278,7 @@ export(modelfit.cor.poly)
export(modelfit.sirt)
export(monoreg.colwise)
export(monoreg.rowwise)
export(move_variables_df)
export(nedelsky.irf)
export(nedelsky.latresp)
export(nedelsky.sim)
2 changes: 1 addition & 1 deletion R/RcppExports.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: RcppExports.R
## File Version: 3.013024
## File Version: 3.013034
# Generated by using Rcpp::compileAttributes() -> do not edit by hand
# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393

34 changes: 27 additions & 7 deletions R/lsem.bootstrap.R
Original file line number Diff line number Diff line change
@@ -1,15 +1,20 @@
## File Name: lsem.bootstrap.R
## File Version: 0.323
## File Version: 0.333


lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL, seed=1,
lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL,
repl_design=NULL, repl_factor=NULL, use_starting_values=TRUE)
{
# fix seed locally
s1 <- Sys.time()
old <- .Random.seed
on.exit({.Random.seed <<- old})
set.seed(seed)

#* do not fix seed
if (FALSE){
old <- .Random.seed
on.exit({.Random.seed <<- old})
# set.seed(seed)
}

if (!is.null(repl_design)){
R <- ncol(repl_design)
}
@@ -33,6 +38,10 @@ lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL, seed=1,
est_joint <- object$est_joint
fitstats_joint <- object$fitstats_joint

#-- bootstrap parameters_summary
parameters_summary <- object$parameters_summary
parameters_var_boot <- matrix(NA, nrow=nrow(parameters_summary), ncol=R)

#-- create output arguments
parameters <- object$parameters
NP <- nrow(parameters)
@@ -47,19 +56,25 @@ lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL, seed=1,

#-- loop over bootstrap samples
lsem_bootstrap_print_start(verbose=verbose)

repl_design_used <- matrix(NA, nrow=nrow(data), ncol=R)

rr <- 1
while (rr<=R){
lsem_bootstrap_print_progress(rr=rr, verbose=verbose, R=R)
#- draw bootstrap sample
lsem_args1 <- lsem_bootstrap_draw_bootstrap_sample(data=data,
res <- lsem_bootstrap_draw_bootstrap_sample(data=data,
sampling_weights=sampling_weights, lsem_args=lsem_args,
cluster=cluster, repl_design=repl_design, rr=rr)
lsem_args1 <- res$lsem_args1
#- fit model
mod1 <- try( do.call(what=lsem.estimate, args=lsem_args1), silent=TRUE)
#- output collection
if ( ! inherits(mod1,"try-error" ) ){
parameters_boot[,rr] <- mod1$parameters$est
fitstats_joint_boot[,rr] <- mod1$fitstats_joint$value
parameters_var_boot[,rr] <- mod1$parameters_summary$SD^2
repl_design_used[,rr] <- res$repl_vector
rr <- rr + 1
}
}
@@ -68,16 +83,21 @@ lsem.bootstrap <- function(object, R=100, verbose=TRUE, cluster=NULL, seed=1,
res <- lsem_bootstrap_postproc_output( parameters=parameters,
parameters_boot=parameters_boot, fitstats_joint=fitstats_joint,
fitstats_joint_boot=fitstats_joint_boot, est_joint=est_joint,
repl_factor=repl_factor )
repl_factor=repl_factor, parameters_summary=parameters_summary,
parameters_var_boot=parameters_var_boot )
parameters <- res$parameters
fitstats_joint <- res$fitstats_joint
object$parameters_summary <- res$parameters_summary

#- include new objects in output
object$parameters_boot <- parameters_boot
object$fitstats_joint_boot <- fitstats_joint_boot
object$parameters <- parameters
object$R <- R
object$class_boot <- TRUE
object$fitstats_joint <- fitstats_joint
object$repl_design <- repl_design
object$repl_design_used <- repl_design_used
s2 <- Sys.time()
object$s1 <- s1
object$s2 <- s2
15 changes: 8 additions & 7 deletions R/lsem.estimate.R
Original file line number Diff line number Diff line change
@@ -1,11 +1,11 @@
## File Name: lsem.estimate.R
## File Version: 1.042
## File Version: 1.051

# estimate LSEM model
lsem.estimate <- function( data, moderator, moderator.grid,
lavmodel, type="LSEM", h=1.1, bw=NULL, residualize=TRUE,
fit_measures=c("rmsea","cfi","tli","gfi","srmr"), standardized=FALSE,
standardized_type="std.all", lavaan_fct="sem", sufficient_statistics=FALSE,
standardized_type="std.all", lavaan_fct="sem", sufficient_statistics=TRUE,
use_lavaan_survey=FALSE, pseudo_weights=0, sampling_weights=NULL,
loc_linear_smooth=TRUE, est_joint=FALSE, par_invariant=NULL, par_linear=NULL,
par_quadratic=NULL, partable_joint=NULL, pw_linear=1,
@@ -140,11 +140,12 @@ lsem.estimate <- function( data, moderator, moderator.grid,
obji$moderator <- obji$moderator
obji$wgt <- obji$wgt
obji$Neff <- obji$Neff
dfr <- data.frame( M=colMeans( obji0[,-1] ), SD=apply( obji0[,-1], 2, stats::sd ),
min=apply( obji0[,-1], 2, min ), max=apply( obji0[,-1], 2, max ))
dfr0 <- data.frame(M=mean( data[,moderator], na.rm=TRUE ), SD=out$sd.moderator,
min=min( data[, moderator], na.rm=TRUE ),
max=max( data[, moderator], na.rm=TRUE ) )
Y <- obji0[,-1]
dfr <- data.frame( M=colMeans(Y), SD=apply( Y, 2, stats::sd ),
min=apply( Y, 2, min ), max=apply( Y, 2, max ) )
x <- data[,moderator]
dfr0 <- data.frame(M=mean( x, na.rm=TRUE ), SD=out$sd.moderator,
min=min( x, na.rm=TRUE ), max=max( x, na.rm=TRUE ) )
obji <- rbind( dfr0, dfr )
rownames(obji) <- NULL
moderator.stat <- data.frame(variable=c("moderator","wgt", "Neff"), obji )
30 changes: 26 additions & 4 deletions R/lsem_bootstrap_draw_bootstrap_sample.R
Original file line number Diff line number Diff line change
@@ -1,14 +1,17 @@
## File Name: lsem_bootstrap_draw_bootstrap_sample.R
## File Version: 0.057
## File Version: 0.067

lsem_bootstrap_draw_bootstrap_sample <- function(data, sampling_weights,
lsem_args, cluster=NULL, repl_design=NULL, rr=NULL)
{
lsem_args1 <- lsem_args
ind <- NULL
used_repl_design <- ! is.null(repl_design)
repl_vector <- NULL
N1 <- N <- nrow(data)

if (is.null(repl_design)){
if (! used_repl_design){
# no replication design
N <- nrow(data)
if (is.null(cluster)){
ind <- sample(1:N, N, replace=TRUE)
} else {
@@ -22,11 +25,30 @@ lsem_bootstrap_draw_bootstrap_sample <- function(data, sampling_weights,
ind <- c(ind, v1)
}
}

lsem_args1$data <- data[ind,]
lsem_args1$sampling_weights <- sampling_weights[ind]

# define replication design
t1 <- table(ind)
t1 <- data.frame( index=as.numeric(names(t1)),
freq=as.numeric(t1) )
rownames(t1) <- NULL

t2 <- data.frame(index=1:N1, weight=sampling_weights)
t1 <- merge(x=t1, y=t2, by="index", all=TRUE)
t1$freq <- ifelse( is.na(t1$freq), 0, t1$freq )
t1$repl_vector <- t1$freq * t1$weight
repl_vector <- t1$repl_vector

} else { # replication design
lsem_args1$sampling_weights <- repl_design[,rr]
repl_vector <- lsem_args1$sampling_weights
}

return(lsem_args1)
#--- arrange output
res <- list(lsem_args1=lsem_args1, repl_vector=repl_vector,
used_repl_design=used_repl_design)

return(res)
}
13 changes: 11 additions & 2 deletions R/lsem_bootstrap_inference.R
Original file line number Diff line number Diff line change
@@ -1,7 +1,8 @@
## File Name: lsem_bootstrap_inference.R
## File Version: 0.08
## File Version: 0.112

lsem_bootstrap_inference <- function(parameters_boot, est, repl_factor=NULL)
lsem_bootstrap_inference <- function(parameters_boot, est, repl_factor=NULL,
bc_square=NULL)
{
R <- ncol(parameters_boot)
est_boot <- rowMeans(parameters_boot, na.rm=TRUE)
@@ -11,6 +12,14 @@ lsem_bootstrap_inference <- function(parameters_boot, est, repl_factor=NULL)
se_boot <- sqrt( rowSums( ( parameters_boot - est_boot )^2 ) * repl_factor )
bias_boot <- (est_boot - est)*repl_factor*(R-1)
est_bc <- est - bias_boot
if (!is.null(bc_square)){
pb2 <- parameters_boot[bc_square,,drop=FALSE]^2
est_boot <- rowMeans( pb2, na.rm=TRUE )
bias_boot <- (est_boot - est[bc_square]^2)*repl_factor*(R-1)
v1 <- est[bc_square]^2 - bias_boot
est_bc[bc_square] <- ifelse( v1>0, sqrt(v1), 0 )
}

#-- output
res <- list(mean_boot=est_boot, se_boot=se_boot, est_bc=est_bc,
bias_boot=bias_boot, est=est)
34 changes: 27 additions & 7 deletions R/lsem_bootstrap_postproc_output.R
Original file line number Diff line number Diff line change
@@ -1,12 +1,13 @@
## File Name: lsem_bootstrap_postproc_output.R
## File Version: 0.05
## File Version: 0.097

lsem_bootstrap_postproc_output <- function(parameters, parameters_boot,
fitstats_joint, fitstats_joint_boot, est_joint=FALSE, repl_factor=NULL)
fitstats_joint, fitstats_joint_boot, est_joint=FALSE, repl_factor=NULL,
parameters_summary, parameters_var_boot)
{
#* parameters
res <- lsem_bootstrap_inference(parameters_boot=parameters_boot, est=parameters$est,
repl_factor=repl_factor)
repl_factor=repl_factor, bc_square=NULL)
parameters$est_bc <- res$est_bc
parameters$se <- res$se_boot
parameters$z <- parameters$est / parameters$se
@@ -15,15 +16,34 @@ lsem_bootstrap_postproc_output <- function(parameters, parameters_boot,
parameters$ci.lower <- parameters$est - quant * parameters$se
parameters$ci.upper <- parameters$est + quant * parameters$se

#* fitstats_joint
#* fitstats_joint: bootstrap inference for fit statistics
if (est_joint){
res <- lsem_bootstrap_inference(parameters_boot=fitstats_joint_boot,
est=fitstats_joint$value, repl_factor=repl_factor)
fjb <- fitstats_joint_boot
# bc_square <- which( rownames(fjb) %in% c("rmsea","srmr") )
bc_square <- which( rownames(fjb) %in% c("srmr") )
val <- fitstats_joint$value
res <- lsem_bootstrap_inference(parameters_boot=fjb,
est=val, repl_factor=repl_factor,
bc_square=bc_square)
fitstats_joint$value_bc <- res$est_bc
fitstats_joint$se <- res$se_boot
}

#* adapt parameters_summary
vt1 <- rowMeans(parameters_var_boot)
vt0 <- parameters_summary$SD^2
parameters_summary$SD_se <- apply(sqrt(parameters_var_boot), 1, stats::sd)
w <- vt0 - (vt1-vt0)
parameters_summary$SD_bc <- ifelse( w < 0, 0, sqrt(w) )
h <- parameters_summary$SD_bc / (parameters_summary$SD_se+1e-100)
h <- ifelse( abs(parameters_summary$SD) < 1e-5*abs(parameters_summary$M), 0, h )
parameters_summary$SD_t <- h

parameters_summary <- move_variables_df(x=parameters_summary,
after_var="SD", move_vars=c("SD_bc", "SD_se", "SD_t"))

#-- output
res <- list(parameters=parameters, fitstats_joint=fitstats_joint)
res <- list(parameters=parameters, fitstats_joint=fitstats_joint,
parameters_summary=parameters_summary)
return(res)
}
2 changes: 1 addition & 1 deletion R/lsem_fitsem.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: lsem_fitsem.R
## File Version: 0.619
## File Version: 0.622

lsem_fitsem <- function( dat, weights, lavfit, fit_measures, NF, G, moderator.grid,
verbose, pars, standardized, variables_model, sufficient_statistics,
3 changes: 2 additions & 1 deletion R/lsem_parameter_summary.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: lsem_parameter_summary.R
## File Version: 0.22
## File Version: 0.232


## lsem parameter summary
@@ -18,6 +18,7 @@ lsem_parameter_summary <- function( parameters, moderator.density, verbose ){
x <- par.pp[,"est"]
pars1$M <- stats::weighted.mean( x, mod.density[,2] )
pars1$SD <- lsem_wtdSD( x, mod.density[,2] )
# pars1$Var <- pars1$SD^2
pars1$MAD <- sum( mod.density[,2] * abs( x - pars1$M ) )
pars1$Min <- min(x)
pars1$Max <- max(x)
8 changes: 8 additions & 0 deletions R/lsem_spline.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,8 @@
## File Name: lsem_spline.R
## File Version: 0.02

lsem_spline <- function( x, y, method="fmm", n=100)
{
res <- stats::spline( x=x, y=y, n=n, method=method )
return(res)
}
6 changes: 3 additions & 3 deletions R/mgsem.R
Original file line number Diff line number Diff line change
@@ -1,10 +1,11 @@
## File Name: mgsem.R
## File Version: 0.412
## File Version: 0.423

mgsem <- function(suffstat, model, data=NULL, group=NULL, weights=NULL,
estimator="ML", p_me=2, p_pen=1, pen_type="scad",
a_scad=3.7, eps_approx=1e-3, comp_se=TRUE, prior_list=NULL, hessian=TRUE,
fixed_parms=FALSE, partable_start=NULL, technical=NULL, control=list() )
fixed_parms=FALSE, partable_start=NULL,
num_approx=FALSE, technical=NULL, control=list() )
{
#- pen_type: lasso, scad or none

@@ -46,7 +47,6 @@ mgsem <- function(suffstat, model, data=NULL, group=NULL, weights=NULL,
I <- res$I
N <- res$N
N_group <- res$N_group

random_sd <- -9
if (test){
random_sd <- 1e-1
2 changes: 1 addition & 1 deletion R/mgsem_compute_model_implied_moments.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: mgsem_compute_model_implied_moments.R
## File Version: 0.165
## File Version: 0.168


mgsem_compute_model_implied_moments <- function(est, is_B=FALSE, calc_Sigma=TRUE,
4 changes: 2 additions & 2 deletions R/mgsem_eval_lp_penalty_matrix.R
Original file line number Diff line number Diff line change
@@ -1,12 +1,12 @@
## File Name: mgsem_eval_lp_penalty_matrix.R
## File Version: 0.082
## File Version: 0.083

mgsem_eval_lp_penalty_matrix <- function(x, fac, p, n, h, eps_approx,
pen_type="lasso", a_scad=3.7)
{
x1 <- x
I1 <- length(x1)
y <- matrix(x1, nrow=I1, ncol=I1)-sirt_matrix2(x1, nrow=I1)
y <- matrix(x1, nrow=I1, ncol=I1)-sirt_matrix2(x=x1, nrow=I1)
y <- mgsem_power_fun_differentiable_approx(x=y, p=p,
eps=eps_approx, deriv=FALSE, approx_method="lp")
if (pen_type=="lasso"){
2 changes: 1 addition & 1 deletion R/mgsem_ic.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: mgsem_ic.R
## File Version: 0.12
## File Version: 0.133

mgsem_ic <- function(opt_fun_output, opt_fun_args, partable, technical)
{
10 changes: 4 additions & 6 deletions R/mgsem_opt_fun.R
Original file line number Diff line number Diff line change
@@ -1,5 +1,5 @@
## File Name: mgsem_opt_fun.R
## File Version: 0.218
## File Version: 0.222


mgsem_opt_fun <- function(x, opt_fun_args, output_all=FALSE)
@@ -74,11 +74,9 @@ mgsem_opt_fun <- function(x, opt_fun_args, output_all=FALSE)
res <- ll
if (output_all){
res <- list(loglike=ll0, eval_pen_res=eval_pen_res, opt_val=ll,
pen_all=eval_pen_res$pen_all,
implied=implied_list, est_tot=est_tot_list,
S1=S1_list,
suffstat=opt_fun_args$suffstat, mean_residual=mean_residual_list,
G=G, estimator=estimator )
pen_all=eval_pen_res$pen_all, implied=implied_list, est_tot=est_tot_list,
S1=S1_list, suffstat=opt_fun_args$suffstat,
mean_residual=mean_residual_list, G=G, estimator=estimator )
}

#-- output
Loading

0 comments on commit 70e11a5

Please sign in to comment.