├── .gitattributes ├── DESCRIPTION ├── NAMESPACE ├── R ├── IRT.anova.sirt.R ├── IRT.expectedCounts.mirt.R ├── IRT.expectedCounts_sirt.R ├── IRT.factor.scores.sirt.R ├── IRT.factor.scores.xxirt.R ├── IRT.irfprob.mirt.R ├── IRT.irfprob.sirt.R ├── IRT.likelihood.mirt.R ├── IRT.likelihood_sirt.R ├── IRT.mle.R ├── IRT.modelfit.sirt.R ├── IRT.posterior.mirt.R ├── IRT.posterior_sirt.R ├── L0_polish.R ├── L0_polish_one_iteration.R ├── L1_polish.R ├── L2_polish.R ├── Probtrace_sirt.R ├── Q3.R ├── Q3.testlet.R ├── R2conquest.R ├── R2noharm-utility.R ├── R2noharm.EAP.R ├── R2noharm.R ├── R2noharm.jackknife.R ├── RcppExports.R ├── Rhat_sirt.R ├── amh_plot.R ├── anova_sirt.R ├── attach.environment.sirt.R ├── automatic.recode.R ├── bounds_parameters.R ├── brm.irf.R ├── brm.sim.R ├── btm.R ├── btm_fit_combine_tables.R ├── btm_fit_statistics.R ├── btm_sim.R ├── btm_trim_increment.R ├── categorize.R ├── ccov.np.R ├── ccov_np_compute_ccov_sum_score.R ├── ccov_np_print_progress.R ├── ccov_np_regression.R ├── ccov_np_score_density.R ├── cfa_meas_inv.R ├── class.accuracy.rasch.R ├── coef.rasch.evm.pcm.R ├── conf.detect.R ├── confint.xxirt.R ├── create.ccov.R ├── data.prep.R ├── data.recode.sirt.R ├── data.wide2long.R ├── decategorize.R ├── detect.index.R ├── dexppow.R ├── diag2.R ├── dif.logisticregression.R ├── dif.strata.variance.R ├── dif.variance.R ├── dimproper.R ├── dirichlet.mle.R ├── dirichlet.simul.R ├── dm_m_est.R ├── dmlavaan.R ├── dmlavaan_add_suffix_column_names.R ├── dmlavaan_adjust_numdiff_h.R ├── dmlavaan_create_coef.R ├── dmlavaan_est_model.R ├── dmlavaan_est_model_bread_matrix_score_derivatives.R ├── dmlavaan_est_model_include_partable.R ├── dmlavaan_est_model_parameterTable.R ├── dmlavaan_extract_logLik_casewise.R ├── dmlavaan_joint_parameterTable.R ├── dmlavaan_joint_parameterTable_merge_table.R ├── dmlavaan_remove_duplicated_columns.R ├── dmlavaan_sandwich_formula.R ├── dmlavaan_se_bootstrap.R ├── dmlavaan_se_bootstrap_create_est_boot.R ├── dmlavaan_se_sandwich.R ├── eigenvalues.manymatrices.R ├── equating.rasch.R ├── equating.rasch.jackknife.R ├── expl.detect.R ├── f1d.irt.R ├── fit.adisop.R ├── fit.gradedresponse.R ├── fit.gradedresponse_alg.R ├── fit.isop.R ├── fit.logistic.R ├── fit.logistic_alg.R ├── fuzcluster.R ├── fuzcluster_estimate.R ├── fuzdiscr.R ├── genlogis.moments.R ├── ginverse_sym.R ├── gom.em.R ├── gom.jml.R ├── gom.jml_alg.R ├── gom_em_calc_probs.R ├── gom_em_calc_theta.R ├── gom_em_compute_total_loglikelihood.R ├── gom_em_est_b.R ├── gom_em_est_covariance.R ├── gom_em_est_lambda.R ├── gom_em_extract_lambda_matrix.R ├── gom_em_ic.R ├── gom_em_inits_lambda.R ├── gom_em_item_parameters.R ├── gom_em_loglike_calc_probs.R ├── gom_em_loglike_grad.R ├── gom_em_loglike_opt_fun.R ├── gom_em_loglike_parameter_conversion.R ├── gom_em_normal_to_membership_scores.R ├── gom_em_numdiff_index.R ├── gom_em_prepare_data.R ├── gom_em_prepare_lambda_index.R ├── greenyang.reliability.R ├── hard_thresholding.R ├── invariance.alignment.R ├── invariance_alignment_aligned_parameters_summary.R ├── invariance_alignment_calc_corr.R ├── invariance_alignment_center_parameters.R ├── invariance_alignment_cfa_config.R ├── invariance_alignment_cfa_config_estimate.R ├── invariance_alignment_cfa_config_estimate_define_lavaan_model.R ├── invariance_alignment_choose_fixed.R ├── invariance_alignment_constraints.R ├── invariance_alignment_constraints_summary_print_item_summary.R ├── invariance_alignment_define_parameters.R ├── invariance_alignment_find_parameter_constraints.R ├── invariance_alignment_proc_labels.R ├── invariance_alignment_process_parameters.R ├── invariance_alignment_simulate.R ├── invariance_alignment_summary_optimization.R ├── invgamma2.R ├── isop.dich.R ├── isop.poly.R ├── isop.scoring.R ├── isop.test.R ├── isop_tests_cpp.R ├── latent.regression.em.normal.R ├── latent.regression.em.raschtype.R ├── lavaan2mirt.R ├── lavaan_object_adjust_sample_size.R ├── lavaanify.sirt.R ├── lc.2raters.R ├── lc.2raters.aux.R ├── likelihood_adjustment.R ├── likelihood_adjustment_aux.R ├── likelihood_moments.R ├── linking.haberman.R ├── linking.haberman.lq.R ├── linking.haebara.R ├── linking.robust.R ├── linking_2groups.R ├── linking_2groups_haebara_fun.R ├── linking_2groups_haebara_grad.R ├── linking_2groups_numerical_gradient.R ├── linking_2groups_power_loss.R ├── linking_2groups_stocking_lord_fun.R ├── linking_2groups_stocking_lord_grad.R ├── linking_2groups_vector_with_names.R ├── linking_haberman_als.R ├── linking_haberman_als_residual_weights.R ├── linking_haberman_als_vcov.R ├── linking_haberman_bisquare_weight.R ├── linking_haberman_compute_lts_mean.R ├── linking_haberman_compute_median.R ├── linking_haberman_huber_weight.R ├── linking_haberman_itempars_convert.R ├── linking_haberman_itempars_convert_process_matrices.R ├── linking_haberman_itempars_prepare.R ├── linking_haberman_lq_pw_create_design.R ├── linking_haberman_lq_pw_le.R ├── linking_haberman_lq_pw_le_arrange_Vgamma.R ├── linking_haberman_lq_pw_le_grad.R ├── linking_haberman_lq_pw_le_hess_delta.R ├── linking_haberman_lq_pw_le_hess_gamma.R ├── linking_haberman_remove_missings_vector.R ├── linking_haberman_summary_estimation_information.R ├── linking_haberman_vcov_transformation.R ├── linking_haebara_gradient_function_R.R ├── linking_haebara_optim_function_R.R ├── linking_haebara_summary_optimization.R ├── linking_proc_itempars.R ├── locpolycor.R ├── locpolycor_est_polycor_itempair.R ├── locpolycor_est_polycor_opt_fun.R ├── locpolycor_est_thresh_grad_fun.R ├── locpolycor_est_thresh_item.R ├── locpolycor_est_thresh_opt_fun.R ├── logLik_sirt.R ├── lq_fit.R ├── lq_fit_estimate_power.R ├── lsdm.R ├── lsdm_est_logist_2pl.R ├── lsdm_est_logist_quant.R ├── lsdm_est_logist_rasch.R ├── lsdm_extract_probquantile.R ├── lsdm_irf_distance_mad.R ├── lsem.MGM.stepfunctions.R ├── lsem.bootstrap.R ├── lsem.estimate.R ├── lsem.permutationTest.R ├── lsem.test.R ├── lsem_aggregate_statistics.R ├── lsem_bootstrap_draw_bootstrap_sample.R ├── lsem_bootstrap_inference.R ├── lsem_bootstrap_postproc_output.R ├── lsem_bootstrap_print_progress.R ├── lsem_bootstrap_print_start.R ├── lsem_define_lavaan_est_fun.R ├── lsem_estimate_proc_args.R ├── lsem_fit_initial_model.R ├── lsem_fit_initial_model_sufficient_statistics.R ├── lsem_fitsem.R ├── lsem_fitsem_compute_sufficient_statistics.R ├── lsem_fitsem_joint_estimation.R ├── lsem_fitsem_joint_estimation_partable.R ├── lsem_fitsem_joint_estimation_partable_id.R ├── lsem_fitsem_joint_estimation_prepare_partable.R ├── lsem_fitsem_joint_estimation_prepare_partable_include_group_label.R ├── lsem_fitsem_raw_data_define_pseudo_weights.R ├── lsem_fitsem_raw_data_lavaan.R ├── lsem_fitsem_raw_data_lavaan_survey.R ├── lsem_fitsem_sufficient_statistics_lavaan.R ├── lsem_fitsem_verbose_progress.R ├── lsem_fitsem_verbose_start.R ├── lsem_group_moderator.R ├── lsem_kernel_weights.R ├── lsem_lavaan_fit_measures.R ├── lsem_lavaan_modify_lavaan_object_test.R ├── lsem_local_weights.R ├── lsem_parameter_summary.R ├── lsem_permutationTest_collect_output.R ├── lsem_permutationTest_define_exported_objects.R ├── lsem_residualize.R ├── lsem_spline.R ├── lsem_wald_test.R ├── lsem_weighted_cov.R ├── lsem_weighted_mean.R ├── lsem_wtdSD.R ├── m_est.R ├── m_est_add_increment.R ├── mad_normalized.R ├── marginal.truescore.reliability.R ├── matrix_functions.R ├── matrixfunctions_sirt.R ├── mcmc.2pno.R ├── mcmc.2pno.ml.R ├── mcmc.2pno.ml_alg.R ├── mcmc.2pno.ml_output.R ├── mcmc.2pno_alg.R ├── mcmc.2pnoh.R ├── mcmc.2pnoh_alg.R ├── mcmc.3pno.testlet.R ├── mcmc.3pno.testlet_alg.R ├── mcmc.3pno.testlet_output.R ├── mcmc.aux.R ├── mcmc.list.descriptives.R ├── mcmc_3pno_testlet_draw_itempars.R ├── mcmc_Rhat.R ├── mcmc_WaldTest.R ├── mcmc_as_formula.R ├── mcmc_coef.R ├── mcmc_confint.R ├── mcmc_derivedPars.R ├── mcmc_extract_samples_first_chain.R ├── mcmc_plot.R ├── mcmc_rename_define_symbols.R ├── mcmc_rename_helper.R ├── mcmc_rename_parameter_names.R ├── mcmc_rename_undo_parameter_names.R ├── mcmc_summary.R ├── mcmc_summary_print_information_criteria.R ├── mcmc_vcov.R ├── mcmcirt_compute_mh.R ├── mcmcirt_create_partable_Theta.R ├── mcmclist2coda.R ├── md.pattern.sirt.R ├── meas_inv_cfa_modify_partable.R ├── meas_inv_cfa_proc_partable.R ├── meas_inv_compute_lavaan_parnames.R ├── mgsem.R ├── mgsem_L0_approx_ot.R ├── mgsem_L0_penalty.R ├── mgsem_add_increment.R ├── mgsem_add_list_entries.R ├── mgsem_bdiag.R ├── mgsem_cd_opt.R ├── mgsem_cda_opt_evaluate_penalties.R ├── mgsem_coef2partable.R ├── mgsem_compute_model_implied_moments.R ├── mgsem_create_index.R ├── mgsem_differ_from_zero.R ├── mgsem_duplication_matrix.R ├── mgsem_eval_lp_penalty_matrix.R ├── mgsem_eval_lp_penalty_vector.R ├── mgsem_evaluate_penalties.R ├── mgsem_evaluate_penalties_evaluate_entry.R ├── mgsem_evaluate_penalties_evaluate_entry_fun_eval.R ├── mgsem_ginv.R ├── mgsem_grad_fun.R ├── mgsem_grad_fun_numeric_approx.R ├── mgsem_ic.R ├── mgsem_list_elements_est_total_implied.R ├── mgsem_loglike_data.R ├── mgsem_loglike_suffstat.R ├── mgsem_loglike_suffstat_derivative.R ├── mgsem_loglike_suffstat_derivative_parameter.R ├── mgsem_loss_function_suffstat.R ├── mgsem_loss_function_suffstat_derivative_parameter.R ├── mgsem_modify_model.R ├── mgsem_modify_suffstat.R ├── mgsem_moments_derivative_parameter.R ├── mgsem_numerical_gradient.R ├── mgsem_observed_information.R ├── mgsem_opt_fun.R ├── mgsem_output_proc_casewise_likelihood.R ├── mgsem_output_proc_residuals.R ├── mgsem_partable2coef.R ├── mgsem_partable2model.R ├── mgsem_power_fun_differentiable_approx.R ├── mgsem_proc_data.R ├── mgsem_proc_model.R ├── mgsem_proc_model_add_specs.R ├── mgsem_proc_model_add_specs_all.R ├── mgsem_proc_model_difflp_information.R ├── mgsem_proc_model_extract_dimension.R ├── mgsem_proc_model_include_missing_entries.R ├── mgsem_proc_model_is_B.R ├── mgsem_proc_model_partable_define_index.R ├── mgsem_proc_model_single_group.R ├── mgsem_proc_model_update_penalties_matrix.R ├── mgsem_proc_suffstat.R ├── mgsem_proc_technical.R ├── mgsem_scad_penalty.R ├── mgsem_smoothic_penalty.R ├── mgsem_sqrt_diag.R ├── mgsem_suffstat_covariance_matrix.R ├── mgsem_test_fun.R ├── mgsem_update_list_entries.R ├── mgsem_vcov_me.R ├── mgsem_vec.R ├── mgsem_vech.R ├── mi_inv_lavaan_modification_indices.R ├── mirt.model.vars.R ├── mirt.specify.partable.R ├── mirt.wrapper.calc.counts.R ├── mirt.wrapper.coef.R ├── mirt.wrapper.fscores.R ├── mirt.wrapper.itemplot.R ├── mirt.wrapper.posterior.R ├── mirt_prodterms.R ├── mirt_summary.R ├── mle.pcm.group.R ├── mle.rasch.R ├── mle.reliability.R ├── mml_calc_like.R ├── mml_raschtype_counts.R ├── modelfit.cor.R ├── modelfit.cor.poly.R ├── modelfit.sirt.R ├── monoreg.colwise.R ├── monoreg.rowwise.R ├── move_variables_df.R ├── nedelsky.irf.R ├── nedelsky.latresp.R ├── nedelsky.sim.R ├── noharm.sirt.R ├── noharm_sirt_compute_chi_square_statistics.R ├── noharm_sirt_compute_final_constants.R ├── noharm_sirt_create_parameter_matrices.R ├── noharm_sirt_efa_rotated_solution.R ├── noharm_sirt_est_residuals.R ├── noharm_sirt_implied_cov.R ├── noharm_sirt_number_estimated_parameters.R ├── noharm_sirt_optim_function.R ├── noharm_sirt_optim_function_R.R ├── noharm_sirt_optim_gradient.R ├── noharm_sirt_optim_gradient_R.R ├── noharm_sirt_optim_gradient_R_der_gamma_item.R ├── noharm_sirt_optim_gradient_R_der_gamma_item_pair.R ├── noharm_sirt_outer_coefs.R ├── noharm_sirt_partable_extract_par.R ├── noharm_sirt_partable_include_par.R ├── noharm_sirt_preproc.R ├── noharm_sirt_preproc_parameter_table_matrix.R ├── noharm_sirt_preproc_pattern_matrix.R ├── normal2.cw.R ├── np.dich.R ├── nr.numdiff.R ├── package_version_date.R ├── parmsummary_extend.R ├── pbivnorm2.R ├── pcm.conversion.R ├── pcm.fit.R ├── penalty_D1_abs.R ├── penalty_D1_mcp.R ├── penalty_D1_scad.R ├── personfit.R ├── personfit.stat.R ├── pgenlogis.R ├── plausible.values.raschtype.R ├── plot.isop.R ├── plot.linking.robust.R ├── plot.lsdm.R ├── plot.lsem.R ├── plot.lsem.permutationTest.R ├── plot.mcmc.sirt.R ├── plot.rasch.mml.R ├── plot.rm.sdt.R ├── polychoric2.R ├── pow.R ├── predict.btm.R ├── predict_scale_group_means.R ├── print.xxirt.R ├── print_digits.R ├── prior_extract_density.R ├── prior_model_pars_CleanString.R ├── prior_model_parse.R ├── prmse.subscores.R ├── prob.guttman.R ├── prob_genlogis_4pl.R ├── prob_raschtype_genlogis.R ├── qmc.nodes.R ├── rasch.conquest.R ├── rasch.copula.R ├── rasch.copula2.R ├── rasch.copula2_aux.R ├── rasch.copula3.R ├── rasch.copula3.covariance.R ├── rasch.copula3_aux.R ├── rasch.evm.pcm.R ├── rasch.jml.R ├── rasch.jml.biascorr.R ├── rasch.mirtlc.R ├── rasch.mml.npirt.R ├── rasch.mml.ramsay.R ├── rasch.mml.raschtype.R ├── rasch.mml2.R ├── rasch.pairwise.R ├── rasch.pairwise.itemcluster.R ├── rasch.pml.R ├── rasch.pml2.R ├── rasch.pml2_aux.R ├── rasch.pml3.R ├── rasch.pml3_aux.R ├── rasch.pml_aux.R ├── rasch.prox.R ├── rasch.va.R ├── rasch_evm_pcm_dif.R ├── rasch_jml_centeritems.R ├── rasch_jml_centerpersons.R ├── rasch_jml_emp_discrim.R ├── rasch_jml_itemfit.R ├── rasch_jml_person_parameters_summary.R ├── rasch_jml_update_b.R ├── rasch_mirtlc_est_a.R ├── rasch_mirtlc_estep_lc.R ├── rasch_mirtlc_estep_mlc1.R ├── rasch_mirtlc_mstep_lc.R ├── rasch_mirtlc_mstep_mlc1.R ├── rasch_mml2_calc_prob.R ├── rasch_mml2_calcprob_missing1.R ├── rasch_mml2_create_theta_k.R ├── rasch_mml2_difference_quotient.R ├── rasch_mml2_estep_missing1.R ├── rasch_mml2_estep_raschtype.R ├── rasch_mml2_estep_raschtype_mirt.R ├── rasch_mml2_impute_data.R ├── rasch_mml2_modify_list_element.R ├── rasch_mml2_mstep_calc_likelihood.R ├── rasch_mml2_mstep_calc_loglike.R ├── rasch_mml2_mstep_missing1.R ├── rasch_mml2_mstep_one_step.R ├── rasch_mml2_mstep_raschtype.R ├── rasch_mml2_numdiff_index.R ├── rasch_mml2_prior_information.R ├── rasch_mml2_prior_information_generate_string.R ├── rasch_mml2_prob_genlogis_4pl_evaluate.R ├── rasch_mml2_raschtype_mstep_parameter_group.R ├── rasch_mml2_raschtype_mstep_parameter_group_evaluate_prior.R ├── rasch_mml2_rmsd.R ├── rasch_pairwise_compute_eps.R ├── rasch_pairwise_iterations.R ├── rasch_pairwise_optimize.R ├── rasch_pairwise_optimize_opt_fun_terms.R ├── rasch_pairwise_optimize_opt_fun_terms2.R ├── rasch_pairwise_zerosum.R ├── read.fwf2.R ├── regpolca.R ├── regpolca_define_customItems.R ├── regpolca_grouped_norm.R ├── regpolca_penalty_fun.R ├── regpolca_penalty_fun_value_grouped.R ├── regpolca_penalty_fun_value_nongrouped.R ├── regpolca_postproc_count_regularized_parameters.R ├── regpolca_postproc_ic.R ├── regpolca_postproc_irf.R ├── regpolca_postproc_prob_Theta.R ├── regpolca_proc_data.R ├── regpolca_run_xxirt_random_starts.R ├── reliability.nonlinear.sem.R ├── resp_groupwise.R ├── rexppow.R ├── rm.facets.R ├── rm.sdt.R ├── rm_calclike.R ├── rm_center_vector.R ├── rm_determine_fixed_tau_parameters.R ├── rm_eap_reliability.R ├── rm_facets_calc_loglikelihood.R ├── rm_facets_calcprobs.R ├── rm_facets_center_value.R ├── rm_facets_center_value_aggregate.R ├── rm_facets_est_a_item.R ├── rm_facets_est_a_rater.R ├── rm_facets_est_b_rater.R ├── rm_facets_est_tau_item.R ├── rm_facets_ic.R ├── rm_facets_itempar_expanded.R ├── rm_facets_pem_acceleration.R ├── rm_facets_pem_inits.R ├── rm_facets_postproc_person.R ├── rm_facets_postproc_rater_parameters.R ├── rm_facets_pp_mle.R ├── rm_facets_pp_mle_calc_ll.R ├── rm_facets_pp_mle_calc_ll_theta.R ├── rm_facets_pp_mle_calc_pcm.R ├── rm_facets_print_progress.R ├── rm_facets_print_progress_deviance.R ├── rm_facets_print_progress_parameter.R ├── rm_facets_print_progress_trait_distribution.R ├── rm_facets_string_part_extract.R ├── rm_grouped_expected_likelihood.R ├── rm_ic_criteria.R ├── rm_numdiff_discrete_differences.R ├── rm_numdiff_index.R ├── rm_numdiff_trim_increment.R ├── rm_pcm_calcprobs.R ├── rm_posterior.R ├── rm_proc_create_pseudoraters.R ├── rm_proc_data.R ├── rm_proc_fixed_values_reference_rater.R ├── rm_sdt_calc_expected_likelihood_item.R ├── rm_sdt_calc_gradient_likelihood_item.R ├── rm_sdt_calc_gradient_likelihood_item_llgrad.R ├── rm_sdt_calc_gradient_likelihood_item_llgrad2.R ├── rm_sdt_calc_probs_gpcm.R ├── rm_sdt_calc_probs_gpcm_rcpp.R ├── rm_sdt_calc_probs_grm_item_rcpp.R ├── rm_sdt_calc_probs_grm_rcpp.R ├── rm_sdt_create_parm_index_modify_elements.R ├── rm_sdt_create_parm_index_rater.R ├── rm_sdt_create_partable.R ├── rm_sdt_create_partable_define_pargroups.R ├── rm_sdt_create_partable_include_fixed_item_category_parameters.R ├── rm_sdt_create_partable_include_index.R ├── rm_sdt_create_partable_include_priors.R ├── rm_sdt_create_partable_pargroup_indices.R ├── rm_sdt_evaluate_prior.R ├── rm_sdt_evaluate_prior_derivative.R ├── rm_sdt_extract_par_from_partable.R ├── rm_sdt_extract_par_from_partable_add_increment.R ├── rm_sdt_fill_init_partable.R ├── rm_sdt_fill_init_partables.R ├── rm_sdt_fill_par_to_partable.R ├── rm_sdt_mstep_include_probs_args.R ├── rm_sdt_mstep_item_function_gradient.R ├── rm_sdt_mstep_item_function_value.R ├── rm_sdt_mstep_numdiff_diffindex.R ├── rm_sdt_mstep_rater_function_gradient.R ├── rm_sdt_mstep_rater_function_value.R ├── rm_sdt_mstep_type_function_gradient.R ├── rm_sdt_mstep_type_function_value.R ├── rm_sdt_pem_inits.R ├── rm_sdt_postproc_ic.R ├── rm_sdt_prepare_diffindex.R ├── rm_sdt_print_progress.R ├── rm_smooth_distribution.R ├── rm_squeeze.R ├── rm_summary_information_criteria.R ├── rm_summary_information_criteria_print_one_criterium.R ├── rm_summary_trait_distribution.R ├── rm_trim_increments_mstep.R ├── rmvn.R ├── rowcolnames.R ├── ruvn.R ├── scale_group_means.R ├── sia.sirt.R ├── sia_sirt_remove_transitive.R ├── sim.rasch.dep.R ├── sim.raschtype.R ├── sirt_EAP.R ├── sirt_MAP.R ├── sirt_Sapply.R ├── sirt_abs_smooth.R ├── sirt_add_increment.R ├── sirt_add_list_elements.R ├── sirt_add_names.R ├── sirt_add_pos.R ├── sirt_antifisherz.R ├── sirt_attach_list_elements.R ├── sirt_colMaxs.R ├── sirt_colMeans.R ├── sirt_colMedians.R ├── sirt_colMins.R ├── sirt_colSDs.R ├── sirt_csink.R ├── sirt_define_eps_sequence.R ├── sirt_define_vector.R ├── sirt_digamma1.R ├── sirt_display_function.R ├── sirt_dmvnorm.R ├── sirt_dmvnorm_discrete.R ├── sirt_dnorm.R ├── sirt_dnorm_discrete.R ├── sirt_eigenvalues.R ├── sirt_fisherz.R ├── sirt_format_numb.R ├── sirt_import_MASS_ginv.R ├── sirt_import_coda_as.mcmc.list.R ├── sirt_import_coda_effectiveSize.R ├── sirt_import_coda_mcmc.R ├── sirt_import_function_value.R ├── sirt_import_lavaan_cfa.R ├── sirt_import_lavaan_fitMeasures.R ├── sirt_import_lavaan_lavaanify.R ├── sirt_import_lavaan_parameterEstimates.R ├── sirt_import_lavaan_parameterTable.R ├── sirt_import_lavaan_standardizedSolution.R ├── sirt_import_psych_cor.smooth.R ├── sirt_import_psych_fa.R ├── sirt_import_psych_omega.R ├── sirt_is_data.R ├── sirt_lavaan_partable_parnames.R ├── sirt_logdet.R ├── sirt_logit_to_probs.R ├── sirt_matrix2.R ├── sirt_matrix_lower_to_upper.R ├── sirt_matrix_names.R ├── sirt_max.R ├── sirt_moving_average.R ├── sirt_optimizer.R ├── sirt_optimizer_hessian.R ├── sirt_optimizer_summary_print.R ├── sirt_osink.R ├── sirt_parlapply.R ├── sirt_pem_adjust_dimension.R ├── sirt_pem_algorithm_compute_Pnew.R ├── sirt_pem_algorithm_compute_t.R ├── sirt_pem_collect_parameters.R ├── sirt_pem_create_parameter_index.R ├── sirt_pem_extract_dimension.R ├── sirt_pem_extract_parameters.R ├── sirt_pem_include_ll_args.R ├── sirt_pem_parameter_sequence_initial_iterations.R ├── sirt_permutations.R ├── sirt_pmvnorm.R ├── sirt_print_helper.R ├── sirt_probs_dichotomous_to_array.R ├── sirt_probs_to_logit.R ├── sirt_progress_cat.R ├── sirt_rbind_fill.R ├── sirt_remove_arguments_function.R ├── sirt_remove_list_entries.R ├── sirt_rename_list_entry.R ├── sirt_rename_list_names.R ├── sirt_rmvnorm.R ├── sirt_round_vector.R ├── sirt_rsquared.R ├── sirt_sign_space.R ├── sirt_squeeze.R ├── sirt_squeeze_probs.R ├── sirt_sum.R ├── sirt_sum_norm.R ├── sirt_summary_cat_label_equal_value.R ├── sirt_summary_label_equal_value.R ├── sirt_summary_print_call.R ├── sirt_summary_print_computation_time.R ├── sirt_summary_print_computation_time_s1.R ├── sirt_summary_print_display.R ├── sirt_summary_print_elapsed_time.R ├── sirt_summary_print_objects.R ├── sirt_summary_print_package.R ├── sirt_summary_print_package_rsession.R ├── sirt_summary_print_packages.R ├── sirt_summary_print_rsession.R ├── sirt_summary_print_vector_summary.R ├── sirt_sup.R ├── sirt_symmetrize.R ├── sirt_trim_increment.R ├── sirt_var.R ├── sirt_vector_with_names.R ├── sirtcat.R ├── smirt.R ├── smirt_alg_comp.R ├── smirt_alg_noncomp.R ├── smirt_alg_partcomp.R ├── smirt_postproc.R ├── smirt_preproc.R ├── smirt_squeeze.R ├── soft_thresholding.R ├── sqrt_diag.R ├── sqrt_diag_positive.R ├── stratified.cronbach.alpha.R ├── stratified_cronbach_alpha_compute_alpha.R ├── summary.R2noharm.R ├── summary.R2noharm.jackknife.R ├── summary.btm.R ├── summary.conf.detect.R ├── summary.fuzcluster.R ├── summary.gom.em.R ├── summary.invariance.alignment.R ├── summary.invariance_alignment_constraints.R ├── summary.isop.R ├── summary.isop.test.R ├── summary.latent.regression.R ├── summary.linking.haberman.R ├── summary.linking.haberman.lq.R ├── summary.linking.haebara.R ├── summary.linking.robust.R ├── summary.lsdm.R ├── summary.lsem.R ├── summary.lsem.permutationTest.R ├── summary.mcmc.sirt.R ├── summary.mcmc_WaldTest.R ├── summary.modelfit.sirt.R ├── summary.noharm.sirt.R ├── summary.rasch.copula2.R ├── summary.rasch.copula3.R ├── summary.rasch.evm.pcm.R ├── summary.rasch.jml.R ├── summary.rasch.mirtlc.R ├── summary.rasch.mml2.R ├── summary.rasch.pairwise.R ├── summary.rasch.pml.R ├── summary.regpolca.R ├── summary.rm.facets.R ├── summary.rm.sdt.R ├── summary.smirt.R ├── summary.xxirt.R ├── summary_round_helper.R ├── tam2mirt.R ├── tam2mirt_fix.R ├── tam2mirt_freed.R ├── testlet.marginalized.R ├── testlet.yen.q3.R ├── tetrachoric2.R ├── tracemat.R ├── truescore.irt.R ├── truescore_irt_irf.R ├── unidim.csn.R ├── vcov.rasch.evm.pcm.R ├── weighted_colMeans.R ├── weighted_colSums.R ├── weighted_rowMeans.R ├── weighted_rowSums.R ├── weighted_stats_extend_wgt.R ├── wle.rasch.R ├── wle.rasch.jackknife.R ├── write.format2.R ├── write.fwf2.R ├── xxirt.R ├── xxirt_EAP.R ├── xxirt_IRT.se.R ├── xxirt_ThetaDistribution_extract_freeParameters.R ├── xxirt_classprobs_lca.R ├── xxirt_classprobs_lca_compute_probs.R ├── xxirt_classprobs_lca_init_par.R ├── xxirt_classprobs_lca_init_par_create.R ├── xxirt_coef.R ├── xxirt_compute_casewise_likelihood.R ├── xxirt_compute_itemprobs.R ├── xxirt_compute_likelihood.R ├── xxirt_compute_posterior.R ├── xxirt_compute_priorDistribution.R ├── xxirt_compute_prior_Theta_from_x.R ├── xxirt_compute_prob_item_from_x.R ├── xxirt_createDiscItem.R ├── xxirt_createItemList.R ├── xxirt_createParTable.R ├── xxirt_createThetaDistribution.R ├── xxirt_data_proc.R ├── xxirt_em_algorithm.R ├── xxirt_em_args_extract.R ├── xxirt_hessian.R ├── xxirt_hessian_compute_loglike.R ├── xxirt_ic.R ├── xxirt_ic_compute_criteria.R ├── xxirt_irf_lca.R ├── xxirt_irf_lca_init_par.R ├── xxirt_modifyParTable.R ├── xxirt_mstep_ThetaParameters.R ├── xxirt_mstep_itemParameters.R ├── xxirt_mstep_itemParameters_evalPrior.R ├── xxirt_newton_raphson.R ├── xxirt_nr_grad_fun_R.R ├── xxirt_nr_grad_fun_Rcpp.R ├── xxirt_nr_grad_fun_numapprox.R ├── xxirt_nr_grad_fun_pml_casewise.R ├── xxirt_nr_opt_fun_pml_casewise.R ├── xxirt_nr_optim_fun.R ├── xxirt_nr_pml_grad_fun.R ├── xxirt_nr_pml_more_arguments.R ├── xxirt_nr_pml_opt_fun.R ├── xxirt_nr_pml_opt_fun_R.R ├── xxirt_nr_pml_preproc_data.R ├── xxirt_parTheta_extract_freeParameters.R ├── xxirt_parTheta_include_freeParameters.R ├── xxirt_partable_extract_freeParameters.R ├── xxirt_partable_include_freeParameters.R ├── xxirt_postproc_parameters.R ├── xxirt_prepare_response_data.R ├── xxirt_print_progress.R ├── xxirt_proc_ParTable.R ├── xxirt_sandwich_pml.R ├── xxirt_simulate.R ├── xxirt_summary_parts.R ├── xxirt_vcov.R ├── yen.q3.R └── zzz.R ├── README.md ├── data ├── data.activity.itempars.rda ├── data.befki.rda ├── data.befki_resp.rda ├── data.big5.qgraph.rda ├── data.big5.rda ├── data.bs07a.rda ├── data.eid.kap4.rda ├── data.eid.kap5.rda ├── data.eid.kap6.rda ├── data.eid.kap7.rda ├── data.eid.rda ├── data.ess2005.rda ├── data.g308.rda ├── data.inv4gr.rda ├── data.liking.science.rda ├── data.long.rda ├── data.lsem01.rda ├── data.lsem02.rda ├── data.lsem03.rda ├── data.math.rda ├── data.mcdonald.LSAT6.rda ├── data.mcdonald.act15.rda ├── data.mcdonald.rape.rda ├── data.mixed1.rda ├── data.ml1.rda ├── data.ml2.rda ├── data.noharm18.rda ├── data.noharmExC.rda ├── data.pars1.2pl.rda ├── data.pars1.rasch.rda ├── data.pirlsmissing.rda ├── data.pisaMath.rda ├── data.pisaPars.rda ├── data.pisaRead.rda ├── data.pw01.rda ├── data.ratings1.rda ├── data.ratings2.rda ├── data.ratings3.rda ├── data.raw1.rda ├── data.read.rda ├── data.reck21.rda ├── data.reck61DAT1.rda ├── data.reck61DAT2.rda ├── data.reck73C1a.rda ├── data.reck73C1b.rda ├── data.reck75C2.rda ├── data.reck78ExA.rda ├── data.reck79ExB.rda ├── data.si01.rda ├── data.si02.rda ├── data.si03.rda ├── data.si04.rda ├── data.si05.rda ├── data.si06.rda ├── data.si07.rda ├── data.si08.rda ├── data.si09.rda ├── data.si10.rda ├── data.timss.rda ├── data.timss07.G8.RUS.rda ├── data.trees.rda └── datalist ├── docs ├── 404.html ├── authors.html ├── deps │ ├── bootstrap-5.2.2 │ │ ├── bootstrap.bundle.min.js │ │ ├── bootstrap.bundle.min.js.map │ │ └── bootstrap.min.css │ ├── data-deps.txt │ └── jquery-3.6.0 │ │ ├── jquery-3.6.0.js │ │ ├── jquery-3.6.0.min.js │ │ └── jquery-3.6.0.min.map ├── index.html ├── link.svg ├── pkgdown.js ├── pkgdown.yml ├── reference │ ├── IRT.mle.html │ ├── Q3.html │ ├── Q3.testlet.html │ ├── R2conquest.html │ ├── R2noharm.EAP.html │ ├── R2noharm.html │ ├── R2noharm.jackknife.html │ ├── automatic.recode.html │ ├── brm.sim.html │ ├── btm.html │ ├── categorize.html │ ├── ccov.np.html │ ├── cfa_meas_inv.html │ ├── class.accuracy.rasch.html │ ├── conf.detect.html │ ├── data.activity.itempars.html │ ├── data.befki.html │ ├── data.big5.html │ ├── data.bs.html │ ├── data.eid.html │ ├── data.ess2005.html │ ├── data.g308.html │ ├── data.inv4gr.html │ ├── data.liking.science.html │ ├── data.long.html │ ├── data.lsem.html │ ├── data.math.html │ ├── data.mcdonald.html │ ├── data.mixed1.html │ ├── data.ml.html │ ├── data.noharm.html │ ├── data.pars1.rasch.html │ ├── data.pirlsmissing.html │ ├── data.pisaMath.html │ ├── data.pisaPars.html │ ├── data.pisaRead.html │ ├── data.pw01.html │ ├── data.ratings1.html │ ├── data.raw1.html │ ├── data.read.html │ ├── data.reck.html │ ├── data.si.html │ ├── data.timss.html │ ├── data.timss07.G8.RUS.html │ ├── data.trees.html │ ├── data.wide2long.html │ ├── detect.index.html │ ├── dif.logistic.regression.html │ ├── dif.strata.variance.html │ ├── dif.variance.html │ ├── dirichlet.mle.html │ ├── dirichlet.simul.html │ ├── dmlavaan.html │ ├── eigenvalues.manymatrices.html │ ├── equating.rasch.html │ ├── equating.rasch.jackknife.html │ ├── expl.detect.html │ ├── f1d.irt.html │ ├── fit.isop.html │ ├── fuzcluster.html │ ├── fuzdiscr.html │ ├── gom.em.html │ ├── gom.jml.html │ ├── greenyang.reliability.html │ ├── index.html │ ├── invariance.alignment.html │ ├── isop.html │ ├── isop.scoring.html │ ├── isop.test.html │ ├── latent.regression.em.raschtype.html │ ├── lavaan2mirt.html │ ├── lc.2raters.html │ ├── likelihood.adjustment.html │ ├── linking.haberman.html │ ├── linking.haebara.html │ ├── linking.robust.html │ ├── linking_2groups.html │ ├── locpolycor.html │ ├── lq_fit.html │ ├── lsdm.html │ ├── lsem.estimate.html │ ├── lsem.permutationTest.html │ ├── lsem.test.html │ ├── marginal.truescore.reliability.html │ ├── matrixfunctions.sirt.html │ ├── mcmc.2pno.html │ ├── mcmc.2pno.ml.html │ ├── mcmc.2pnoh.html │ ├── mcmc.3pno.testlet.html │ ├── mcmc.list.descriptives.html │ ├── mcmc_Rhat.html │ ├── mcmc_coef.html │ ├── mcmclist2coda.html │ ├── md.pattern.sirt.html │ ├── mgsem.html │ ├── mirt.specify.partable.html │ ├── mirt.wrapper.html │ ├── mle.pcm.group.html │ ├── modelfit.sirt.html │ ├── monoreg.rowwise.html │ ├── nedelsky.sim.html │ ├── noharm.sirt.html │ ├── np.dich.html │ ├── parmsummary_extend.html │ ├── pbivnorm2.html │ ├── pcm.conversion.html │ ├── pcm.fit.html │ ├── person.parameter.rasch.copula.html │ ├── personfit.stat.html │ ├── pgenlogis.html │ ├── plausible.value.imputation.raschtype.html │ ├── plot.mcmc.sirt.html │ ├── plot.np.dich.html │ ├── polychoric2.html │ ├── prior_model_parse.html │ ├── prmse.subscores.scales.html │ ├── prob.guttman.html │ ├── qmc.nodes.html │ ├── rasch.copula.html │ ├── rasch.evm.pcm.html │ ├── rasch.jml.biascorr.html │ ├── rasch.jml.html │ ├── rasch.jml.jackknife1.html │ ├── rasch.mirtlc.html │ ├── rasch.mml.html │ ├── rasch.pairwise.html │ ├── rasch.pairwise.itemcluster.html │ ├── rasch.pml3.html │ ├── rasch.prox.html │ ├── rasch.va.html │ ├── reliability.nonlinearSEM.html │ ├── resp_groupwise.html │ ├── rinvgamma2.html │ ├── rm.facets.html │ ├── rm.sdt.html │ ├── rmvn.html │ ├── scale_group_means.html │ ├── sia.sirt.html │ ├── sim.qm.ramsay.html │ ├── sim.rasch.dep.html │ ├── sim.raschtype.html │ ├── sirt-defunct.html │ ├── sirt-package.html │ ├── sirt-utilities.html │ ├── sirt_eigenvalues.html │ ├── smirt.html │ ├── stratified.cronbach.alpha.html │ ├── summary.mcmc.sirt.html │ ├── tam2mirt.html │ ├── testlet.marginalized.html │ ├── tetrachoric2.html │ ├── truescore.irt.html │ ├── unidim.test.csn.html │ ├── wle.rasch.html │ ├── wle.rasch.jackknife.html │ ├── xxirt.html │ ├── xxirt_createParTable.html │ └── xxirt_createThetaDistribution.html ├── search.json └── sitemap.xml ├── inst ├── CITATION └── NEWS ├── man ├── IRT.mle.Rd ├── Q3.Rd ├── Q3.testlet.Rd ├── R2conquest.Rd ├── R2noharm.EAP.Rd ├── R2noharm.Rd ├── R2noharm.jackknife.Rd ├── automatic.recode.Rd ├── brm.sim.Rd ├── btm.Rd ├── categorize.Rd ├── ccov.np.Rd ├── cfa_meas_inv.Rd ├── class.accuracy.rasch.Rd ├── conf.detect.Rd ├── data.activity.itempars.Rd ├── data.befki.Rd ├── data.big5.Rd ├── data.bs.Rd ├── data.eid.Rd ├── data.ess2005.Rd ├── data.g308.Rd ├── data.inv4gr.Rd ├── data.liking.science.Rd ├── data.long.Rd ├── data.lsem.Rd ├── data.math.Rd ├── data.mcdonald.Rd ├── data.mixed1.Rd ├── data.ml.Rd ├── data.noharm.Rd ├── data.pars1.rasch.Rd ├── data.pirlsmissing.Rd ├── data.pisaMath.Rd ├── data.pisaPars.Rd ├── data.pisaRead.Rd ├── data.pw01.Rd ├── data.ratings1.Rd ├── data.raw1.Rd ├── data.read.Rd ├── data.reck.Rd ├── data.si.Rd ├── data.timss.Rd ├── data.timss07.G8.RUS.Rd ├── data.trees.Rd ├── data.wide2long.Rd ├── detect.index.Rd ├── dif.logistic.regression.Rd ├── dif.strata.variance.Rd ├── dif.variance.Rd ├── dirichlet.mle.Rd ├── dirichlet.simul.Rd ├── dmlavaan.Rd ├── eigenvalues.manymatrices.Rd ├── equating.rasch.Rd ├── equating.rasch.jackknife.Rd ├── expl.detect.Rd ├── f1d.irt.Rd ├── fit.isop.Rd ├── fuzcluster.Rd ├── fuzdiscr.Rd ├── gom.em.Rd ├── gom.jml.Rd ├── greenyang.reliability.Rd ├── invariance.alignment.Rd ├── isop.Rd ├── isop.scoring.Rd ├── isop.test.Rd ├── latent.regression.em.raschtype.Rd ├── lavaan2mirt.Rd ├── lc.2raters.Rd ├── likelihood.adjustment.Rd ├── linking.haberman.Rd ├── linking.haebara.Rd ├── linking.robust.Rd ├── linking_2groups.Rd ├── locpolycor.Rd ├── lq_fit.Rd ├── lsdm.Rd ├── lsem.estimate.Rd ├── lsem.permutationTest.Rd ├── lsem.test.Rd ├── marginal.truescore.reliability.Rd ├── matrixfunctions.sirt.Rd ├── mcmc.2pno.Rd ├── mcmc.2pno.ml.Rd ├── mcmc.2pnoh.Rd ├── mcmc.3pno.testlet.Rd ├── mcmc.list.descriptives.Rd ├── mcmc_Rhat.Rd ├── mcmc_coef.Rd ├── mcmclist2coda.Rd ├── md.pattern.sirt.Rd ├── mgsem.Rd ├── mirt.specify.partable.Rd ├── mirt.wrapper.Rd ├── mle.pcm.group.Rd ├── modelfit.sirt.Rd ├── monoreg.rowwise.Rd ├── nedelsky.sim.Rd ├── noharm.sirt.Rd ├── np.dich.Rd ├── parmsummary_extend.Rd ├── pbivnorm2.Rd ├── pcm.conversion.Rd ├── pcm.fit.Rd ├── person.parameter.rasch.copula.Rd ├── personfit.stat.Rd ├── pgenlogis.Rd ├── plausible.value.imputation.raschtype.Rd ├── plot.mcmc.sirt.Rd ├── plot.np.dich.Rd ├── polychoric2.Rd ├── prior_model_parse.Rd ├── prmse.subscores.scales.Rd ├── prob.guttman.Rd ├── qmc.nodes.Rd ├── rasch.copula.Rd ├── rasch.evm.pcm.Rd ├── rasch.jml.Rd ├── rasch.jml.biascorr.Rd ├── rasch.jml.jackknife1.Rd ├── rasch.mirtlc.Rd ├── rasch.mml.Rd ├── rasch.pairwise.Rd ├── rasch.pairwise.itemcluster.Rd ├── rasch.pml3.Rd ├── rasch.prox.Rd ├── rasch.va.Rd ├── reliability.nonlinearSEM.Rd ├── resp_groupwise.Rd ├── rinvgamma2.Rd ├── rm.facets.Rd ├── rm.sdt.Rd ├── rmvn.Rd ├── scale_group_means.Rd ├── sia.sirt.Rd ├── sim.qm.ramsay.Rd ├── sim.rasch.dep.Rd ├── sim.raschtype.Rd ├── sirt-defunct.Rd ├── sirt-package.Rd ├── sirt-utilities.Rd ├── sirt_eigenvalues.Rd ├── smirt.Rd ├── stratified.cronbach.alpha.Rd ├── summary.mcmc.sirt.Rd ├── tam2mirt.Rd ├── testlet.marginalized.Rd ├── tetrachoric2.Rd ├── truescore.irt.Rd ├── unidim.test.csn.Rd ├── wle.rasch.Rd ├── wle.rasch.jackknife.Rd ├── xxirt.Rd ├── xxirt_createParTable.Rd └── xxirt_createThetaDistribution.Rd └── src ├── Makevars ├── Makevars.win ├── RcppExports.cpp ├── gooijer_isop_rcpp.cpp ├── matrixfunctions_sirt_rcpp.cpp ├── mle_pcm_group_rcpp.cpp ├── probs_multcat_items_counts_rcpp.cpp ├── rm_smirt_mml2_rcpp.cpp ├── sirt_rcpp_ccov.cpp ├── sirt_rcpp_discrete_inverse.cpp ├── sirt_rcpp_eigenvalues.cpp ├── sirt_rcpp_eigenvalues.h ├── sirt_rcpp_evm_comp_poly.cpp ├── sirt_rcpp_gom_em.cpp ├── sirt_rcpp_inference_jackknife.cpp ├── sirt_rcpp_inference_jackknife.h ├── sirt_rcpp_invariance_alignment.cpp ├── sirt_rcpp_linking_haebara.cpp ├── sirt_rcpp_lq_fit.cpp ├── sirt_rcpp_mgsem_functions.cpp ├── sirt_rcpp_monoreg.cpp ├── sirt_rcpp_noharm.cpp ├── sirt_rcpp_pbvnorm.cpp ├── sirt_rcpp_pbvnorm.h ├── sirt_rcpp_polychoric2.cpp ├── sirt_rcpp_rm_proc_data.cpp ├── sirt_rcpp_rm_sdt.cpp └── sirt_rcpp_xxirt.cpp /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto -------------------------------------------------------------------------------- /R/IRT.factor.scores.xxirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: IRT.factor.scores.xxirt.R 2 | ## File Version: 0.07 3 | 4 | 5 | ########################################################### 6 | # object of class xxirt 7 | IRT.factor.scores.xxirt <- function( object, type="EAP", ... ) 8 | { 9 | if ( ! ( type %in% c("EAP") ) ){ 10 | stop("Requested type is not supported!\n") 11 | } 12 | # EAP 13 | if ( type=="EAP"){ 14 | ll <- object$EAP 15 | } 16 | attr(ll,"type") <- type 17 | return(ll) 18 | } 19 | ########################################################### 20 | -------------------------------------------------------------------------------- /R/IRT.posterior.mirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: IRT.posterior.mirt.R 2 | ## File Version: 0.21 3 | 4 | 5 | 6 | #--- likelihood singleGroup 7 | IRT.posterior.mirt.singleGroup <- function( object, ... ) 8 | { 9 | ll <- IRT_likelihood_mirt_singleGroup( object=object, type="f.qk.yi", ...) 10 | return(ll) 11 | } 12 | IRT.posterior.ConfirmatoryClass <- IRT.posterior.mirt.singleGroup 13 | IRT.posterior.ExploratoryClass <- IRT.posterior.mirt.singleGroup 14 | IRT.posterior.SingleGroupClass <- IRT.posterior.mirt.singleGroup 15 | 16 | IRT.posterior.mirt.multipleGroup <- function( object, ... ) 17 | { 18 | ll <- IRT_likelihood_mirt_multipleGroup( object=object, type="f.qk.yi", ... ) 19 | return(ll) 20 | } 21 | IRT.posterior.MultipleGroupClass <- IRT.posterior.mirt.multipleGroup 22 | -------------------------------------------------------------------------------- /R/L0_polish.R: -------------------------------------------------------------------------------- 1 | ## File Name: L0_polish.R 2 | ## File Version: 0.131 3 | 4 | 5 | L0_polish <- function(x, tol, conv=0.01, maxiter=30, type=1, verbose=TRUE) 6 | { 7 | res <- list(x_update=x, iterate_further=TRUE) 8 | #-- iterate 9 | while(res$iterate_further){ 10 | res <- L0_polish_one_iteration(x=res$x_update, tol=tol, type=type, eps=conv) 11 | if (verbose){ 12 | v1 <- paste0('Interactions detected: ', res$N_elim) 13 | v2 <- paste0(' | Absolute value residual: ', round(res$max_resid,3) ) 14 | cat(v1, v2, '\n') 15 | utils::flush.console() 16 | } 17 | } 18 | #--- output 19 | return(res) 20 | } 21 | -------------------------------------------------------------------------------- /R/Probtrace_sirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: Probtrace_sirt.R 2 | ## File Version: 0.05 3 | 4 | 5 | # auxiliary function for mirt package 6 | # trace function for all items 7 | Probtrace_sirt <- function(items, Theta) 8 | { 9 | TAM::require_namespace_msg("mirt") 10 | traces <- lapply(items, mirt::probtrace, Theta=Theta) 11 | ret <- do.call(cbind, traces) 12 | return(ret) 13 | } 14 | -------------------------------------------------------------------------------- /R/attach.environment.sirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: attach.environment.sirt.R 2 | ## File Version: 0.081 3 | 4 | 5 | #--- attach all elements of an object in an environment 6 | .attach.environment.sirt <- function( res, envir ) 7 | { 8 | CC <- length(res) 9 | for (cc in 1L:CC){ 10 | assign( names(res)[cc], res[[cc]], envir=envir ) 11 | } 12 | } 13 | 14 | -------------------------------------------------------------------------------- /R/bounds_parameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: bounds_parameters.R 2 | ## File Version: 0.08 3 | 4 | 5 | bounds_parameters <- function( pars, lower=NULL, upper=NULL) 6 | { 7 | if ( ! is.null(lower)){ 8 | pars <- ifelse( pars < lower, lower, pars ) 9 | } 10 | if ( ! is.null(upper)){ 11 | pars <- ifelse( pars > upper, upper, pars ) 12 | } 13 | return(pars) 14 | } 15 | -------------------------------------------------------------------------------- /R/brm.irf.R: -------------------------------------------------------------------------------- 1 | ## File Name: brm.irf.R 2 | ## File Version: 0.121 3 | 4 | #--- item response function (discretized) beta response model 5 | brm.irf <- function( Theta, delta, tau, ncat, thdim=1, eps=1E-10 ) 6 | { 7 | TP <- nrow(Theta) 8 | K <- ncat 9 | # compute mid points 10 | mp <- seq( 1 / (2*(ncat) ), 1, 1/ncat ) 11 | probs <- matrix( 0, nrow=TP, ncol=K ) 12 | eps <- 1E-10 13 | # compute beta shape parameters 14 | m1 <- Theta[,thdim] - delta + tau 15 | m1 <- exp( m1 / 2 ) 16 | m2 <- - Theta[,thdim] + delta + tau 17 | m2 <- exp( m2 / 2 ) 18 | for (cc in 1L:ncat){ 19 | probs[,cc] <- stats::dbeta( mp[cc], shape1=m1, shape2=m2 ) 20 | } 21 | probs <- probs + eps 22 | probs <- probs / rowSums(probs) 23 | return(probs) 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/brm.sim.R: -------------------------------------------------------------------------------- 1 | ## File Name: brm.sim.R 2 | ## File Version: 0.124 3 | 4 | 5 | #-- brm.sim 6 | brm.sim <- function( theta, delta, tau, K=NULL) 7 | { 8 | I <- length(delta) 9 | N <- length(theta) 10 | dat <- matrix( 0, nrow=N, ncol=I ) 11 | colnames(dat) <- paste0( 'I', 1L:9 ) 12 | if ( ! is.null(K) ){ 13 | br <- seq( 0, 1, len=K+1 ) 14 | } 15 | for (ii in 1L:I){ 16 | m1 <- exp( ( theta - delta[ii] + tau[ii] ) / 2 ) 17 | n1 <- exp( ( - theta + delta[ii] + tau[ii] ) / 2 ) 18 | dat[,ii] <- stats::rbeta( N, shape1=m1, shape2=n1 ) 19 | if ( ! is.null(K) ){ 20 | dat[,ii] <- as.numeric(cut( dat[,ii], breaks=br )) - 1 21 | } 22 | } 23 | return(dat) 24 | } 25 | -------------------------------------------------------------------------------- /R/btm_fit_combine_tables.R: -------------------------------------------------------------------------------- 1 | ## File Name: btm_fit_combine_tables.R 2 | ## File Version: 0.07 3 | 4 | 5 | btm_fit_combine_tables <- function( win1, win2, ind1, ind2, TP ) 6 | { 7 | win <- rep( 0, TP ) 8 | win[ind1] <- win1[, 1] 9 | win[ind2] <- win[ind2] + win2[, 1] 10 | return(win) 11 | } 12 | -------------------------------------------------------------------------------- /R/btm_trim_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: btm_trim_increment.R 2 | ## File Version: 0.04 3 | 4 | btm_trim_increment <- function(incr, maxincr ) 5 | { 6 | res <- ifelse( abs(incr) > maxincr, maxincr*sign(incr), incr ) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/ccov_np_print_progress.R: -------------------------------------------------------------------------------- 1 | ## File Name: ccov_np_print_progress.R 2 | ## File Version: 0.03 3 | 4 | ccov_np_print_progress <- function(progress, i, ii, display) 5 | { 6 | if ( i < 20 ){ 7 | if ( ii==display[i] & progress ){ 8 | cat( paste( 5*i, '% ', sep='' ) ) 9 | i <- i + 1 10 | if (i==11){ 11 | cat('\n' ) 12 | } 13 | utils::flush.console() 14 | } 15 | } 16 | return(i) 17 | } 18 | -------------------------------------------------------------------------------- /R/ccov_np_regression.R: -------------------------------------------------------------------------------- 1 | ## File Name: ccov_np_regression.R 2 | ## File Version: 0.141 3 | 4 | ccov_np_regression <- function(x, y, xgrid, bwscale=1.1, smooth=TRUE, score=NULL) 5 | { 6 | N <- length(x) 7 | if (smooth){ 8 | y <- stats::ksmooth( x=x, y=y, bandwidth=bwscale*N^(-1/5), 9 | x.points=xgrid, kernel='normal')$y 10 | } else { 11 | a1 <- stats::aggregate(y, list(score), mean, na.rm=TRUE) 12 | y <- a1[,2] 13 | } 14 | return(y) 15 | } 16 | -------------------------------------------------------------------------------- /R/ccov_np_score_density.R: -------------------------------------------------------------------------------- 1 | ## File Name: ccov_np_score_density.R 2 | ## File Version: 0.07 3 | 4 | ccov_np_score_density <- function(score, thetagrid, smooth=TRUE) 5 | { 6 | if (smooth){ 7 | thg_dens <- stats::density(x=score, from=min(thetagrid), to=max(thetagrid)) 8 | wgt_thetagrid <- ccov_np_regression(x=thg_dens$x, y=thg_dens$y, 9 | xgrid=thetagrid, bwscale=.1) 10 | wgt_thetagrid <- sirt_sum_norm(x=wgt_thetagrid) 11 | } else { 12 | a1 <- stats::aggregate(x=1+0*score, by=list(score), FUN=sum, na.rm=TRUE) 13 | wgt_thetagrid <- sirt_sum_norm(x=a1[,2]) 14 | } 15 | return(wgt_thetagrid) 16 | } 17 | -------------------------------------------------------------------------------- /R/coef.rasch.evm.pcm.R: -------------------------------------------------------------------------------- 1 | ## File Name: coef.rasch.evm.pcm.R 2 | ## File Version: 0.13 3 | 4 | 5 | coef.rasch.evm.pcm <- function( object, ... ) 6 | { 7 | return(object$coef) 8 | } 9 | -------------------------------------------------------------------------------- /R/confint.xxirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: confint.xxirt.R 2 | ## File Version: 0.13 3 | 4 | 5 | #--- confidence interval for xxirt object 6 | confint.xxirt <- function( object, parm, level=.95, ... ) 7 | { 8 | c1 <- coef.xxirt(object) 9 | v1 <- vcov.xxirt(object) 10 | if ( ! missing(parm) ){ 11 | c1 <- c1[parm] 12 | v1 <- v1[ parm, parm] 13 | } 14 | 15 | q1 <- ( 1 - level ) / 2 16 | q2 <- 1 - ( 1 - level ) / 2 17 | quant <- stats::qnorm(q2) 18 | se <- sqrt( diag(v1) ) 19 | res <- data.frame( a=c1-quant*se, b=c1+quant*se ) 20 | colnames(res)[1] <- paste0( round( 100*q1,1 ), ' %') 21 | colnames(res)[2] <- paste0( round( 100*q2,1 ), ' %') 22 | rownames(res) <- names(c1) 23 | return(res) 24 | } 25 | 26 | -------------------------------------------------------------------------------- /R/create.ccov.R: -------------------------------------------------------------------------------- 1 | ## File Name: create.ccov.R 2 | ## File Version: 1.091 3 | 4 | 5 | #**** auxiliary function for creating a covariance matrix 6 | create.ccov <- function( cc, data ) 7 | { 8 | ccc <- cc$ccov.table 9 | I <- max( ccc$item1ID, ccc$item2ID ) 10 | ccov.matrix <- matrix( 0, nrow=I, ncol=I) 11 | rownames(ccov.matrix) <- colnames(ccov.matrix) <- colnames(data) 12 | LL <- nrow(ccc) 13 | for (ll in 1L:LL){ 14 | ccov.matrix[ ccc$item1ID[ll], ccc$item2ID[ll] ] <- ccc$ccov[ll] 15 | ccov.matrix[ ccc$item2ID[ll], ccc$item1ID[ll] ] <- 16 | ccov.matrix[ ccc$item1ID[ll], ccc$item2ID[ll] ] 17 | } 18 | return(ccov.matrix) 19 | } 20 | 21 | 22 | .create.ccov <- create.ccov 23 | -------------------------------------------------------------------------------- /R/data.recode.sirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: data.recode.sirt.R 2 | ## File Version: 0.02 3 | 4 | 5 | #*** utility function for recoding a raw dataset 6 | data.recode.sirt <- function( data.raw, keys ) 7 | { 8 | item.stat <- keys 9 | V <- ncol(data.raw) 10 | data.scored <- matrix( 0, nrow(data.raw), ncol(data.raw) ) 11 | colnames(data.scored) <- colnames(data.raw ) 12 | for (vv in 1L:V){ 13 | data.scored[,vv] <- 1* ( paste(data.raw[,vv])== 14 | paste(item.stat[ item.stat$item==colnames(data.raw)[vv], 'key' ]) ) 15 | data.scored[ paste( data.raw[,vv] )=='NA', vv ] <- NA 16 | } 17 | return(data.scored) 18 | } 19 | -------------------------------------------------------------------------------- /R/decategorize.R: -------------------------------------------------------------------------------- 1 | ## File Name: decategorize.R 2 | ## File Version: 0.124 3 | 4 | #* decategorize 5 | decategorize <- function( dat, categ_design=NULL ) 6 | { 7 | # preliminaries 8 | dat4 <- dat3 <- dat 9 | dfr <- categ_design 10 | 11 | #** handle categories 12 | if ( ! is.null( dfr ) ){ 13 | vars <- sort(unique(paste(dfr$variable))) 14 | VV <- length(vars) 15 | for (vv in 1L:VV){ 16 | dfr.vv <- dfr[ paste(dfr$variable)==vars[vv], ] 17 | dat4[, vars[vv] ] <- dfr.vv[ match( dat3[,vars[vv]], dfr.vv$recode ), 'orig'] 18 | } 19 | } 20 | return(dat4) 21 | } 22 | 23 | -------------------------------------------------------------------------------- /R/dexppow.R: -------------------------------------------------------------------------------- 1 | ## File Name: dexppow.R 2 | ## File Version: 0.054 3 | 4 | 5 | dexppow <- function (x, mu=0, sigmap=1, pow=2, log=FALSE) 6 | { 7 | p <- pow 8 | cost <- 2 * p^(1/p) * gamma(1 + 1/p) * sigmap 9 | expon1 <- (abs(x - mu))^p 10 | expon2 <- p * sigmap^p 11 | dsty <- (1/cost) * exp(-expon1/expon2) 12 | if (log){ 13 | dsty <- log(dsty) 14 | } 15 | return(dsty) 16 | } 17 | -------------------------------------------------------------------------------- /R/diag2.R: -------------------------------------------------------------------------------- 1 | ## File Name: diag2.R 2 | ## File Version: 0.04 3 | 4 | diag2 <- function( vec) 5 | { 6 | if ( length(vec) > 1){ 7 | res <- diag(vec) 8 | } else { 9 | res <- matrix(vec, nrow=1,ncol=1) 10 | } 11 | return(res) 12 | } 13 | -------------------------------------------------------------------------------- /R/dimproper.R: -------------------------------------------------------------------------------- 1 | ## File Name: dimproper.R 2 | ## File Version: 0.04 3 | 4 | ################################################### 5 | # improper density which is constant to 1 6 | dimproper <- function(x){ 7 | N <- length(x) 8 | dx <- rep(1,N) 9 | return(dx) 10 | } 11 | ################################################### 12 | -------------------------------------------------------------------------------- /R/dirichlet.simul.R: -------------------------------------------------------------------------------- 1 | ## File Name: dirichlet.simul.R 2 | ## File Version: 0.131 3 | 4 | 5 | #-- simulate from a Dirichlet distribution 6 | dirichlet.simul <- function( alpha ) 7 | { 8 | N <- nrow(alpha) 9 | K <- ncol(alpha) 10 | ygamma <- 0*alpha 11 | for (ii in 1L:K){ 12 | ygamma[,ii] <- stats::rgamma( n=N, shape=alpha[,ii] ) 13 | } 14 | x <- ygamma / rowSums(ygamma) 15 | return(x) 16 | } 17 | -------------------------------------------------------------------------------- /R/dm_m_est.R: -------------------------------------------------------------------------------- 1 | ## File Name: dm_m_est.R 2 | ## File Version: 0.106 3 | 4 | dm_m_est <- function(mod1, mod2) 5 | { 6 | #*** create joint parameter table 7 | res <- dmlavaan_joint_parameterTable(mod1=mod1, mod2=mod2, 8 | label_parnames='parnames') 9 | partable <- res$partable 10 | parnames <- res$parnames 11 | NP <- res$NP 12 | 13 | #*** sandwich estimate 14 | res <- dmlavaan_se_sandwich(mod1=mod1, mod2=mod2, partable=partable, 15 | label_parnames='parnames', label_NPU='NP', label_B='B', 16 | is_dmlavaan=TRUE) 17 | partable <- res$partable 18 | V <- res$partable 19 | 20 | #--- output 21 | res <- list(partable=partable, V=V, parnames=parnames, NP=NP) 22 | return(res) 23 | } 24 | -------------------------------------------------------------------------------- /R/dmlavaan_add_suffix_column_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_add_suffix_column_names.R 2 | ## File Version: 0.02 3 | 4 | dmlavaan_add_suffix_column_names <- function(x, suffix) 5 | { 6 | colnames(x) <- paste0(colnames(x), suffix) 7 | return(x) 8 | } 9 | -------------------------------------------------------------------------------- /R/dmlavaan_adjust_numdiff_h.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_adjust_numdiff_h.R 2 | ## File Version: 0.03 3 | 4 | dmlavaan_adjust_numdiff_h <- function(h, val) 5 | { 6 | # h1 <- ifelse(abs(val)>1, h*abs(val), h ) 7 | h1 <- h 8 | return(h1) 9 | } 10 | -------------------------------------------------------------------------------- /R/dmlavaan_create_coef.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_create_coef.R 2 | ## File Version: 0.01 3 | 4 | dmlavaan_create_coef <- function(partable) 5 | { 6 | coef1 <- partable$est1 7 | names(coef1) <- paste0(partable$parname, '_mod1') 8 | coef2 <- partable$est2 9 | names(coef2) <- paste0(partable$parname, '_mod2') 10 | coef <- c( coef1, coef2 ) 11 | coef <- coef[ ! is.na(coef) ] 12 | return(coef) 13 | } 14 | -------------------------------------------------------------------------------- /R/dmlavaan_est_model_include_partable.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_est_model_include_partable.R 2 | ## File Version: 0.06 3 | 4 | dmlavaan_est_model_include_partable <- function(partable, se_sw) 5 | { 6 | ind <- which(partable$free>0) 7 | partable1 <- partable[ind,] 8 | partable$se_sw <- 0 9 | partable1$se_sw <- se_sw[ partable1$pnid ] 10 | partable[ind,] <- partable1 11 | #-- output 12 | return(partable) 13 | } 14 | -------------------------------------------------------------------------------- /R/dmlavaan_extract_logLik_casewise.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_extract_logLik_casewise.R 2 | ## File Version: 0.03 3 | 4 | dmlavaan_extract_logLik_casewise <- function(mod) 5 | { 6 | requireNamespace('lavaan') 7 | res <- unlist( lavaan::lavInspect(mod, what='loglik.casewise', list.by.group=FALSE) ) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/dmlavaan_joint_parameterTable_merge_table.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_joint_parameterTable_merge_table.R 2 | ## File Version: 0.04 3 | 4 | dmlavaan_joint_parameterTable_merge_table <- function(partable, mod, model_index=1) 5 | { 6 | y1 <- mod$partable[, c('parname','est','se_sw')] 7 | colnames(y1) <- c('parname',paste0(c('est','se'), model_index ) ) 8 | y1 <- y1[ ! duplicated(y1$parname), ] 9 | partable <- merge(x=partable, y=y1, by='parname', all.x=TRUE) 10 | partable <- partable[ order(partable$id), ] 11 | return(partable) 12 | } 13 | -------------------------------------------------------------------------------- /R/dmlavaan_remove_duplicated_columns.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_remove_duplicated_columns.R 2 | ## File Version: 0.03 3 | 4 | dmlavaan_remove_duplicated_columns <- function(x) 5 | { 6 | x <- x[, ! duplicated(colnames(x)) ] 7 | return(x) 8 | } 9 | -------------------------------------------------------------------------------- /R/dmlavaan_sandwich_formula.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_sandwich_formula.R 2 | ## File Version: 0.06 3 | 4 | dmlavaan_sandwich_formula <- function(A, B, parnames=NULL) 5 | { 6 | requireNamespace('MASS') 7 | B1 <- MASS::ginv(X=B) 8 | V <- B1 %*% A %*% B1 9 | if (!is.null(parnames)){ 10 | rownames(V) <- colnames(V) <- parnames 11 | } 12 | se_sw <- sqrt( diag(V) ) 13 | #-- output 14 | res <- list(V=V, se_sw=se_sw) 15 | return(res) 16 | } 17 | -------------------------------------------------------------------------------- /R/dmlavaan_se_bootstrap_create_est_boot.R: -------------------------------------------------------------------------------- 1 | ## File Name: dmlavaan_se_bootstrap_create_est_boot.R 2 | ## File Version: 0.05 3 | 4 | 5 | dmlavaan_se_bootstrap_create_est_boot <- function(est_boot1, est_boot2) 6 | { 7 | #-- est_boot 8 | est_boot1 <- dmlavaan_add_suffix_column_names(x=est_boot1, suffix='_mod1') 9 | est_boot2 <- dmlavaan_add_suffix_column_names(x=est_boot2, suffix='_mod2') 10 | est_boot <- data.frame( est_boot1, est_boot2) 11 | colnames(est_boot) <- c(colnames(est_boot1), colnames(est_boot2) ) 12 | 13 | #-- compute covariance matrix 14 | V <- stats::cov(est_boot) 15 | 16 | #--- output 17 | res <- list(est_boot=est_boot, V=V) 18 | return(res) 19 | } 20 | -------------------------------------------------------------------------------- /R/fuzdiscr.R: -------------------------------------------------------------------------------- 1 | ## File Name: fuzdiscr.R 2 | ## File Version: 0.093 3 | 4 | fuzdiscr <- function( X, theta0=NULL, maxiter=200, conv=.0001 ) 5 | { 6 | if ( is.null(theta0) ){ 7 | theta0 <- rep( 1/ ncol(X), ncol(X) ) 8 | } 9 | theta <- theta0 10 | iter <- 0 11 | change <- 1000 12 | while( ( iter < maxiter ) & ( change > conv ) ){ 13 | # update xsi 14 | thetaM <- matrix( theta, nrow=nrow(X), ncol=ncol(X), byrow=TRUE) 15 | xsi <- thetaM * X / rowSums( thetaM * X ) 16 | # update theta 17 | theta <- colMeans(xsi) 18 | change <- max( abs( theta - theta0 ) ) 19 | theta0 <- theta 20 | iter <- iter + 1 21 | } 22 | return(theta) 23 | } 24 | -------------------------------------------------------------------------------- /R/genlogis.moments.R: -------------------------------------------------------------------------------- 1 | ## File Name: genlogis.moments.R 2 | ## File Version: 0.02 3 | 4 | 5 | #-- moments of generalized logistic distribution 6 | genlogis.moments <- function( alpha1, alpha2) 7 | { 8 | x0 <- seq(-30, 30, len=30000 ) 9 | y0 <- pgenlogis( x=x0, alpha1=alpha1, alpha2=alpha2 ) 10 | wgt <- y0[-1] - y0[ - length(y0) ] 11 | wgt <- wgt / sum(wgt) 12 | out <- ( x0[ -1 ] + x0[ - length(x0) ] ) / 2 13 | M <- sum( wgt * out ) 14 | SD <- sqrt( sum( wgt*out^2 ) - M^2 ) 15 | moments <- c(M, SD, SD^2 ) 16 | names(moments) <- c('M','SD','Var') 17 | return(moments) 18 | } 19 | -------------------------------------------------------------------------------- /R/ginverse_sym.R: -------------------------------------------------------------------------------- 1 | ## File Name: ginverse_sym.R 2 | ## File Version: 0.08 3 | 4 | 5 | #--- code from Eugene Demidenko: book mixed effects models 6 | ginverse_sym <- function(A, eps=1E-8) 7 | { 8 | # generalized inverse of a symmetric matrix A 9 | PV <- eigen(A, symmetric=TRUE) 10 | V0 <- IV <- PV$values 11 | av0 <- abs(V0) 12 | IV[ av0 > eps] <- 1/V0[ av0 > eps] 13 | IV[ av0 <=eps] <- 0 14 | Ainv <- PV$vectors %*% ( IV*( t(PV$vectors) ) ) 15 | return(Ainv) 16 | } 17 | -------------------------------------------------------------------------------- /R/gom_em_calc_probs.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_calc_probs.R 2 | ## File Version: 0.13 3 | 4 | 5 | 6 | #--- gom calcprobs 7 | gom_em_calc_probs <- function( lambda, theta.k, b=NULL, theta0.k=NULL ) 8 | { 9 | if ( ! is.null( b ) ){ 10 | lambda <- stats::plogis( - b + matrix( theta0.k, length(b), length(theta0.k), 11 | byrow=TRUE ) ) 12 | } 13 | probs <- tcrossprod( lambda, theta.k) 14 | probsL <- array( 0, dim=c( nrow(lambda), 2, nrow(theta.k) ) ) 15 | probsL[,2,] <- probs 16 | probsL[,1,] <- 1-probs 17 | res <- list(probs=probs, probsL=probsL) 18 | return(res) 19 | } 20 | 21 | .gom.calcprobs <- gom_em_calc_probs 22 | -------------------------------------------------------------------------------- /R/gom_em_calc_theta.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_calc_theta.R 2 | ## File Version: 0.181 3 | 4 | 5 | #--- calculate theta grid 6 | gom_em_calc_theta <- function( K, problevels, eps=1e-5 ) 7 | { 8 | m1 <- problevels 9 | if ( ! is.matrix(problevels) ){ 10 | PL <- length(problevels) 11 | m1 <- matrix(problevels, PL, 1 ) 12 | for (kk in 2L:K){ 13 | NM <- nrow(m1) 14 | m1 <- cbind( m1[ rep( 1L:NM, PL), ], rep( problevels, each=NM) ) 15 | m1 <- m1[ rowSums(m1) <=1, ] 16 | } 17 | } 18 | m1 <- m1[ abs( rowSums(m1) - 1 ) < eps, ] 19 | return(m1) 20 | } 21 | 22 | 23 | 24 | .gom.calc.theta <- gom_em_calc_theta 25 | -------------------------------------------------------------------------------- /R/gom_em_compute_total_loglikelihood.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_compute_total_loglikelihood.R 2 | ## File Version: 0.02 3 | 4 | gom_em_compute_total_loglikelihood <- function(f.yi.qk, pi.k, weights) 5 | { 6 | N <- nrow(f.yi.qk) 7 | ll <- sum( weights*log( rowSums( f.yi.qk * sirt_matrix2( x=pi.k, nrow=N ) ) ) ) 8 | return(ll) 9 | } 10 | -------------------------------------------------------------------------------- /R/gom_em_extract_lambda_matrix.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_extract_lambda_matrix.R 2 | ## File Version: 0.01 3 | 4 | gom_em_extract_lambda_matrix <- function(lambda_logit, I, K) 5 | { 6 | lambda <- matrix( stats::plogis(lambda_logit), nrow=I, ncol=K) 7 | return(lambda) 8 | } 9 | -------------------------------------------------------------------------------- /R/gom_em_inits_lambda.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_inits_lambda.R 2 | ## File Version: 0.05 3 | 4 | gom_em_inits_lambda <- function(I, K, lambda.inits=NULL, lambda_partable=NULL) 5 | { 6 | if (is.null(lambda.inits)){ 7 | lambda <- matrix( seq( 1/(2*K), 1, 1/K), I, K, byrow=TRUE ) 8 | } else { 9 | lambda <- lambda.inits 10 | } 11 | a1 <- stats::aggregate( as.vector(lambda), list(lambda_partable$par_index), mean ) 12 | lambda <- matrix( a1[lambda_partable$par_index,2], nrow=I, ncol=K) 13 | return(lambda) 14 | } 15 | -------------------------------------------------------------------------------- /R/gom_em_loglike_calc_probs.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_loglike_calc_probs.R 2 | ## File Version: 0.03 3 | 4 | gom_em_loglike_calc_probs <- function(x, ind_pi, ind_lambda, I, K, theta.k, 5 | theta0.k) 6 | { 7 | pi_k_logit <- x[ind_pi] 8 | lambda_logit <- x[ind_lambda] 9 | pi.k <- sirt_logit_to_probs(y=pi_k_logit) 10 | lambda <- gom_em_extract_lambda_matrix(lambda_logit=lambda_logit, I=I, K=K) 11 | res <- gom_em_calc_probs( lambda=lambda, theta.k=theta.k, b=NULL, 12 | theta0.k=theta0.k ) 13 | probs <- res$probs 14 | return(probs) 15 | } 16 | -------------------------------------------------------------------------------- /R/gom_em_normal_to_membership_scores.R: -------------------------------------------------------------------------------- 1 | ## File Name: gom_em_normal_to_membership_scores.R 2 | ## File Version: 0.03 3 | 4 | 5 | gom_em_normal_to_membership_scores <- function(theta_grid, K, TP) 6 | { 7 | theta0 <- matrix(0, nrow=TP, ncol=K) 8 | for (kk in 1:(K-1)){ 9 | theta0[,kk] <- theta_grid[,kk] 10 | } 11 | theta0_rowmax <- rowMaxs.sirt(matr=theta0)$maxval 12 | theta0 <- theta0 - theta0_rowmax 13 | theta.k <- exp(theta0) 14 | theta.k <- theta.k / rowSums(theta.k) 15 | return(theta.k) 16 | } 17 | -------------------------------------------------------------------------------- /R/hard_thresholding.R: -------------------------------------------------------------------------------- 1 | ## File Name: hard_thresholding.R 2 | ## File Version: 0.06 3 | 4 | 5 | hard_thresholding <- function( x, lambda ) 6 | { 7 | x_abs <- abs(x) 8 | x <- ifelse( x_abs > lambda, x, 0 ) 9 | return(x) 10 | } 11 | -------------------------------------------------------------------------------- /R/invariance_alignment_aligned_parameters_summary.R: -------------------------------------------------------------------------------- 1 | ## File Name: invariance_alignment_aligned_parameters_summary.R 2 | ## File Version: 0.07 3 | 4 | invariance_alignment_aligned_parameters_summary <- function(x, label=NULL) 5 | { 6 | dfr <- data.frame(Med=sirt_colMedians(x=x), M=colMeans(x=x, na.rm=TRUE), 7 | SD=sirt_colSDs(x=x), Min=sirt_colMins(x=x), 8 | Max=sirt_colMaxs(x=x) ) 9 | if ( ! is.null(label) ){ 10 | colnames(dfr) <- paste0( colnames(dfr), '.', label ) 11 | } 12 | return(dfr) 13 | } 14 | -------------------------------------------------------------------------------- /R/invariance_alignment_calc_corr.R: -------------------------------------------------------------------------------- 1 | ## File Name: invariance_alignment_calc_corr.R 2 | ## File Version: 0.03 3 | 4 | 5 | # auxiliary function for calculation of correlations 6 | invariance_alignment_calc_corr <- function(parsM) 7 | { 8 | cM <- stats::cor(parsM) 9 | I <- ncol(cM) 10 | rbar <- ( sum(cM) - I )/ ( I^2 - I) 11 | return(rbar) 12 | } 13 | -------------------------------------------------------------------------------- /R/invariance_alignment_choose_fixed.R: -------------------------------------------------------------------------------- 1 | ## File Name: invariance_alignment_choose_fixed.R 2 | ## File Version: 0.03 3 | 4 | invariance_alignment_choose_fixed <- function(fixed, G, Gmax=6) 5 | { 6 | if (is.null(fixed)){ 7 | if (G>Gmax){ 8 | fixed <- FALSE 9 | } else { 10 | fixed <- TRUE 11 | } 12 | } 13 | return(fixed) 14 | } 15 | -------------------------------------------------------------------------------- /R/invariance_alignment_proc_labels.R: -------------------------------------------------------------------------------- 1 | ## File Name: invariance_alignment_proc_labels.R 2 | ## File Version: 0.06 3 | 4 | invariance_alignment_proc_labels <- function(x) 5 | { 6 | G <- nrow(x) 7 | I <- ncol(x) 8 | if (is.null(colnames(x))){ 9 | colnames(x) <- paste0('I', 1L:I) 10 | } 11 | if (is.null(rownames(x))){ 12 | rownames(x) <- paste0('G', 1L:G) 13 | } 14 | return(x) 15 | } 16 | -------------------------------------------------------------------------------- /R/invariance_alignment_process_parameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: invariance_alignment_process_parameters.R 2 | ## File Version: 0.03 3 | 4 | invariance_alignment_process_parameters <- function(par.aligned, par) 5 | { 6 | res <- sirt_matrix_names(x=par.aligned, extract_names=par) 7 | res[is.na(par)] <- NA 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/isop_tests_cpp.R: -------------------------------------------------------------------------------- 1 | ## File Name: isop_tests_cpp.R 2 | ## File Version: 0.06 3 | 4 | 5 | isop_tests_cpp <- function( dat, dat.resp, weights, jackunits, JJ ) 6 | { 7 | res <- isop_tests_C( dat=dat, dat_resp=dat.resp, weights=weights, 8 | jackunits=jackunits, JJ=JJ ) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/lavaanify.sirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: lavaanify.sirt.R 2 | ## File Version: 1.14 3 | 4 | lavaanify.sirt <- TAM::lavaanify.IRT 5 | -------------------------------------------------------------------------------- /R/likelihood_moments.R: -------------------------------------------------------------------------------- 1 | ## File Name: likelihood_moments.R 2 | ## File Version: 0.121 3 | 4 | ##**** 5 | likelihood_moments <- function( likelihood, theta=NULL ) 6 | { 7 | if ( is.null(theta) ){ 8 | theta <- attr( likelihood, 'theta' ) 9 | } 10 | nstud <- nrow(likelihood) 11 | TP <- ncol(likelihood) 12 | thetaM <- matrix( theta, nstud, TP, byrow=TRUE ) 13 | likelihood <- likelihood / rowSums( likelihood ) 14 | M1 <- rowSums( thetaM * likelihood ) 15 | SD1 <- rowSums( thetaM^2 * likelihood ) 16 | SD1 <- sqrt( SD1 - M1^2 ) 17 | res <- list( M=M1, SD=SD1 ) 18 | return(res) 19 | } 20 | 21 | -------------------------------------------------------------------------------- /R/linking_2groups_haebara_grad.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_2groups_haebara_grad.R 2 | ## File Version: 0.02 3 | 4 | 5 | linking_2groups_haebara_grad <- function(x, pars, Theta, wgt, type="asymm", 6 | pow=2, eps=0.001, simultan=FALSE) 7 | { 8 | res <- linking_2groups_haebara_fun(x=x, pars=pars, Theta=Theta, wgt=wgt, type=type, 9 | pow=pow, eps=eps, simultan=simultan, deriv=TRUE ) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/linking_2groups_numerical_gradient.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_2groups_numerical_gradient.R 2 | ## File Version: 0.03 3 | 4 | 5 | linking_2groups_numerical_gradient <- function(fun, args, h=1e-4) 6 | { 7 | NP <- length(args$x) 8 | grad <- rep(0, NP) 9 | args2 <- args 10 | for (pp in 1L:NP){ 11 | args2$x <- mgsem_add_increment(x=args$x, h=h, i1=pp) 12 | f1 <- do.call( what=fun, args=args2) 13 | args2$x <- mgsem_add_increment(x=args$x, h=-h, i1=pp) 14 | f2 <- do.call( what=fun, args=args2) 15 | grad[pp] <- (f1-f2)/(2*h) 16 | } 17 | return(grad) 18 | } 19 | -------------------------------------------------------------------------------- /R/linking_2groups_stocking_lord_grad.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_2groups_stocking_lord_grad.R 2 | ## File Version: 0.03 3 | 4 | 5 | linking_2groups_stocking_lord_grad <- function(x, pars, Theta, wgt, type="asymm", 6 | pow=2, eps=1e-3, simultan=FALSE) 7 | { 8 | res <- linking_2groups_stocking_lord_fun(x=x, pars=pars, Theta=Theta, wgt=wgt, 9 | type=type, pow=pow, eps=eps, simultan=simultan, deriv=TRUE ) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/linking_2groups_vector_with_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_2groups_vector_with_names.R 2 | ## File Version: 0.02 3 | 4 | linking_2groups_vector_with_names <- function(x, names) 5 | { 6 | names(x) <- names 7 | return(x) 8 | } 9 | -------------------------------------------------------------------------------- /R/linking_haberman_bisquare_weight.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_bisquare_weight.R 2 | ## File Version: 0.02 3 | 4 | linking_haberman_bisquare_weight <- function(x, cutoff) 5 | { 6 | wgt_adj <- ( 1 - ( x / cutoff )^2 )^2 7 | wgt_adj <- (abs(x)<=cutoff)*wgt_adj 8 | return(wgt_adj) 9 | } 10 | -------------------------------------------------------------------------------- /R/linking_haberman_compute_median.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_compute_median.R 2 | ## File Version: 0.02 3 | 4 | linking_haberman_compute_median <- function(x, w) 5 | { 6 | res <- linking_haberman_remove_missings_vector(x=x,w=w) 7 | x <- res$x 8 | w <- res$w 9 | res <- stats::quantile(x=x, weights=w, probs=.5, na.rm=TRUE, ties=TRUE) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/linking_haberman_huber_weight.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_huber_weight.R 2 | ## File Version: 0.04 3 | 4 | linking_haberman_huber_weight <- function(x, cutoff) 5 | { 6 | eps <- 1e-10 7 | wgt_adj <- (abs(x) >=cutoff)*cutoff / abs(x) + (abs(x) < cutoff)*1 8 | return(wgt_adj) 9 | } 10 | -------------------------------------------------------------------------------- /R/linking_haberman_itempars_convert_process_matrices.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_itempars_convert_process_matrices.R 2 | ## File Version: 0.01 3 | 4 | 5 | linking_haberman_itempars_convert_process_matrices <- function(mat, est_pars) 6 | { 7 | mat[ ! est_pars ] <- NA 8 | return(mat) 9 | } 10 | -------------------------------------------------------------------------------- /R/linking_haberman_lq_pw_le_arrange_Vgamma.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_lq_pw_le_arrange_Vgamma.R 2 | ## File Version: 0.04 3 | 4 | 5 | linking_haberman_lq_pw_le_arrange_Vgamma <- function(vcov_list, par_gamma, I, G, 6 | ind_items, ind_studies) 7 | { 8 | 9 | NPG <- 2*I*G 10 | Vgamma <- matrix(0, nrow=NPG, ncol=NPG, 11 | dimnames=list(names(par_gamma), names(par_gamma) ) ) 12 | if (!is.null(vcov_list)){ 13 | for (gg in 1L:G){ 14 | items_gg <- ind_items[ ind_studies==gg ] 15 | Igg <- length(items_gg) 16 | items_gg <- rep(items_gg, each=2) 17 | ind2 <- 2*I*(gg-1) + 2*(items_gg-1)+rep(1L:2, Igg) 18 | Vgamma[ind2, ind2] <- vcov_list[[gg]] 19 | } 20 | } 21 | return(Vgamma) 22 | } 23 | -------------------------------------------------------------------------------- /R/linking_haberman_remove_missings_vector.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_remove_missings_vector.R 2 | ## File Version: 0.01 3 | 4 | linking_haberman_remove_missings_vector <- function(x,w) 5 | { 6 | ind <- ! is.na(x) 7 | x <- x[ind] 8 | w <- w[ind] 9 | res <- list(x=x, w=w) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/linking_haberman_summary_estimation_information.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_summary_estimation_information.R 2 | ## File Version: 0.051 3 | 4 | linking_haberman_summary_estimation_information <- function(res_opt) 5 | { 6 | cat('Estimation type', '=', res_opt$estimation,'\n') 7 | cat('Number of iterations', '=', res_opt$iter,'\n') 8 | cat('Used trimming factor (\'BSQ\',\'HUB\')', '=', res_opt$cutoff,'\n') 9 | cat('Trimming factor estimated (\'BSQ\',\'HUB\')', '=', res_opt$k_estimate,'\n') 10 | cat('Proportion retained observation (\'LTS\')', '=', res_opt$lts_prop,'\n') 11 | } 12 | -------------------------------------------------------------------------------- /R/linking_haberman_vcov_transformation.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haberman_vcov_transformation.R 2 | ## File Version: 0.12 3 | 4 | linking_haberman_vcov_transformation <- function( H1, aj_vcov ) 5 | { 6 | if (is.null(aj_vcov)){ 7 | aj_se <- NA 8 | } else { 9 | aj_vcov <- H1 %*% aj_vcov %*% t(H1) 10 | aj_se <- c( sqrt( diag( aj_vcov ) ) ) 11 | } 12 | res <- list( vcov=aj_vcov, se=aj_se ) 13 | return(res) 14 | } 15 | -------------------------------------------------------------------------------- /R/linking_haebara_summary_optimization.R: -------------------------------------------------------------------------------- 1 | ## File Name: linking_haebara_summary_optimization.R 2 | ## File Version: 0.091 3 | 4 | linking_haebara_summary_optimization <- function(object, digits) 5 | { 6 | cat('Distance function type', '=', object$dist, '\n') 7 | if (object$dist=='L1'){ 8 | cat('Epsilon Value', '=', object$eps, '\n') 9 | } 10 | cat('Optimization Function Value', '=', round(object$res_optim$value, digits), '\n') 11 | cat('Optimizer', '=', object$res_optim$optimizer, '\n') 12 | cat('use_rcpp', '=', object$use_rcpp, '\n') 13 | cat('Number of iterations', '=', object$res_optim$iter, '\n') 14 | cat('Converged', '=', object$res_optim$converged, '\n') 15 | } 16 | -------------------------------------------------------------------------------- /R/lsdm_extract_probquantile.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsdm_extract_probquantile.R 2 | ## File Version: 0.14 3 | 4 | 5 | # auxiliary function for extracting quantiles of curves 6 | lsdm_extract_probquantile <- function( vec, theta, quant ) 7 | { 8 | x2 <- theta[ vec>=quant ][1] 9 | x1 <- sort( theta[ vec0){ 12 | partable[ ind, hh] <- paste0(partable[ ind, hh], 'g', gg) 13 | } 14 | } 15 | partable$plabel <- paste0(label_list,'g', gg) 16 | partable$plabel[ paste(label_list)=='' ] <- '' 17 | return(partable) 18 | } 19 | -------------------------------------------------------------------------------- /R/lsem_fitsem_verbose_progress.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_fitsem_verbose_progress.R 2 | ## File Version: 0.03 3 | 4 | lsem_fitsem_verbose_progress <- function(gg, G, pr, verbose) 5 | { 6 | if (verbose){ 7 | if (gg %in% pr ){ 8 | cat('-') 9 | } 10 | if (gg>G){ 11 | cat('|\n') 12 | } 13 | utils::flush.console() 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /R/lsem_fitsem_verbose_start.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_fitsem_verbose_start.R 2 | ## File Version: 0.05 3 | 4 | lsem_fitsem_verbose_start <- function(G, verbose) 5 | { 6 | pr <- NULL 7 | if (verbose){ 8 | cat( '** Fit lavaan model\n') 9 | G1 <- min(G,10) 10 | pr <- round( seq(1, G, len=G1) ) 11 | cat('|') 12 | cat( paste0( rep('*',G1), collapse='') ) 13 | cat('|\n') 14 | cat('|') 15 | } 16 | return(pr) 17 | } 18 | -------------------------------------------------------------------------------- /R/lsem_kernel_weights.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_kernel_weights.R 2 | ## File Version: 0.061 3 | 4 | lsem_kernel_weights <- function(x, x0, bw, kernel="gaussian") 5 | { 6 | if (kernel=='gaussian'){ 7 | wgt <- exp( - (x - x0)^2 / (2*bw^2) ) 8 | } 9 | if (kernel=='uniform'){ 10 | wgt <- 1*(abs(x-x0) <=bw) 11 | } 12 | if (kernel=='epanechnikov'){ 13 | z <- (x-x0)/bw 14 | wgt <- abs(z<1)*3/4*(1-z^2) 15 | } 16 | return(wgt) 17 | } 18 | -------------------------------------------------------------------------------- /R/lsem_lavaan_fit_measures.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_lavaan_fit_measures.R 2 | ## File Version: 0.07 3 | 4 | lsem_lavaan_fit_measures <- function(object, fit_measures) 5 | { 6 | fM <- sirt_import_lavaan_fitMeasures(object=object, fit_measures=fit_measures) 7 | fit_measures <- intersect( fit_measures, names(fM)) 8 | fM <- fM[ fit_measures ] 9 | return(fM) 10 | } 11 | -------------------------------------------------------------------------------- /R/lsem_lavaan_modify_lavaan_object_test.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_lavaan_modify_lavaan_object_test.R 2 | ## File Version: 0.03 3 | 4 | lsem_lavaan_modify_lavaan_object_test <- function(object) 5 | { 6 | # object@test 7 | test <- object@test 8 | test[[1]]$test <- 'standard' 9 | object@test <- test 10 | 11 | #-- output 12 | return(object) 13 | } 14 | -------------------------------------------------------------------------------- /R/lsem_permutationTest_collect_output.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_permutationTest_collect_output.R 2 | ## File Version: 0.02 3 | 4 | lsem_permutationTest_collect_output <- function(res0) 5 | { 6 | res0_out <- list(est=res0$parameters$est, M=res0$parameters_summary$M, 7 | SD=res0$parameters_summary$SD, 8 | MAD=res0$parameters_summary$MAD, 9 | lin_slo=res0$parameters_summary$lin_slo) 10 | return(res0_out) 11 | } 12 | -------------------------------------------------------------------------------- /R/lsem_permutationTest_define_exported_objects.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_permutationTest_define_exported_objects.R 2 | ## File Version: 0.105 3 | 4 | lsem_permutationTest_define_exported_objects <- function() 5 | { 6 | varlist <- c('arglist', 'lsem_permutationTest_collect_output') 7 | return(varlist) 8 | } 9 | -------------------------------------------------------------------------------- /R/lsem_spline.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_spline.R 2 | ## File Version: 0.02 3 | 4 | lsem_spline <- function( x, y, method="fmm", n=100) 5 | { 6 | res <- stats::spline( x=x, y=y, n=n, method=method ) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/lsem_wald_test.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_wald_test.R 2 | ## File Version: 0.04 3 | 4 | lsem_wald_test <- function(theta, V, A) 5 | { 6 | requireNamespace('MASS') 7 | r <- ( A %*% theta )[,1] 8 | W <- A %*% V %*% t(A) 9 | W1 <- MASS::ginv( X=W ) 10 | chisq <- ( t(r) %*% W1 %*% r )[1,1] 11 | df <- nrow(A) 12 | p <- 1 - stats::pchisq(q=chisq, df=df) 13 | 14 | #-- output 15 | res <- list(chisq=chisq, df=df, p=p) 16 | return(res) 17 | } 18 | -------------------------------------------------------------------------------- /R/lsem_wtdSD.R: -------------------------------------------------------------------------------- 1 | ## File Name: lsem_wtdSD.R 2 | ## File Version: 0.16 3 | 4 | 5 | lsem_wtdSD <- function( x, w ) 6 | { 7 | res1 <- sum( x*w ) 8 | res2 <- sum( x^2*w) 9 | res12 <- res1^2 10 | if( res2 >=res12 ){ 11 | res <- sqrt( res2 - res12 ) 12 | } else { 13 | res <- 0 14 | } 15 | return(res) 16 | } 17 | -------------------------------------------------------------------------------- /R/m_est_add_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: m_est_add_increment.R 2 | ## File Version: 0.01 3 | 4 | m_est_add_increment <- function(x, pos, h) 5 | { 6 | y <- x 7 | y[pos] <- x[pos] + h 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/mad_normalized.R: -------------------------------------------------------------------------------- 1 | ## File Name: mad_normalized.R 2 | ## File Version: 0.03 3 | 4 | mad_normalized <- function(x) 5 | { 6 | x <- stats::na.omit(x) 7 | res <- stats::median( abs( x - stats::median(x) ) ) 8 | res <- res/0.6745 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/mcmc.aux.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc.aux.R 2 | ## File Version: 0.08 3 | 4 | ################################################################### 5 | # draw variances from inverse chi square distribution 6 | .mcmc.draw.variance <- function( N, w0, sig02, n, sig2 ){ 7 | # INPUT: 8 | # N ... number of random draws 9 | # w0 ... sample size prior 10 | # sig02 ... prior variance 11 | # n ... empirical sample size 12 | # sig2 ... empirical variance 13 | res <- 1/ stats::rgamma( N, (w0+n) / 2, 0.5 * ( w0*sig02 + n*sig2 ) ) 14 | return(res) 15 | } 16 | ##################################################################### 17 | -------------------------------------------------------------------------------- /R/mcmc_Rhat.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_Rhat.R 2 | ## File Version: 0.121 3 | 4 | mcmc_Rhat <- function( mcmc_object, n_splits=3 ) 5 | { 6 | n_samples <- nrow(mcmc_object) 7 | n_pars <- ncol(mcmc_object) 8 | n_within <- floor( n_samples / n_splits ) 9 | rhat_vec <- rep(NA, n_pars) 10 | names(rhat_vec) <- colnames(mcmc_object) 11 | for (pp in 1L:n_pars){ 12 | matr <- matrix( NA, nrow=n_within, ncol=n_splits) 13 | for (ss in 1L:n_splits){ 14 | matr[,ss] <- mcmc_object[ (ss-1)* n_within + 1L:n_within, pp ] 15 | } 16 | rhat_vec[pp] <- Rhat1(matr) 17 | } 18 | return(rhat_vec) 19 | } 20 | -------------------------------------------------------------------------------- /R/mcmc_as_formula.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_as_formula.R 2 | ## File Version: 0.121 3 | 4 | mcmc_as_formula <- function( string ) 5 | { 6 | string <- paste0( string, collapse=' ' ) 7 | string <- gsub('___ ', '___', string, fixed=TRUE ) 8 | form <- stats::as.formula(string) 9 | return(form) 10 | } 11 | -------------------------------------------------------------------------------- /R/mcmc_coef.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_coef.R 2 | ## File Version: 0.09 3 | 4 | ########################################### 5 | # coefficients from one MCMC chain 6 | mcmc_coef <- function( mcmcobj, exclude="deviance" ) 7 | { 8 | mcmcobj <- mcmc_extract_samples_first_chain(mcmcobj=mcmcobj) 9 | mcmcobj <- mcmcobj[, ! ( colnames(mcmcobj) %in% exclude ) ] 10 | res <- colMeans(mcmcobj) 11 | colnames(mcmcobj) -> names(res) 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/mcmc_confint.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_confint.R 2 | ## File Version: 0.121 3 | 4 | 5 | #*** confidence interval 6 | mcmc_confint <- function( mcmcobj, parm, level=.95, exclude="deviance" ) 7 | { 8 | mcmcobj <- mcmcobj[, ! ( colnames(mcmcobj) %in% exclude ) ] 9 | if ( ! missing(parm) ){ 10 | mcmcobj <- mcmcobj[,parm] 11 | } 12 | q1 <- ( 1 - level ) / 2 13 | h1 <- apply( mcmcobj, 2, stats::quantile, q1 ) 14 | q2 <- 1 - ( 1 - level ) / 2 15 | h2 <- apply( mcmcobj, 2, stats::quantile, q2 ) 16 | res <- data.frame( h1, h2) 17 | colnames(res)[1] <- paste0( round( 100*q1,1 ), ' %') 18 | colnames(res)[2] <- paste0( round( 100*q2,1 ), ' %') 19 | rownames(res) <- colnames(mcmcobj) 20 | return(res) 21 | } 22 | -------------------------------------------------------------------------------- /R/mcmc_extract_samples_first_chain.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_extract_samples_first_chain.R 2 | ## File Version: 0.04 3 | 4 | mcmc_extract_samples_first_chain <- function(mcmcobj) 5 | { 6 | if ( ! is.matrix(mcmcobj) ){ 7 | dat.bugs <- mcmcobj[[1]] 8 | } else { 9 | dat.bugs <- mcmcobj 10 | } 11 | return(dat.bugs) 12 | } 13 | -------------------------------------------------------------------------------- /R/mcmc_plot.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_plot.R 2 | ## File Version: 0.222 3 | 4 | 5 | #-- mcmc plot 6 | mcmc_plot <- function(mcmcobj, ...) 7 | { 8 | mcmcobj <- mcmc_extract_samples_first_chain(mcmcobj=mcmcobj) 9 | x <- list( mcmcobj=mcmcobj ) 10 | x$amh_summary <- mcmc_summary(mcmcobj) 11 | class(x) <- 'amh' 12 | amh_plot(x, ... ) 13 | } 14 | -------------------------------------------------------------------------------- /R/mcmc_rename_define_symbols.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_rename_define_symbols.R 2 | ## File Version: 0.061 3 | 4 | mcmc_rename_define_symbols <- function() 5 | { 6 | trans <- c('X', 'Z', 'M') 7 | orig <- c('[', ']', ',') 8 | res <- list(trans=trans, orig=orig) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/mcmc_rename_helper.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_rename_helper.R 2 | ## File Version: 0.051 3 | 4 | mcmc_rename_helper <- function( string, rep_string=3, pre=3, suff=3) 5 | { 6 | string <- paste0(rep( string, rep_string ), collapse='') 7 | pre <- paste0(rep( '_', pre ), collapse='') 8 | suff <- paste0(rep( '_', suff ), collapse='') 9 | trans <- paste0( pre, string, suff ) 10 | return(trans) 11 | } 12 | -------------------------------------------------------------------------------- /R/mcmc_rename_parameter_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_rename_parameter_names.R 2 | ## File Version: 0.121 3 | 4 | mcmc_rename_parameter_names <- function( vec, orig, trans) 5 | { 6 | NO <- length(orig) 7 | for (oo in 1L:NO){ 8 | trans_oo <- mcmc_rename_helper( string=trans[oo] ) 9 | trans_oo <- gsub( ' ', '', trans_oo) 10 | vec <- gsub( orig[oo], trans_oo, vec, fixed=TRUE) 11 | } 12 | return(vec) 13 | } 14 | -------------------------------------------------------------------------------- /R/mcmc_rename_undo_parameter_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_rename_undo_parameter_names.R 2 | ## File Version: 0.061 3 | 4 | mcmc_rename_undo_parameter_names <- function( vec, orig, trans) 5 | { 6 | NO <- length(orig) 7 | for (oo in 1L:NO){ 8 | trans_oo <- mcmc_rename_helper( string=trans[oo] ) 9 | vec <- gsub( trans_oo, orig[oo], vec, fixed=TRUE) 10 | } 11 | return(vec) 12 | } 13 | -------------------------------------------------------------------------------- /R/mcmc_vcov.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmc_vcov.R 2 | ## File Version: 0.13 3 | 4 | 5 | #--- variance covariance matrix 6 | mcmc_vcov <- function( mcmcobj, exclude="deviance" ) 7 | { 8 | mcmcobj <- mcmc_extract_samples_first_chain(mcmcobj=mcmcobj) 9 | mcmcobj <- mcmcobj[, ! ( colnames(mcmcobj) %in% exclude ) ] 10 | res <- stats::var(mcmcobj) 11 | colnames(mcmcobj) -> colnames(res) -> rownames(res) 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/mcmcirt_compute_mh.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmcirt_compute_mh.R 2 | ## File Version: 0.04 3 | 4 | 5 | mcmcirt_compute_mh <- function(ll_old, ll_new) 6 | { 7 | NL <- length(ll_new) 8 | mh <- ll_new - ll_old 9 | prob_mh <- ifelse(mh<0, exp(mh), 1) 10 | accept <- stats::runif(NL) < prob_mh 11 | #--- output 12 | ll_recent <- ifelse(accept, ll_new, ll_old) 13 | res <- list(accept=accept, ll_recent=ll_recent) 14 | return(res) 15 | } 16 | -------------------------------------------------------------------------------- /R/mcmclist2coda.R: -------------------------------------------------------------------------------- 1 | ## File Name: mcmclist2coda.R 2 | ## File Version: 0.121 3 | 4 | 5 | # write elements from mcmcmlist into code file 6 | mcmclist2coda <- function( mcmclist, name, coda.digits=5 ) 7 | { 8 | m1 <- mcmclist[[1]] 9 | vars <- colnames(m1) 10 | #--- create codaIndex file 11 | BB <- nrow(m1) 12 | VV <- length(vars) 13 | c1 <- paste( vars, seq( 1, BB*VV, BB ), seq( BB, BB*VV, BB ) ) 14 | writeLines( c1, paste0( name, '_codaIndex.txt' ) ) 15 | #--- create coda file 16 | m2 <- matrix( m1, ncol=1 ) 17 | m2 <- paste( rep(1L:BB, VV ), round( m2[,1], coda.digits ) ) 18 | writeLines( m2, paste0( name, '_coda1.txt' ) ) 19 | } 20 | 21 | -------------------------------------------------------------------------------- /R/md.pattern.sirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: md.pattern.sirt.R 2 | ## File Version: 0.121 3 | 4 | #----- Function for analyzing response patterns 5 | md.pattern.sirt <- function(dat) 6 | { 7 | dat <- as.matrix(dat) 8 | if ( ncol(dat)>1000 ){ 9 | stop('Function only works for datasets with fewer than 1000 variables!\n') 10 | } 11 | res <- md_pattern_rcpp( dat_=dat ) 12 | rp_unique <- unique(res$unique_resp_patt) 13 | res$unique_resp_patt <- match( res$unique_resp_patt, rp_unique ) 14 | res$resp_patt <- match( res$resp_patt, rp_unique ) 15 | res$dat.ordered <- res$dat[ order( res$resp_patt ), ] 16 | return(res) 17 | } 18 | 19 | 20 | #----- calling the Rcpp function 21 | md_pattern_rcpp <- function(dat_){ 22 | md_pattern_csource( dat_ ) 23 | } 24 | -------------------------------------------------------------------------------- /R/meas_inv_compute_lavaan_parnames.R: -------------------------------------------------------------------------------- 1 | ## File Name: meas_inv_compute_lavaan_parnames.R 2 | ## File Version: 0.01 3 | 4 | 5 | meas_inv_compute_lavaan_parnames <- function(object) 6 | { 7 | pars <- paste0( object$lhs, object$op, object$rhs ) 8 | return(pars) 9 | } 10 | -------------------------------------------------------------------------------- /R/mgsem_L0_approx_ot.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_L0_approx_ot.R 2 | ## File Version: 0.02 3 | 4 | 5 | mgsem_L0_approx_ot <- function(x, gamma, eps) 6 | { 7 | y <- 2/(1+exp(-gamma*(x^2+eps)^1/2) )-1 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/mgsem_L0_penalty.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_L0_penalty.R 2 | ## File Version: 0.03 3 | 4 | mgsem_L0_penalty <- function(x=x, eps, gamma, deriv=FALSE, h=min(1e-4,eps/10) ) 5 | { 6 | if (deriv){ 7 | y1 <- mgsem_L0_approx_ot(x=x+h, gamma=gamma, eps=eps) 8 | y2 <- mgsem_L0_approx_ot(x=x-h, gamma=gamma, eps=eps) 9 | y <- (y1-y2)/(2*h) 10 | } else { 11 | y <- mgsem_L0_approx_ot(x=x, gamma=gamma, eps=eps) 12 | } 13 | return(y) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_add_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_add_increment.R 2 | ## File Version: 0.04 3 | 4 | 5 | mgsem_add_increment <- function(x, h, i1, i2=NULL, symm=FALSE ) 6 | { 7 | x1 <- x 8 | if (is.vector(x)){ 9 | x1[i1] <- x[i1] + h 10 | } else { 11 | x1[i1,i2] <- x[i1,i2] + h 12 | if (symm & (i1!=i2) & (!is.null(i2)) ){ 13 | x1[i2,i1] <- x1[i2,i1] + h 14 | } 15 | } 16 | return(x1) 17 | } 18 | -------------------------------------------------------------------------------- /R/mgsem_add_list_entries.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_add_list_entries.R 2 | ## File Version: 0.06 3 | 4 | 5 | mgsem_add_list_entries <- function(list1, add_list, output_list, elements=NULL) 6 | { 7 | if (is.null(elements)){ 8 | elements <- names(add_list) 9 | } 10 | for (nn in elements){ 11 | output_list[[nn]] <- list1[[nn]] + add_list[[nn]] 12 | } 13 | return(output_list) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_bdiag.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_bdiag.R 2 | ## File Version: 0.06 3 | 4 | mgsem_bdiag <- function(x1, x2) 5 | { 6 | vars <- c(rownames(x1),rownames(x2)) 7 | n1 <- ncol(x1) 8 | n2 <- ncol(x2) 9 | mat <- matrix(0,nrow=n1+n2,ncol=n1+n2) 10 | rownames(mat) <- colnames(mat) 11 | mat[1L:n1,1L:n1] <- x1 12 | mat[n1+1L:n2,n1+1L:n2] <- x2 13 | return(mat) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_coef2partable.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_coef2partable.R 2 | ## File Version: 0.01 3 | 4 | mgsem_coef2partable <- function(coef, partable) 5 | { 6 | dfr <- partable 7 | dfr$est <- coef[ dfr$index ] 8 | return(dfr) 9 | } 10 | -------------------------------------------------------------------------------- /R/mgsem_differ_from_zero.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_differ_from_zero.R 2 | ## File Version: 0.01 3 | 4 | mgsem_differ_from_zero <- function(x, eps) 5 | { 6 | res <- abs(x) > eps 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/mgsem_eval_lp_penalty_matrix.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_eval_lp_penalty_matrix.R 2 | ## File Version: 0.084 3 | 4 | mgsem_eval_lp_penalty_matrix <- function(x, fac, p, n, h, eps_approx, 5 | pen_type="lasso", a_scad=3.7) 6 | { 7 | x1 <- x 8 | I1 <- length(x1) 9 | y <- matrix(x1, nrow=I1, ncol=I1)-sirt_matrix2(x=x1, nrow=I1) 10 | y <- mgsem_power_fun_differentiable_approx(x=y, p=p, 11 | eps=eps_approx, deriv=FALSE, approx_method='lp') 12 | if (pen_type=='lasso'){ 13 | val <- fac*y 14 | } 15 | if (pen_type=='scad'){ 16 | val <- mgsem_scad_penalty(x=y, lambda=fac, a=a_scad) 17 | } 18 | res <- sum(n*val) 19 | return(res) 20 | } 21 | -------------------------------------------------------------------------------- /R/mgsem_evaluate_penalties_evaluate_entry_fun_eval.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_evaluate_penalties_evaluate_entry_fun_eval.R 2 | ## File Version: 0.10 3 | 4 | 5 | mgsem_evaluate_penalties_evaluate_entry_fun_eval <- function(x, fun_eval, 6 | args_eval, h, deriv=FALSE) 7 | { 8 | if (deriv){ 9 | args_eval$x <- x+h 10 | val1 <- do.call(what=fun_eval, args=args_eval ) 11 | args_eval$x <- x-h 12 | val2 <- do.call(what=fun_eval, args=args_eval ) 13 | val <- (val1-val2)/(2*h) 14 | } else { 15 | args_eval$x <- x 16 | val <- do.call(what=fun_eval, args=args_eval ) 17 | } 18 | return(val) 19 | } 20 | -------------------------------------------------------------------------------- /R/mgsem_ginv.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_ginv.R 2 | ## File Version: 0.04 3 | 4 | mgsem_ginv <- function(X) 5 | { 6 | requireNamespace('MASS') 7 | res <- MASS::ginv(X=X) 8 | rownames(res) <- colnames(res) <- colnames(X) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/mgsem_grad_fun_numeric_approx.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_grad_fun_numeric_approx.R 2 | ## File Version: 0.06 3 | 4 | 5 | mgsem_grad_fun_numeric_approx <- function(x, opt_fun_args) 6 | { 7 | h <- opt_fun_args$technical$h 8 | NP <- opt_fun_args$NP 9 | grad <- rep(0,NP) 10 | for (pp in seq_len(NP) ){ 11 | coef1 <- mgsem_add_increment(x=x,h=h, i1=pp) 12 | coef2 <- mgsem_add_increment(x=x,h=-h, i1=pp) 13 | ll1 <- mgsem_opt_fun(x=coef1, opt_fun_args=opt_fun_args) 14 | ll2 <- mgsem_opt_fun(x=coef2, opt_fun_args=opt_fun_args) 15 | D1 <- (ll1-ll2)/(2*h) 16 | grad[pp] <- grad[pp] + D1 17 | } 18 | return(grad) 19 | } 20 | -------------------------------------------------------------------------------- /R/mgsem_loglike_data.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_loglike_data.R 2 | ## File Version: 0.03 3 | 4 | 5 | mgsem_loglike_data <- function(dat, Mu, Sigma) 6 | { 7 | requireNamespace('mvtnorm') 8 | ll <- sum(mvtnorm::dmvnorm(dat, mean=Mu, sigma=Sigma, log=TRUE)) 9 | return(ll) 10 | } 11 | -------------------------------------------------------------------------------- /R/mgsem_loglike_suffstat_derivative.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_loglike_suffstat_derivative.R 2 | ## File Version: 0.172 3 | 4 | 5 | mgsem_loglike_suffstat_derivative <- function(suffstat, Mu, Sigma ) 6 | { 7 | N <- suffstat$N 8 | M <- suffstat$M 9 | S <- suffstat$S 10 | if (missing(Sigma)){ 11 | res <- Mu 12 | Mu <- res$Mu 13 | Sigma <- res$Sigma 14 | } 15 | S1 <- mgsem_ginv(X=Sigma) 16 | p <- length(Mu) 17 | m1 <- M-Mu 18 | 19 | #*** mean 20 | dermean <- as.vector( N*( crossprod(m1, S1 ))) 21 | 22 | #*** covariance matrix 23 | y <- S1 %*% m1 24 | S2 <- S %*% S1 25 | S3 <- S1 %*% S2 26 | 27 | #-- output 28 | res <- list(dermean=dermean, y=y, S1=S1, S2=S2, S3=S3) 29 | return(res) 30 | } 31 | -------------------------------------------------------------------------------- /R/mgsem_modify_model.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_modify_model.R 2 | ## File Version: 0.04 3 | 4 | 5 | mgsem_modify_model <- function(model, group, entry, type, value) 6 | { 7 | for (gg in group){ 8 | for (ee in entry){ 9 | for (tt in type){ 10 | model[[gg+1]][[ee]][[tt]] <- value+0*model[[gg+1]][[ee]][[tt]] 11 | } # end tt 12 | } # end ee 13 | } # end gg 14 | #--- output 15 | return(model) 16 | } 17 | -------------------------------------------------------------------------------- /R/mgsem_modify_suffstat.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_modify_suffstat.R 2 | ## File Version: 0.01 3 | 4 | 5 | mgsem_modify_suffstat <- function(model, group, entry, value) 6 | { 7 | for (gg in group){ 8 | for (ee in entry){ 9 | model[[gg]][[ee]] <- value+0*model[[gg]][[ee]] 10 | } # end ee 11 | } # end gg 12 | #--- output 13 | return(model) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_numerical_gradient.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_numerical_gradient.R 2 | ## File Version: 0.05 3 | 4 | 5 | mgsem_numerical_gradient <- function(par, FUN, h, symmetrize=FALSE, ...) 6 | { 7 | res <- CDM::numerical_gradient(par=par, FUN=FUN, h=h, ...) 8 | if (symmetrize){ 9 | res <- sirt_symmetrize(x=res) 10 | res <- sirt_add_names(x=res, names=names(par)) 11 | } 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/mgsem_partable2coef.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_partable2coef.R 2 | ## File Version: 0.05 3 | 4 | mgsem_partable2coef <- function(partable) 5 | { 6 | dfr <- partable 7 | ind <- which(dfr$unique==1) 8 | coef <- dfr[ ind,'est'] 9 | names(coef) <- dfr[ind,'name'] 10 | return(coef) 11 | } 12 | -------------------------------------------------------------------------------- /R/mgsem_proc_model_add_specs.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_proc_model_add_specs.R 2 | ## File Version: 0.07 3 | 4 | 5 | mgsem_proc_model_add_specs <- function(model, entry, type, ii, jj, default) 6 | { 7 | val <- default 8 | mat <- model[[entry]][[type]] 9 | if (!is.null(mat)){ 10 | val <- mat[ii,jj] 11 | } 12 | return(val) 13 | } 14 | -------------------------------------------------------------------------------- /R/mgsem_proc_model_extract_dimension.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_proc_model_extract_dimension.R 2 | ## File Version: 0.09 3 | 4 | 5 | mgsem_proc_model_extract_dimension <- function(model, entry="est", type, nrow=TRUE) 6 | { 7 | G <- length(model) 8 | gg <- 1 9 | while (gg<=G){ 10 | mat <- model[[gg]][[entry]][[type]] 11 | if (!is.null(mat)){ 12 | val <- ifelse(nrow, nrow(mat), ncol(mat) ) 13 | gg <- G+1 14 | } 15 | gg <- gg + 1 16 | } 17 | return(val) 18 | } 19 | 20 | -------------------------------------------------------------------------------- /R/mgsem_proc_model_is_B.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_proc_model_is_B.R 2 | ## File Version: 0.04 3 | 4 | 5 | mgsem_proc_model_is_B <- function(model) 6 | { 7 | H <- length(model) 8 | is_B <- 0 9 | for (hh in 1L:H){ 10 | is_B <- is_B + ( ! is.null( model[[hh]][['est']][['B']] ) ) 11 | } 12 | is_B <- ( is_B > 0 ) 13 | return(is_B) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_proc_model_single_group.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_proc_model_single_group.R 2 | ## File Version: 0.081 3 | 4 | mgsem_proc_model_single_group <- function(model) 5 | { 6 | H <- length(model) 7 | if (H==1){ 8 | entries <- c('est','index') 9 | group1 <- list() 10 | group0 <- model[[1]] 11 | for (ee in entries){ 12 | v1 <- list() 13 | for (vv in names(group0[[ee]]) ){ 14 | v1[[vv]] <- 0*group0[[ee]][[vv]] 15 | } # end vv 16 | group1[[ee]] <- v1 17 | } # end ee 18 | res <- list( group0=group0, group1=group1) 19 | } else { 20 | res <- model 21 | } 22 | #-- output 23 | return(res) 24 | } 25 | -------------------------------------------------------------------------------- /R/mgsem_scad_penalty.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_scad_penalty.R 2 | ## File Version: 0.02 3 | 4 | mgsem_scad_penalty <- function(x, lambda, a=3.7) 5 | { 6 | a <- max(a,1) 7 | x <- abs(x) 8 | res <- ifelse( x < lambda, lambda * x, 0) 9 | res <- res + ifelse( ( x >=lambda ) & ( x < a*lambda), 10 | - ( x^2 - 2*a*lambda*x+lambda^2) / ( 2*(a-1)),0 ) 11 | res <- res + ifelse( x>=a*lambda, (a+1)*lambda^2 / 2, 0 ) 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/mgsem_smoothic_penalty.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_smoothic_penalty.R 2 | ## File Version: 0.04 3 | 4 | 5 | mgsem_smoothic_penalty <- function(x, eps, deriv=FALSE) 6 | { 7 | if (deriv){ ## derivative 8 | res <- 2*x*eps / (x^2+eps)^2 9 | # 2*x*(x^2+eps) - x^2*(2*x) 10 | } else { # no derivative 11 | res <- x^2 / (x^2 + eps) 12 | } 13 | return(res) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_sqrt_diag.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_sqrt_diag.R 2 | ## File Version: 0.01 3 | 4 | mgsem_sqrt_diag <- function(x) 5 | { 6 | sqrt(diag(x)) 7 | } 8 | -------------------------------------------------------------------------------- /R/mgsem_test_fun.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_test_fun.R 2 | ## File Version: 0.161 3 | 4 | 5 | mgsem_test_fun <- function(test, coef, opt_fun_args) 6 | { 7 | if (test){ 8 | requireNamespace('miceadds') 9 | #- function evaluation 10 | ll <- mgsem_opt_fun(x=coef, opt_fun_args=opt_fun_args) 11 | #- numerical gradient 12 | grad1 <- mgsem_grad_fun_numeric_approx(x=coef, opt_fun_args=opt_fun_args) 13 | #- analytical gradient 14 | args <- list(x=coef, opt_fun_args=opt_fun_args) 15 | grad <- do.call( what=mgsem_grad_fun, args=args) 16 | 17 | # dfr <- cbind( grad, grad1) 18 | 19 | #- print 20 | miceadds::Revalpr('ll') 21 | miceadds::Revalpr_maxabs('grad','grad1') 22 | stop() 23 | } 24 | } 25 | -------------------------------------------------------------------------------- /R/mgsem_update_list_entries.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_update_list_entries.R 2 | ## File Version: 0.041 3 | 4 | 5 | mgsem_update_list_entries <- function(add_list, output_list, elements=NULL) 6 | { 7 | if (is.null(elements)){ 8 | elements <- names(add_list) 9 | } 10 | for (nn in elements){ 11 | output_list[[nn]] <- add_list[[nn]] 12 | } 13 | return(output_list) 14 | } 15 | -------------------------------------------------------------------------------- /R/mgsem_vec.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_vec.R 2 | ## File Version: 0.01 3 | 4 | mgsem_vec <- function(x) 5 | { 6 | as.vector(x) 7 | } 8 | -------------------------------------------------------------------------------- /R/mgsem_vech.R: -------------------------------------------------------------------------------- 1 | ## File Name: mgsem_vech.R 2 | ## File Version: 0.02 3 | 4 | mgsem_vech <- function(x) 5 | { 6 | res <- x[ ! upper.tri(x) ] 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/mi_inv_lavaan_modification_indices.R: -------------------------------------------------------------------------------- 1 | ## File Name: mi_inv_lavaan_modification_indices.R 2 | ## File Version: 0.06 3 | 4 | mi_inv_lavaan_modification_indices <- function(mod, op=c("~1","=~")) 5 | { 6 | requireNamespace('lavaan') 7 | res <- lavaan::modificationIndices(object=mod, free.remove=FALSE, 8 | op=op, sort=TRUE) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/mirt.wrapper.itemplot.R: -------------------------------------------------------------------------------- 1 | ## File Name: mirt.wrapper.itemplot.R 2 | ## File Version: 0.08 3 | 4 | 5 | 6 | mirt.wrapper.itemplot <- function( mirt.obj, ask=TRUE, ...) 7 | { 8 | TAM::require_namespace_msg("mirt") 9 | I <- ncol( mirt.obj@Data$data ) 10 | for (ii in 1:I){ 11 | main <- paste0("Trace Lines of Item ", colnames( mirt.obj@Data$data )[ii] ) 12 | print( mirt::itemplot(mirt.obj, item=ii, main=main, ...) ) 13 | graphics::par(ask=ask) 14 | } 15 | } 16 | -------------------------------------------------------------------------------- /R/mirt_prodterms.R: -------------------------------------------------------------------------------- 1 | ## File Name: mirt_prodterms.R 2 | ## File Version: 0.091 3 | 4 | 5 | # prodterms function from mirt package 6 | # This function is not exported and hence redefined in sirt 7 | mirt_prodterms <- function (theta0, prodlist) 8 | { 9 | products <- matrix(1, ncol=length(prodlist), nrow=nrow(theta0)) 10 | for (i in 1L:length(prodlist)) { 11 | tmp <- prodlist[[i]] 12 | for (j in 1L:length(tmp)){ 13 | products[, i] <- products[, i] * theta0[, tmp[j]] 14 | } 15 | } 16 | ret <- cbind(theta0, products) 17 | return(ret) 18 | } 19 | -------------------------------------------------------------------------------- /R/mml_calc_like.R: -------------------------------------------------------------------------------- 1 | ## File Name: mml_calc_like.R 2 | ## File Version: 0.04 3 | 4 | 5 | #-- calculation of the likelihood 6 | mml_calc_like <- function (dat2, dat2resp, probs, pseudoll=0) 7 | { 8 | if ( pseudoll==0 ){ 9 | res <- MML2_CALCPOST_V1( DAT2=dat2, DAT2RESP=dat2resp, PROBS=probs) 10 | } 11 | if ( pseudoll==1 ){ 12 | res <- sirt_rcpp_rasch_mml2_calcpost_pseudoll( DAT2=dat2, DAT2RESP=dat2resp, 13 | PROBS=probs) 14 | } 15 | return(res) 16 | } 17 | 18 | -------------------------------------------------------------------------------- /R/mml_raschtype_counts.R: -------------------------------------------------------------------------------- 1 | ## File Name: mml_raschtype_counts.R 2 | ## File Version: 0.08 3 | 4 | 5 | 6 | # calculation of counts 7 | mml_raschtype_counts <- function (dat2, dat2resp, dat1, fqkyi, pik, fyiqk) 8 | { 9 | res <- MML2_RASCHTYPE_COUNTS( DAT2=dat2, DAT2RESP=dat2resp, DAT1=dat1, 10 | FQKYI=fqkyi, PIK=pik, FYIQK=fyiqk) 11 | return(res) 12 | } 13 | -------------------------------------------------------------------------------- /R/monoreg.colwise.R: -------------------------------------------------------------------------------- 1 | ## File Name: monoreg.colwise.R 2 | ## File Version: 0.13 3 | 4 | 5 | # monotone regression for all columns in a matrix 6 | monoreg.colwise <- function(yM, wM) 7 | { 8 | yM <- as.matrix(t(yM)) 9 | wM <- as.matrix(t(wM)) 10 | res <- sirt_rcpp_monoreg_rowwise( YM=yM, WM=wM ) 11 | return(t(res)) 12 | } 13 | -------------------------------------------------------------------------------- /R/monoreg.rowwise.R: -------------------------------------------------------------------------------- 1 | ## File Name: monoreg.rowwise.R 2 | ## File Version: 0.11 3 | 4 | 5 | # monotone regression for all rows in a matrix 6 | monoreg.rowwise <- function(yM, wM) 7 | { 8 | yM <- as.matrix(yM) 9 | wM <- as.matrix(wM) 10 | res <- sirt_rcpp_monoreg_rowwise( YM=yM, WM=wM ) 11 | return(res) 12 | } 13 | 14 | -------------------------------------------------------------------------------- /R/move_variables_df.R: -------------------------------------------------------------------------------- 1 | ## File Name: move_variables_df.R 2 | ## File Version: 0.02 3 | 4 | ##-- move variables in a data frame 5 | move_variables_df <- function(x, after_var, move_vars) 6 | { 7 | cnx <- colnames(x) 8 | i1 <- which(cnx==after_var) 9 | vars1 <- cnx[ seq(1,i1) ] 10 | vars2 <- move_vars 11 | vars3 <- setdiff( cnx, c(vars1, vars2) ) 12 | x <- x[, c(vars1, vars2, vars3) ] 13 | return(x) 14 | } 15 | -------------------------------------------------------------------------------- /R/nedelsky.latresp.R: -------------------------------------------------------------------------------- 1 | ## File Name: nedelsky.latresp.R 2 | ## File Version: 0.113 3 | 4 | 5 | #---- latent responses for Nedelsky function 6 | nedelsky.latresp <- function(K) 7 | { 8 | nodes <- c(0,1) 9 | ndim <- K 10 | combis <- as.matrix( expand.grid( as.data.frame( 11 | matrix( rep(nodes, ndim), ncol=ndim )))) 12 | return(combis) 13 | } 14 | -------------------------------------------------------------------------------- /R/noharm_sirt_create_parameter_matrices.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_create_parameter_matrices.R 2 | ## File Version: 0.041 3 | 4 | noharm_sirt_create_parameter_matrices <- function(mat_label, parm_table, parm_index) 5 | { 6 | nrow <- parm_index[[mat_label]]$nrow 7 | ncol <- parm_index[[mat_label]]$ncol 8 | mat <- matrix(0, nrow=nrow, ncol=ncol) 9 | x1 <- parm_table[ parm_index[[mat_label]]$row_parm_table, 'est'] 10 | mat[ as.matrix(parm_index[[mat_label]]$entries) ] <- x1 11 | return(mat) 12 | } 13 | -------------------------------------------------------------------------------- /R/noharm_sirt_implied_cov.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_implied_cov.R 2 | ## File Version: 0.01 3 | 4 | noharm_sirt_implied_cov <- function(Fmat, Pmat, Psimat) 5 | { 6 | gamma_val <- (Fmat %*% Pmat) %*% t(Fmat) + Psimat 7 | return(gamma_val) 8 | } 9 | -------------------------------------------------------------------------------- /R/noharm_sirt_number_estimated_parameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_number_estimated_parameters.R 2 | ## File Version: 0.03 3 | 4 | noharm_sirt_number_estimated_parameters <- function(I, Fpatt, Ppatt, Psipatt) 5 | { 6 | Nestpars <- list(total=0) 7 | Nestpars$total <- Nestpars$thresh <- I 8 | Nestpars$F <- sum( Fpatt > 0 ) 9 | Nestpars$total <- Nestpars$total + Nestpars$F 10 | Nestpars$P <- sum( diag(Ppatt)==1 ) / 2 + sum( Ppatt==1 ) / 2 11 | Nestpars$total <- Nestpars$total + Nestpars$P 12 | Nestpars$Psi <- 1/2 * sum( Psipatt==1 ) 13 | Nestpars$total <- Nestpars$total + Nestpars$Psi 14 | #--- output 15 | return(Nestpars) 16 | } 17 | -------------------------------------------------------------------------------- /R/noharm_sirt_optim_function_R.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_optim_function_R.R 2 | ## File Version: 0.05 3 | 4 | 5 | noharm_sirt_optim_function_R <- function(gamma_val, delta, I, wgtm, pm, 6 | b0.jk, b1.jk, b2.jk, b3.jk) 7 | { 8 | val <- 0 9 | for (ii in 1L:(I-1)){ 10 | for (jj in (ii+1):I){ 11 | if (wgtm[ii,jj]>0 ){ 12 | x_ij <- gamma_val[ii,jj] / sqrt( delta[ii] * delta[jj] ) 13 | pm_exp <- b0.jk[ii,jj] + b1.jk[ii,jj]*x_ij + b2.jk[ii,jj]*x_ij^2 + 14 | b3.jk[ii,jj]*x_ij^3 15 | val <- val + wgtm[ii,jj]*(pm[ii,jj] - pm_exp)^2 16 | } 17 | } 18 | } 19 | #-- output 20 | return(val) 21 | } 22 | -------------------------------------------------------------------------------- /R/noharm_sirt_outer_coefs.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_outer_coefs.R 2 | ## File Version: 0.03 3 | 4 | noharm_sirt_outer_coefs <- function(x) 5 | { 6 | y <- as.matrix( TAM::tam_outer(x,x) ) 7 | return(y) 8 | } 9 | -------------------------------------------------------------------------------- /R/noharm_sirt_partable_extract_par.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_partable_extract_par.R 2 | ## File Version: 0.03 3 | 4 | noharm_sirt_partable_extract_par <- function(parm_table, col="est") 5 | { 6 | extract_index <- attr(parm_table, 'extract_index') 7 | x <- parm_table[ extract_index, col] 8 | return(x) 9 | } 10 | -------------------------------------------------------------------------------- /R/noharm_sirt_partable_include_par.R: -------------------------------------------------------------------------------- 1 | ## File Name: noharm_sirt_partable_include_par.R 2 | ## File Version: 0.02 3 | 4 | noharm_sirt_partable_include_par <- function(par, parm_table) 5 | { 6 | non_fixed <- attr(parm_table, 'non_fixed') 7 | include_index <- attr(parm_table, 'include_index') 8 | parm_table$est[ non_fixed ] <- par[ include_index ] 9 | return(parm_table) 10 | } 11 | -------------------------------------------------------------------------------- /R/nr.numdiff.R: -------------------------------------------------------------------------------- 1 | ## File Name: nr.numdiff.R 2 | ## File Version: 0.09 3 | 4 | 5 | nr.numdiff <- function( ll0, ll1, ll2, h, eps=10^(-10) ) 6 | { 7 | d1 <- ( ll1 - ll2 ) / ( 2 * h ) # negative sign? 8 | # second order derivative 9 | # f(x+h)+f(x-h)=2*f(x) + f''(x)*h^2 10 | d2 <- ( ll1 + ll2 - 2*ll0 ) / h^2 11 | d2 <- ifelse( abs(d2) < eps, eps, d2 ) 12 | delta.change <- - d1 / d2 13 | return(delta.change) 14 | } 15 | -------------------------------------------------------------------------------- /R/package_version_date.R: -------------------------------------------------------------------------------- 1 | ## File Name: package_version_date.R 2 | ## File Version: 0.091 3 | 4 | package_version_date <- function(package) 5 | { 6 | d1 <- utils::packageDescription(pkg=package) 7 | res <- paste( d1$Package, ' ', d1$Version, 8 | ' (', d1$Date, ')', sep='') 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/penalty_D1_abs.R: -------------------------------------------------------------------------------- 1 | ## File Name: penalty_D1_abs.R 2 | ## File Version: 0.02 3 | 4 | 5 | penalty_D1_abs <- function(x, lambda, eps) 6 | { 7 | res <- lambda*sqrt( x^2 + eps ) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/penalty_D1_mcp.R: -------------------------------------------------------------------------------- 1 | ## File Name: penalty_D1_mcp.R 2 | ## File Version: 0.03 3 | 4 | 5 | penalty_D1_mcp <- function(x, lambda, eps, a=2.7) 6 | { 7 | x <- abs(x) 8 | res <- ifelse( x < a*lambda, lambda*sqrt(x^2 + eps) - x^2 / (2*a), .5*a*lambda^2) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/penalty_D1_scad.R: -------------------------------------------------------------------------------- 1 | ## File Name: penalty_D1_scad.R 2 | ## File Version: 0.05 3 | 4 | 5 | penalty_D1_scad <- function(x, lambda, eps, a=3.7) 6 | { 7 | x <- abs(x) 8 | res <- ifelse( x < lambda, lambda * sqrt( x^2 + eps ), 0) 9 | res <- res + ifelse( ( x >=lambda ) & ( x < a*lambda), 10 | - ( x^2 - 2*a*lambda*sqrt(x^2+eps)+lambda^2) / ( 2*(a-1)),0 ) 11 | res <- res + ifelse( x>=a*lambda, (a+1)*lambda^2 / 2, 0 ) 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/plot.lsdm.R: -------------------------------------------------------------------------------- 1 | ## File Name: plot.lsdm.R 2 | ## File Version: 0.02 3 | 4 | 5 | plot.lsdm <- function(x, ...) 6 | { 7 | graphics::matplot( x=x$theta, y=t(x$attr.curves), xlab=expression(theta), 8 | ylab="Attribute response curve", ylim=c(0,1), ... ) 9 | } 10 | -------------------------------------------------------------------------------- /R/pow.R: -------------------------------------------------------------------------------- 1 | ## File Name: pow.R 2 | ## File Version: 0.05 3 | 4 | pow <- function(x, a) 5 | { 6 | return( x^a ) 7 | } 8 | -------------------------------------------------------------------------------- /R/predict_scale_group_means.R: -------------------------------------------------------------------------------- 1 | ## File Name: predict_scale_group_means.R 2 | ## File Version: 0.03 3 | 4 | 5 | predict_scale_group_means <- function(object, M, SD) 6 | { 7 | a <- object$a 8 | b <- object$b 9 | M_trafo <- a*M+b 10 | SD_trafo <- a*SD 11 | #-- output 12 | res <- list(M_trafo=M_trafo, SD_trafo=SD_trafo) 13 | return(res) 14 | } 15 | -------------------------------------------------------------------------------- /R/print_digits.R: -------------------------------------------------------------------------------- 1 | ## File Name: print_digits.R 2 | ## File Version: 0.03 3 | 4 | print_digits <- function(x, digits=NULL) 5 | { 6 | NC <- ncol(x) 7 | if (length(digits)==1){ 8 | digits <- rep(digits, NC) 9 | } 10 | for (cc in 1:NC){ 11 | y <- x[,cc] 12 | if (is.numeric(y)){ 13 | x[,cc] <- round(y, digits=digits[cc]) 14 | } 15 | } 16 | print(x) 17 | invisible(x) 18 | } 19 | -------------------------------------------------------------------------------- /R/prior_model_pars_CleanString.R: -------------------------------------------------------------------------------- 1 | ## File Name: prior_model_pars_CleanString.R 2 | ## File Version: 0.09 3 | 4 | 5 | #-- clean string 6 | prior_model_pars_CleanString <- function( ps ){ 7 | ps <- gsub( " ", "", ps ) 8 | ps <- ps[ ps !="" ] 9 | NP <- length(ps) 10 | for (pp in 1:NP){ 11 | ps_pp <- ps[pp] 12 | # locate comment symbol 13 | h1 <- gregexpr(pattern='#', text=ps_pp) 14 | if ( h1 > 0){ 15 | ps[pp] <- substring( ps_pp, 1, h1[[1]] -1) 16 | } 17 | } 18 | ps <- ps[ ps !="" ] 19 | return(ps) 20 | } 21 | -------------------------------------------------------------------------------- /R/prob_genlogis_4pl.R: -------------------------------------------------------------------------------- 1 | ## File Name: prob_genlogis_4pl.R 2 | ## File Version: 0.08 3 | 4 | 5 | prob_genlogis_4pl <- function(theta, b, a, c, d, alpha1, alpha2, Qmatrix) 6 | { 7 | pjk <- prob_raschtype_genlogis( theta=theta, b=b, alpha1=alpha1, 8 | alpha2=alpha2, fixed.a=a, Qmatrix=Qmatrix) 9 | if ( (any(c>0)) | (any(d<1)) ){ 10 | np <- nrow(pjk) 11 | cM <- sirt_matrix2( x=c, nrow=np ) 12 | dM <- sirt_matrix2( x=d, nrow=np ) 13 | pjk <- cM + (dM - cM) * pjk 14 | } 15 | #--- output 16 | return(pjk) 17 | } 18 | -------------------------------------------------------------------------------- /R/qmc.nodes.R: -------------------------------------------------------------------------------- 1 | ## File Name: qmc.nodes.R 2 | ## File Version: 0.15 3 | 4 | qmc.nodes <- function( snodes, ndim ) 5 | { 6 | TAM::require_namespace_msg("sfsmisc") 7 | r1 <- sfsmisc::QUnif(n=snodes, min=0, max=1, n.min=1, p=ndim, leap=409) 8 | theta <- as.matrix( stats::qnorm(r1) ) 9 | return(theta) 10 | } 11 | -------------------------------------------------------------------------------- /R/rasch.conquest.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch.conquest.R 2 | ## File Version: 1.34 3 | rasch.conquest <- function(...){ 4 | .Defunct(new="R2conquest", package="sirt") 5 | } 6 | -------------------------------------------------------------------------------- /R/rasch.pml2.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch.pml2.R 2 | ## File Version: 4.15 3 | rasch.pml2 <- function(...){ 4 | .Defunct(new="rasch.pml3", package="sirt") 5 | } 6 | -------------------------------------------------------------------------------- /R/rasch_jml_centeritems.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_jml_centeritems.R 2 | ## File Version: 0.04 3 | 4 | rasch_jml_centeritems <- function(b, centeritems) 5 | { 6 | if (centeritems){ 7 | b <- b - mean(b) 8 | } 9 | return(b) 10 | } 11 | -------------------------------------------------------------------------------- /R/rasch_jml_centerpersons.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_jml_centerpersons.R 2 | ## File Version: 0.04 3 | 4 | rasch_jml_centerpersons <- function(theta, dat1, centerpersons) 5 | { 6 | if (centerpersons){ 7 | theta <- theta - stats::weighted.mean( theta, dat1[,2] ) 8 | } 9 | return(theta) 10 | } 11 | -------------------------------------------------------------------------------- /R/rasch_jml_emp_discrim.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_jml_emp_discrim.R 2 | ## File Version: 0.08 3 | 4 | 5 | 6 | # Function for calculating empirical discrimination 7 | # slope estimation (WINSTEPS manual p. 300) 8 | rasch_jml_emp_discrim <- function( theta, b, dat, dat.resp=1-is.na(dat.resp), freq ) 9 | { 10 | N <- length(theta) 11 | I <- length(b) 12 | pni <- .prob.rasch( theta=theta, b=b ) 13 | bM <- matrix(b, nrow=N, ncol=I, byrow=TRUE) 14 | thetaM <- matrix(theta, nrow=N, ncol=I) 15 | tbdiff <- thetaM - bM 16 | tdf <- tbdiff * dat.resp * freq 17 | t1 <- colSums( ( dat - pni ) * tdf ) 18 | t2 <- colSums( pni * ( 1 - pni ) * tbdiff * tdf) 19 | res <- 1 + t1/t2 20 | return(res) 21 | } 22 | 23 | # emp.discr <- rasch_jml_emp_discrim 24 | -------------------------------------------------------------------------------- /R/rasch_jml_itemfit.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_jml_itemfit.R 2 | ## File Version: 0.05 3 | 4 | 5 | 6 | #*** item fit Rasch model 7 | rasch_jml_itemfit <- function( theta0, b, dat ) 8 | { 9 | dat9 <- dat 10 | dat9[ is.na(dat)] <- 9 11 | ind <- is.finite(theta0) 12 | dat2 <- dat9[ ind, ] 13 | dat2.resp <- 1 * ( dat2 !=9 ) 14 | theta0 <- theta0[ ind ] 15 | p <- .prob.rasch( theta0, b ) 16 | v <- p * (1 - p) 17 | z2 <- dat2.resp * (dat2 - p)/v 18 | z2d <- z2 * dat2.resp 19 | infit <- colSums( z2d * v ) / colSums( v * dat2.resp ) 20 | outfit <- colSums(z2d) / colSums( dat2.resp ) 21 | res <- data.frame(infit, outfit ) 22 | return(res) 23 | } 24 | 25 | rasch.itemfit <- rasch_jml_itemfit 26 | 27 | -------------------------------------------------------------------------------- /R/rasch_jml_person_parameters_summary.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_jml_person_parameters_summary.R 2 | ## File Version: 0.04 3 | 4 | rasch_jml_person_parameters_summary <- function(x) 5 | { 6 | res <- data.frame(N=length(x), mean=mean(x), 7 | median=stats::quantile(x, probs=.5), 8 | sd=stats::sd(x), min=min(x), max=max(x) 9 | ) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/rasch_mml2_calc_prob.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_calc_prob.R 2 | ## File Version: 0.09 3 | 4 | rasch_mml2_calc_prob <- function( theta.k, b, fixed.a, fixed.c, fixed.d, 5 | alpha1, alpha2, Qmatrix, eps=1e-40) 6 | { 7 | pjk <- prob_genlogis_4pl(theta=theta.k, b=b, a=fixed.a, c=fixed.c, d=fixed.d, 8 | alpha1=alpha1, alpha2=alpha2, Qmatrix=Qmatrix) 9 | pjk <- ( pjk + eps ) / ( 1 + 2*eps ) 10 | pjk.M <- t(pjk) 11 | return(pjk.M) 12 | } 13 | -------------------------------------------------------------------------------- /R/rasch_mml2_difference_quotient.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_difference_quotient.R 2 | ## File Version: 0.12 3 | 4 | rasch_mml2_difference_quotient <- function(ll0, ll1, ll2, h, eps=1e-6) 5 | { 6 | # first order derivative 7 | # f(x+h) - f(x-h)=2*f'(x)*h 8 | d1 <- ( ll1 - ll2 ) / ( 2 * h ) # negative sign? 9 | # second order derivative 10 | # f(x+h)+f(x-h)=2*f(x) + f''(x)*h^2 11 | d2 <- ( ll1 + ll2 - 2*ll0 ) / h^2 12 | # change in item difficulty 13 | d2[ abs(d2) < eps ] <- eps 14 | #--- output 15 | res <- list( d1=d1, d2=d2) 16 | return(res) 17 | } 18 | -------------------------------------------------------------------------------- /R/rasch_mml2_modify_list_element.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_modify_list_element.R 2 | ## File Version: 0.03 3 | 4 | rasch_mml2_modify_list_element <- function( x, entry, value ) 5 | { 6 | x[[ entry ]] <- value 7 | return( x ) 8 | } 9 | -------------------------------------------------------------------------------- /R/rasch_mml2_mstep_calc_likelihood.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_mstep_calc_likelihood.R 2 | ## File Version: 0.06 3 | 4 | rasch_mml2_mstep_calc_likelihood <- function(G, pjk.M, n.jk, r.jk ) 5 | { 6 | qjk.M <- 1 - pjk.M 7 | ll0 <- rep(0,G) 8 | for (gg in 1:G){ 9 | ll0[gg] <- sum( r.jk[,,gg] * log(pjk.M) + (n.jk[,,gg]-r.jk[,,gg])*log(qjk.M)) 10 | } 11 | res <- sum(ll0) 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/rasch_mml2_mstep_calc_loglike.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_mstep_calc_loglike.R 2 | ## File Version: 0.02 3 | 4 | 5 | rasch_mml2_mstep_calc_loglike <- function( exp_r, prob1, exp_n, prob0=NULL) 6 | { 7 | if (is.null(prob0)){ 8 | prob0 <- 1 - prob1 9 | } 10 | y <- rowSums( exp_r * log(prob1) + (exp_n - exp_r) * log(prob0) ) 11 | return(y) 12 | } 13 | -------------------------------------------------------------------------------- /R/rasch_mml2_prior_information.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_prior_information.R 2 | ## File Version: 0.04 3 | 4 | rasch_mml2_prior_information <- function(prior.a, prior.b, prior.c, 5 | prior.d) 6 | { 7 | a <- rasch_mml2_prior_information_generate_string(prior=prior.a, 8 | distribution="N") 9 | b <- rasch_mml2_prior_information_generate_string(prior=prior.b, 10 | distribution="N") 11 | c <- rasch_mml2_prior_information_generate_string(prior=prior.c, 12 | distribution="Beta") 13 | d <- rasch_mml2_prior_information_generate_string(prior=prior.d, 14 | distribution="Beta") 15 | priors <- list( a=a, b=b, c=c, d=d) 16 | return(priors) 17 | 18 | } 19 | -------------------------------------------------------------------------------- /R/rasch_mml2_prior_information_generate_string.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_mml2_prior_information_generate_string.R 2 | ## File Version: 0.02 3 | 4 | 5 | rasch_mml2_prior_information_generate_string <- function(prior, distribution) 6 | { 7 | string <- "None" 8 | if (!is.null(prior)){ 9 | string <- paste0(distribution,"(", prior[1], ",", prior[2],")") 10 | } 11 | return(string) 12 | } 13 | -------------------------------------------------------------------------------- /R/rasch_pairwise_compute_eps.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_pairwise_compute_eps.R 2 | ## File Version: 0.02 3 | 4 | 5 | rasch_pairwise_compute_eps <- function(x) 6 | { 7 | I <- length(x)+1 8 | eps <- rep(1,I) 9 | eps[2:I] <- exp(-x) 10 | return(eps) 11 | } 12 | -------------------------------------------------------------------------------- /R/rasch_pairwise_optimize_opt_fun_terms.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_pairwise_optimize_opt_fun_terms.R 2 | ## File Version: 0.03 3 | 4 | rasch_pairwise_optimize_opt_fun_terms <- function(eps_horiz, eps_vert, n.ij, n.ji) 5 | { 6 | eps <- eps_horiz 7 | I <- length(eps) 8 | epsM <- matrix(eps_vert, nrow=I, ncol=I, byrow=TRUE) 9 | t1 <- ( n.ij*eps - n.ji*epsM )^2 10 | t2 <- (n.ij+n.ji)*eps*epsM + 1e-7 11 | t3 <- t1/t2 12 | return(t3) 13 | } 14 | -------------------------------------------------------------------------------- /R/rasch_pairwise_optimize_opt_fun_terms2.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_pairwise_optimize_opt_fun_terms2.R 2 | ## File Version: 0.131 3 | 4 | rasch_pairwise_optimize_opt_fun_terms2 <- function(eps_horiz, eps_vert, y.ij, y.ji, 5 | estimator="MINCHI") 6 | { 7 | tol <- 1e-10 8 | eps1 <- sqrt(eps_horiz + tol) 9 | I <- length(eps1) 10 | if (estimator=='ULS'){ 11 | eps_v <- eps_vert 12 | } 13 | if (estimator=='MINCHI'){ 14 | eps_v <- sqrt(eps_vert+tol) 15 | } 16 | epsM1 <- matrix(eps_v, nrow=I, ncol=I, byrow=TRUE) 17 | if (estimator=='MINCHI'){ 18 | h1 <- eps1/epsM1 19 | t3 <- ( y.ij*h1 - y.ji/h1 )^2 20 | } 21 | if (estimator=='ULS'){ 22 | t3 <- ( y.ij/epsM1 - y.ji/eps_horiz )^2 23 | } 24 | return(t3) 25 | } 26 | -------------------------------------------------------------------------------- /R/rasch_pairwise_zerosum.R: -------------------------------------------------------------------------------- 1 | ## File Name: rasch_pairwise_zerosum.R 2 | ## File Version: 0.02 3 | 4 | 5 | rasch_pairwise_zerosum <- function(eps) 6 | { 7 | b1 <- - log(eps) 8 | b2 <- b1 - mean(b1) 9 | eps <- exp(-b2) 10 | #- output 11 | return(eps) 12 | } 13 | -------------------------------------------------------------------------------- /R/read.fwf2.R: -------------------------------------------------------------------------------- 1 | ## File Name: read.fwf2.R 2 | ## File Version: 1.11 3 | 4 | 5 | # This function reads fwf files 6 | read.fwf2 <- function( file, format, variables=NULL) 7 | { 8 | ff <- readLines( file ) 9 | ind.ff1 <- c( 1, cumsum(format)[- length(format) ] + 1 ) 10 | ind.ff2 <- cumsum(format) 11 | I <- length(format) 12 | n <- length( ff ) 13 | dfr <- data.frame( matrix(0, nrow=n, ncol=I ) ) 14 | for (ii in 1:I){ 15 | dfr[,ii ] <- as.numeric( substring( ff, ind.ff1[ii], ind.ff2[ii] ) ) 16 | } 17 | if (!is.null(variables)){ 18 | colnames(dfr) <- variables 19 | } 20 | return(dfr) 21 | } 22 | 23 | -------------------------------------------------------------------------------- /R/regpolca_grouped_norm.R: -------------------------------------------------------------------------------- 1 | ## File Name: regpolca_grouped_norm.R 2 | ## File Version: 0.01 3 | 4 | regpolca_grouped_norm <- function(x) 5 | { 6 | nx <- length(x) 7 | norm <- sqrt(nx)*sqrt(sum(x^2)) 8 | return(norm) 9 | } 10 | -------------------------------------------------------------------------------- /R/regpolca_penalty_fun_value_grouped.R: -------------------------------------------------------------------------------- 1 | ## File Name: regpolca_penalty_fun_value_grouped.R 2 | ## File Version: 0.01 3 | 4 | regpolca_penalty_fun_value_grouped <- function(x_ii, combis_ii, 5 | regular_lam, eps, penalty_used) 6 | { 7 | diff_ii <- x_ii[ combis_ii[,1] ] - x_ii[ combis_ii[,2] ] 8 | norm_ii <- regpolca_grouped_norm(x=diff_ii) 9 | a1 <- penalty_used( x=norm_ii, lambda=regular_lam, eps=eps ) 10 | return(a1) 11 | } 12 | -------------------------------------------------------------------------------- /R/regpolca_penalty_fun_value_nongrouped.R: -------------------------------------------------------------------------------- 1 | ## File Name: regpolca_penalty_fun_value_nongrouped.R 2 | ## File Version: 0.02 3 | 4 | regpolca_penalty_fun_value_nongrouped <- function(x_ii, combis_ii, 5 | regular_lam, eps, penalty_used) 6 | { 7 | diff_ii <- x_ii[ combis_ii[,1] ] - x_ii[ combis_ii[,2] ] 8 | a1 <- penalty_used( x=diff_ii, lambda=regular_lam, eps=eps ) 9 | return(a1) 10 | } 11 | -------------------------------------------------------------------------------- /R/regpolca_postproc_ic.R: -------------------------------------------------------------------------------- 1 | ## File Name: regpolca_postproc_ic.R 2 | ## File Version: 0.05 3 | 4 | 5 | regpolca_postproc_ic <- function(ic, n_reg) 6 | { 7 | ic$n_reg <- n_reg 8 | ic$np.items <- ic$np.items - ic$n_reg 9 | ic <- xxirt_ic_compute_criteria(ic=ic) 10 | return(ic) 11 | } 12 | -------------------------------------------------------------------------------- /R/regpolca_postproc_prob_Theta.R: -------------------------------------------------------------------------------- 1 | ## File Name: regpolca_postproc_prob_Theta.R 2 | ## File Version: 0.08 3 | 4 | regpolca_postproc_prob_Theta <- function(probs_Theta) 5 | { 6 | K <- nrow(probs_Theta) 7 | G <- ncol(probs_Theta) 8 | rownames(probs_Theta) <- paste0('Class', 1:K) 9 | colnames(probs_Theta) <- paste0('Gr', 1:G) 10 | return(probs_Theta) 11 | } 12 | -------------------------------------------------------------------------------- /R/regpolca_proc_data.R: -------------------------------------------------------------------------------- 1 | ## File Name: regpolca_proc_data.R 2 | ## File Version: 0.03 3 | 4 | regpolca_proc_data <- function(dat, group) 5 | { 6 | ncats <- apply(dat, 2, max, na.rm=TRUE)+1 7 | lca_dich <- max(ncats)==2 8 | I <- ncol(dat) 9 | N <- nrow(dat) 10 | if (is.null(group)){ 11 | group <- rep(1, N) 12 | } 13 | groups <- unique(sort(group)) 14 | group <- match(group, groups) 15 | G <- length(groups) 16 | Ni <- colSums(1-is.na(dat)) 17 | #- output 18 | res <- list(ncats=ncats, lca_dich=lca_dich, I=I, N=N, group=group, 19 | groups=groups, G=G, Ni=Ni) 20 | return(res) 21 | } 22 | -------------------------------------------------------------------------------- /R/rm_calclike.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_calclike.R 2 | ## File Version: 0.07 3 | 4 | 5 | #**** calculation of the likelihood 6 | rm_calclike <- function(dat2, dat2resp, probs,K){ 7 | RM_CALCPOST( DAT2=dat2, DAT2RESP=dat2resp, PROBS=probs, KK=K) 8 | } 9 | -------------------------------------------------------------------------------- /R/rm_center_vector.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_center_vector.R 2 | ## File Version: 0.09 3 | 4 | rm_center_vector <- function( vec, center_type, do_log=FALSE ) 5 | { 6 | # log metric 7 | if (do_log){ 8 | vec <- log(vec) 9 | } 10 | #--- center_type=1 11 | if ( center_type==1){ 12 | RR <- length(vec) 13 | vec[RR] <- - sum( vec[-RR] ) 14 | } 15 | #--- center_type=2 16 | if ( center_type==2){ 17 | vec <- vec - mean(vec) 18 | } 19 | # reconvert to exp metric 20 | if (do_log){ 21 | vec <- exp(vec) 22 | } 23 | #--- output 24 | return(vec) 25 | } 26 | -------------------------------------------------------------------------------- /R/rm_determine_fixed_tau_parameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_determine_fixed_tau_parameters.R 2 | ## File Version: 0.082 3 | 4 | rm_determine_fixed_tau_parameters <- function( K, maxK, VV, tau.item.fixed=NULL, val=99) 5 | { 6 | if ( min(maxK) < K ){ 7 | for (vv in 1L:VV){ 8 | K.vv <- maxK[vv] 9 | if ( K.vv < K ){ 10 | for (zz in (K.vv+1):K ){ 11 | d1 <- data.frame( item=vv, categ=zz, val=val) 12 | tau.item.fixed <- rbind( tau.item.fixed, d1 ) 13 | } 14 | } 15 | } 16 | tau.item.fixed <- as.matrix(tau.item.fixed ) 17 | } 18 | return(tau.item.fixed) 19 | } 20 | -------------------------------------------------------------------------------- /R/rm_eap_reliability.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_eap_reliability.R 2 | ## File Version: 0.05 3 | 4 | rm_eap_reliability <- function( EAP, SE_EAP ) 5 | { 6 | EAP.rel <- 1 - mean( SE_EAP^2 ) / ( mean( SE_EAP^2 ) + stats::var( EAP ) ) 7 | return(EAP.rel) 8 | } 9 | -------------------------------------------------------------------------------- /R/rm_facets_calcprobs.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_calcprobs.R 2 | ## File Version: 0.102 3 | 4 | 5 | #--- cpp implementation of calculation of facets probabilities 6 | rm_facets_calcprobs <- function( b.item, b.rater, Qmatrix, tau.item, 7 | VV, K, I, TP, a.item, a.rater, item.index, rater.index, 8 | theta.k, RR ) 9 | { 10 | probs <- rm_facets_calcprobs_cpp( b_item=b.item, b_rater=b.rater, 11 | Qmatrix=Qmatrix, tau_item=tau.item, K=K, I=I, 12 | TP=TP, a_item=a.item, a_rater=a.rater, item_index=item.index-1, 13 | rater_index=rater.index-1, theta_k=theta.k ) 14 | probs <- array( probs, dim=c(I, K+1, TP ) ) 15 | return(probs) 16 | } 17 | 18 | .rm.facets.calcprobs2 <- rm_facets_calcprobs 19 | -------------------------------------------------------------------------------- /R/rm_facets_center_value.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_center_value.R 2 | ## File Version: 0.04 3 | 4 | rm_facets_center_value <- function(x, value=0) 5 | { 6 | y <- x + value - mean(x, na.rm=TRUE) 7 | return(y) 8 | } 9 | 10 | -------------------------------------------------------------------------------- /R/rm_facets_center_value_aggregate.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_center_value_aggregate.R 2 | ## File Version: 0.071 3 | 4 | rm_facets_center_value_aggregate <- function(x, index, value=0) 5 | { 6 | y <- rep(NA, length(x) ) 7 | index_unique <- unique(index) 8 | NI <- length(index_unique) 9 | for (ii in 1L:NI){ 10 | index_ii <- index_unique[ii] 11 | ind_ii <- which( index==index_ii ) 12 | y[ind_ii] <- rm_facets_center_value(x=x[ind_ii], value=value) 13 | } 14 | return(y) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_facets_itempar_expanded.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_itempar_expanded.R 2 | ## File Version: 0.08 3 | 4 | 5 | 6 | ####################################################### 7 | # parameters expanded dataset 8 | rm_facets_itempar_expanded <- function( b.item, b.rater, Qmatrix, tau.item, 9 | VV, K, I, TP, a.item, a.rater, item.index, rater.index, 10 | theta.k, RR ) 11 | { 12 | b <- tau.item[ item.index, ] 13 | b0 <- ( matrix( b.rater, nrow=RR, ncol=K) )[ rater.index, ] * Qmatrix[ item.index,] 14 | b <- b + b0 15 | # a parameter 16 | a <- a.item[ item.index ] * a.rater[ rater.index ] 17 | res <- list(a=a, b=b ) 18 | return(res) 19 | } 20 | ######################################################### 21 | -------------------------------------------------------------------------------- /R/rm_facets_postproc_person.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_postproc_person.R 2 | ## File Version: 0.11 3 | 4 | rm_facets_postproc_person <- function( dat2, dat2.resp, procdata, maxK, RR, theta.k, f.qk.yi ) 5 | { 6 | person <- procdata$person.index 7 | NP <- nrow(person) 8 | person$score <- rowSums( dat2 * dat2.resp ) 9 | mkrr <- rep( maxK, RR ) 10 | person$maxscore <- rowSums( dat2.resp * sirt_matrix2( mkrr, nrow=NP) ) 11 | person$EAP <- rowSums( f.qk.yi * sirt_matrix2( theta.k, nrow=NP) ) 12 | person$SE.EAP <- sqrt( rowSums( f.qk.yi * sirt_matrix2( theta.k^2, nrow=NP) ) - ( person$EAP) ^2 ) 13 | EAP.rel <- rm_eap_reliability( EAP=person$EAP, SE_EAP=person$SE.EAP ) 14 | #--- output 15 | res <- list( person=person, EAP.rel=EAP.rel ) 16 | return(res) 17 | } 18 | -------------------------------------------------------------------------------- /R/rm_facets_pp_mle_calc_ll.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_pp_mle_calc_ll.R 2 | ## File Version: 0.151 3 | 4 | 5 | # calculate individual likelihood for item ii 6 | rm_facets_pp_mle_calc_ll <- function( probs, data, ii, eps=1e-20 ) 7 | { 8 | N <- nrow(data) 9 | probs <- log(probs) 10 | m1 <- matrix(1L:N, nrow=N, ncol=2) 11 | m1[,2] <- data[,ii] + 1 12 | h1 <- probs[ m1 ] 13 | h1[ is.na(h1) ] <- 0 14 | return(h1) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_facets_pp_mle_calc_ll_theta.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_pp_mle_calc_ll_theta.R 2 | ## File Version: 0.11 3 | 4 | 5 | 6 | rm_facets_pp_mle_calc_ll_theta <- function( data, a, b, theta ) 7 | { 8 | N <- length(theta) 9 | I <- ncol(data) 10 | ll0 <- rep(0,N) 11 | for (ii in 1L:I){ 12 | probs.ii <- rm_facets_pp_mle_calc_pcm( theta=theta, a=a, b=b, ii=ii ) 13 | res <- rm_facets_pp_mle_calc_ll( probs=probs.ii, data=data, ii=ii ) 14 | ll0 <- ll0 + res 15 | } 16 | return(ll0) 17 | } 18 | 19 | 20 | -------------------------------------------------------------------------------- /R/rm_facets_pp_mle_calc_pcm.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_pp_mle_calc_pcm.R 2 | ## File Version: 0.13 3 | 4 | 5 | #--- calculate item response probabilities 6 | rm_facets_pp_mle_calc_pcm <- function( theta, a, b, ii ) 7 | { 8 | K <- ncol(b) 9 | N <- length(theta) 10 | matrK <- sirt_matrix2( x=0:K, nrow=N) 11 | eta <- a[ii] * theta * matrK - sirt_matrix2( x=c(0,b[ii,]), nrow=N) 12 | eta <- exp(eta) 13 | probs <- eta / rowSums(eta, na.rm=TRUE) 14 | return(probs) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_facets_print_progress_deviance.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_print_progress_deviance.R 2 | ## File Version: 0.08 3 | 4 | 5 | rm_facets_print_progress_deviance <- function( dev, dev0, digits_deviance, iter ) 6 | { 7 | cat( paste( " Deviance=", round( dev, digits_deviance ), 8 | if (iter > 1 ){ " | Deviance change=" } else {""}, 9 | if( iter>1){ round( - dev + dev0, digits_deviance + 2)} else { ""} ,"\n",sep="") ) 10 | } 11 | -------------------------------------------------------------------------------- /R/rm_facets_print_progress_parameter.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_print_progress_parameter.R 2 | ## File Version: 0.08 3 | 4 | 5 | rm_facets_print_progress_parameter <- function( parm, parm0, parmlabel, digits_parm ) 6 | { 7 | cat( paste( " Maximum ", parmlabel, " parameter change=", 8 | paste( round(max(abs(parm0-parm)), digits_parm), collapse=" " ), "\n", sep="")) 9 | } 10 | -------------------------------------------------------------------------------- /R/rm_facets_print_progress_trait_distribution.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_print_progress_trait_distribution.R 2 | ## File Version: 0.08 3 | 4 | 5 | rm_facets_print_progress_trait_distribution <- function( parm, parmlabel, digits_trait ) 6 | { 7 | cat( paste( " ", parmlabel, "=", round( parm, digits_trait ), sep=""), "\n") 8 | } 9 | -------------------------------------------------------------------------------- /R/rm_facets_string_part_extract.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_facets_string_part_extract.R 2 | ## File Version: 0.06 3 | 4 | rm_facets_string_part_extract <- function( x, split, part) 5 | { 6 | vec <- strsplit( paste(x), split=split ) 7 | vec <- unlist( lapply( vec, FUN=function(vv){ vv[part] } ) ) 8 | return(vec) 9 | } 10 | -------------------------------------------------------------------------------- /R/rm_grouped_expected_likelihood.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_grouped_expected_likelihood.R 2 | ## File Version: 0.06 3 | 4 | rm_grouped_expected_likelihood <- function(pjk, n.ik, diffindex=NULL, eps=1E-30) 5 | { 6 | ll0 <- rowSums( n.ik * log(pjk+eps) ) 7 | if ( ! is.null(diffindex) ){ 8 | ll0 <- rowsum(ll0, diffindex )[,1] 9 | } 10 | return(ll0) 11 | } 12 | -------------------------------------------------------------------------------- /R/rm_ic_criteria.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_ic_criteria.R 2 | ## File Version: 0.05 3 | 4 | rm_ic_criteria <- function(ic) 5 | { 6 | dev <- ic$deviance 7 | # AIC 8 | ic$AIC <- dev + 2*ic$np 9 | # BIC 10 | ic$BIC <- dev + ( log(ic$n) )*ic$np 11 | # CAIC (consistent AIC) 12 | ic$CAIC <- dev + ( log(ic$n) + 1 )*ic$np 13 | # corrected AIC 14 | ic$AICc <- ic$AIC + 2*ic$np * ( ic$np + 1 ) / ( ic$n - ic$np - 1 ) 15 | #---- output 16 | return(ic) 17 | } 18 | -------------------------------------------------------------------------------- /R/rm_numdiff_discrete_differences.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_numdiff_discrete_differences.R 2 | ## File Version: 0.08 3 | 4 | rm_numdiff_discrete_differences <- function(ll0, ll1, ll2, h) 5 | { 6 | # first derivative 7 | # f(x+h)-f(x-h)=2*f'(x)*h 8 | d1 <- ( ll1 - ll2 ) / ( 2 * h ) 9 | # second order derivative 10 | # f(x+h)+f(x-h)=2*f(x) + f''(x)*h^2 11 | d2 <- ( ll1 + ll2 - 2*ll0 ) / h^2 12 | #--- output 13 | res <- list(d1=d1, d2=d2) 14 | return(res) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_numdiff_trim_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_numdiff_trim_increment.R 2 | ## File Version: 0.12 3 | 4 | rm_numdiff_trim_increment <- function( increment, max.increment, eps2 ) 5 | { 6 | aincr <- abs(increment) 7 | amaxincr <- abs(max.increment) 8 | ci <- ceiling( aincr / ( amaxincr + eps2 ) ) 9 | increment <- ifelse( aincr > amaxincr, increment/(2*ci), increment) 10 | return(increment) 11 | } 12 | -------------------------------------------------------------------------------- /R/rm_pcm_calcprobs.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_pcm_calcprobs.R 2 | ## File Version: 0.141 3 | 4 | 5 | 6 | #- calculation of probabilities in the partial credit model 7 | rm_pcm_calcprobs <- function( a, b, Qmatrix, theta.k, I, K, TP ) 8 | { 9 | probs <- array( 0, dim=c(I,K+1,TP) ) # categories 0, ..., K 10 | for (kk in 1L:K){ 11 | l0 <- matrix( - b[,kk], nrow=I,ncol=TP) 12 | l0 <- l0 + TAM::tam_outer( a * Qmatrix[, kk], theta.k ) 13 | probs[,kk+1,] <- l0 14 | } 15 | probs <- exp(probs) 16 | probs1 <- probs[,1,] 17 | for (kk in 2L:(K+1)){ 18 | probs1 <- probs1 + probs[,kk,] 19 | } 20 | for (kk in 1L:(K+1)){ 21 | probs[,kk,] <- probs[,kk,] / probs1 22 | } 23 | return(probs) 24 | } 25 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_expected_likelihood_item.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_expected_likelihood_item.R 2 | ## File Version: 0.16 3 | 4 | 5 | rm_sdt_calc_expected_likelihood_item <- function( nik.item, a.item, tau.item, Qmatrix, 6 | theta.k, VV, K, TP, eps=1E-10) 7 | { 8 | prob_dim <- c(VV, K+1, TP) 9 | nik_item <- as.vector(nik.item) 10 | probs <- rm_sdt_calc_probs_gpcm_rcpp( a.item=a.item, tau.item=tau.item, 11 | Qmatrix=Qmatrix, theta.k=theta.k, VV=VV, K=K, TP=TP, eps=eps, use_log=TRUE, 12 | as_vector=TRUE) 13 | ll <- sirt_rcpp_rm_sdt_calc_gradient_likelihood_item_llgrad( logprob_D1=probs, 14 | prob_D1_dim=prob_dim, nik_item=nik_item ) 15 | return(ll) 16 | } 17 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_gradient_likelihood_item.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_gradient_likelihood_item.R 2 | ## File Version: 0.08 3 | 4 | rm_sdt_calc_gradient_likelihood_item <- function(logprob1, logprob2, 5 | numdiff.parm, nik.item, diffindex) 6 | { 7 | K <- dim(nik.item)[2] - 1 8 | logprob_D1 <- ( logprob1 - logprob2 ) / (2*numdiff.parm) 9 | ll <- rowSums( logprob_D1[,1,] * nik.item[,1,] ) 10 | for (kk in 2:(K+1) ){ 11 | ll <- ll + rowSums( logprob_D1[,kk,] * nik.item[,kk,] ) 12 | } 13 | ll_grad <- ll 14 | ll_grad <- rowsum(ll_grad, diffindex ) 15 | ll_grad <- ll_grad[ rownames(ll_grad) > 0, 1 ] 16 | return(ll_grad) 17 | } 18 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_gradient_likelihood_item_llgrad.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_gradient_likelihood_item_llgrad.R 2 | ## File Version: 0.06 3 | 4 | rm_sdt_calc_gradient_likelihood_item_llgrad <- function(logprob_D1, nik.item, diffindex, K) 5 | { 6 | ll <- rowSums( logprob_D1[,1,] * nik.item[,1,] ) 7 | for (kk in 2:(K+1) ){ 8 | ll <- ll + rowSums( logprob_D1[,kk,] * nik.item[,kk,] ) 9 | } 10 | ll_grad <- ll 11 | ll_grad <- rowsum(ll_grad, diffindex ) 12 | ll_grad <- ll_grad[ rownames(ll_grad) > 0, 1 ] 13 | return(ll_grad) 14 | } 15 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_gradient_likelihood_item_llgrad2.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_gradient_likelihood_item_llgrad2.R 2 | ## File Version: 0.18 3 | 4 | rm_sdt_calc_gradient_likelihood_item_llgrad2 <- function(logprob_D1, nik.item, diffindex, K, 5 | prob_D1_dim ) 6 | { 7 | nik_item <- as.vector(nik.item) 8 | logprob_D1 <- as.vector(logprob_D1) 9 | ll_grad <- sirt_rcpp_rm_sdt_calc_gradient_likelihood_item_llgrad( logprob_D1=logprob_D1, 10 | prob_D1_dim=prob_D1_dim, nik_item=nik_item ) 11 | ll_grad <- rowsum(ll_grad, diffindex ) 12 | ll_grad <- ll_grad[ rownames(ll_grad) > 0, 1 ] 13 | return(ll_grad) 14 | } 15 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_probs_gpcm.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_probs_gpcm.R 2 | ## File Version: 0.11 3 | 4 | rm_sdt_calc_probs_gpcm <- function(a.item, tau.item, Qmatrix, theta.k, VV, K, TP, 5 | eps=0, use_log=FALSE) 6 | { 7 | a <- a.item 8 | b <- tau.item 9 | res <- rm_pcm_calcprobs( a=a, b=b, Qmatrix=Qmatrix, theta.k=theta.k, I=VV, K=K, TP=TP ) 10 | if (eps > 0){ 11 | res[ res < eps ] <- eps 12 | } 13 | if (use_log){ 14 | res <- log(res) 15 | } 16 | return(res) 17 | } 18 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_probs_gpcm_rcpp.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_probs_gpcm_rcpp.R 2 | ## File Version: 0.12 3 | 4 | rm_sdt_calc_probs_gpcm_rcpp <- function(a.item, tau.item, Qmatrix, theta.k, VV, K, TP, 5 | eps=0, use_log=FALSE, as_vector=FALSE) 6 | { 7 | K1 <- K+1 8 | prob_dim <- c(VV, K1, TP) 9 | res <- sirt_rcpp_rm_sdt_calc_probs_gpcm( a=a.item, tau=tau.item, 10 | theta_k=theta.k, VV=VV, K1=K1, TP=TP, eps=eps, use_log=use_log ) 11 | if ( ! as_vector ){ 12 | res <- array(res, dim=prob_dim) 13 | } 14 | return(res) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_probs_grm_item_rcpp.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_probs_grm_item_rcpp.R 2 | ## File Version: 0.05 3 | 4 | 5 | rm_sdt_calc_probs_grm_item_rcpp <- function( tau.item, a.item, theta.k, VV, 6 | K, TP, eps=0, use_log=FALSE) 7 | { 8 | prob_item <- sirt_rcpp_rm_sdt_calc_probs_grm_item( tau_item=tau.item, a_item=a.item, 9 | theta_k=theta.k, VV=VV, K=K, TP=TP, eps=eps, use_log=use_log) 10 | prob.item <- array(prob_item, dim=c(VV,K+1,TP) ) 11 | return(prob.item) 12 | } 13 | -------------------------------------------------------------------------------- /R/rm_sdt_calc_probs_grm_rcpp.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_calc_probs_grm_rcpp.R 2 | ## File Version: 0.05 3 | 4 | 5 | rm_sdt_calc_probs_grm_rcpp <- function(c.rater, d.rater, I, K, eps=0, use_log=FALSE) 6 | { 7 | res <- sirt_rcpp_rm_sdt_calc_probs_grm_rater( c_rater=c.rater, d_rater=d.rater, I=I, K=K, 8 | eps=eps, use_log=use_log) 9 | K1 <- K + 1 10 | res <- array(res, dim=c(I,K1,K1)) 11 | return(res) 12 | } 13 | -------------------------------------------------------------------------------- /R/rm_sdt_create_parm_index_rater.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_create_parm_index_rater.R 2 | ## File Version: 0.06 3 | 4 | 5 | rm_sdt_create_parm_index_rater <- function( est.rater, ND, item.index, 6 | rater.index) 7 | { 8 | g1 <- NULL 9 | if ( est.rater=="a"){ g1 <- seq_len(ND) } 10 | if ( est.rater=="r"){ g1 <- rater.index } 11 | if ( est.rater=="i"){ g1 <- item.index } 12 | if ( est.rater=="e"){ g1 <- rep(1,ND) } 13 | if ( est.rater=="n"){ g1 <- rep(-999,ND) } 14 | return(g1) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_sdt_create_partable_define_pargroups.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_create_partable_define_pargroups.R 2 | ## File Version: 0.09 3 | 4 | 5 | rm_sdt_create_partable_define_pargroups <- function(partable, pg1, pg2) 6 | { 7 | partable$pargroup <- 0 8 | # K <- max( partable$row, na.rm=TRUE) 9 | K <- max( partable$col, na.rm=TRUE) # changed ARb 2019-07-21 10 | for (kk in 1:K){ 11 | m1 <- max(partable$pargroup) + 1 12 | ind <- ( partable$type==pg1 ) & ( partable$col==kk) 13 | partable[ ind, "pargroup"] <- m1 * ( sum( partable[ind,"est"] ) > 0 ) 14 | } 15 | m1 <- max(partable$pargroup) + 1 16 | ind <- ( partable$type==pg2 ) 17 | partable[ ind, "pargroup"] <- m1 * ( sum( partable[ind,"est"] ) > 0 ) 18 | return(partable) 19 | } 20 | -------------------------------------------------------------------------------- /R/rm_sdt_create_partable_include_index.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_create_partable_include_index.R 2 | ## File Version: 0.05 3 | 4 | 5 | rm_sdt_create_partable_include_index <- function(partable) 6 | { 7 | partable <- data.frame( index=1:nrow(partable), partable) 8 | return(partable) 9 | } 10 | -------------------------------------------------------------------------------- /R/rm_sdt_create_partable_include_priors.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_create_partable_include_priors.R 2 | ## File Version: 0.05 3 | 4 | rm_sdt_create_partable_include_priors <- function(partable, type, obj) 5 | { 6 | vars <- c("prior_M", "prior_SD") 7 | for (vv in 1:2){ 8 | partable[ ( partable$type==type) & ( partable$est ), vars[vv] ] <- obj[vv] 9 | } 10 | return(partable) 11 | } 12 | -------------------------------------------------------------------------------- /R/rm_sdt_evaluate_prior.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_evaluate_prior.R 2 | ## File Version: 0.07 3 | 4 | rm_sdt_evaluate_prior <- function(partable) 5 | { 6 | partable <- partable[ partable$est, ] 7 | m1 <- partable$prior_M 8 | sd1 <- partable$prior_SD 9 | y1 <- sirt_dnorm(partable$value, mean=m1, sd=sd1, log=TRUE) 10 | y2 <- sirt_dnorm(m1, mean=m1, sd=sd1, log=TRUE) 11 | res <- - ( y1 - y2 ) 12 | return(res) 13 | } 14 | -------------------------------------------------------------------------------- /R/rm_sdt_evaluate_prior_derivative.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_evaluate_prior_derivative.R 2 | ## File Version: 0.08 3 | 4 | 5 | rm_sdt_evaluate_prior_derivative <- function(partable, h) 6 | { 7 | partable <- partable[ partable$est, ] 8 | m1 <- partable$prior_M 9 | sd1 <- partable$prior_SD 10 | y1 <- sirt_dnorm(partable$value+h, mean=m1, sd=sd1, log=TRUE) 11 | y2 <- sirt_dnorm(partable$value-h, mean=m1, sd=sd1, log=TRUE) 12 | res <- - ( y1 - y2 ) / (2*h) 13 | res <- ifelse(is.na(res),0,res) 14 | return(res) 15 | } 16 | -------------------------------------------------------------------------------- /R/rm_sdt_extract_par_from_partable.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_extract_par_from_partable.R 2 | ## File Version: 0.03 3 | 4 | 5 | rm_sdt_extract_par_from_partable <- function(partable) 6 | { 7 | return( partable[ partable$est, "value" ] ) 8 | } 9 | -------------------------------------------------------------------------------- /R/rm_sdt_extract_par_from_partable_add_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_extract_par_from_partable_add_increment.R 2 | ## File Version: 0.07 3 | 4 | 5 | rm_sdt_extract_par_from_partable_add_increment <- function(partable, 6 | pargroup, increment ) 7 | { 8 | partable <- partable[ partable$est, ] 9 | res <- partable[ partable$est, "value" ] 10 | res <- res + increment * ( partable$pargroup==pargroup ) 11 | return(res) 12 | } 13 | -------------------------------------------------------------------------------- /R/rm_sdt_fill_init_partable.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_fill_init_partable.R 2 | ## File Version: 0.11 3 | 4 | 5 | rm_sdt_fill_init_partable <- function(partable, par_index, tau.item, a.item, 6 | c.rater, d.rater, type) 7 | { 8 | #--- collect parameters 9 | if( type=='item' ){ 10 | pars <- list( tau.item=tau.item, a.item=a.item) 11 | } else { 12 | pars <- list( c.rater=c.rater, d.rater=d.rater) 13 | } 14 | #--- inits 15 | for (pp in names(pars)){ 16 | par_pp <- par_index[[pp]] 17 | if ( length(par_pp) > 0 ){ 18 | partable[ par_pp, "value" ] <- as.vector( pars[[ pp ]] ) 19 | } 20 | } 21 | #-- output 22 | return(partable) 23 | } 24 | -------------------------------------------------------------------------------- /R/rm_sdt_mstep_include_probs_args.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_mstep_include_probs_args.R 2 | ## File Version: 0.04 3 | 4 | rm_sdt_mstep_include_probs_args <- function(probs_args, parm_list, 5 | update_probs_args ) 6 | { 7 | for ( uu in update_probs_args){ 8 | probs_args[[ uu ]] <- parm_list[[ uu ]] 9 | } 10 | return(probs_args) 11 | } 12 | -------------------------------------------------------------------------------- /R/rm_sdt_mstep_numdiff_diffindex.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_mstep_numdiff_diffindex.R 2 | ## File Version: 0.04 3 | 4 | 5 | rm_sdt_mstep_numdiff_diffindex <- function(ll1, ll2, numdiff.parm, 6 | diffindex ) 7 | { 8 | ll_grad <- ( ll1 - ll2 ) / (2*numdiff.parm) 9 | ll_grad <- rowsum(ll_grad, diffindex ) 10 | ll_grad <- ll_grad[ rownames(ll_grad) > 0, 1 ] 11 | return(ll_grad) 12 | } 13 | -------------------------------------------------------------------------------- /R/rm_sdt_mstep_rater_function_value.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_sdt_mstep_rater_function_value.R 2 | ## File Version: 0.09 3 | 4 | 5 | rm_sdt_mstep_rater_function_value <- function(x, par_index, partable_rater, I, K, 6 | nik_rater, eps=1E-10) 7 | { 8 | K1 <- K + 1 9 | probs_dim <- c(I, K1, K1) 10 | probs_fun <- rm_sdt_calc_probs_grm_rcpp 11 | update_probs_args <- c('c.rater', 'd.rater') 12 | probs_args <- list( I=I, K=K, eps=eps, use_log=TRUE ) 13 | post <- rm_sdt_mstep_type_function_value( x=x, par_index=par_index, 14 | partable=partable_rater, type='rater', probs_args=probs_args, 15 | probs_fun=probs_fun, probs_dim=probs_dim, 16 | update_probs_args=update_probs_args, nik=nik_rater ) 17 | return(post) 18 | } 19 | -------------------------------------------------------------------------------- /R/rm_smooth_distribution.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_smooth_distribution.R 2 | ## File Version: 0.261 3 | 4 | rm_smooth_distribution <- function( theta.k, pi.k, est.mean=FALSE, 5 | skillspace="normal", est.sigma=TRUE, sigma=NULL ) 6 | { 7 | m2 <- 0 8 | if ( est.mean ){ 9 | m2 <- sum( theta.k * pi.k ) 10 | } 11 | if (est.sigma){ 12 | w2 <- sum( theta.k^2 * pi.k ) - m2^2 13 | sigma <- sqrt(w2) 14 | } 15 | if ( skillspace=='normal' ){ 16 | pi.k <- sirt_dnorm_discrete(x=theta.k, mean=m2, sd=sigma) 17 | } 18 | res <- list( mu=m2, sigma=sigma, pi.k=pi.k) 19 | return(res) 20 | } 21 | 22 | rm.smooth.distribution <- rm_smooth_distribution 23 | -------------------------------------------------------------------------------- /R/rm_squeeze.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_squeeze.R 2 | ## File Version: 0.03 3 | 4 | rm_squeeze <- function(x, lower, upper ) 5 | { 6 | x[ x < lower ] <- lower 7 | x[ x > upper ] <- upper 8 | return(x) 9 | } 10 | -------------------------------------------------------------------------------- /R/rm_summary_information_criteria_print_one_criterium.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_summary_information_criteria_print_one_criterium.R 2 | ## File Version: 0.12 3 | 4 | rm_summary_information_criteria_print_one_criterium <- function(ic, crit, desc, digits_crit=0, digits_penalty=2) 5 | { 6 | val <- ic[[crit]] 7 | deviance <- ic[["deviance"]] 8 | crit_label0 <- crit 9 | if ( nchar(crit_label0)==3){ 10 | crit_label0 <- paste0( crit_label0, " " ) 11 | } 12 | crit_label <- paste0( crit_label0, " ", "=", " ") 13 | penalty <- val - deviance 14 | cat( crit_label, round( val, digits_crit ), " | penalty","=", round( penalty,digits_penalty ), 15 | " |", desc, " \n" ) 16 | } 17 | -------------------------------------------------------------------------------- /R/rm_summary_trait_distribution.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_summary_trait_distribution.R 2 | ## File Version: 0.07 3 | 4 | rm_summary_trait_distribution <- function(object) 5 | { 6 | cat( "Trait Distribution\n" ) 7 | cat( "Mean=", round( object$mu, 3), " SD=", round( object$sigma, 3) ) 8 | cat( "\n\nEAP Reliability=") 9 | cat(round( object$EAP.rel,3 ) ) 10 | cat( "\n") 11 | } 12 | -------------------------------------------------------------------------------- /R/rm_trim_increments_mstep.R: -------------------------------------------------------------------------------- 1 | ## File Name: rm_trim_increments_mstep.R 2 | ## File Version: 0.062 3 | 4 | rm_trim_increments_mstep <- function( parm, parm0, max.increment ) 5 | { 6 | increment <- parm - parm0 7 | increment <- rm_numdiff_trim_increment( increment=increment, 8 | max.increment=max.increment, eps2=1E-10) 9 | parm <- parm0 + increment 10 | return(parm) 11 | } 12 | -------------------------------------------------------------------------------- /R/rowcolnames.R: -------------------------------------------------------------------------------- 1 | ## File Name: rowcolnames.R 2 | ## File Version: 0.02 3 | 4 | rowcolnames <- function(x, names) 5 | { 6 | rownames(x) <- colnames(x) <- names 7 | return(x) 8 | } 9 | -------------------------------------------------------------------------------- /R/ruvn.R: -------------------------------------------------------------------------------- 1 | ## File Name: ruvn.R 2 | ## File Version: 0.02 3 | 4 | ruvn <- function(N, mean=0, sd=1, exact=TRUE) 5 | { 6 | x <- stats::rnorm(N, mean=mean, sd=sd) 7 | y <- x 8 | if (exact){ 9 | v1 <- sirt_var(x) 10 | m1 <- mean(x) 11 | y <- mean+(x-m1)/sqrt(v1)*sd 12 | } 13 | 14 | #--- output 15 | return(y) 16 | } 17 | -------------------------------------------------------------------------------- /R/sirt_EAP.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_EAP.R 2 | ## File Version: 0.02 3 | 4 | sirt_EAP <- function(post, theta) 5 | { 6 | TP <- ncol(post) 7 | N <- nrow(post) 8 | D <- ncol(theta) 9 | EAP <- matrix(NA, nrow=N, ncol=D) 10 | for (tt in 1L:D){ 11 | thetaM <- sirt_matrix2(theta[,tt], nrow=N) 12 | EAP[,tt] <- rowSums(thetaM * post) 13 | } 14 | return(EAP) 15 | } 16 | -------------------------------------------------------------------------------- /R/sirt_MAP.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_MAP.R 2 | ## File Version: 0.02 3 | 4 | sirt_MAP <- function(post, theta) 5 | { 6 | TP <- ncol(post) 7 | maxval <- post[,1] 8 | indval <- 1 9 | for (tt in 2L:TP){ 10 | m0 <- maxval 11 | maxval <- ifelse( post[,tt] > m0, post[,tt], m0 ) 12 | indval <- ifelse( post[,tt] > m0, tt, indval ) 13 | } 14 | MAP <- theta[ indval, ] 15 | return(MAP) 16 | } 17 | -------------------------------------------------------------------------------- /R/sirt_Sapply.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_Sapply.R 2 | ## File Version: 0.075 3 | 4 | 5 | sirt_Sapply <- function(...) 6 | { 7 | args <- list(...) 8 | fun <- utils::getFromNamespace(x='mySapply', ns='mirt') 9 | return( do.call(what=fun, args=args) ) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_abs_smooth.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_abs_smooth.R 2 | ## File Version: 0.07 3 | 4 | sirt_abs_smooth <- function(x, deriv=0, eps=1e-4) 5 | { 6 | .expr2 <- x^2 + eps 7 | y <- sqrt(.expr2) 8 | if (deriv==0){ 9 | z <- y 10 | } 11 | if (deriv==1){ 12 | z <- x / y 13 | } 14 | if (deriv==2){ 15 | .expr4 <- 2 * x 16 | .expr5 <- 1 / y 17 | z <- .expr5 - x^2 * .expr2^(-1.5) 18 | } 19 | return(z) 20 | } 21 | -------------------------------------------------------------------------------- /R/sirt_add_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_add_increment.R 2 | ## File Version: 0.01 3 | 4 | sirt_add_increment <- function(x, pos, value) 5 | { 6 | y <- x 7 | y[pos] <- x[pos] + value 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_add_list_elements.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_add_list_elements.R 2 | ## File Version: 0.04 3 | 4 | sirt_add_list_elements <- function(res, res2) 5 | { 6 | NR <- length(res2) 7 | for (rr in 1L:NR){ 8 | res[[ names(res2)[[rr]] ]] <- res2[[rr]] 9 | } 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_add_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_add_names.R 2 | ## File Version: 0.02 3 | 4 | sirt_add_names <- function(x, names) 5 | { 6 | if (! is.null(names)){ 7 | if (is.vector(x)){ 8 | names(x) <- names 9 | } 10 | if (is.matrix(x)){ 11 | rownames(x) <- names 12 | colnames(x) <- names 13 | } 14 | } 15 | return(x) 16 | } 17 | -------------------------------------------------------------------------------- /R/sirt_add_pos.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_add_pos.R 2 | ## File Version: 0.01 3 | 4 | sirt_add_pos <- function(x, pos, val) 5 | { 6 | y <- x 7 | y[pos] <- y[pos] + val 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_antifisherz.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_antifisherz.R 2 | ## File Version: 0.04 3 | 4 | ## see fisherz2r in psych package 5 | sirt_antifisherz <- function(z) 6 | { 7 | ( exp(2*z) - 1 ) / ( exp(2*z) + 1 ) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_attach_list_elements.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_attach_list_elements.R 2 | ## File Version: 0.06 3 | 4 | sirt_attach_list_elements <- function(x, envir) 5 | { 6 | vars <- names(x) 7 | for (vv in vars){ 8 | assign( vv, x[[ vv ]], envir=envir ) 9 | } 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_colMaxs.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_colMaxs.R 2 | ## File Version: 0.06 3 | 4 | sirt_colMaxs <- function(x, na.rm=TRUE) 5 | { 6 | res <- apply(x, 2, max, na.rm=na.rm) 7 | return(res) 8 | } 9 | 10 | sirt_colMax <- sirt_colMaxs 11 | -------------------------------------------------------------------------------- /R/sirt_colMeans.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_colMeans.R 2 | ## File Version: 0.03 3 | 4 | sirt_colMeans <- function(x, na.rm=TRUE) 5 | { 6 | res <- colMeans(x, na.rm=na.rm) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_colMedians.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_colMedians.R 2 | ## File Version: 0.04 3 | 4 | sirt_colMedians <- function(x, na.rm=TRUE) 5 | { 6 | res <- apply(x, 2, stats::median, na.rm=na.rm) 7 | return(res) 8 | } 9 | 10 | sirt_colMedian <- sirt_colMedians 11 | -------------------------------------------------------------------------------- /R/sirt_colMins.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_colMins.R 2 | ## File Version: 0.04 3 | 4 | sirt_colMins <- function(x, na.rm=TRUE) 5 | { 6 | res <- apply(x, 2, min, na.rm=na.rm) 7 | return(res) 8 | } 9 | 10 | sirt_colMin <- sirt_colMins 11 | -------------------------------------------------------------------------------- /R/sirt_colSDs.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_colSDs.R 2 | ## File Version: 0.04 3 | 4 | sirt_colSDs <- function(x, na.rm=TRUE) 5 | { 6 | res <- apply(x, 2, stats::sd, na.rm=na.rm) 7 | return(res) 8 | } 9 | 10 | sirt_colSD <- sirt_colSDs 11 | -------------------------------------------------------------------------------- /R/sirt_csink.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_csink.R 2 | ## File Version: 0.06 3 | 4 | sirt_csink <- function(file) 5 | { 6 | CDM::csink( file=file ) 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_define_eps_sequence.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_define_eps_sequence.R 2 | ## File Version: 0.01 3 | 4 | sirt_define_eps_sequence <- function(eps, eps_vec) 5 | { 6 | eps_vec <- unique(c(eps_vec, eps)) 7 | eps_vec <- eps_vec[ order(eps_vec, decreasing=TRUE) ] 8 | eps_vec <- eps_vec[ eps_vec >=eps ] 9 | return(eps_vec) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_define_vector.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_define_vector.R 2 | ## File Version: 0.01 3 | 4 | sirt_define_vector <- function( value, names) 5 | { 6 | NN <- length(names) 7 | res <- rep(value, NN) 8 | names(res) <- names 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_digamma1.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_digamma1.R 2 | ## File Version: 0.01 3 | 4 | 5 | #-- derivative of digamma function 6 | sirt_digamma1 <- function(x, h=1e-3) 7 | { 8 | ( digamma(x+h) - digamma(x-h) ) / (2*h) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_display_function.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_display_function.R 2 | ## File Version: 0.02 3 | 4 | sirt_display_function <- function(length=66) 5 | { 6 | disp <- paste0( rep('-',length), collapse='') 7 | cat(disp, '\n') 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_dmvnorm.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_dmvnorm.R 2 | ## File Version: 0.114 3 | 4 | sirt_dmvnorm <- function(x, mean=NULL, sigma=NULL, ... ) 5 | { 6 | TAM::require_namespace_msg('mvtnorm') 7 | if (is.matrix(x)){ 8 | p <- ncol(x) 9 | } else { 10 | p <- 1 11 | } 12 | if (is.null(mean)){ 13 | mean <- rep(0,p) 14 | } 15 | if (is.null(sigma)){ 16 | sigma <- diag(p) 17 | if (p==1){ 18 | sigma <- 1 19 | } 20 | } 21 | if (( p>1 ) | (is.matrix(x)) ){ 22 | y <- mvtnorm::dmvnorm(x=x, mean=mean, sigma=sigma, ...) 23 | } else { 24 | y <- stats::dnorm(x=x, mean=mean, sd=sigma, ...) 25 | } 26 | return(y) 27 | } 28 | -------------------------------------------------------------------------------- /R/sirt_dmvnorm_discrete.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_dmvnorm_discrete.R 2 | ## File Version: 0.07 3 | 4 | sirt_dmvnorm_discrete <- function(x, mean=NULL, sigma=NULL, as_matrix=FALSE, 5 | eps=0, ...) 6 | { 7 | y <- sirt_dmvnorm(x=x, mean=mean, sigma=sigma, ... ) 8 | if (as_matrix){ 9 | y <- matrix(y, nrow=length(y), ncol=1) 10 | } 11 | y <- y + eps 12 | y <- y / sum(y) 13 | return(y) 14 | } 15 | -------------------------------------------------------------------------------- /R/sirt_dnorm.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_dnorm.R 2 | ## File Version: 0.01 3 | 4 | sirt_dnorm <- function(x, mean=0, sd=1, ...) 5 | { 6 | y <- stats::dnorm(x=x, mean=mean, sd=sd, ...) 7 | return(y) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_dnorm_discrete.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_dnorm_discrete.R 2 | ## File Version: 0.04 3 | 4 | sirt_dnorm_discrete <- function(x, mean=0, sd=1, ...) 5 | { 6 | fx <- stats::dnorm(x, mean=mean, sd=sd, ...) 7 | fx <- fx / sum(fx) 8 | return(fx) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_eigenvalues.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_eigenvalues.R 2 | ## File Version: 0.25 3 | 4 | 5 | # calculation of first D eigenvalues 6 | sirt_eigenvalues <- function(X, D, maxit=200, conv=10^(-6) ) 7 | { 8 | # Rcpp::List sirt_rcpp_D_eigenvalues( Rcpp::NumericMatrix Xr, int D, int maxit, 9 | # double conv ) 10 | res <- sirt_rcpp_D_eigenvalues( Xr=X, D=D, maxit=maxit, conv=conv) 11 | return(res) 12 | } 13 | -------------------------------------------------------------------------------- /R/sirt_fisherz.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_fisherz.R 2 | ## File Version: 0.07 3 | 4 | 5 | ### just a copy of fisherz from psych package 6 | sirt_fisherz <- function(rho) 7 | { 8 | 0.5 * log((1 + rho)/(1 - rho)) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_format_numb.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_format_numb.R 2 | ## File Version: 0.141 3 | 4 | 5 | #------ format numbers 6 | sirt_format_numb <- function( x, digits ) 7 | { 8 | a1 <- round( x, digits ) + 10^{-(digits +1 ) } 9 | a1 <- substring( a1, 1, nchar(a1) - 1 ) 10 | return(a1) 11 | } 12 | 13 | format_numb <- sirt_format_numb 14 | -------------------------------------------------------------------------------- /R/sirt_import_MASS_ginv.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_MASS_ginv.R 2 | ## File Version: 0.13 3 | 4 | sirt_import_MASS_ginv <- function(X,...) 5 | { 6 | TAM::require_namespace_msg('MASS') 7 | y <- MASS::ginv(X=X, ...) 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_coda_as.mcmc.list.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_coda_as.mcmc.list.R 2 | ## File Version: 0.02 3 | 4 | sirt_import_coda_as.mcmc.list <- function(...) 5 | { 6 | TAM::require_namespace_msg('coda') 7 | res <- coda::as.mcmc.list(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_coda_effectiveSize.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_coda_effectiveSize.R 2 | ## File Version: 0.02 3 | 4 | 5 | sirt_import_coda_effectiveSize <- function(...) 6 | { 7 | TAM::require_namespace_msg('coda') 8 | res <- coda::effectiveSize(...) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_import_coda_mcmc.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_coda_mcmc.R 2 | ## File Version: 0.02 3 | 4 | sirt_import_coda_mcmc <- function(...) 5 | { 6 | TAM::require_namespace_msg('coda') 7 | res <- coda::mcmc(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_function_value.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_function_value.R 2 | ## File Version: 0.091 3 | 4 | sirt_import_function_value <- function(fun, pkg, ...) 5 | { 6 | TAM::require_namespace_msg(pkg) 7 | fun1 <- NULL 8 | eval(parse(text=paste0('fun1 <- ', pkg,'::', fun))) 9 | res <- fun1(...) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_import_lavaan_cfa.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_lavaan_cfa.R 2 | ## File Version: 0.05 3 | 4 | sirt_import_lavaan_cfa <- function(...) 5 | { 6 | TAM::require_namespace_msg('lavaan') 7 | res <- lavaan::cfa(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_lavaan_fitMeasures.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_lavaan_fitMeasures.R 2 | ## File Version: 0.06 3 | 4 | sirt_import_lavaan_fitMeasures <- function(...) 5 | { 6 | TAM::require_namespace_msg('lavaan') 7 | res <- lavaan::fitMeasures(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_lavaan_lavaanify.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_lavaan_lavaanify.R 2 | ## File Version: 0.06 3 | 4 | sirt_import_lavaan_lavaanify <- function(...) 5 | { 6 | TAM::require_namespace_msg('lavaan') 7 | res <- lavaan::lavaanify(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_lavaan_parameterEstimates.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_lavaan_parameterEstimates.R 2 | ## File Version: 0.07 3 | 4 | sirt_import_lavaan_parameterEstimates <- function(...) 5 | { 6 | TAM::require_namespace_msg('lavaan') 7 | res <- lavaan::parameterEstimates(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_lavaan_parameterTable.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_lavaan_parameterTable.R 2 | ## File Version: 0.05 3 | 4 | sirt_import_lavaan_parameterTable <- function(...) 5 | { 6 | TAM::require_namespace_msg('lavaan') 7 | res <- lavaan::parameterTable(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_lavaan_standardizedSolution.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_lavaan_standardizedSolution.R 2 | ## File Version: 0.05 3 | 4 | sirt_import_lavaan_standardizedSolution <- function(...) 5 | { 6 | TAM::require_namespace_msg('lavaan') 7 | res <- lavaan::standardizedSolution(...) 8 | return(res) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_psych_cor.smooth.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_psych_cor.smooth.R 2 | ## File Version: 0.03 3 | 4 | sirt_import_psych_cor.smooth <- function(x, ...) 5 | { 6 | TAM::require_namespace_msg('psych') 7 | y <- psych::cor.smooth(x=x, ...) 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_psych_fa.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_psych_fa.R 2 | ## File Version: 0.03 3 | 4 | sirt_import_psych_fa <- function(r, nfactors, ...) 5 | { 6 | TAM::require_namespace_msg('psych') 7 | y <- psych::fa( r=r, nfactors=nfactors, ...) 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_import_psych_omega.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_import_psych_omega.R 2 | ## File Version: 0.02 3 | 4 | sirt_import_psych_omega <- function(m, nfactors, ...) 5 | { 6 | TAM::require_namespace_msg('psych') 7 | y <- psych::omega( m=m, nfactors=nfactors, ...) 8 | return(y) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_is_data.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_is_data.R 2 | ## File Version: 0.01 3 | 4 | sirt_is_data <- function(dat) 5 | { 6 | is_data <- is.data.frame(dat) | is.matrix(dat) 7 | return(is_data) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_lavaan_partable_parnames.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_lavaan_partable_parnames.R 2 | ## File Version: 0.02 3 | 4 | sirt_lavaan_partable_parnames <- function(partable) 5 | { 6 | res <- paste0( partable$lhs, partable$op, partable$rhs ) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_logdet.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_logdet.R 2 | ## File Version: 0.02 3 | 4 | sirt_logdet <- function(x) 5 | { 6 | as.numeric(determinant(x=x, logarithm=TRUE)$modulus) 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_logit_to_probs.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_logit_to_probs.R 2 | ## File Version: 0.04 3 | 4 | 5 | sirt_logit_to_probs <- function(y) 6 | { 7 | K1 <- length(y) 8 | x <- rep(0,K1+1) 9 | x[1L:K1] <- y 10 | x <- exp(x) 11 | x <- x / sum(x) 12 | return(x) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_matrix2.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_matrix2.R 2 | ## File Version: 0.04 3 | 4 | sirt_matrix2 <- function(x, nrow) 5 | { 6 | matr <- matrix( x, nrow=nrow, ncol=length(x), byrow=TRUE ) 7 | return(matr) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_matrix_lower_to_upper.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_matrix_lower_to_upper.R 2 | ## File Version: 0.03 3 | 4 | sirt_matrix_lower_to_upper <- function(x) 5 | { 6 | N <- ncol(x) 7 | for (ii in 1L:N){ 8 | for (jj in ii:N){ 9 | x[ii,jj] <- x[jj,ii] 10 | } 11 | } 12 | return(x) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_matrix_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_matrix_names.R 2 | ## File Version: 0.07 3 | 4 | sirt_matrix_names <- function(x, row_names=NULL, col_names=NULL, extract_names=NULL) 5 | { 6 | if ( ! is.null(extract_names) ){ 7 | row_names <- rownames(extract_names) 8 | col_names <- colnames(extract_names) 9 | } 10 | if ( ! is.null(row_names) ){ 11 | rownames(x) <- row_names 12 | } 13 | if ( ! is.null(col_names) ){ 14 | colnames(x) <- col_names 15 | } 16 | return(x) 17 | } 18 | -------------------------------------------------------------------------------- /R/sirt_max.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_max.R 2 | ## File Version: 0.02 3 | 4 | sirt_max <- function(x, value=0) 5 | { 6 | y <- x[ ! is.na(x) ] 7 | if (length(y)>0){ 8 | z <- max(x, na.rm=TRUE) 9 | } else { 10 | z <- 0 11 | } 12 | return(z) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_optimizer_hessian.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_optimizer_hessian.R 2 | ## File Version: 0.04 3 | 4 | sirt_optimizer_hessian <- function(res, fn, grad, h, ...) 5 | { 6 | a1 <- list(...) 7 | arglist <- list(...) 8 | if (!is.null(grad)){ 9 | fun <- grad 10 | hess_fun <- CDM::numerical_gradient 11 | } else { 12 | fun <- fn 13 | hess_fun <- CDM::numerical_Hessian 14 | } 15 | arglist <- sirt_remove_arguments_function(fun=fun, args=arglist) 16 | arglist$par <- res$par 17 | arglist$FUN <- fun 18 | arglist$h <- h 19 | res$hessian <- do.call(what=hess_fun, args=arglist) 20 | 21 | #--- output 22 | return(res) 23 | } 24 | 25 | -------------------------------------------------------------------------------- /R/sirt_optimizer_summary_print.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_optimizer_summary_print.R 2 | ## File Version: 0.141 3 | 4 | sirt_optimizer_summary_print <- function(res, msg="Information about optimization") 5 | { 6 | digits <- 6 7 | cat('\n---', msg, '---\n\n') 8 | cat( 'Optimizer', '=', res$optimizer, '\n') 9 | cat( 'Converged', '=', res$converged, '\n') 10 | cat('Optimization Function Value', '=', round(res$value,digits), '\n' ) 11 | cat( 'Number of iterations', '=', res$iter, '\n') 12 | cat( 'Elapsed time', '=', ' ') 13 | print(res$time) 14 | cat('\n') 15 | } 16 | -------------------------------------------------------------------------------- /R/sirt_osink.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_osink.R 2 | ## File Version: 0.07 3 | 4 | 5 | sirt_osink <- function(file) 6 | { 7 | CDM::osink( file=file, suffix=paste0( '__SUMMARY.Rout') ) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_parlapply.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_parlapply.R 2 | ## File Version: 0.02 3 | 4 | sirt_parlapply <- function(cl, X, FUN, verbose=FALSE, ...) 5 | { 6 | args <- list(...) 7 | args$cl <- cl 8 | args$X <- X 9 | if (verbose){ 10 | what <- pbapply::pblapply 11 | args$FUN <- FUN 12 | } else { 13 | what <- parallel::parLapply 14 | args$fun <- FUN 15 | } 16 | res_all <- do.call(what=what, args=args) 17 | return(res_all) 18 | } 19 | -------------------------------------------------------------------------------- /R/sirt_pem_adjust_dimension.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_adjust_dimension.R 2 | ## File Version: 0.06 3 | 4 | sirt_pem_adjust_dimension <- function(x, x_dim ) 5 | { 6 | if ( length(x_dim)==2 ){ 7 | x <- matrix(x, nrow=x_dim[1], ncol=x_dim[2] ) 8 | } 9 | if ( length(x_dim) >=3){ 10 | x <- array(x, dim=x_dim ) 11 | } 12 | return(x) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_pem_algorithm_compute_Pnew.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_algorithm_compute_Pnew.R 2 | ## File Version: 0.03 3 | 4 | sirt_pem_algorithm_compute_Pnew <- function( tt, P0, P1, P2) 5 | { 6 | Pnew <- (1-tt)^2 * P0 + 2*tt*(1-tt)*P1 + tt^2 * P2 7 | return(Pnew) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_pem_algorithm_compute_t.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_algorithm_compute_t.R 2 | ## File Version: 0.03 3 | 4 | sirt_pem_algorithm_compute_t <- function( i, a=1.5, h=0.1) 5 | { 6 | return( 1 + a^i * h ) 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_pem_collect_parameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_collect_parameters.R 2 | ## File Version: 0.07 3 | 4 | sirt_pem_collect_parameters <- function( parmlist, pem_parameter_index ) 5 | { 6 | NV <- pem_parameter_index[['__length_parameter_vector']] 7 | parm <- rep(0, NV) 8 | NP <- pem_parameter_index[['__n_parameters']] 9 | NPL <- length(parmlist) 10 | for (pp in 1L:NPL){ 11 | var_pp <- names(parmlist)[pp] 12 | parm_index_pp <- pem_parameter_index[[ var_pp ]] 13 | x <- as.vector(parmlist[[pp]]) 14 | parm[ parm_index_pp$index ] <- x 15 | } 16 | return(parm) 17 | } 18 | -------------------------------------------------------------------------------- /R/sirt_pem_extract_dimension.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_extract_dimension.R 2 | ## File Version: 0.03 3 | 4 | sirt_pem_extract_dimension <- function(x) 5 | { 6 | x_dim <- NULL 7 | if ( is.vector(x) ){ 8 | x_dim <- length(x) 9 | } 10 | if ( is.matrix(x) | is.array(x) | is.data.frame(x) ){ 11 | x_dim <- dim(x) 12 | } 13 | return(x_dim) 14 | } 15 | -------------------------------------------------------------------------------- /R/sirt_pem_extract_parameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_extract_parameters.R 2 | ## File Version: 0.03 3 | 4 | sirt_pem_extract_parameters <- function( parm, parmgroup, pem_parameter_index ) 5 | { 6 | info <- pem_parameter_index[[ parmgroup ]] 7 | x_dim <- info$dim 8 | x <- parm[ info$index ] 9 | x <- sirt_pem_adjust_dimension(x=x, x_dim=x_dim ) 10 | return(x) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_pem_include_ll_args.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_include_ll_args.R 2 | ## File Version: 0.06 3 | 4 | sirt_pem_include_ll_args <- function(ll_args, pem_parm, pem_pars, pem_parameter_index) 5 | { 6 | for (pp in pem_pars){ 7 | ll_args[[ pp ]] <- sirt_pem_extract_parameters( parm=pem_parm, parmgroup=pp, 8 | pem_parameter_index=pem_parameter_index ) 9 | } 10 | return(ll_args) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_pem_parameter_sequence_initial_iterations.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pem_parameter_sequence_initial_iterations.R 2 | ## File Version: 0.07 3 | 4 | sirt_pem_parameter_sequence_initial_iterations <- function( pem_parm, 5 | pem_parameter_sequence, iter ) 6 | { 7 | if (iter < 3){ 8 | for (ii in 0:2){ 9 | if (iter==ii){ 10 | pem_parameter_sequence[[ paste0('P',ii) ]] <- pem_parm 11 | } 12 | } 13 | } 14 | return(pem_parameter_sequence) 15 | } 16 | -------------------------------------------------------------------------------- /R/sirt_permutations.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_permutations.R 2 | ## File Version: 0.02 3 | 4 | 5 | sirt_permutations <- function(r,v) 6 | { 7 | NL <- length(v) 8 | NC <- NL^r 9 | mat <- matrix(0, nrow=NC, ncol=r) 10 | hh <- 1 11 | for (dd in seq(r,1,by=-1)){ 12 | m1 <- rep(v, each=NL^(hh-1) ) 13 | m1 <- rep(m1, NC/length(m1) ) 14 | mat[,dd] <- m1 15 | hh <- hh + 1 16 | } 17 | return(mat) 18 | } 19 | -------------------------------------------------------------------------------- /R/sirt_pmvnorm.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_pmvnorm.R 2 | ## File Version: 0.02 3 | 4 | 5 | sirt_pmvnorm <- function(... ) 6 | { 7 | TAM::require_namespace_msg('mvtnorm') 8 | res <- mvtnorm::pmvnorm(...) 9 | return(res) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_probs_dichotomous_to_array.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_probs_dichotomous_to_array.R 2 | ## File Version: 0.02 3 | 4 | sirt_probs_dichotomous_to_array <- function(probs) 5 | { 6 | I <- nrow(probs) 7 | TP <- ncol(probs) 8 | ncat <- 2 9 | probs1 <- array(0, dim=c(I,ncat,TP) ) 10 | probs1[,2,] <- probs 11 | probs1[,1,] <- 1 - probs 12 | return(probs1) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_probs_to_logit.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_probs_to_logit.R 2 | ## File Version: 0.02 3 | 4 | sirt_probs_to_logit <- function(y) 5 | { 6 | K <- length(y) 7 | y_logit <- log( y[-K] / y[K] ) 8 | return(y_logit) 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_progress_cat.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_progress_cat.R 2 | ## File Version: 0.04 3 | 4 | sirt_progress_cat <- function(progress) 5 | { 6 | if (progress){ 7 | cat('\n') 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_rbind_fill.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_rbind_fill.R 2 | ## File Version: 0.06 3 | 4 | ## reimplementation of plyr::rbind.fill 5 | 6 | sirt_rbind_fill <- function( x, y ) 7 | { 8 | nx <- nrow(x) 9 | ny <- nrow(y) 10 | vars <- c( colnames(x), setdiff( colnames(y), colnames(x) ) ) 11 | z <- matrix( NA, nrow=nx+ny, ncol=length(vars) ) 12 | colnames(z) <- vars 13 | z <- as.data.frame(z) 14 | z[ 1L:nx, colnames(x) ] <- x 15 | z[ nx + 1L:ny, colnames(y) ] <- y 16 | return(z) 17 | } 18 | -------------------------------------------------------------------------------- /R/sirt_remove_arguments_function.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_remove_arguments_function.R 2 | ## File Version: 0.02 3 | 4 | sirt_remove_arguments_function <- function(fun, args) 5 | { 6 | fun_formals <- formals(fun=fun) 7 | rem <- setdiff( names(args), names(fun_formals)) 8 | args <- sirt_remove_list_entries(list=args, rem=rem) 9 | return(args) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_remove_list_entries.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_remove_list_entries.R 2 | ## File Version: 0.02 3 | 4 | sirt_remove_list_entries <- function(list, rem) 5 | { 6 | NR <- length(rem) 7 | if (NR>0){ 8 | for (rr in rem){ 9 | list[[rr]] <- NULL 10 | } 11 | } 12 | return(list) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_rename_list_entry.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_rename_list_entry.R 2 | ## File Version: 0.101 3 | 4 | sirt_rename_list_entry <- function(model, name1, name2) 5 | { 6 | model_temp <- model 7 | G <- length(model) 8 | for (gg in 1L:G){ 9 | model_gg <- model_temp[[gg]] 10 | TP <- length(model_gg) 11 | for (tt in 1L:TP){ 12 | model_gg_tt <- model_gg[[tt]] 13 | ind <- which( names(model_gg_tt)==name1) 14 | if (length(ind)>0){ 15 | names(model_gg_tt)[ind] <- name2 16 | } 17 | model_gg[[tt]] <- model_gg_tt 18 | } 19 | model_temp[[gg]] <- model_gg 20 | } 21 | return(model_temp) 22 | } 23 | -------------------------------------------------------------------------------- /R/sirt_rename_list_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_rename_list_names.R 2 | ## File Version: 0.03 3 | 4 | 5 | sirt_rename_list_names <- function(x, old, new) 6 | { 7 | ind1 <- which( names(x)==old ) 8 | if (length(ind1)>0){ 9 | names(x)[ind1] <- new 10 | } 11 | return(x) 12 | } 13 | -------------------------------------------------------------------------------- /R/sirt_rmvnorm.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_rmvnorm.R 2 | ## File Version: 0.09 3 | 4 | 5 | sirt_rmvnorm <- function (n, mean=NULL, sigma, ...) 6 | { 7 | if (is.null(mean)){ 8 | mean <- rep(0,ncol(sigma) ) 9 | } 10 | CDM::CDM_rmvnorm( n=n, mean=mean, sigma=sigma ) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_round_vector.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_round_vector.R 2 | ## File Version: 0.04 3 | 4 | 5 | sirt_round_vector <- function(x, digits) 6 | { 7 | if (is.numeric(x)){ 8 | x <- round( x, digits ) 9 | } 10 | return(x) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_rsquared.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_rsquared.R 2 | ## File Version: 0.03 3 | 4 | sirt_rsquared <- function(x, expl, na.rm=TRUE) 5 | { 6 | res <- 1 - sum( ( x - expl)^2, na.rm=na.rm ) / sum( x^2, na.rm=na.rm) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_sign_space.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_sign_space.R 2 | ## File Version: 0.04 3 | 4 | sirt_sign_space <- function(sign1="=") 5 | { 6 | return( paste0(' ', sign1, ' ') ) 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_squeeze.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_squeeze.R 2 | ## File Version: 0.03 3 | 4 | sirt_squeeze <- function(x, lower=NULL, upper=NULL) 5 | { 6 | if (!is.null(lower)){ 7 | x <- ifelse( xupper, upper, x) 11 | } 12 | return(x) 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_squeeze_probs.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_squeeze_probs.R 2 | ## File Version: 0.02 3 | 4 | sirt_squeeze_probs <- function(probs, eps) 5 | { 6 | res <- ( probs + eps ) / ( 1 + 2*eps) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_sum.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_sum.R 2 | ## File Version: 0.04 3 | 4 | sirt_sum <- function(x, na.rm=TRUE) 5 | { 6 | sum(x, na.rm=na.rm) 7 | } 8 | 9 | sum0 <- sirt_sum 10 | -------------------------------------------------------------------------------- /R/sirt_sum_norm.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_sum_norm.R 2 | ## File Version: 0.04 3 | 4 | sirt_sum_norm <- function(x, na.rm=TRUE) 5 | { 6 | y <- x/sum(x, na.rm=na.rm) 7 | return(y) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_summary_cat_label_equal_value.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_cat_label_equal_value.R 2 | ## File Version: 0.05 3 | 4 | 5 | 6 | sirt_summary_cat_label_equal_value <- function( label, value, label2="", digits=NULL ) 7 | { 8 | res <- sirt_summary_label_equal_value(label=label, value=value, 9 | label2=label2, digits=digits) 10 | cat(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_summary_label_equal_value.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_label_equal_value.R 2 | ## File Version: 0.07 3 | 4 | sirt_summary_label_equal_value <- function( label, value, label2="", digits=NULL ) 5 | { 6 | if ( ! is.null(digits) ){ 7 | value <- round( value, digits) 8 | } 9 | res <- paste0( label, ' ', '=', ' ', value, ' ', label2 ) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_summary_print_call.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_call.R 2 | ## File Version: 0.09 3 | 4 | sirt_summary_print_call <- function(CALL) 5 | { 6 | TAM::tam_print_call(CALL=CALL) 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_summary_print_computation_time.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_computation_time.R 2 | ## File Version: 0.06 3 | 4 | sirt_summary_print_computation_time <- function( object ) 5 | { 6 | t1 <- object$time$start 7 | t2 <- object$time$end 8 | cat( 'Date of Analysis:', '\n' ) 9 | cat( ' Start:', paste( t1 ), '\n' ) 10 | cat( ' End :', paste( t2 ), '\n' ) 11 | cat('Computation time:', print( t2 - t1 ), '\n\n') 12 | } 13 | -------------------------------------------------------------------------------- /R/sirt_summary_print_computation_time_s1.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_computation_time_s1.R 2 | ## File Version: 0.07 3 | 4 | sirt_summary_print_computation_time_s1 <- function(object) 5 | { 6 | cat('Date of Analysis:', paste(object$s2 ), '\n' ) 7 | cat('Computation Time:', print(object$s2 - object$s1), '\n\n') 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_summary_print_display.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_display.R 2 | ## File Version: 0.04 3 | 4 | sirt_summary_print_display <- function(symbol="-", len=65) 5 | { 6 | res <- paste0( paste0(rep(symbol, len), collapse=''), '\n' ) 7 | return(res) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_summary_print_elapsed_time.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_elapsed_time.R 2 | ## File Version: 0.04 3 | 4 | sirt_summary_print_elapsed_time <- function(object) 5 | { 6 | cat( 'Elapsed time pre-processing', '=', ' ') 7 | print(object$time$time_pre) 8 | cat( 'Elapsed time optimization', '=', ' ') 9 | print(object$time$time_opt) 10 | cat( 'Elapsed time post-processing', '=', ' ') 11 | print(object$time$time_post) 12 | cat('\n') 13 | } 14 | -------------------------------------------------------------------------------- /R/sirt_summary_print_package.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_package.R 2 | ## File Version: 0.06 3 | 4 | sirt_summary_print_package <- function(pack) 5 | { 6 | cat( package_version_date(package=pack), '\n' ) 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_summary_print_package_rsession.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_package_rsession.R 2 | ## File Version: 0.07 3 | 4 | sirt_summary_print_package_rsession <- function(pack) 5 | { 6 | res <- TAM::tam_packageinfo(pack=pack) 7 | cat(res,'\n') 8 | res <- TAM::tam_rsessinfo() 9 | cat(res, '\n') 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_summary_print_packages.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_packages.R 2 | ## File Version: 0.04 3 | 4 | sirt_summary_print_packages <- function(packages) 5 | { 6 | for (pack in packages){ 7 | sirt_summary_print_package(pack=pack) 8 | } 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_summary_print_rsession.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_rsession.R 2 | ## File Version: 0.04 3 | 4 | 5 | sirt_summary_print_rsession <- function() 6 | { 7 | res <- TAM::tam_rsessinfo() 8 | cat(res, '\n\n') 9 | } 10 | -------------------------------------------------------------------------------- /R/sirt_summary_print_vector_summary.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_summary_print_vector_summary.R 2 | ## File Version: 0.03 3 | 4 | sirt_summary_print_vector_summary <- function(obji, digits) 5 | { 6 | obji <- round( summary(obji), digits) 7 | print(obji) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_sup.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_sup.R 2 | ## File Version: 0.01 3 | 4 | ## sort(unique(paste(x))) 5 | sirt_sup <- function(x) 6 | { 7 | sort(unique(paste(x))) 8 | } 9 | -------------------------------------------------------------------------------- /R/sirt_symmetrize.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_symmetrize.R 2 | ## File Version: 0.01 3 | 4 | sirt_symmetrize <- function(x) 5 | { 6 | ( x+t(x) ) / 2 7 | } 8 | -------------------------------------------------------------------------------- /R/sirt_trim_increment.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_trim_increment.R 2 | ## File Version: 0.02 3 | 4 | sirt_trim_increment <- function(increment, max_increment) 5 | { 6 | eps <- 1E-10 7 | ci <- ceiling( abs(increment) / ( max_increment + eps ) ) 8 | change <- ifelse( abs(increment) > max_increment, increment/(2*ci), increment ) 9 | return(change) 10 | } 11 | -------------------------------------------------------------------------------- /R/sirt_var.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_var.R 2 | ## File Version: 0.01 3 | 4 | sirt_var <- function(x, method="ML", na.rm=TRUE) 5 | { 6 | v1 <- stats::var(x, na.rm=na.rm) 7 | N <- sum(1-is.na(x)) 8 | v1 <- v1 * (N-1) / N 9 | return(v1) 10 | 11 | } 12 | -------------------------------------------------------------------------------- /R/sirt_vector_with_names.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirt_vector_with_names.R 2 | ## File Version: 0.06 3 | 4 | sirt_vector_with_names <- function(value, names) 5 | { 6 | vec <- rep( value, length(names) ) 7 | if ( ! is.numeric(names) ){ 8 | names(vec) <- names 9 | } 10 | return(vec) 11 | } 12 | -------------------------------------------------------------------------------- /R/sirtcat.R: -------------------------------------------------------------------------------- 1 | ## File Name: sirtcat.R 2 | ## File Version: 0.091 3 | 4 | 5 | sirtcat <- function( label, time0, active ) 6 | { 7 | if (active){ 8 | z0 <- time0 9 | cat( label, ' ' ) 10 | z1 <- Sys.time() 11 | print(z1-z0) 12 | z0 <- z1 13 | zout <- z0 14 | } else { 15 | zout <- NULL 16 | } 17 | return(zout) 18 | } 19 | -------------------------------------------------------------------------------- /R/soft_thresholding.R: -------------------------------------------------------------------------------- 1 | ## File Name: soft_thresholding.R 2 | ## File Version: 0.07 3 | 4 | 5 | soft_thresholding <- function( x, lambda ) 6 | { 7 | x_abs <- abs(x) 8 | x <- ifelse( x_abs > lambda, x - sign(x) * lambda, 0 ) 9 | return(x) 10 | } 11 | 12 | 13 | mlnormal_soft_thresholding <- soft_thresholding 14 | -------------------------------------------------------------------------------- /R/sqrt_diag.R: -------------------------------------------------------------------------------- 1 | ## File Name: sqrt_diag.R 2 | ## File Version: 0.03 3 | 4 | sqrt_diag <- function(x, names=NULL) 5 | { 6 | v1 <- diag(x) 7 | v1 <- v1*(v1>0) 8 | res <- sqrt(v1) 9 | names(res) <- colnames(x) 10 | if (!is.null(names)){ 11 | names(res) <- names 12 | } 13 | return(res) 14 | } 15 | -------------------------------------------------------------------------------- /R/sqrt_diag_positive.R: -------------------------------------------------------------------------------- 1 | ## File Name: sqrt_diag_positive.R 2 | ## File Version: 0.02 3 | 4 | sqrt_diag_positive <- function(x) 5 | { 6 | y <- diag(x) 7 | y <- ifelse(y<0,0,y) 8 | names(y) <- rownames(x) 9 | res <- sqrt(y) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/stratified_cronbach_alpha_compute_alpha.R: -------------------------------------------------------------------------------- 1 | ## File Name: stratified_cronbach_alpha_compute_alpha.R 2 | ## File Version: 0.06 3 | 4 | 5 | #** compute alpha 6 | stratified_cronbach_alpha_compute_alpha <- function( data ) 7 | { 8 | # covariance 9 | c1 <- stats::cov( data, use="pairwise.complete.obs" ) 10 | # mean covariance 11 | c1a <- c1 12 | diag(c1a) <- 0 13 | I <- ncol(data) 14 | mc <- sum(c1a) / ( I^2 - I ) 15 | 16 | # mean and variance 17 | mv <- mean( diag(c1) ) 18 | alpha <- I*mc / ( mv + (I-1)*mc ) 19 | mean.tot <- mean( rowSums(data), na.rm=TRUE ) 20 | var.tot <- stats::var( rowSums(data), na.rm=TRUE ) 21 | res <- list( I=I, alpha=alpha, mean.tot=mean.tot, var.tot=var.tot ) 22 | return(res) 23 | } 24 | -------------------------------------------------------------------------------- /R/summary.isop.test.R: -------------------------------------------------------------------------------- 1 | ## File Name: summary.isop.test.R 2 | ## File Version: 0.07 3 | 4 | #################################################### 5 | # summary for ISOP test 6 | summary.isop.test <- function( object, ... ) 7 | { 8 | obji <- object$itemstat 9 | VV <- ncol(obji) 10 | cat("*** Test for the W1 Axiom in the ISOP Model **** \n\n") 11 | for (vv in 2:VV){ 12 | obji[,vv] <- round( obji[,vv],3) 13 | } 14 | print(obji) 15 | cat(paste0("\n-- Statistical inference is based on ", object$JJ, 16 | " jackknife units.\n")) 17 | } 18 | -------------------------------------------------------------------------------- /R/summary.latent.regression.R: -------------------------------------------------------------------------------- 1 | ## File Name: summary.latent.regression.R 2 | ## File Version: 0.12 3 | 4 | 5 | summary.latent.regression <- function( object, ... ) 6 | { 7 | cat("\nRegression Parameters\n\n") 8 | .prnum(object$summary.coef,4) # print results 9 | cat( paste( "\nResidual Variance=", round( object$sigma^2, 4 ) ), "\n" ) 10 | cat( paste( "Explained Variance=", round( object$explvar, 4 ) ), "\n" ) 11 | cat( paste( "Total Variance=", round( object$totalvar, 4 ) ), "\n" ) 12 | cat( paste( " R2=", round( object$rsquared, 4 ) ), "\n" ) 13 | } 14 | -------------------------------------------------------------------------------- /R/summary.modelfit.sirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: summary.modelfit.sirt.R 2 | ## File Version: 1.07 3 | 4 | 5 | ############################################################## 6 | # summary modelfit.sirt 7 | summary.modelfit.sirt <- function( object, ... ) 8 | { 9 | cat("Test of Global Model Fit\n") 10 | sirt_summary_print_objects(obji=object$modelfit.test, digits=5, from=2) 11 | 12 | cat("\nFit Statistics\n") 13 | sirt_summary_print_objects(obji=object$modelfit.stat, digits=5, from=1, 14 | rownames_null=FALSE) 15 | } 16 | ################################################################# 17 | 18 | 19 | -------------------------------------------------------------------------------- /R/summary.rasch.copula3.R: -------------------------------------------------------------------------------- 1 | ## File Name: summary.rasch.copula3.R 2 | ## File Version: 0.131 3 | 4 | 5 | #* summary for rasch.copula object 6 | summary.rasch.copula3 <- function( object, file=NULL, digits=3, ...) 7 | { 8 | summary.rasch.copula2( object=object, file=file, digits=digits, ... ) 9 | } 10 | -------------------------------------------------------------------------------- /R/summary.xxirt.R: -------------------------------------------------------------------------------- 1 | ## File Name: summary.xxirt.R 2 | ## File Version: 0.275 3 | 4 | 5 | #--- summary for xxirt object 6 | summary.xxirt <- function( object, digits=3, file=NULL, ...) 7 | { 8 | # open sink 9 | sirt_osink( file=file ) 10 | 11 | # print summary 12 | res <- xxirt_summary_parts(object=object, digits=digits) 13 | 14 | # close sink 15 | sirt_csink( file=file ) 16 | } 17 | -------------------------------------------------------------------------------- /R/summary_round_helper.R: -------------------------------------------------------------------------------- 1 | ## File Name: summary_round_helper.R 2 | ## File Version: 0.101 3 | 4 | summary_round_helper <- function( obji, digits, exclude=NULL, print=TRUE) 5 | { 6 | NC <- ncol(obji) 7 | ind <- 1L:NC 8 | if ( ! is.null(exclude) ){ 9 | ind2 <- which( colnames(obji) %in% exclude ) 10 | ind <- setdiff( ind, ind2 ) 11 | } 12 | obji[,ind] <- round( obji[,ind], digits ) 13 | rownames(obji) <- NULL 14 | print(obji) 15 | invisible(obji) 16 | } 17 | -------------------------------------------------------------------------------- /R/testlet.yen.q3.R: -------------------------------------------------------------------------------- 1 | ## File Name: testlet.yen.q3.R 2 | ## File Version: 2.051 3 | 4 | testlet.yen.q3 <- function(...) 5 | { 6 | .Defunct(new='Q3.testlet', package='sirt') 7 | } 8 | -------------------------------------------------------------------------------- /R/tracemat.R: -------------------------------------------------------------------------------- 1 | ## File Name: tracemat.R 2 | ## File Version: 0.07 3 | 4 | ######################################## 5 | # trace of a matrix 6 | tracemat <- function(A) 7 | { 8 | res <- sum(diag(A)) 9 | return(res) 10 | } 11 | ######################################## 12 | -------------------------------------------------------------------------------- /R/vcov.rasch.evm.pcm.R: -------------------------------------------------------------------------------- 1 | ## File Name: vcov.rasch.evm.pcm.R 2 | ## File Version: 0.13 3 | 4 | 5 | vcov.rasch.evm.pcm <- function( object, ... ) 6 | { 7 | return(object$vcov) 8 | } 9 | -------------------------------------------------------------------------------- /R/weighted_colMeans.R: -------------------------------------------------------------------------------- 1 | ## File Name: weighted_colMeans.R 2 | ## File Version: 0.09 3 | 4 | weighted_colMeans <- function( mat, wgt=NULL) 5 | { 6 | wgt <- weighted_stats_extend_wgt( wgt=wgt, mat=mat ) 7 | mat1 <- colSums( mat * wgt, na.rm=TRUE) 8 | mat2 <- colSums( wgt, na.rm=TRUE) 9 | mat1 <- mat1 / mat2 10 | return(mat1) 11 | } 12 | -------------------------------------------------------------------------------- /R/weighted_colSums.R: -------------------------------------------------------------------------------- 1 | ## File Name: weighted_colSums.R 2 | ## File Version: 0.08 3 | 4 | 5 | weighted_colSums <- function( mat, wgt=NULL) 6 | { 7 | wgt <- weighted_stats_extend_wgt( wgt=wgt, mat=mat ) 8 | mat1 <- colSums( mat * wgt, na.rm=TRUE) 9 | return(mat1) 10 | } 11 | -------------------------------------------------------------------------------- /R/weighted_rowMeans.R: -------------------------------------------------------------------------------- 1 | ## File Name: weighted_rowMeans.R 2 | ## File Version: 0.09 3 | 4 | weighted_rowMeans <- function( mat, wgt=NULL) 5 | { 6 | wgt <- weighted_stats_extend_wgt( wgt=wgt, mat=mat ) 7 | mat1 <- rowSums( mat * wgt, na.rm=TRUE) 8 | mat2 <- rowSums( wgt, na.rm=TRUE) 9 | mat1 <- mat1 / mat2 10 | return(mat1) 11 | } 12 | -------------------------------------------------------------------------------- /R/weighted_rowSums.R: -------------------------------------------------------------------------------- 1 | ## File Name: weighted_rowSums.R 2 | ## File Version: 0.08 3 | 4 | 5 | weighted_rowSums <- function( mat, wgt=NULL) 6 | { 7 | wgt <- weighted_stats_extend_wgt( wgt=wgt, mat=mat ) 8 | mat1 <- rowSums( mat * wgt, na.rm=TRUE) 9 | return(mat1) 10 | } 11 | -------------------------------------------------------------------------------- /R/weighted_stats_extend_wgt.R: -------------------------------------------------------------------------------- 1 | ## File Name: weighted_stats_extend_wgt.R 2 | ## File Version: 0.09 3 | 4 | weighted_stats_extend_wgt <- function( wgt, mat ) 5 | { 6 | N1 <- nrow(mat) 7 | N2 <- ncol(mat) 8 | if ( is.null(wgt) ){ 9 | wgt <- rep( 1, N1 ) 10 | } 11 | if ( is.vector(wgt) ){ 12 | wgt <- matrix( wgt, nrow=N1, ncol=N2 ) 13 | } 14 | return(wgt) 15 | } 16 | -------------------------------------------------------------------------------- /R/xxirt_EAP.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_EAP.R 2 | ## File Version: 0.117 3 | 4 | 5 | #--- compute EAP and its standard deviation 6 | xxirt_EAP <- function(p.aj.xi, Theta ) 7 | { 8 | D <- ncol(Theta) 9 | e1 <- p.aj.xi %*% Theta 10 | colnames(e1) <- paste0('EAP.Dim', 1L:D) 11 | e2 <- p.aj.xi %*% Theta^2 12 | colnames(e2) <- paste0('SD.EAP.Dim', 1L:D) 13 | e2 <- e2 - e1^2 14 | res <- cbind( e1, e2) 15 | res <- res[, rep( c(0,D), D ) + 1L:D ] 16 | return(res) 17 | } 18 | 19 | -------------------------------------------------------------------------------- /R/xxirt_IRT.se.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_IRT.se.R 2 | ## File Version: 0.11 3 | 4 | 5 | IRT.se.xxirt <- function( object, ...) 6 | { 7 | c1 <- coef(object) 8 | v1 <- vcov(object) 9 | par1 <- xxirt_partable_extract_freeParameters( object$partable ) 10 | par2 <- xxirt_parTheta_extract_freeParameters( object$customTheta ) 11 | N1 <- length(par1) 12 | N2 <- length(par2) 13 | dfr <- data.frame(partype=c( rep('item',N1), rep('Theta',N2) )) 14 | dfr$parlabel <- names(c1) 15 | dfr$value <- c1 16 | dfr$se <- sqrt( diag(v1) ) 17 | return(dfr) 18 | } 19 | -------------------------------------------------------------------------------- /R/xxirt_ThetaDistribution_extract_freeParameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_ThetaDistribution_extract_freeParameters.R 2 | ## File Version: 0.10 3 | 4 | 5 | xxirt_ThetaDistribution_extract_freeParameters <- function( customTheta ) 6 | { 7 | est <- customTheta$est 8 | if ( sum(est)==0 ){ 9 | par1 <- NULL 10 | } else { 11 | par1 <- customTheta$par[ est ] 12 | } 13 | return(par1) 14 | } 15 | -------------------------------------------------------------------------------- /R/xxirt_classprobs_lca.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_classprobs_lca.R 2 | ## File Version: 0.09 3 | 4 | xxirt_classprobs_lca <- function(par, Theta, G) 5 | { 6 | K <- nrow(Theta) 7 | probs <- matrix(NA, nrow=K, ncol=G) 8 | for (gg in 1L:G){ 9 | logitprobs_gg <- par[ (K-1)*(gg-1) + ( 1L:(K-1) ) ] 10 | probs[,gg] <- xxirt_classprobs_lca_compute_probs(logitprobs=logitprobs_gg) 11 | } 12 | return(probs) 13 | } 14 | -------------------------------------------------------------------------------- /R/xxirt_classprobs_lca_compute_probs.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_classprobs_lca_compute_probs.R 2 | ## File Version: 0.04 3 | 4 | xxirt_classprobs_lca_compute_probs <- function(logitprobs) 5 | { 6 | v1 <- c( logitprobs, 0 ) 7 | v1 <- v1 - max(v1) 8 | l1 <- exp(v1) 9 | res <- sirt_sum_norm(x=l1) 10 | return(res) 11 | } 12 | -------------------------------------------------------------------------------- /R/xxirt_classprobs_lca_init_par_create.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_classprobs_lca_init_par_create.R 2 | ## File Version: 0.04 3 | 4 | 5 | xxirt_classprobs_lca_init_par_create <- function(K, random_sd=0) 6 | { 7 | par_Theta <- rep(0, K-1) 8 | par_Theta <- par_Theta + stats::rnorm(K-1, sd=random_sd) 9 | return(par_Theta) 10 | } 11 | -------------------------------------------------------------------------------- /R/xxirt_coef.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_coef.R 2 | ## File Version: 0.09 3 | 4 | ########################################## 5 | # coef S3 method for xxirt objects 6 | coef.xxirt <- function(object,...) 7 | { 8 | par1 <- xxirt_partable_extract_freeParameters( object$partable ) 9 | par2 <- xxirt_parTheta_extract_freeParameters( object$customTheta ) 10 | par <- c(par1, par2) 11 | return(par) 12 | } 13 | ########################################## 14 | -------------------------------------------------------------------------------- /R/xxirt_compute_casewise_likelihood.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_compute_casewise_likelihood.R 2 | ## File Version: 0.085 3 | 4 | xxirt_compute_casewise_likelihood <- function(prior_Theta, group, p.xi.aj, 5 | customTheta=NULL) 6 | { 7 | if (is.null(customTheta)){ 8 | customTheta <- list(person_covariates=FALSE) 9 | } 10 | if (customTheta$person_covariates){ 11 | prior1 <- t( prior_Theta ) 12 | } else { 13 | prior1 <- t( prior_Theta[, group ] ) 14 | } 15 | p.aj.xi <- prior1 * p.xi.aj 16 | ll_case <- rowSums(p.aj.xi) 17 | return(ll_case) 18 | } 19 | -------------------------------------------------------------------------------- /R/xxirt_compute_priorDistribution.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_compute_priorDistribution.R 2 | ## File Version: 0.148 3 | 4 | 5 | xxirt_compute_priorDistribution <- function( Theta, customTheta, G ) 6 | { 7 | P_Theta <- customTheta$P 8 | arg_Theta <- list( Theta=Theta, par=customTheta$par, G=G ) 9 | if (customTheta$person_covariates){ 10 | arg_Theta$X <- customTheta$X 11 | } 12 | prior_Theta <- do.call( what=P_Theta, args=arg_Theta ) 13 | return(prior_Theta) 14 | } 15 | -------------------------------------------------------------------------------- /R/xxirt_compute_prior_Theta_from_x.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_compute_prior_Theta_from_x.R 2 | ## File Version: 0.07 3 | 4 | xxirt_compute_prior_Theta_from_x <- function(x, em_args) 5 | { 6 | # include parameters 7 | customTheta <- xxirt_parTheta_include_freeParameters( 8 | customTheta=em_args$customTheta, 9 | x=x[ em_args$parindex_Theta ]) 10 | 11 | #*** compute prior distribution 12 | prior_Theta <- xxirt_compute_priorDistribution( Theta=em_args$Theta, 13 | customTheta=customTheta, G=em_args$G ) 14 | 15 | return(prior_Theta) 16 | } 17 | -------------------------------------------------------------------------------- /R/xxirt_compute_prob_item_from_x.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_compute_prob_item_from_x.R 2 | ## File Version: 0.06 3 | 4 | xxirt_compute_prob_item_from_x <- function(x, em_args, item_index=NULL) 5 | { 6 | partable <- xxirt_partable_include_freeParameters( partable=em_args$partable, 7 | x=x[ em_args$parindex_items ] ) 8 | probs_items <- xxirt_compute_itemprobs( item_list=em_args$item_list, 9 | items=em_args$items, Theta=em_args$Theta, 10 | ncat=em_args$ncat, partable=partable, 11 | partable_index=em_args$partable_index, 12 | item_index=item_index) 13 | return(probs_items) 14 | } 15 | -------------------------------------------------------------------------------- /R/xxirt_createDiscItem.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_createDiscItem.R 2 | ## File Version: 0.174 3 | 4 | xxirt_createDiscItem <- function( name, par, est, P, lower=-Inf, 5 | upper=Inf, prior=NULL, prior_par1=NULL, prior_par2=NULL, 6 | X=NULL) 7 | { 8 | res <- list() 9 | res$name <- name 10 | res$par <- par 11 | res$est <- est 12 | res$P <- P 13 | res$lower <- lower 14 | res$upper <- upper 15 | res$prior <- prior 16 | res$prior_par1 <- prior_par1 17 | res$prior_par2 <- prior_par2 18 | res$X <- X 19 | if (is.null(X)){ 20 | res$person_covariates <- FALSE 21 | } else { 22 | res$person_covariates <- TRUE 23 | } 24 | class(res) <- 'DiscItem' 25 | return(res) 26 | } 27 | -------------------------------------------------------------------------------- /R/xxirt_em_args_extract.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_em_args_extract.R 2 | ## File Version: 0.02 3 | 4 | xxirt_em_args_extract <- function(em_args, em_out, object) 5 | { 6 | v1 <- em_out[[object]] 7 | if (is.null(v1)){ 8 | v1 <- em_args[[object]] 9 | } 10 | return(v1) 11 | } 12 | -------------------------------------------------------------------------------- /R/xxirt_hessian_compute_loglike.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_hessian_compute_loglike.R 2 | ## File Version: 0.03 3 | 4 | 5 | xxirt_hessian_compute_loglike <- function(p.xi.aj, prior1, weights) 6 | { 7 | post_unnorm <- prior1 * p.xi.aj 8 | # compute log-likelihood 9 | dev <- sum( weights * log( rowSums( post_unnorm ) ) ) 10 | return(dev) 11 | } 12 | -------------------------------------------------------------------------------- /R/xxirt_ic.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_ic.R 2 | ## File Version: 0.195 3 | 4 | 5 | #-- information criteria xxirt 6 | xxirt_ic <- function( dev, N, par_items, par_Theta, I, par_items_bounds, np_item=NULL, 7 | np_theta=NULL, estimator="ML") 8 | { 9 | # Information criteria 10 | ic <- list( deviance=dev, n=N, I=I ) 11 | ic$np.items <- sum(par_items_bounds$active) 12 | if ( ! is.null(np_item) ){ 13 | ic$np.items <- np_item 14 | } 15 | NPT <- length(par_Theta) 16 | if (!is.null(np_theta)){ 17 | NPT <- np_theta 18 | } 19 | ic$np.Theta <- NPT 20 | ic <- xxirt_ic_compute_criteria(ic=ic, estimator=estimator) 21 | return(ic) 22 | } 23 | 24 | -------------------------------------------------------------------------------- /R/xxirt_ic_compute_criteria.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_ic_compute_criteria.R 2 | ## File Version: 0.07 3 | 4 | xxirt_ic_compute_criteria <- function(ic, compute_np=TRUE, estimator="ML") 5 | { 6 | dev <- ic$deviance 7 | if (compute_np){ 8 | ic$np <- ic$np.item + ic$np.Theta 9 | } 10 | if (estimator=='ML'){ 11 | ic$AIC <- dev + 2*ic$np 12 | log_n <- log(ic$n) 13 | ic$BIC <- dev + log_n * ic$np 14 | ic$CAIC <- dev + ( log_n + 1 )*ic$np 15 | ic$AICc <- ic$AIC + 2*ic$np * ( ic$np + 1 ) / ( ic$n - ic$np - 1 ) 16 | } 17 | return(ic) 18 | } 19 | -------------------------------------------------------------------------------- /R/xxirt_irf_lca.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_irf_lca.R 2 | ## File Version: 0.071 3 | 4 | xxirt_irf_lca <- function(par, Theta, ncat) 5 | { 6 | K <- nrow(Theta) 7 | P <- matrix( NA, nrow=K, ncol=ncat) 8 | P[,1] <- 0 9 | for (hh in 2L:ncat){ 10 | b <- par[ K*(hh-2) + seq(1,K) ] 11 | P[,hh] <- b 12 | } 13 | a1M <- matrix(apply(P, 1, max), nrow=K, ncol=ncat) 14 | P <- exp(P-a1M) 15 | P <- P / rowSums(P) 16 | return(P) 17 | } 18 | -------------------------------------------------------------------------------- /R/xxirt_irf_lca_init_par.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_irf_lca_init_par.R 2 | ## File Version: 0.05 3 | 4 | 5 | xxirt_irf_lca_init_par <- function(K, ncat, random_sd=0, rg_val=1.5) 6 | { 7 | v1 <- NULL 8 | for (cc in 2L:ncat){ 9 | par <- rg_val*seq( -1, 1, length=K ) 10 | names(par) <- paste0('b',1L:K, '_Cat',cc-1) 11 | par <- par + stats::rnorm(K, sd=random_sd) 12 | v1 <- c(v1, par) 13 | } 14 | if (ncat==2){ 15 | names(v1) <- paste0('b',1L:K) 16 | } 17 | return(v1) 18 | } 19 | -------------------------------------------------------------------------------- /R/xxirt_nr_grad_fun_numapprox.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_nr_grad_fun_numapprox.R 2 | ## File Version: 0.092 3 | 4 | xxirt_nr_grad_fun_numapprox <- function(x, em_args, opt_fun) 5 | { 6 | grad <- 0*x 7 | ll1 <- opt_fun(x=x, em_args=em_args) 8 | h <- em_args$h 9 | for (pp in 1L:em_args$NP){ 10 | x1 <- sirt_add_increment(x=x, pos=pp, value=h) 11 | ll2 <- opt_fun(x=x1, em_args=em_args) 12 | x1 <- sirt_add_increment(x=x, pos=pp, value=-h) 13 | ll2b <- opt_fun(x=x1, em_args=em_args) 14 | grad[pp] <- (ll2-ll2b) / (2*h) 15 | } 16 | return(grad) 17 | } 18 | -------------------------------------------------------------------------------- /R/xxirt_nr_grad_fun_pml_casewise.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_nr_grad_fun_pml_casewise.R 2 | ## File Version: 0.05 3 | 4 | 5 | #-- case-wise optimization function for PML 6 | xxirt_nr_grad_fun_pml_casewise <- function(x, args, opt_fun, h=1e-4) 7 | { 8 | NP <- length(x) 9 | f0 <- do.call(what=opt_fun, args=args) 10 | N <- length(f0) 11 | grad <- matrix(0, nrow=N, ncol=NP) 12 | colnames(grad) <- names(x) 13 | for (pp in 1L:NP){ 14 | args1 <- args 15 | args1$x <- sirt_add_increment(x=x, pos=pp, value=h) 16 | f1 <- do.call(what=opt_fun, args=args1) 17 | grad[,pp] <- (f1-f0)/h 18 | } 19 | #- output 20 | return(grad) 21 | } 22 | -------------------------------------------------------------------------------- /R/xxirt_parTheta_extract_freeParameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_parTheta_extract_freeParameters.R 2 | ## File Version: 0.08 3 | 4 | 5 | xxirt_parTheta_extract_freeParameters <- function( customTheta ) 6 | { 7 | ind <- customTheta$est 8 | p1 <- customTheta$par[ ind ] 9 | names(p1) <- names(customTheta$par)[ind] 10 | return(p1) 11 | } 12 | -------------------------------------------------------------------------------- /R/xxirt_parTheta_include_freeParameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_parTheta_include_freeParameters.R 2 | ## File Version: 0.02 3 | 4 | 5 | xxirt_parTheta_include_freeParameters <- function(customTheta, x) 6 | { 7 | if (!is.null(x)){ 8 | customTheta$par[ customTheta$est ] <- x 9 | } 10 | return(customTheta) 11 | } 12 | -------------------------------------------------------------------------------- /R/xxirt_partable_extract_freeParameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_partable_extract_freeParameters.R 2 | ## File Version: 0.121 3 | 4 | 5 | xxirt_partable_extract_freeParameters <- function( partable ) 6 | { 7 | partable <- partable[ partable$est, ] 8 | partable <- partable[ order(partable$parindex), ] 9 | partable <- partable[ ! duplicated( partable$parindex), ] 10 | x <- partable$value 11 | names(x) <- partable$parlabel 12 | return(x) 13 | } 14 | 15 | -------------------------------------------------------------------------------- /R/xxirt_partable_include_freeParameters.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_partable_include_freeParameters.R 2 | ## File Version: 0.11 3 | 4 | 5 | 6 | xxirt_partable_include_freeParameters <- function( partable, x ) 7 | { 8 | vals <- x[ partable$parindex ] 9 | ind <- is.na(vals) 10 | vals[ ind ] <- partable$value[ ind ] 11 | partable$value <- vals 12 | return(partable) 13 | } 14 | 15 | -------------------------------------------------------------------------------- /R/xxirt_prepare_response_data.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_prepare_response_data.R 2 | ## File Version: 0.095 3 | 4 | xxirt_prepare_response_data <- function(G, group_index, weights, dat1, 5 | dat_resp, maxK ) 6 | { 7 | N <- nrow(dat_resp) 8 | I <- ncol(dat_resp) 9 | dat1_resp <- array(0, dim=c(N,I,maxK) ) 10 | for (gg in 1L:G){ 11 | ind_gg <- group_index[[gg]] 12 | for (kk in 1L:maxK){ 13 | dat1_resp[ind_gg,,kk] <- weights[ind_gg] * ( dat1[ind_gg, ]==(kk-1) ) * 14 | ( dat_resp[ind_gg, ] ) 15 | } # end kk 16 | } # end gg 17 | return(dat1_resp) 18 | } 19 | -------------------------------------------------------------------------------- /R/xxirt_vcov.R: -------------------------------------------------------------------------------- 1 | ## File Name: xxirt_vcov.R 2 | ## File Version: 0.09 3 | 4 | vcov.xxirt <- function( object, ...) 5 | { 6 | res <- xxirt_hessian( object ) 7 | return( solve(-res) ) 8 | } 9 | -------------------------------------------------------------------------------- /R/yen.q3.R: -------------------------------------------------------------------------------- 1 | ## File Name: yen.q3.R 2 | ## File Version: 2.051 3 | yen.q3 <- function(...){ 4 | .Defunct(new='Q3', package='sirt') 5 | } 6 | -------------------------------------------------------------------------------- /data/data.activity.itempars.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.activity.itempars.rda -------------------------------------------------------------------------------- /data/data.befki.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.befki.rda -------------------------------------------------------------------------------- /data/data.befki_resp.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.befki_resp.rda -------------------------------------------------------------------------------- /data/data.big5.qgraph.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.big5.qgraph.rda -------------------------------------------------------------------------------- /data/data.big5.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.big5.rda -------------------------------------------------------------------------------- /data/data.bs07a.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.bs07a.rda -------------------------------------------------------------------------------- /data/data.eid.kap4.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.eid.kap4.rda -------------------------------------------------------------------------------- /data/data.eid.kap5.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.eid.kap5.rda -------------------------------------------------------------------------------- /data/data.eid.kap6.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.eid.kap6.rda -------------------------------------------------------------------------------- /data/data.eid.kap7.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.eid.kap7.rda -------------------------------------------------------------------------------- /data/data.eid.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.eid.rda -------------------------------------------------------------------------------- /data/data.ess2005.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.ess2005.rda -------------------------------------------------------------------------------- /data/data.g308.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.g308.rda -------------------------------------------------------------------------------- /data/data.inv4gr.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.inv4gr.rda -------------------------------------------------------------------------------- /data/data.liking.science.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.liking.science.rda -------------------------------------------------------------------------------- /data/data.long.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.long.rda -------------------------------------------------------------------------------- /data/data.lsem01.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.lsem01.rda -------------------------------------------------------------------------------- /data/data.lsem02.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.lsem02.rda -------------------------------------------------------------------------------- /data/data.lsem03.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.lsem03.rda -------------------------------------------------------------------------------- /data/data.math.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.math.rda -------------------------------------------------------------------------------- /data/data.mcdonald.LSAT6.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.mcdonald.LSAT6.rda -------------------------------------------------------------------------------- /data/data.mcdonald.act15.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.mcdonald.act15.rda -------------------------------------------------------------------------------- /data/data.mcdonald.rape.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.mcdonald.rape.rda -------------------------------------------------------------------------------- /data/data.mixed1.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.mixed1.rda -------------------------------------------------------------------------------- /data/data.ml1.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.ml1.rda -------------------------------------------------------------------------------- /data/data.ml2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.ml2.rda -------------------------------------------------------------------------------- /data/data.noharm18.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.noharm18.rda -------------------------------------------------------------------------------- /data/data.noharmExC.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.noharmExC.rda -------------------------------------------------------------------------------- /data/data.pars1.2pl.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pars1.2pl.rda -------------------------------------------------------------------------------- /data/data.pars1.rasch.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pars1.rasch.rda -------------------------------------------------------------------------------- /data/data.pirlsmissing.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pirlsmissing.rda -------------------------------------------------------------------------------- /data/data.pisaMath.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pisaMath.rda -------------------------------------------------------------------------------- /data/data.pisaPars.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pisaPars.rda -------------------------------------------------------------------------------- /data/data.pisaRead.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pisaRead.rda -------------------------------------------------------------------------------- /data/data.pw01.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.pw01.rda -------------------------------------------------------------------------------- /data/data.ratings1.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.ratings1.rda -------------------------------------------------------------------------------- /data/data.ratings2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.ratings2.rda -------------------------------------------------------------------------------- /data/data.ratings3.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.ratings3.rda -------------------------------------------------------------------------------- /data/data.raw1.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.raw1.rda -------------------------------------------------------------------------------- /data/data.read.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.read.rda -------------------------------------------------------------------------------- /data/data.reck21.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck21.rda -------------------------------------------------------------------------------- /data/data.reck61DAT1.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck61DAT1.rda -------------------------------------------------------------------------------- /data/data.reck61DAT2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck61DAT2.rda -------------------------------------------------------------------------------- /data/data.reck73C1a.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck73C1a.rda -------------------------------------------------------------------------------- /data/data.reck73C1b.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck73C1b.rda -------------------------------------------------------------------------------- /data/data.reck75C2.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck75C2.rda -------------------------------------------------------------------------------- /data/data.reck78ExA.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck78ExA.rda -------------------------------------------------------------------------------- /data/data.reck79ExB.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.reck79ExB.rda -------------------------------------------------------------------------------- /data/data.si01.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si01.rda -------------------------------------------------------------------------------- /data/data.si02.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si02.rda -------------------------------------------------------------------------------- /data/data.si03.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si03.rda -------------------------------------------------------------------------------- /data/data.si04.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si04.rda -------------------------------------------------------------------------------- /data/data.si05.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si05.rda -------------------------------------------------------------------------------- /data/data.si06.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si06.rda -------------------------------------------------------------------------------- /data/data.si07.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si07.rda -------------------------------------------------------------------------------- /data/data.si08.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si08.rda -------------------------------------------------------------------------------- /data/data.si09.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si09.rda -------------------------------------------------------------------------------- /data/data.si10.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.si10.rda -------------------------------------------------------------------------------- /data/data.timss.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.timss.rda -------------------------------------------------------------------------------- /data/data.timss07.G8.RUS.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.timss07.G8.RUS.rda -------------------------------------------------------------------------------- /data/data.trees.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/alexanderrobitzsch/sirt/bcda334232a1fa1fa9ce672ea87aced95fcc2012/data/data.trees.rda -------------------------------------------------------------------------------- /docs/deps/data-deps.txt: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | -------------------------------------------------------------------------------- /docs/pkgdown.yml: -------------------------------------------------------------------------------- 1 | pandoc: 3.1.1 2 | pkgdown: 2.0.7 3 | pkgdown_sha: ~ 4 | articles: {} 5 | last_built: 2025-05-20T10:13Z 6 | 7 | -------------------------------------------------------------------------------- /man/data.pw01.Rd: -------------------------------------------------------------------------------- 1 | %% File Name: data.pw01.Rd 2 | %% File Version: 0.06 3 | 4 | \name{data.pw} 5 | \alias{data.pw01} 6 | \docType{data} 7 | \title{ 8 | Datasets for Pairwise Comparisons 9 | } 10 | \description{ 11 | Some datasets for pairwise comparisons. 12 | } 13 | \usage{ 14 | data(data.pw01) 15 | } 16 | \format{ 17 | The dataset \code{data.pw01} contains results of a German football league 18 | from the season 2000/01. 19 | } 20 | 21 | %\details{ 22 | %% ~~ If necessary, more details than the __description__ above ~~ 23 | %} 24 | %\source{ 25 | %% ~~ reference to a publication or URL from which the data were obtained ~~ 26 | %} 27 | %\references{ 28 | %% ~~ possibly secondary sources and usages ~~ 29 | %} 30 | %\examples{ 31 | %data(data.pw01) 32 | %} 33 | %% \keyword{datasets} 34 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | ## Use the R_HOME indirection to support installations of multiple R version 2 | PKG_LIBS = `$(R_HOME)/bin/Rscript -e "Rcpp:::LdFlags()"` $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 3 | PKG_CPPFLAGS = -I../inst/include -DBOOST_NO_LONG_LONG -DBOOST_NO_AUTO_PTR -DRCPP_USE_UNWIND_PROTECT 4 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | 2 | ## This assume that we can call Rscript to ask Rcpp about its locations 3 | ## Use the R_HOME indirection to support installations of multiple R version 4 | PKG_LIBS = $(shell $(R_HOME)/bin/Rscript.exe -e "Rcpp:::LdFlags()") $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) 5 | PKG_CPPFLAGS = -I../inst/include -DBOOST_NO_LONG_LONG -DBOOST_NO_AUTO_PTR -DRCPP_USE_UNWIND_PROTECT 6 | -------------------------------------------------------------------------------- /src/sirt_rcpp_eigenvalues.h: -------------------------------------------------------------------------------- 1 | //// File Name: sirt_rcpp_eigenvalues.h 2 | //// File Version: 4.28 3 | 4 | #ifndef _SIRT_SIRT_RCPP_EIGENVALUES_H 5 | #define _SIRT_SIRT_RCPP_EIGENVALUES_H 6 | 7 | #include 8 | #include 9 | using namespace Rcpp; 10 | 11 | Rcpp::List sirt_rcpp_first_eigenvalue(arma::mat X, int maxit, double conv, double K); 12 | 13 | Rcpp::List sirt_rcpp_D_eigenvalues( Rcpp::NumericMatrix Xr, int D, int maxit, double conv ); 14 | 15 | #endif // _SIRT_SIRT_RCPP_EIGENVALUES_H 16 | -------------------------------------------------------------------------------- /src/sirt_rcpp_inference_jackknife.h: -------------------------------------------------------------------------------- 1 | //// File Name: sirt_rcpp_inference_jackknife.h 2 | //// File Version: 0.03 3 | 4 | #ifndef _SIRT_SIRT_RCPP_INFERENCE_JACKKNIFE_H 5 | #define _SIRT_SIRT_RCPP_INFERENCE_JACKKNIFE_H 6 | 7 | #include 8 | #include 9 | using namespace Rcpp; 10 | 11 | Rcpp::List sirt_rcpp_inference_jackknife( Rcpp::NumericMatrix PARS ); 12 | 13 | #endif // _SIRT_SIRT_RCPP_INFERENCE_JACKKNIFE_H 14 | --------------------------------------------------------------------------------