From 532bc4a3159339eee1698e0e2404b62ec5b4bd8b Mon Sep 17 00:00:00 2001 From: Robitzsch Date: Sat, 20 Apr 2024 18:09:24 +0200 Subject: [PATCH] 4.2-57 --- DESCRIPTION | 4 +- R/RcppExports.R | 2 +- R/invariance_alignment_cfa_config_estimate.R | 10 +-- R/invariance_alignment_proc_labels.R | 6 +- R/invariance_alignment_simulate.R | 18 ++--- R/likelihood_adjustment.R | 50 +++++++------- R/likelihood_adjustment_aux.R | 6 +- R/linking.haberman.R | 4 +- R/linking.haberman.lq.R | 8 +-- R/linking.haebara.R | 10 +-- R/linking.robust.R | 4 +- R/linking_haberman_als.R | 8 +-- R/linking_haberman_als_residual_weights.R | 10 +-- R/linking_haberman_als_vcov.R | 9 ++- R/linking_haberman_compute_lts_mean.R | 8 +-- R/linking_haberman_itempars_prepare.R | 6 +- R/linking_haebara_gradient_function_R.R | 6 +- R/linking_haebara_optim_function_R.R | 9 +-- R/noharm.sirt.R | 4 +- R/noharm_sirt_efa_rotated_solution.R | 4 +- R/noharm_sirt_optim_function.R | 19 ++++-- R/noharm_sirt_optim_gradient.R | 32 +++++---- R/noharm_sirt_optim_gradient_R.R | 11 ++-- ...arm_sirt_optim_gradient_R_der_gamma_item.R | 21 +++--- ...irt_optim_gradient_R_der_gamma_item_pair.R | 21 +++--- R/noharm_sirt_partable_extract_par.R | 4 +- R/noharm_sirt_partable_include_par.R | 6 +- R/noharm_sirt_preproc.R | 65 ++++++++++--------- ...harm_sirt_preproc_parameter_table_matrix.R | 9 ++- R/noharm_sirt_preproc_pattern_matrix.R | 4 +- R/sirt_max.R | 13 ++++ R/write.format2.R | 4 +- README.md | 4 +- docs/404.html | 2 +- docs/authors.html | 8 +-- docs/index.html | 2 +- docs/pkgdown.yml | 2 +- docs/search.json | 2 +- inst/NEWS | 2 +- src/RcppExports.cpp | 2 +- 40 files changed, 220 insertions(+), 199 deletions(-) create mode 100644 R/sirt_max.R diff --git a/DESCRIPTION b/DESCRIPTION index 3f852858..8d5652fd 100644 --- 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] () Maintainer: Alexander Robitzsch Description: diff --git a/R/RcppExports.R b/R/RcppExports.R index 21ac173b..5a6b4553 100644 --- 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 index 5b24a874..bbbd5b57 100644 --- 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 index f349a30a..6b7fe13b 100644 --- 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 index 53b8d57b..922bee3d 100644 --- 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] 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 index ed8bd540..d0debfe6 100644 --- 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 index a129adbb..66edd007 100644 --- 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 index 653714f3..bd0eef8c 100644 --- 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 index d0ce1ccc..90f2c1df 100644 --- 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 index 8301f73e..6c5144da 100644 --- 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 index 3b3b4e27..8e3985d4 100644 --- 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 index b25ce525..98415cc9 100644 --- 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 } } diff --git a/R/linking_haberman_als_vcov.R b/R/linking_haberman_als_vcov.R index 764c63b0..ad46ed35 100644 --- a/R/linking_haberman_als_vcov.R +++ b/R/linking_haberman_als_vcov.R @@ -1,5 +1,5 @@ ## File Name: linking_haberman_als_vcov.R -## File Version: 0.165 +## File Version: 0.167 linking_haberman_als_vcov <- function( regr_resid, regr_wgt, transf_pars, selitems, estimation="OLS", vcov=TRUE, NS=NULL ) @@ -14,15 +14,14 @@ linking_haberman_als_vcov <- function( regr_resid, regr_wgt, transf_pars, } N <- nrow(regr_resid) data <- data.frame( y=matrix( regr_resid, ncol=1 ), - study=rep(1:NS, each=N) ) + study=rep(1L:NS, each=N) ) data$wgt <- matrix( regr_wgt, ncol=1 ) data <- stats::na.omit(data) - for (ss in 2:NS){ + for (ss in 2L:NS){ data[, paste0('X', ss) ] <- 1*(data$study==ss) } - # form <- paste0( 'y ~ 0 + ', paste0('X', 2:NS, collapse=' + ' ) ) if (vcov){ - form <- paste0( 'y ~ ', paste0('X', 2:NS, collapse=' + ' ) ) + form <- paste0( 'y ~ ', paste0('X', 2L:NS, collapse=' + ' ) ) mod <- stats::lm( stats::as.formula(form), data=data, weights=data$wgt ) mod_vcov <- stats::vcov(mod) vcov <- mod_vcov[-1,-1] diff --git a/R/linking_haberman_compute_lts_mean.R b/R/linking_haberman_compute_lts_mean.R index 10ed56d7..6c651d82 100644 --- a/R/linking_haberman_compute_lts_mean.R +++ b/R/linking_haberman_compute_lts_mean.R @@ -1,5 +1,5 @@ ## File Name: linking_haberman_compute_lts_mean.R -## File Version: 0.08 +## File Version: 0.091 linking_haberman_compute_lts_mean <- function(x, w, lts_prop, maxiter=10) { @@ -11,15 +11,15 @@ linking_haberman_compute_lts_mean <- function(x, w, lts_prop, maxiter=10) if (n < k){ k <- n } - index <- 1:k + index <- 1L:k m1 <- stats::weighted.mean(x=x, w=w) iter <- 0 iterate <- TRUE - dfr <- data.frame(index=1:n, x=x, e=x-m1, w=w) + dfr <- data.frame(index=1L:n, x=x, e=x-m1, w=w) while(iterate){ m0 <- m1 dfr <- dfr[ order(abs(dfr$e)), ] - m1 <- stats::weighted.mean(x=dfr$x[1:k], w=dfr$w[1:k]) + m1 <- stats::weighted.mean(x=dfr$x[1L:k], w=dfr$w[1L:k]) dfr$e <- dfr$x - m1 iter <- iter + 1 if (iter>maxiter){ iterate <- FALSE } diff --git a/R/linking_haberman_itempars_prepare.R b/R/linking_haberman_itempars_prepare.R index ff78d3f8..585d0292 100644 --- a/R/linking_haberman_itempars_prepare.R +++ b/R/linking_haberman_itempars_prepare.R @@ -1,5 +1,5 @@ ## File Name: linking_haberman_itempars_prepare.R -## File Version: 0.131 +## File Version: 0.132 linking_haberman_itempars_prepare <- function(b, a=NULL, wgt=NULL) @@ -8,10 +8,10 @@ linking_haberman_itempars_prepare <- function(b, a=NULL, wgt=NULL) NS <- ncol(b) if ( is.null(rownames(b) )){ i0 <- ceiling( log10(I) + 1 ) - rownames(b) <- paste0('I', 10^i0 + 1:I) + rownames(b) <- paste0('I', 10^i0 + 1L:I) } if ( is.null(colnames(b) )){ - colnames(b) <- 1:NS + colnames(b) <- 1L:NS } if (is.null(a)){ a <- matrix(1, nrow=I, ncol=NS) diff --git a/R/linking_haebara_gradient_function_R.R b/R/linking_haebara_gradient_function_R.R index e9681cd0..fcd054af 100644 --- a/R/linking_haebara_gradient_function_R.R +++ b/R/linking_haebara_gradient_function_R.R @@ -1,5 +1,5 @@ ## File Name: linking_haebara_gradient_function_R.R -## File Version: 0.293 +## File Version: 0.294 linking_haebara_gradient_function_R <- function(NI, NS, dist, aM, bM, theta, @@ -11,8 +11,8 @@ linking_haebara_gradient_function_R <- function(NI, NS, dist, aM, bM, theta, # th=SIG*TH+MU=> logit(p)=a*(SIG*TH+MU-b)=a*SIG*(TH-(-MU)/SIG-b/SIG) grad <- rep(0, 2*NI+2*(NS-1) ) names(grad) <- parnames - for (ii in 1:NI){ - for (ss in 1:NS){ + for (ii in 1L:NI){ + for (ss in 1L:NS){ if (est_pars[ii,ss]){ p_obs <- stats::plogis( aM[ii,ss] * (theta - bM[ii,ss] ) ) a_exp <- a[ii] * sigma[ss] diff --git a/R/linking_haebara_optim_function_R.R b/R/linking_haebara_optim_function_R.R index ec864bbc..aba09121 100644 --- a/R/linking_haebara_optim_function_R.R +++ b/R/linking_haebara_optim_function_R.R @@ -1,5 +1,5 @@ ## File Name: linking_haebara_optim_function_R.R -## File Version: 0.171 +## File Version: 0.174 linking_haebara_optim_function_R <- function(NI, NS, dist, aM, bM, theta, @@ -8,16 +8,13 @@ linking_haebara_optim_function_R <- function(NI, NS, dist, aM, bM, theta, # logit(p)=a*(th-b) # th=SIG*TH+MU=> logit(p)=a*(SIG*TH+MU-b)=a*SIG*(TH-(-MU)/SIG-b/SIG) val <- 0 - for (ii in 1:NI){ - for (ss in 1:NS){ + for (ii in 1L:NI){ + for (ss in 1L:NS){ if (est_pars[ii,ss]){ p_obs <- stats::plogis( aM[ii,ss] * (theta - bM[ii,ss] ) ) a_exp <- a[ii] * sigma[ss] b_exp <- ( b[ii] - mu[ss] ) / sigma[ss] - # p_exp <- stats::plogis( a_exp * (theta - b_exp ) ) p_exp <- stats::plogis( a_exp*theta - a[ii]*( b[ii] - mu[ss] ) ) - ## a_exp[ii]=a[ii]*sigma[ss] - ## a_exp[ii] * b_exp[ii]=a[ii]*(b[ii]-mu[ss]) dist2 <- (p_obs - p_exp)^2 if (dist=='L2'){ dist1 <- sum( dist2*prob_theta ) diff --git a/R/noharm.sirt.R b/R/noharm.sirt.R index 1e86663e..258dfcb4 100644 --- a/R/noharm.sirt.R +++ b/R/noharm.sirt.R @@ -1,5 +1,5 @@ ## File Name: noharm.sirt.R -## File Version: 0.928 +## File Version: 0.935 ######################################## @@ -29,6 +29,7 @@ noharm.sirt <- function(dat, pm=NULL, N=NULL, weights=NULL, Fval=NULL, Fpatt=NUL } else { input_pm <- FALSE } + res <- noharm_sirt_preproc( dat=dat, pm=pm, N=N, weights=weights, Fpatt=Fpatt, Fval=Fval, Ppatt=Ppatt, Pval=Pval, Psipatt=Psipatt, Psival=Psival, wgtm=wgtm, dimensions=dimensions, pos.loading=pos.loading, @@ -89,7 +90,6 @@ noharm.sirt <- function(dat, pm=NULL, N=NULL, weights=NULL, Fval=NULL, Fpatt=NUL args_optim <- list(parm_table=parm_table, parm_index=parm_index, I=I, D=D, b0.jk=b0.jk, b1.jk=b1.jk, b2.jk=b2.jk, b3.jk=b3.jk, pm=pm, wgtm=wgtm, use_rcpp=TRUE) - optim_fn <- function(x){ args_optim$x <- x val <- do.call(what=noharm_sirt_optim_function, args=args_optim) diff --git a/R/noharm_sirt_efa_rotated_solution.R b/R/noharm_sirt_efa_rotated_solution.R index 7e5b353e..9fbde0d6 100644 --- a/R/noharm_sirt_efa_rotated_solution.R +++ b/R/noharm_sirt_efa_rotated_solution.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_efa_rotated_solution.R -## File Version: 0.05 +## File Version: 0.06 noharm_sirt_efa_rotated_solution <- function(res, items, F_dimnames) @@ -9,7 +9,7 @@ noharm_sirt_efa_rotated_solution <- function(res, items, F_dimnames) D <- ncol(L1) m1 <- stats::promax(L1) p1 <- matrix( 0, nrow=I, ncol=D) - for (dd in 1:D){ + for (dd in 1L:D){ p1[,dd] <- m1$loadings[,dd] } colnames(p1) <- F_dimnames diff --git a/R/noharm_sirt_optim_function.R b/R/noharm_sirt_optim_function.R index 4e01663c..581ec9bc 100644 --- a/R/noharm_sirt_optim_function.R +++ b/R/noharm_sirt_optim_function.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_optim_function.R -## File Version: 0.18 +## File Version: 0.199 noharm_sirt_optim_function <- function(x, parm_table, parm_index, I, D, @@ -7,9 +7,12 @@ noharm_sirt_optim_function <- function(x, parm_table, parm_index, I, D, { parm_table <- noharm_sirt_partable_include_par(par=x, parm_table=parm_table) - Fmat <- noharm_sirt_create_parameter_matrices("F", parm_table=parm_table, parm_index=parm_index) - Pmat <- noharm_sirt_create_parameter_matrices("P", parm_table=parm_table, parm_index=parm_index) - Psimat <- noharm_sirt_create_parameter_matrices("Psi", parm_table=parm_table, parm_index=parm_index) + Fmat <- noharm_sirt_create_parameter_matrices(mat_label='F', parm_table=parm_table, + parm_index=parm_index) + Pmat <- noharm_sirt_create_parameter_matrices(mat_label='P', parm_table=parm_table, + parm_index=parm_index) + Psimat <- noharm_sirt_create_parameter_matrices(mat_label='Psi', + parm_table=parm_table, parm_index=parm_index) #- implied covariance: gamma values gamma_val <- noharm_sirt_implied_cov(Fmat=Fmat, Pmat=Pmat, Psimat=Psimat) @@ -18,14 +21,16 @@ noharm_sirt_optim_function <- function(x, parm_table, parm_index, I, D, gamma_diag <- diag(gamma_val) delta <- 1 + gamma_diag + use_rcpp <- FALSE + #- compute least squares function if (!use_rcpp){ val <- noharm_sirt_optim_function_R( gamma_val=gamma_val, delta=delta, I=I, - wgtm=wgtm, pm=pm, b0.jk=b0.jk, b1.jk=b1.jk, b2.jk=b2.jk, b3.jk=b3.jk ) + wgtm=wgtm, pm=pm, b0.jk=b0.jk, b1.jk=b1.jk, b2.jk=b2.jk, b3.jk=b3.jk) } else { val <- sirt_rcpp_noharm_sirt_optim_fn_rcpp( gamma_val=gamma_val, - delta=delta, I=I, wgtm=wgtm, pm=pm, b0_jk=b0.jk, b1_jk=b1.jk, b2_jk=b2.jk, - b3_jk=b3.jk ) + delta=delta, I=I, wgtm=wgtm, pm=pm, b0_jk=b0.jk, b1_jk=b1.jk, + b2_jk=b2.jk, b3_jk=b3.jk ) } #-- output diff --git a/R/noharm_sirt_optim_gradient.R b/R/noharm_sirt_optim_gradient.R index cbd0e429..82b0e276 100644 --- a/R/noharm_sirt_optim_gradient.R +++ b/R/noharm_sirt_optim_gradient.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_optim_gradient.R -## File Version: 0.463 +## File Version: 0.467 noharm_sirt_optim_gradient <- function(x, parm_table, parm_index, I, D, @@ -7,20 +7,23 @@ noharm_sirt_optim_gradient <- function(x, parm_table, parm_index, I, D, { parm_table <- noharm_sirt_partable_include_par(par=x, parm_table=parm_table) - Fmat <- noharm_sirt_create_parameter_matrices("F", parm_table=parm_table, parm_index=parm_index) - Pmat <- noharm_sirt_create_parameter_matrices("P", parm_table=parm_table, parm_index=parm_index) - Psimat <- noharm_sirt_create_parameter_matrices("Psi", parm_table=parm_table, parm_index=parm_index) - npar <- attr(parm_table, "npar") + Fmat <- noharm_sirt_create_parameter_matrices('F', parm_table=parm_table, + parm_index=parm_index) + Pmat <- noharm_sirt_create_parameter_matrices('P', parm_table=parm_table, + parm_index=parm_index) + Psimat <- noharm_sirt_create_parameter_matrices('Psi', parm_table=parm_table, + parm_index=parm_index) + npar <- attr(parm_table, 'npar') # gamma values (diagonal) gamma_val <- noharm_sirt_implied_cov(Fmat=Fmat, Pmat=Pmat, Psimat=Psimat) FP <- Fmat %*% Pmat - npar <- attr(parm_table, "npar") - NH <- attr(parm_table, "NH") + npar <- attr(parm_table, 'npar') + NH <- attr(parm_table, 'NH') #- extract parameter table with free parameters - parm_table_free <- parm_table[ attr(parm_table, "parm_table_free_index"), ] + parm_table_free <- parm_table[ attr(parm_table, 'parm_table_free_index'), ] #* computations if (use_rcpp){ @@ -29,15 +32,16 @@ noharm_sirt_optim_gradient <- function(x, parm_table, parm_index, I, D, pt_col <- parm_table_free$col - 1 pt_matid <- parm_table_free$matid res <- sirt_rcpp_noharm_sirt_optim_gr_rcpp( gamma_val=gamma_val, NH=NH, - I=I, wgtm=wgtm, pm=pm, b0_jk=b0.jk, b1_jk=b1.jk, b2_jk=b2.jk, b3_jk=b3.jk, npar=npar, - pt_matid=pt_matid, pt_index=pt_index, pt_row=pt_row, - pt_col=pt_col, FP=FP, Fmat=Fmat, Pmat=Pmat, Psimat=Psimat ) + I=I, wgtm=wgtm, pm=pm, b0_jk=b0.jk, b1_jk=b1.jk, b2_jk=b2.jk, + b3_jk=b3.jk, npar=npar, pt_matid=pt_matid, pt_index=pt_index, + pt_row=pt_row, pt_col=pt_col, FP=FP, Fmat=Fmat, Pmat=Pmat, + Psimat=Psimat ) grad0 <- res$grad0 } else { grad0 <- noharm_sirt_optim_gradient_R( parm_table_free=parm_table_free, - Fmat=Fmat, Pmat=Pmat, Psimat=Psimat, FP=FP, npar=npar, NH=NH, I=I, - gamma_val=gamma_val, pm=pm, wgtm=wgtm, b0.jk=b0.jk, b1.jk=b1.jk, b2.jk=b2.jk, - b3.jk=b3.jk ) + Fmat=Fmat, Pmat=Pmat, Psimat=Psimat, FP=FP, npar=npar, NH=NH, + I=I, gamma_val=gamma_val, pm=pm, wgtm=wgtm, b0.jk=b0.jk, + b1.jk=b1.jk, b2.jk=b2.jk, b3.jk=b3.jk ) } #-- output diff --git a/R/noharm_sirt_optim_gradient_R.R b/R/noharm_sirt_optim_gradient_R.R index 6ffc67aa..e581a300 100644 --- a/R/noharm_sirt_optim_gradient_R.R +++ b/R/noharm_sirt_optim_gradient_R.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_optim_gradient_R.R -## File Version: 0.03 +## File Version: 0.042 noharm_sirt_optim_gradient_R <- function(parm_table_free, Fmat, Pmat, Psimat, FP, npar, NH, I, gamma_val, pm, wgtm, b0.jk, b1.jk, b2.jk, b3.jk) @@ -14,15 +14,16 @@ noharm_sirt_optim_gradient_R <- function(parm_table_free, Fmat, Pmat, Psimat, FP delta <- 1+diag(gamma_val) grad_gamma_diag1 <- grad_gamma_diag / delta grad0 <- rep(0, npar) - for (ii in 1:(I-1)){ + for (ii in 1L:(I-1)){ for (jj in (ii+1):I){ if (wgtm[ii,jj] >0 ){ #- compute gradient for item pair grad1 <- noharm_sirt_optim_gradient_R_der_gamma_item_pair( parm_table_free=parm_table_free, Fmat=Fmat, Pmat=Pmat, - Psimat=Psimat, FP=FP, npar=npar, NH=NH, I=I, gamma_val=gamma_val, - grad_gamma_diag1=grad_gamma_diag1, pm=pm, b0.jk=b0.jk, - b1.jk=b1.jk, b2.jk=b2.jk, b3.jk=b3.jk, wgtm=wgtm, ii=ii, jj=jj ) + Psimat=Psimat, FP=FP, npar=npar, NH=NH, I=I, + gamma_val=gamma_val, grad_gamma_diag1=grad_gamma_diag1, + pm=pm, b0.jk=b0.jk, b1.jk=b1.jk, b2.jk=b2.jk, b3.jk=b3.jk, + wgtm=wgtm, ii=ii, jj=jj ) grad0 <- grad0 + grad1 } } diff --git a/R/noharm_sirt_optim_gradient_R_der_gamma_item.R b/R/noharm_sirt_optim_gradient_R_der_gamma_item.R index 14d80faa..55693f3b 100644 --- a/R/noharm_sirt_optim_gradient_R_der_gamma_item.R +++ b/R/noharm_sirt_optim_gradient_R_der_gamma_item.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_optim_gradient_R_der_gamma_item.R -## File Version: 0.05 +## File Version: 0.07 noharm_sirt_optim_gradient_R_der_gamma_item <- function(parm_table_free, Fmat, @@ -7,16 +7,16 @@ noharm_sirt_optim_gradient_R_der_gamma_item <- function(parm_table_free, Fmat, { grad_gamma_diag <- matrix(0, nrow=I, ncol=npar) grad_gamma_diag_bool <- matrix(FALSE, nrow=I, ncol=npar) - for (iii in 1:I){ + for (iii in 1L:I){ grad <- rep(0,npar) grad_bool <- rep(FALSE,npar) - for (hh in 1:NH){ - mat_hh <- parm_table_free[hh,"mat"] - par_index_hh <- parm_table_free[hh,"index"] - row <- parm_table_free[hh,"row"] - col <- parm_table_free[hh,"col"] + for (hh in 1L:NH){ + mat_hh <- parm_table_free[hh,'mat'] + par_index_hh <- parm_table_free[hh,'index'] + row <- parm_table_free[hh,'row'] + col <- parm_table_free[hh,'col'] # F - if (mat_hh=="F"){ + if (mat_hh=='F'){ if (row==iii){ der <- 2*FP[iii,col] grad[par_index_hh] <- grad[par_index_hh] + der @@ -24,7 +24,7 @@ noharm_sirt_optim_gradient_R_der_gamma_item <- function(parm_table_free, Fmat, } } # P - if (mat_hh=="P"){ + if (mat_hh=='P'){ der <- 0 if (row==col){ der <- Fmat[iii,col]^2 @@ -41,6 +41,7 @@ noharm_sirt_optim_gradient_R_der_gamma_item <- function(parm_table_free, Fmat, } #-- output - res <- list(grad_gamma_diag=grad_gamma_diag, grad_gamma_diag_bool=grad_gamma_diag_bool) + res <- list(grad_gamma_diag=grad_gamma_diag, + grad_gamma_diag_bool=grad_gamma_diag_bool) return(res) } diff --git a/R/noharm_sirt_optim_gradient_R_der_gamma_item_pair.R b/R/noharm_sirt_optim_gradient_R_der_gamma_item_pair.R index 320dba1f..bdfdbdb6 100644 --- a/R/noharm_sirt_optim_gradient_R_der_gamma_item_pair.R +++ b/R/noharm_sirt_optim_gradient_R_der_gamma_item_pair.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_optim_gradient_R_der_gamma_item_pair.R -## File Version: 0.18 +## File Version: 0.192 noharm_sirt_optim_gradient_R_der_gamma_item_pair <- function(parm_table_free, Fmat, @@ -8,13 +8,13 @@ noharm_sirt_optim_gradient_R_der_gamma_item_pair <- function(parm_table_free, Fm { grad <- rep(0,npar) if (wgtm[ii,jj]>0){ - for (hh in 1:NH){ - mat_hh <- parm_table_free[hh,"mat"] - par_index_hh <- parm_table_free[hh,"index"] - row <- parm_table_free[hh,"row"] - col <- parm_table_free[hh,"col"] + for (hh in 1L:NH){ + mat_hh <- parm_table_free[hh,'mat'] + par_index_hh <- parm_table_free[hh,'index'] + row <- parm_table_free[hh,'row'] + col <- parm_table_free[hh,'col'] # F - if (mat_hh=="F"){ + if (mat_hh=='F'){ der <- 0 if (row==ii){ der <- FP[jj,col] @@ -26,7 +26,7 @@ noharm_sirt_optim_gradient_R_der_gamma_item_pair <- function(parm_table_free, Fm } } # P - if (mat_hh=="P"){ + if (mat_hh=='P'){ der <- 0 if (row==col){ der <- Fmat[ii,col]*Fmat[jj,col] @@ -37,7 +37,7 @@ noharm_sirt_optim_gradient_R_der_gamma_item_pair <- function(parm_table_free, Fm } } # Psi - if (mat_hh=="Psi"){ + if (mat_hh=='Psi'){ if (row==ii){ if (col==jj){ der <- 1 @@ -65,7 +65,8 @@ noharm_sirt_optim_gradient_R_der_gamma_item_pair <- function(parm_table_free, Fm #-- discrepancy function x_ij <- val - pm_exp <- b0.jk[ii,jj] + b1.jk[ii,jj]*x_ij + b2.jk[ii,jj]*x_ij^2 + b3.jk[ii,jj]*x_ij^3 + pm_exp <- b0.jk[ii,jj] + b1.jk[ii,jj]*x_ij + b2.jk[ii,jj]*x_ij^2 + + b3.jk[ii,jj]*x_ij^3 pm_exp_der <- b1.jk[ii,jj] + 2*b2.jk[ii,jj]*x_ij + 3*b3.jk[ii,jj]*x_ij^2 grad <- pm_exp_der*grad temp1 <- -2*wgtm[ii,jj] * ( pm[ii,jj] - pm_exp ) diff --git a/R/noharm_sirt_partable_extract_par.R b/R/noharm_sirt_partable_extract_par.R index 1a5b6422..7fabc713 100644 --- a/R/noharm_sirt_partable_extract_par.R +++ b/R/noharm_sirt_partable_extract_par.R @@ -1,9 +1,9 @@ ## File Name: noharm_sirt_partable_extract_par.R -## File Version: 0.02 +## File Version: 0.03 noharm_sirt_partable_extract_par <- function(parm_table, col="est") { - extract_index <- attr(parm_table, "extract_index") + extract_index <- attr(parm_table, 'extract_index') x <- parm_table[ extract_index, col] return(x) } diff --git a/R/noharm_sirt_partable_include_par.R b/R/noharm_sirt_partable_include_par.R index 43486639..33ac5c2f 100644 --- a/R/noharm_sirt_partable_include_par.R +++ b/R/noharm_sirt_partable_include_par.R @@ -1,10 +1,10 @@ ## File Name: noharm_sirt_partable_include_par.R -## File Version: 0.01 +## File Version: 0.02 noharm_sirt_partable_include_par <- function(par, parm_table) { - non_fixed <- attr(parm_table, "non_fixed") - include_index <- attr(parm_table, "include_index") + non_fixed <- attr(parm_table, 'non_fixed') + include_index <- attr(parm_table, 'include_index') parm_table$est[ non_fixed ] <- par[ include_index ] return(parm_table) } diff --git a/R/noharm_sirt_preproc.R b/R/noharm_sirt_preproc.R index d9cb0f90..d5e536c4 100644 --- a/R/noharm_sirt_preproc.R +++ b/R/noharm_sirt_preproc.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_preproc.R -## File Version: 0.398 +## File Version: 0.409 #**** data preprocessing noharm.sirt @@ -58,23 +58,23 @@ noharm_sirt_preproc <- function( dat, pm, N, weights, Fpatt, Fval, # CFA or EFA? if ( is.null(dimensions) ){ - model.type <- "CFA" + model.type <- 'CFA' modtype <- 3 # 3 - multidimensional CFA } else { - model.type <- "EFA" + model.type <- 'EFA' modtype <- 2 # 2 - multidimensional EFA D <- dimensions Pval <- diag(D) Ppatt <- 0*diag(D) Fpatt <- matrix(1,nrow=I,ncol=D) if (D>1){ - for (dd in 2:D){ - Fpatt[dd,1:(dd-1)] <- 0 + for (dd in 2L:D){ + Fpatt[dd,1L:(dd-1)] <- 0 } } Fval <- .5*(Fpatt>0) if ( D==1 ){ # 1 dimension - model.type <- "CFA" + model.type <- 'CFA' modtype <- 3 } } @@ -93,13 +93,14 @@ noharm_sirt_preproc <- function( dat, pm, N, weights, Fpatt, Fval, wgtm.default <- TRUE } diag(wgtm) <- 0 + wgtm <- ( wgtm + t(wgtm) ) / 2 wgtm <- wgtm * ( ss > 0 ) res$wgtm <- wgtm res$sumwgtm <- ( sum( wgtm > 0 ) - sum( diag(wgtm) > 0 ) ) / 2 #*** column names D <- ncol(Ppatt) - cn <- paste0("F",1:D) + cn <- paste0('F',1L:D) if (is.null(colnames(Fpatt) ) ){ colnames(Fpatt) <- cn } @@ -119,14 +120,15 @@ noharm_sirt_preproc <- function( dat, pm, N, weights, Fpatt, Fval, # F parm_table <- noharm_sirt_preproc_parameter_table_matrix(pattmat=Fpatt, valmat=Fval, - patt_id=1, patt_label="F", minval=0, symm=FALSE) + patt_id=1, patt_label='F', minval=0, symm=FALSE) # P parm1 <- noharm_sirt_preproc_parameter_table_matrix(pattmat=Ppatt, valmat=Pval, - patt_id=2, patt_label="P", minval=max(parm_table$index, na.rm=TRUE), symm=TRUE) + patt_id=2, patt_label='P', minval=sirt_max(parm_table$index), symm=TRUE) parm_table <- rbind(parm_table, parm1) + # Psi parm1 <- noharm_sirt_preproc_parameter_table_matrix(pattmat=Psipatt, valmat=Psival, - patt_id=3, patt_label="Psi", minval=max(parm_table$index, na.rm=TRUE), symm=TRUE) + patt_id=3, patt_label='Psi', minval=sirt_max(parm_table$index), symm=TRUE) parm_table <- rbind(parm_table, parm1) parm_table <- parm_table[ parm_table$nonnull_par==1, ] rownames(parm_table) <- NULL @@ -135,7 +137,7 @@ noharm_sirt_preproc <- function( dat, pm, N, weights, Fpatt, Fval, # indices ip <- parm_table$index ip[duplicated(ip)] <- NA - extract_index <- match(1:npar, ip) + extract_index <- match(1L:npar, ip) extract_index <- intersect( which( ! is.na( parm_table$index ) ), which( ! duplicated( parm_table$index ) ) ) parm_table$est <- parm_table$starts @@ -144,44 +146,43 @@ noharm_sirt_preproc <- function( dat, pm, N, weights, Fpatt, Fval, ind <- NULL if (pos.variance){ - ind1 <- which((parm_table$mat=="P") & (parm_table$row==parm_table$col )) + ind1 <- which((parm_table$mat=='P') & (parm_table$row==parm_table$col )) ind <- union(ind, ind1) } if (pos.loading){ - ind1 <- which((parm_table$mat=="F") ) + ind1 <- which((parm_table$mat=='F') ) ind <- union(ind, ind1) } if (pos.residcorr){ - ind1 <- which((parm_table$mat=="Psi") ) + ind1 <- which((parm_table$mat=='Psi') ) ind <- union(ind, ind1) } - parm_table[ind, "lower"] <- 0 - parm_table[ is.na(parm_table$index), "lower"] <- NA - + parm_table[ind, 'lower'] <- 0 + parm_table[ is.na(parm_table$index), 'lower'] <- NA non_fixed <- ! parm_table$fixed include_index <- parm_table$index[ non_fixed ] parm_table$nonnull_par <- NULL - attr(parm_table, "extract_index") <- extract_index - attr(parm_table, "non_fixed") <- non_fixed - attr(parm_table, "include_index") <- include_index - attr(parm_table, "npar") <- npar - attr(parm_table, "NH") <- sum(non_fixed) - attr(parm_table, "est_par_index") <- which(parm_table$est_par==1) - attr(parm_table, "parm_table_free_index") <- which(parm_table$fixed==0) + attr(parm_table, 'extract_index') <- extract_index + attr(parm_table, 'non_fixed') <- non_fixed + attr(parm_table, 'include_index') <- include_index + attr(parm_table, 'npar') <- npar + attr(parm_table, 'NH') <- sum(non_fixed) + attr(parm_table, 'est_par_index') <- which(parm_table$est_par==1) + attr(parm_table, 'parm_table_free_index') <- which(parm_table$fixed==0) parm_index <- list() - for (mat_label in c("F", "P", "Psi") ){ + for (mat_label in c('F', 'P', 'Psi') ){ ind_mat <- which(parm_table$mat==mat_label) parm_index[[ mat_label ]] <- list() - parm_index[[ mat_label ]][[ "row_parm_table" ]] <- ind_mat - parm_index[[ mat_label ]][[ "entries" ]] <- parm_table[ ind_mat, c("row","col")] - parm_index[[ mat_label ]][[ "len" ]] <- length(ind_mat) + parm_index[[ mat_label ]][[ 'row_parm_table' ]] <- ind_mat + parm_index[[ mat_label ]][[ 'entries' ]] <- parm_table[ ind_mat, c('row','col')] + parm_index[[ mat_label ]][[ 'len' ]] <- length(ind_mat) nrow <- I ncol <- D - if (mat_label=="P"){ nrow <- D} - if (mat_label=="Psi"){ ncol <- I} - parm_index[[ mat_label ]][["nrow"]] <- nrow - parm_index[[ mat_label ]][["ncol"]] <- ncol + if (mat_label=='P'){ nrow <- D} + if (mat_label=='Psi'){ ncol <- I} + parm_index[[ mat_label ]][['nrow']] <- nrow + parm_index[[ mat_label ]][['ncol']] <- ncol } res$parm_table <- parm_table diff --git a/R/noharm_sirt_preproc_parameter_table_matrix.R b/R/noharm_sirt_preproc_parameter_table_matrix.R index b3a69244..cd24e904 100644 --- a/R/noharm_sirt_preproc_parameter_table_matrix.R +++ b/R/noharm_sirt_preproc_parameter_table_matrix.R @@ -1,15 +1,18 @@ ## File Name: noharm_sirt_preproc_parameter_table_matrix.R -## File Version: 0.09 +## File Version: 0.105 noharm_sirt_preproc_parameter_table_matrix <- function(pattmat, valmat, patt_id, patt_label, minval, symm=FALSE) { + if (!is.finite(minval)){ + minval <- 0 + } pattmat <- noharm_sirt_preproc_pattern_matrix(pattmat=pattmat, minval=minval, symm=symm) I <- nrow(pattmat) D <- ncol(pattmat) - parm1 <- data.frame(mat=patt_label, matid=patt_id, row=rep(1:I,D), - col=rep(1:D, each=I) ) + parm1 <- data.frame(mat=patt_label, matid=patt_id, row=rep(1L:I,D), + col=rep(1L:D, each=I) ) parm1$index <- as.vector(pattmat) parm1$starts <- as.vector(valmat) parm1$est_par <- 1 - is.na(parm1$index) diff --git a/R/noharm_sirt_preproc_pattern_matrix.R b/R/noharm_sirt_preproc_pattern_matrix.R index 484ac5ae..317dba02 100644 --- a/R/noharm_sirt_preproc_pattern_matrix.R +++ b/R/noharm_sirt_preproc_pattern_matrix.R @@ -1,5 +1,5 @@ ## File Name: noharm_sirt_preproc_pattern_matrix.R -## File Version: 0.17 +## File Version: 0.182 noharm_sirt_preproc_pattern_matrix <- function(pattmat, minval=0, symm=FALSE) { @@ -15,7 +15,7 @@ noharm_sirt_preproc_pattern_matrix <- function(pattmat, minval=0, symm=FALSE) ind <- ( pattmat > 0 ) & ( pattmat <=1 ) if (sum(ind) > 0 ){ DI <- prod(dim(pattmat)) - v1 <- matrix( 1:DI, nrow=I ) + v1 <- matrix( 1L:DI, nrow=I ) if (symm){ v1 <- sirt_matrix_lower_to_upper(x=v1) } diff --git a/R/sirt_max.R b/R/sirt_max.R new file mode 100644 index 00000000..7d076db5 --- /dev/null +++ b/R/sirt_max.R @@ -0,0 +1,13 @@ +## File Name: sirt_max.R +## File Version: 0.02 + +sirt_max <- function(x, value=0) +{ + y <- x[ ! is.na(x) ] + if (length(y)>0){ + z <- max(x, na.rm=TRUE) + } else { + z <- 0 + } + return(z) +} diff --git a/R/write.format2.R b/R/write.format2.R index dce9d7bf..ac0bd541 100644 --- a/R/write.format2.R +++ b/R/write.format2.R @@ -1,5 +1,5 @@ ## File Name: write.format2.R -## File Version: 1.132 +## File Version: 1.133 @@ -16,7 +16,7 @@ write.format2 <- function( vec1, ff, fr ) blank.vv <- paste( rep( ' ', ff+1 ), collapse='' ) d.vv <- paste( substring( blank.vv, 1, ff+1 - nchar(d.vv) ), d.vv, sep='') g.vv <- grep('NA',d.vv) - d.vv[ g.vv ] <- ifelse( ff > 1, gsub( 'NA', ' .', d.vv[g.vv] ), + d.vv[ g.vv ] <- ifelse( ff > 1, gsub( 'NA', ' .', d.vv[g.vv] ), gsub( 'NA', '.', d.vv[g.vv] ) ) vec2 <- substring( d.vv, 1, ff ) vec2 diff --git a/README.md b/README.md index 582848f4..181e4e7c 100644 --- 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` 4.2-52 (2024-04-15) +#### GitHub version `sirt` 4.2-57 (2024-04-20) -[![](https://img.shields.io/badge/github%20version-4.2--52-orange.svg)](https://github.com/alexanderrobitzsch/sirt)   +[![](https://img.shields.io/badge/github%20version-4.2--57-orange.svg)](https://github.com/alexanderrobitzsch/sirt)   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 index 55c17440..f962a0e9 100644 --- a/docs/404.html +++ b/docs/404.html @@ -24,7 +24,7 @@ sirt - 4.2-52 + 4.2-57