├── R ├── .DS_Store ├── module0_irt_utils.R ├── module0_ctt_utils.R ├── module1_helpers.R ├── module0_stat_utils.R ├── module5_mst_sim.R ├── module1_model_3pl.R ├── module1_model_grm.R ├── module1_model_gpcm.R ├── module3_ata_helpers.R ├── module5_mst.R ├── module4_cat.R ├── module2_estimate_grm.R └── module2_estimate_3pl.R ├── README_cache ├── markdown_github │ ├── unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.rdb │ ├── unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.rdb │ ├── unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.rdb │ ├── unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.rdb │ ├── unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.rdb │ ├── unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.rdb │ ├── unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.rdb │ ├── __packages │ ├── .DS_Store │ ├── unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.rdb │ ├── unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.rdx │ ├── unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.rdx │ ├── unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.rdb │ ├── unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.rdx │ ├── unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.rdb │ ├── unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.rdx │ ├── unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.rdb │ ├── unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.rdx │ ├── unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.rdb │ ├── unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.rdx │ ├── unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.rdb │ ├── unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.rdx │ ├── unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.rdb │ ├── unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.rdx │ ├── unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.rdb │ ├── unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.rdx │ ├── unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.rdx │ ├── unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.rdb │ ├── unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.rdx │ ├── unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.rdx │ ├── unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.rdx │ ├── unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.rdx │ ├── unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.rdx │ ├── unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.rdb │ ├── unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.rdx │ ├── unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.rdb │ ├── unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.rdx │ ├── unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.rdb │ ├── unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.rdx │ ├── unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.rdb │ ├── unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.rdx │ ├── unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.rdb │ ├── unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.rdx │ ├── unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.rdb │ ├── unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.rdx │ ├── unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.rdb │ ├── unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.rdx │ ├── unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.rdb │ ├── unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.rdx │ ├── unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.rdb │ ├── unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.rdx │ ├── unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.rdb │ ├── unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.rdx │ ├── unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.rdb │ ├── unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.rdx │ ├── unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.rdx │ ├── unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.rdb │ ├── unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.rdx │ ├── unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.rdb │ ├── unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.rdx │ ├── unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.rdb │ ├── unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.rdx │ ├── unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.rdb │ ├── unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.rdx │ ├── unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.rdb │ ├── unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.rdx │ ├── unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.RData │ ├── unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.RData │ ├── unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.RData │ ├── unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.RData │ ├── unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.RData │ ├── unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.RData │ ├── unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.RData │ ├── unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.RData │ ├── unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.RData │ ├── unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.RData │ ├── unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.RData │ ├── unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.RData │ ├── unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.RData │ ├── unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.RData │ ├── unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.RData │ ├── unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.RData │ ├── unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.RData │ ├── unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.RData │ ├── unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.RData │ ├── unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.RData │ ├── unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.RData │ ├── unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.RData │ ├── unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.RData │ ├── unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.RData │ ├── unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.RData │ ├── unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.RData │ ├── unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.RData │ ├── unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.RData │ ├── unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.RData │ ├── unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.RData │ ├── unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.RData │ └── unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.RData └── .DS_Store ├── README_files ├── .DS_Store └── figure-markdown_github │ ├── .DS_Store │ ├── unnamed-chunk-3-1.png │ ├── unnamed-chunk-3-2.png │ ├── unnamed-chunk-4-1.png │ ├── unnamed-chunk-7-1.png │ ├── unnamed-chunk-7-2.png │ ├── unnamed-chunk-7-3.png │ ├── unnamed-chunk-8-1.png │ ├── unnamed-chunk-8-2.png │ ├── unnamed-chunk-11-1.png │ ├── unnamed-chunk-11-2.png │ ├── unnamed-chunk-12-1.png │ ├── unnamed-chunk-12-2.png │ ├── unnamed-chunk-12-3.png │ ├── unnamed-chunk-12-4.png │ ├── unnamed-chunk-13-1.png │ ├── unnamed-chunk-14-1.png │ ├── unnamed-chunk-15-1.png │ ├── unnamed-chunk-15-2.png │ ├── unnamed-chunk-16-1.png │ ├── unnamed-chunk-16-2.png │ ├── unnamed-chunk-17-1.png │ ├── unnamed-chunk-17-2.png │ ├── unnamed-chunk-19-1.png │ ├── unnamed-chunk-19-2.png │ ├── unnamed-chunk-19-3.png │ ├── unnamed-chunk-20-1.png │ ├── unnamed-chunk-20-2.png │ ├── unnamed-chunk-20-3.png │ ├── unnamed-chunk-20-4.png │ ├── unnamed-chunk-25-1.png │ ├── unnamed-chunk-27-1.png │ ├── unnamed-chunk-28-1.png │ ├── unnamed-chunk-29-1.png │ ├── unnamed-chunk-30-1.png │ ├── unnamed-chunk-31-1.png │ └── unnamed-chunk-32-1.png ├── .gitignore ├── .Rbuildignore ├── man ├── rmse.Rd ├── hermite_gauss.Rd ├── freq.Rd ├── cronbach_alpha.Rd ├── expected_raw_score_dist.Rd ├── spearman_brown.Rd ├── estimate_helpers.Rd ├── mst_sim.Rd ├── ata_helpers.Rd ├── model_grm.Rd ├── model_3pl.Rd ├── model_gpcm.Rd ├── estimate_grm.Rd ├── estimate_gpcm.Rd ├── estimate_3pl.Rd ├── cat_sim.Rd ├── ata.Rd └── mst.Rd ├── xxIRT.Rproj ├── DESCRIPTION └── NAMESPACE /R/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/R/.DS_Store -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.rdb: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /README_cache/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/.DS_Store -------------------------------------------------------------------------------- /README_cache/markdown_github/__packages: -------------------------------------------------------------------------------- 1 | base 2 | xxIRT 3 | dplyr 4 | ggplot2 5 | reshape2 6 | -------------------------------------------------------------------------------- /README_files/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/.DS_Store -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | .Ruserdata 5 | tests/ 6 | change_log.txt 7 | -------------------------------------------------------------------------------- /README_cache/markdown_github/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/.DS_Store -------------------------------------------------------------------------------- /README_files/figure-markdown_github/.DS_Store: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/.DS_Store -------------------------------------------------------------------------------- /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^.*\.Rproj$ 2 | ^\.Rproj\.user$ 3 | 4 | ^README.*$ 5 | ^README_cache$ 6 | ^README_files$ 7 | ^tests$ 8 | 9 | ^change_log.txt$ 10 | -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-3-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-3-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-3-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-3-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-4-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-4-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-7-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-7-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-7-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-7-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-7-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-7-3.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-8-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-8-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-8-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-8-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-11-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-11-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-11-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-11-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-12-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-12-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-12-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-12-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-12-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-12-3.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-12-4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-12-4.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-13-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-13-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-14-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-14-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-15-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-15-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-15-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-15-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-16-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-16-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-16-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-16-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-17-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-17-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-17-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-17-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-19-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-19-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-19-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-19-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-19-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-19-3.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-20-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-20-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-20-2.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-20-2.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-20-3.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-20-3.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-20-4.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-20-4.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-25-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-25-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-27-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-27-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-28-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-28-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-29-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-29-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-30-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-30-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-31-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-31-1.png -------------------------------------------------------------------------------- /README_files/figure-markdown_github/unnamed-chunk-32-1.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_files/figure-markdown_github/unnamed-chunk-32-1.png -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.rdb: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.rdb -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.rdx: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.rdx -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-10_5fba93046e1eecda025d78ced68a864e.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-11_91b2c4345b503dfa8d64e21ac353ce52.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-12_419717e4081af9f91a770a7b5895f4cb.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-13_94e7ba1a6e7af6ed3567897c289e97d4.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-14_7851f7b34f0acac23a49615e0bd16f88.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-15_f2a01d8f6f7210e2ee57e056774c2d10.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-16_435eb051df25360ad9d9ca204c7262e7.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-17_4ce02f3b0aa4e07afc175b78f141b04d.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-18_ac62b4a0356a59760e8917599e1fc8eb.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-19_c8530e7ea0449f34ee16f254dcc31057.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-1_b3b1efb6d2a59d010d913502f780e5c2.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-20_bdcf33882b44b049b848ad5e49829414.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-21_a1a0f0403d2028c816bf7780d15c21ab.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-22_ffde76dd001ff8d8673e49ddda66388f.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-23_9279409608c66d4fca8de6954c03d002.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-24_80c9d202e2bd3688773b7509f5b817e4.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-25_a6a900b3c0620757fb6073c137f12ba6.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-26_5c2a292ec7df55d34bc0e4f7c7e00363.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-27_9b245263e3786d3ba5a5a83ad4508caa.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-28_badfdb5676fa27edbccd8ce020c0ada6.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-29_4f83ba6a322506518cb58dd010f65392.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-2_2107f0bf89bc50e4cce08a7eeaf80894.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-30_6b6c2fb0b50af424ffae05f2dfabc580.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-31_96ad31b4e5ad68b5aee2350f76a64740.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-32_605bec2140408b321800de58f9ac5c7f.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-3_5188394bd9194cb40fdfde792bac6115.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-4_e6a46dacf028c7a05790414fe4059bf8.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-5_55356aeb2e1ef76a20bc1a5b6c46ef30.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-6_cdf0a0689f3dcad54330b5d8e3243cb5.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-7_40ec1869573268dacfee7d7a893c24b7.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-8_d0a5dc852b29556fe15e434181666f0b.RData -------------------------------------------------------------------------------- /README_cache/markdown_github/unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.RData: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/xluo11/xxIRT/HEAD/README_cache/markdown_github/unnamed-chunk-9_646a82d387f1e8184db1b333673d793d.RData -------------------------------------------------------------------------------- /man/rmse.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module0_stat_utils.R 3 | \name{rmse} 4 | \alias{rmse} 5 | \title{Root Mean Squared Error} 6 | \usage{ 7 | rmse(x, y) 8 | } 9 | \arguments{ 10 | \item{x}{a numeric vector/matrix} 11 | 12 | \item{y}{a numeric vector/matrix} 13 | } 14 | \description{ 15 | Root mean squared error (RMSE) of two numeric vectors/matrices 16 | } 17 | -------------------------------------------------------------------------------- /xxIRT.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | 15 | BuildType: Package 16 | PackageUseDevtools: Yes 17 | PackageInstallArgs: --no-multiarch --with-keep.source 18 | PackageCheckArgs: --as-cran 19 | PackageRoxygenize: rd,collate,namespace 20 | -------------------------------------------------------------------------------- /man/hermite_gauss.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module0_stat_utils.R 3 | \name{hermite_gauss} 4 | \alias{hermite_gauss} 5 | \title{Hermite-Gauss Quadrature} 6 | \usage{ 7 | hermite_gauss(degree = c("20", "11", "7")) 8 | } 9 | \arguments{ 10 | \item{degree}{the degree of hermite-gauss quadrature: '20', '11', '7'} 11 | } 12 | \description{ 13 | Pre-computed hermite gaussian quadratures points and weights 14 | } 15 | \keyword{internal} 16 | -------------------------------------------------------------------------------- /man/freq.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module0_stat_utils.R 3 | \name{freq} 4 | \alias{freq} 5 | \title{Frequency Counts} 6 | \usage{ 7 | freq(x, values = NULL, rounding = NULL) 8 | } 9 | \arguments{ 10 | \item{x}{a numeric or character vector} 11 | 12 | \item{values}{valid values, \code{NULL} to include all values} 13 | 14 | \item{rounding}{round percentage to n-th decimal places} 15 | } 16 | \description{ 17 | Frequency counts of a vector 18 | } 19 | -------------------------------------------------------------------------------- /man/cronbach_alpha.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module0_ctt_utils.R 3 | \name{cronbach_alpha} 4 | \alias{cronbach_alpha} 5 | \title{Cronbach's alpha} 6 | \usage{ 7 | cronbach_alpha(responses) 8 | } 9 | \arguments{ 10 | \item{responses}{the oberved responses, 2d matrix} 11 | } 12 | \description{ 13 | \code{cronbach_alpha} computes Cronbach's alpha internal consistency reliability 14 | } 15 | \examples{ 16 | cronbach_alpha(model_3pl_gendata(1000, 20)$u) 17 | } 18 | -------------------------------------------------------------------------------- /man/expected_raw_score_dist.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module0_irt_utils.R 3 | \name{expected_raw_score_dist} 4 | \alias{expected_raw_score_dist} 5 | \title{#' Distribution of Expected Raw Scores} 6 | \usage{ 7 | expected_raw_score_dist(t, a, b, c) 8 | } 9 | \arguments{ 10 | \item{t}{the ability parameters, 1d vector} 11 | 12 | \item{a}{the item discrimination parameters, 1d vector} 13 | 14 | \item{b}{the item difficulty parameters, 1d vector} 15 | 16 | \item{c}{the item guessing parameters, 1d vector} 17 | } 18 | \description{ 19 | Calculate the distribution of expected raw scores 20 | } 21 | -------------------------------------------------------------------------------- /R/module0_irt_utils.R: -------------------------------------------------------------------------------- 1 | #' #' Distribution of Expected Raw Scores 2 | #' @description Calculate the distribution of expected raw scores 3 | #' @param t the ability parameters, 1d vector 4 | #' @param a the item discrimination parameters, 1d vector 5 | #' @param b the item difficulty parameters, 1d vector 6 | #' @param c the item guessing parameters, 1d vector 7 | #' @export 8 | expected_raw_score_dist <- function(t, a, b, c){ 9 | if(length(b) != length(a) || length(b) != length(c)) 10 | stop('incompatible dimensions for item parameters:', length(a), length(b), length(c)) 11 | p <- model_3pl_prob(t, a, b, c) 12 | rs <- 1 13 | for(i in 1:ncol(p)) 14 | rs <- cbind(rs * (1 - p[,i]), 0) + cbind(0, rs * p[, i]) 15 | rs 16 | } 17 | 18 | 19 | -------------------------------------------------------------------------------- /man/spearman_brown.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module0_ctt_utils.R 3 | \name{spearman_brown} 4 | \alias{spearman_brown} 5 | \alias{spearman_brown_reverse} 6 | \title{Spearman Brown Prophecy} 7 | \usage{ 8 | spearman_brown(n, rho) 9 | 10 | spearman_brown_reverse(rho, target) 11 | } 12 | \arguments{ 13 | \item{n}{extend the test length to n-fold} 14 | 15 | \item{rho}{the reliability of current test} 16 | 17 | \item{target}{the targeted reliability} 18 | } 19 | \description{ 20 | Use Spearman-brown formula to compute the predicted reliability 21 | when the test length is extened to n-fold or reversely the n-fold extension of 22 | test length in order to reach the targeted reliability 23 | } 24 | \examples{ 25 | spearman_brown(2, .70) 26 | spearman_brown_reverse(.70, .85) 27 | } 28 | -------------------------------------------------------------------------------- /man/estimate_helpers.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module1_helpers.R 3 | \name{estimate_helpers} 4 | \alias{estimate_helpers} 5 | \alias{estimate_nr_iteration} 6 | \alias{model_polytomous_3dindex} 7 | \alias{model_polytomous_3dresponse} 8 | \title{Helper functions of Model Estimation} 9 | \usage{ 10 | estimate_nr_iteration(param, free, dv, h_max, lr, bound) 11 | 12 | model_polytomous_3dindex(u) 13 | 14 | model_polytomous_3dresponse(u) 15 | } 16 | \arguments{ 17 | \item{param}{the parameter being estimated} 18 | 19 | \item{free}{TRUE to freely estimate specific parameters} 20 | 21 | \item{dv}{the first and second derivatives} 22 | 23 | \item{h_max}{the maximum value of h} 24 | 25 | \item{lr}{the learning rate} 26 | 27 | \item{bound}{the lower and upper bounds of the parameter} 28 | 29 | \item{u}{the observed response, 2d matrix, values start from 0} 30 | } 31 | \description{ 32 | miscellaneous helper functions for estimating IRT models 33 | 34 | \code{estimate_nr_iteration} updates the parameters using the newton-raphson method 35 | } 36 | \keyword{internal} 37 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: xxIRT 2 | Type: Package 3 | Title: Item Response Theory and Computer-Based Testing 4 | Version: 2.1.2 5 | Date: 2019-3-21 6 | Authors@R: c(person("Xiao", "Luo", role=c("aut","cre"), email="xluo1986@gmail.com")) 7 | Author: Xiao Luo [aut, cre] 8 | Maintainer: Xiao Luo 9 | Description: A suite of psychometric analysis tools for research and operation, including: 10 | (1) computation of probability, information, and likelihood for the 3PL, GPCM, and GRM; 11 | (2) parameter estimation using joint or marginal likelihood estimation method; 12 | (3) simulation of computerized adaptive testing using built-in or customized algorithms; 13 | (4) assembly and simulation of multistage testing. 14 | The full documentation and tutorials are at . 15 | License: GPL (>= 3) 16 | Depends: 17 | R (>= 3.5.0) 18 | URL: https://github.com/xluo11/xxIRT 19 | BugReports: https://github.com/xluo11/xxIRT/issues 20 | Imports: 21 | ggplot2, 22 | glpkAPI, 23 | lpSolveAPI, 24 | reshape2, 25 | stats 26 | RoxygenNote: 6.1.1 27 | Encoding: UTF-8 28 | -------------------------------------------------------------------------------- /R/module0_ctt_utils.R: -------------------------------------------------------------------------------- 1 | #' Cronbach's alpha 2 | #' @description \code{cronbach_alpha} computes Cronbach's alpha internal consistency reliability 3 | #' @param responses the oberved responses, 2d matrix 4 | #' @examples 5 | #' cronbach_alpha(model_3pl_gendata(1000, 20)$u) 6 | #' @importFrom stats var 7 | #' @export 8 | cronbach_alpha <- function(responses){ 9 | k <- ncol(responses) 10 | total_var <- var(rowSums(responses, na.rm=T)) 11 | item_var <- sum(apply(responses, 2, var, na.rm=T)) 12 | k / (k - 1) * (1 - item_var / total_var) 13 | } 14 | 15 | #' Spearman Brown Prophecy 16 | #' @description Use Spearman-brown formula to compute the predicted reliability 17 | #' when the test length is extened to n-fold or reversely the n-fold extension of 18 | #' test length in order to reach the targeted reliability 19 | #' @param n extend the test length to n-fold 20 | #' @param rho the reliability of current test 21 | #' @examples 22 | #' spearman_brown(2, .70) 23 | #' @export 24 | spearman_brown <- function(n, rho){ 25 | n * rho / (1 + (n - 1) * rho) 26 | } 27 | 28 | #' @rdname spearman_brown 29 | #' @param target the targeted reliability 30 | #' @examples 31 | #' spearman_brown_reverse(.70, .85) 32 | #' @export 33 | spearman_brown_reverse <- function(rho, target){ 34 | target * (1 - rho) / rho / (1 - target) 35 | } 36 | 37 | 38 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /R/module1_helpers.R: -------------------------------------------------------------------------------- 1 | #' Helper functions of Model Estimation 2 | #' @description miscellaneous helper functions for estimating IRT models 3 | #' @name estimate_helpers 4 | NULL 5 | 6 | #' @rdname estimate_helpers 7 | #' @description \code{estimate_nr_iteration} updates the parameters using the newton-raphson method 8 | #' @param param the parameter being estimated 9 | #' @param free TRUE to freely estimate specific parameters 10 | #' @param dv the first and second derivatives 11 | #' @param h_max the maximum value of h 12 | #' @param lr the learning rate 13 | #' @param bound the lower and upper bounds of the parameter 14 | #' @keywords internal 15 | estimate_nr_iteration <- function(param, free, dv, h_max, lr, bound){ 16 | h <- dv$dv1 / dv$dv2 17 | h[is.na(h)] <- 0 18 | h <- ifelse(abs(h) > h_max, sign(h) * h_max, h) * lr 19 | h[!free] <- 0 20 | param <- param - h 21 | param[param < bound[1]] <- bound[1] 22 | param[param > bound[2]] <- bound[2] 23 | list(param=param, h=h) 24 | } 25 | 26 | 27 | #' @rdname estimate_helpers 28 | #' @param u the observed response, 2d matrix, values start from 0 29 | #' @keywords internal 30 | model_polytomous_3dindex <- function(u){ 31 | n_p <- dim(u)[1] 32 | n_i <- dim(u)[2] 33 | n_c <- max(u) + 1 34 | cbind(rep(1:n_p, n_i), rep(1:n_i, each=n_p), as.vector(u+1)) 35 | } 36 | 37 | #' @rdname estimate_helpers 38 | #' @keywords internal 39 | model_polytomous_3dresponse <- function(u){ 40 | n_c <- max(u) + 1 41 | x <- array(0, dim=c(dim(u), n_c)) 42 | x[model_polytomous_3dindex(u)] <- 1 43 | x 44 | } -------------------------------------------------------------------------------- /man/mst_sim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module5_mst_sim.R 3 | \name{mst_sim} 4 | \alias{mst_sim} 5 | \alias{print.mst_sim} 6 | \alias{plot.mst_sim} 7 | \title{Simulation of Multistage Testing} 8 | \usage{ 9 | mst_sim(x, true, rdp = NULL, ...) 10 | 11 | \method{print}{mst_sim}(x, ...) 12 | 13 | \method{plot}{mst_sim}(x, ...) 14 | } 15 | \arguments{ 16 | \item{x}{the assembled MST} 17 | 18 | \item{true}{the true theta parameter (numeric)} 19 | 20 | \item{rdp}{routing decision points (list)} 21 | 22 | \item{...}{additional option/control parameters} 23 | } 24 | \description{ 25 | \code{mst_sim} simulates a MST administration 26 | } 27 | \examples{ 28 | \dontrun{ 29 | ## assemble a MST 30 | nitems <- 200 31 | pool <- with(model_3pl_gendata(1, nitems), data.frame(a=a, b=b, c=c)) 32 | pool$content <- sample(1:3, nrow(pool), replace=TRUE) 33 | x <- mst(pool, "1-2-2", 2, 'topdown', len=20, max_use=1) 34 | x <- mst_obj(x, theta=-1, indices=1) 35 | x <- mst_obj(x, theta=0, indices=2:3) 36 | x <- mst_obj(x, theta=1, indices=4) 37 | x <- mst_constraint(x, "content", 6, 6, level=1) 38 | x <- mst_constraint(x, "content", 6, 6, level=2) 39 | x <- mst_constraint(x, "content", 8, 8, level=3) 40 | x <- mst_stage_length(x, 1:2, min=5) 41 | x <- mst_assemble(x) 42 | 43 | ## ex. 1: administer the MST using fixed RDP for routing 44 | x_sim <- mst_sim(x, .5, list(stage1=0, stage2=0)) 45 | plot(x_sim) 46 | 47 | ## ex. 2: administer the MST using the max. info. for routing 48 | x_sim <- mst_sim(x, .5) 49 | plot(x_sim, ylim=c(-5, 5)) 50 | } 51 | } 52 | -------------------------------------------------------------------------------- /man/ata_helpers.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module3_ata_helpers.R 3 | \name{ata_helpers} 4 | \alias{ata_helpers} 5 | \alias{ata_append_constraints} 6 | \alias{ata_form_index} 7 | \alias{ata_obj_coef} 8 | \alias{ata_solve_lpsolve} 9 | \alias{ata_solve_glpk} 10 | \title{Helper functions of ATA} 11 | \usage{ 12 | ata_append_constraints(x, mat, dir, rhs) 13 | 14 | ata_form_index(x, forms, collapse, internal_index) 15 | 16 | ata_obj_coef(x, coef, compensate) 17 | 18 | ata_solve_lpsolve(x, time_limit, message, ...) 19 | 20 | ata_solve_glpk(x, time_limit, message, ...) 21 | } 22 | \arguments{ 23 | \item{mat}{coefficient matrix} 24 | 25 | \item{dir}{direction} 26 | 27 | \item{rhs}{right-hand-side value} 28 | 29 | \item{forms}{indices of forms} 30 | 31 | \item{collapse}{\code{TRUE} to collaspe forms into one form} 32 | 33 | \item{internal_index}{\code{TRUE} to use internal form indices} 34 | 35 | \item{coef}{coefficients} 36 | 37 | \item{compensate}{\code{TRUE} to combine coefficients} 38 | 39 | \item{time_limit}{the time limit in seconds passed along to solvers} 40 | 41 | \item{message}{\code{TRUE} to print messages from solvers} 42 | 43 | \item{...}{additional control parameters for solvers} 44 | } 45 | \description{ 46 | miscellaneous helper functions of ATA 47 | 48 | \code{ata_append_constraints} appends constraint definitions to the model 49 | 50 | \code{ata_form_index} converts input forms into actual form indices in the model 51 | 52 | \code{ata_obj_coef} processes input coefficients of the objective functions 53 | 54 | \code{ata_solve_lpsolve} solves the the MIP model using lp_solve 55 | 56 | \code{ata_solve_glpk} solves the the MIP model using GLPK 57 | } 58 | \keyword{internal} 59 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method(plot,ata) 4 | S3method(plot,cat) 5 | S3method(plot,mst) 6 | S3method(plot,mst_sim) 7 | S3method(print,ata) 8 | S3method(print,cat) 9 | S3method(print,mst) 10 | S3method(print,mst_sim) 11 | export(ata) 12 | export(ata_constraint) 13 | export(ata_item_enemy) 14 | export(ata_item_fixedvalue) 15 | export(ata_item_use) 16 | export(ata_obj_absolute) 17 | export(ata_obj_relative) 18 | export(ata_solve) 19 | export(cat_estimate_eap) 20 | export(cat_estimate_hybrid) 21 | export(cat_estimate_mle) 22 | export(cat_select_ccat) 23 | export(cat_select_maxinfo) 24 | export(cat_select_shadow) 25 | export(cat_sim) 26 | export(cat_stop_default) 27 | export(cat_stop_projection) 28 | export(cronbach_alpha) 29 | export(expected_raw_score_dist) 30 | export(freq) 31 | export(model_3pl_eap_scoring) 32 | export(model_3pl_estimate_jmle) 33 | export(model_3pl_estimate_mmle) 34 | export(model_3pl_fitplot) 35 | export(model_3pl_gendata) 36 | export(model_3pl_info) 37 | export(model_3pl_lh) 38 | export(model_3pl_map_scoring) 39 | export(model_3pl_plot) 40 | export(model_3pl_plot_loglh) 41 | export(model_3pl_prob) 42 | export(model_3pl_rescale) 43 | export(model_gpcm_eap_scoring) 44 | export(model_gpcm_estimate_jmle) 45 | export(model_gpcm_estimate_mmle) 46 | export(model_gpcm_fitplot) 47 | export(model_gpcm_gendata) 48 | export(model_gpcm_info) 49 | export(model_gpcm_lh) 50 | export(model_gpcm_map_scoring) 51 | export(model_gpcm_plot) 52 | export(model_gpcm_plot_loglh) 53 | export(model_gpcm_prob) 54 | export(model_gpcm_rescale) 55 | export(model_grm_eap_scoring) 56 | export(model_grm_estimate_jmle) 57 | export(model_grm_estimate_mmle) 58 | export(model_grm_fitplot) 59 | export(model_grm_gendata) 60 | export(model_grm_info) 61 | export(model_grm_lh) 62 | export(model_grm_map_scoring) 63 | export(model_grm_plot) 64 | export(model_grm_plot_loglh) 65 | export(model_grm_prob) 66 | export(model_grm_rescale) 67 | export(mst) 68 | export(mst_assemble) 69 | export(mst_constraint) 70 | export(mst_get_items) 71 | export(mst_module_info) 72 | export(mst_obj) 73 | export(mst_rdp) 74 | export(mst_route) 75 | export(mst_sim) 76 | export(mst_stage_length) 77 | export(rmse) 78 | export(spearman_brown) 79 | export(spearman_brown_reverse) 80 | import(ggplot2) 81 | import(glpkAPI) 82 | import(lpSolveAPI) 83 | importFrom(reshape2,melt) 84 | importFrom(stats,aggregate) 85 | importFrom(stats,cor) 86 | importFrom(stats,dnorm) 87 | importFrom(stats,qnorm) 88 | importFrom(stats,rbeta) 89 | importFrom(stats,rlnorm) 90 | importFrom(stats,rnorm) 91 | importFrom(stats,runif) 92 | importFrom(stats,sd) 93 | importFrom(stats,var) 94 | -------------------------------------------------------------------------------- /man/model_grm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module1_model_grm.R 3 | \name{model_grm} 4 | \alias{model_grm} 5 | \alias{model_grm_prob} 6 | \alias{model_grm_info} 7 | \alias{model_grm_lh} 8 | \alias{model_grm_gendata} 9 | \alias{model_grm_rescale} 10 | \alias{model_grm_plot} 11 | \alias{model_grm_plot_loglh} 12 | \title{Graded Response Model} 13 | \usage{ 14 | model_grm_prob(t, a, b, D = 1.702, raw = FALSE) 15 | 16 | model_grm_info(t, a, b, D = 1.702) 17 | 18 | model_grm_lh(u, t, a, b, D = 1.702, log = FALSE) 19 | 20 | model_grm_gendata(n_p, n_i, n_c, t = NULL, a = NULL, b = NULL, 21 | D = 1.702, t_dist = c(0, 1), a_dist = c(-0.1, 0.2), b_dist = c(0, 22 | 0.8), missing = NULL) 23 | 24 | model_grm_rescale(t, a, b, param = c("t", "b"), mean = 0, sd = 1) 25 | 26 | model_grm_plot(a, b, D = 1.702, type = c("prob", "info"), 27 | by_item = FALSE, total = FALSE, xaxis = seq(-6, 6, 0.1), 28 | raw = FALSE) 29 | 30 | model_grm_plot_loglh(u, a, b, D = 1.702, xaxis = seq(-6, 6, 0.1), 31 | show_mle = FALSE) 32 | } 33 | \arguments{ 34 | \item{t}{ability parameters, 1d vector} 35 | 36 | \item{a}{discrimination parameters, 1d vector} 37 | 38 | \item{b}{item location parameters, 2d matrix} 39 | 40 | \item{D}{the scaling constant, 1.702 by default} 41 | 42 | \item{raw}{TRUE to return P*} 43 | 44 | \item{u}{the observed scores (starting from 0), 2d matrix} 45 | 46 | \item{log}{TRUE to return log-likelihood} 47 | 48 | \item{n_p}{the number of people to be generated} 49 | 50 | \item{n_i}{the number of items to be generated} 51 | 52 | \item{n_c}{the number of score categories} 53 | 54 | \item{t_dist}{parameters of the normal distribution used to generate t-parameters} 55 | 56 | \item{a_dist}{parameters of the lognormal distribution used to generate a-parameters} 57 | 58 | \item{b_dist}{parameters of the normal distribution used to generate b-parameters} 59 | 60 | \item{missing}{the proportion or number of missing responses} 61 | 62 | \item{param}{the parameter of the new scale: 't' or 'b'} 63 | 64 | \item{mean}{the mean of the new scale} 65 | 66 | \item{sd}{the standard deviation of the new scale} 67 | 68 | \item{type}{the type of plot, prob for ICC and info for IIFC} 69 | 70 | \item{by_item}{TRUE to combine categories} 71 | 72 | \item{total}{TRUE to sum values over items} 73 | 74 | \item{xaxis}{the values of x-axis} 75 | 76 | \item{show_mle}{TRUE to print maximum likelihood values} 77 | } 78 | \description{ 79 | Routine functions for the GRM 80 | } 81 | \examples{ 82 | with(model_grm_gendata(10, 5, 3), model_grm_prob(t, a, b)) 83 | with(model_grm_gendata(10, 5, 3), model_grm_info(t, a, b)) 84 | with(model_grm_gendata(10, 5, 3), model_grm_lh(u, t, a, b)) 85 | model_grm_gendata(10, 5, 3) 86 | model_grm_gendata(10, 5, 3, missing=.1) 87 | with(model_grm_gendata(10, 5, 3), model_grm_plot(a, b, type='prob')) 88 | with(model_grm_gendata(10, 5, 3), model_grm_plot(a, b, type='info', by_item=TRUE)) 89 | with(model_grm_gendata(5, 50, 3), model_grm_plot_loglh(u, a, b)) 90 | } 91 | -------------------------------------------------------------------------------- /man/model_3pl.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module1_model_3pl.R 3 | \name{model_3pl} 4 | \alias{model_3pl} 5 | \alias{model_3pl_prob} 6 | \alias{model_3pl_info} 7 | \alias{model_3pl_lh} 8 | \alias{model_3pl_rescale} 9 | \alias{model_3pl_gendata} 10 | \alias{model_3pl_plot} 11 | \alias{model_3pl_plot_loglh} 12 | \title{3-parameter-logistic model} 13 | \usage{ 14 | model_3pl_prob(t, a, b, c, D = 1.702) 15 | 16 | model_3pl_info(t, a, b, c, D = 1.702) 17 | 18 | model_3pl_lh(u, t, a, b, c, D = 1.702, log = FALSE) 19 | 20 | model_3pl_rescale(t, a, b, c, param = c("t", "b"), mean = 0, sd = 1) 21 | 22 | model_3pl_gendata(n_p, n_i, t = NULL, a = NULL, b = NULL, c = NULL, 23 | D = 1.702, t_dist = c(0, 1), a_dist = c(-0.1, 0.2), b_dist = c(0, 24 | 0.7), c_dist = c(5, 46), missing = NULL) 25 | 26 | model_3pl_plot(a, b, c, D = 1.702, type = c("prob", "info"), 27 | total = FALSE, xaxis = seq(-4, 4, 0.1)) 28 | 29 | model_3pl_plot_loglh(u, a, b, c, D = 1.702, xaxis = seq(-4, 4, 0.1), 30 | show_mle = FALSE) 31 | } 32 | \arguments{ 33 | \item{t}{ability parameters, 1d vector} 34 | 35 | \item{a}{discrimination parameters, 1d vector} 36 | 37 | \item{b}{difficulty parameters, 1d vector} 38 | 39 | \item{c}{guessing parameters, 1d vector} 40 | 41 | \item{D}{the scaling constant, 1.702 by default} 42 | 43 | \item{u}{observed responses, 2d matrix} 44 | 45 | \item{log}{True to return log-likelihood} 46 | 47 | \item{param}{the parameter of the new scale: 't' or 'b'} 48 | 49 | \item{mean}{the mean of the new scale} 50 | 51 | \item{sd}{the standard deviation of the new scale} 52 | 53 | \item{n_p}{the number of people to be generated} 54 | 55 | \item{n_i}{the number of items to be generated} 56 | 57 | \item{t_dist}{parameters of the normal distribution used to generate t-parameters} 58 | 59 | \item{a_dist}{parameters of the lognormal distribution used to generate a-parameters} 60 | 61 | \item{b_dist}{parameters of the normal distribution used to generate b-parameters} 62 | 63 | \item{c_dist}{parameters of the beta distribution used to generate c-parameters} 64 | 65 | \item{missing}{the proportion or number of missing responses} 66 | 67 | \item{type}{the type of plot: 'prob' for item characteristic curve (ICC) and 68 | 'info' for item information function curve (IIFC)} 69 | 70 | \item{total}{TRUE to sum values over items} 71 | 72 | \item{xaxis}{the values of x-axis} 73 | 74 | \item{show_mle}{TRUE to print maximum likelihood estimates} 75 | } 76 | \description{ 77 | Routine functions for the 3PL model 78 | } 79 | \examples{ 80 | with(model_3pl_gendata(10, 5), model_3pl_prob(t, a, b, c)) 81 | with(model_3pl_gendata(10, 5), model_3pl_info(t, a, b, c)) 82 | with(model_3pl_gendata(10, 5), model_3pl_lh(u, t, a, b, c)) 83 | model_3pl_gendata(10, 5) 84 | model_3pl_gendata(10, 5, a=1, c=0, missing=.1) 85 | with(model_3pl_gendata(10, 5), model_3pl_plot(a, b, c, type="prob")) 86 | with(model_3pl_gendata(10, 5), model_3pl_plot(a, b, c, type="info", total=TRUE)) 87 | with(model_3pl_gendata(5, 50), model_3pl_plot_loglh(u, a, b, c, show_mle=TRUE)) 88 | } 89 | -------------------------------------------------------------------------------- /R/module0_stat_utils.R: -------------------------------------------------------------------------------- 1 | #' Root Mean Squared Error 2 | #' @description Root mean squared error (RMSE) of two numeric vectors/matrices 3 | #' @param x a numeric vector/matrix 4 | #' @param y a numeric vector/matrix 5 | #' @export 6 | rmse <- function(x, y){ 7 | x <- as.matrix(x) 8 | y <- as.matrix(y) 9 | if(any(dim(x) != dim(y))) stop("x and y have different dimensions") 10 | sqrt(colMeans((x - y)^2)) 11 | } 12 | 13 | #' Frequency Counts 14 | #' @description Frequency counts of a vector 15 | #' @param x a numeric or character vector 16 | #' @param values valid values, \code{NULL} to include all values 17 | #' @param rounding round percentage to n-th decimal places 18 | #' @export 19 | freq <- function(x, values=NULL, rounding=NULL){ 20 | if(is.null(values)) values <- sort(unique(x)) 21 | rs <- data.frame(table(factor(x, levels=values, labels=values)), stringsAsFactors=F) 22 | colnames(rs) <- c("value", "freq") 23 | 24 | rs$perc <- rs$freq / sum(rs$freq) 25 | rs$cum_freq <- cumsum(rs$freq) 26 | rs$cum_perc <- cumsum(rs$perc) 27 | 28 | if(!is.null(rounding)){ 29 | rs$perc <- round(rs$perc, rounding) 30 | rs$cum_perc <- round(rs$cum_perc, rounding) 31 | } 32 | rs 33 | } 34 | 35 | #' Hermite-Gauss Quadrature 36 | #' @description Pre-computed hermite gaussian quadratures points and weights 37 | #' @param degree the degree of hermite-gauss quadrature: '20', '11', '7' 38 | #' @keywords internal 39 | hermite_gauss <- function(degree=c('20', '11', '7')){ 40 | switch(match.arg(degree), 41 | '20'=list(t=c(-5.38748089001123,-4.60368244955074,-3.94476404011562,-3.34785456738321,-2.78880605842813,-2.25497400208927,-1.73853771211658,-1.23407621539532,-0.737473728545394,-0.245340708300901,0.245340708300901,0.737473728545394,1.23407621539532,1.73853771211658,2.25497400208927,2.78880605842813,3.34785456738321,3.94476404011562,4.60368244955074,5.38748089001123), 42 | w=c(2.22939364553415E-13,4.39934099227318E-10,1.08606937076928E-07,7.80255647853206E-06,0.000228338636016353,0.00324377334223786,0.0248105208874636,0.109017206020023,0.286675505362834,0.46224366960061,0.46224366960061,0.286675505362834,0.109017206020023,0.0248105208874636,0.00324377334223786,0.000228338636016353,7.80255647853206E-06,1.08606937076928E-07,4.39934099227318E-10,2.22939364553415E-13)), 43 | '11'=list(t=c(-3.66847084655958,-2.78329009978165,-2.02594801582575,-1.32655708449493,-0.656809566882099,0,0.656809566882099,1.32655708449493,2.02594801582575,2.78329009978165,3.66847084655958), 44 | w=c(1.43956039371425E-06,0.000346819466323345,0.0119113954449115,0.117227875167708,0.429359752356125,0.654759286914591,0.429359752356125,0.117227875167708,0.0119113954449115,0.000346819466323345,1.43956039371425E-06)), 45 | '7'=list(t=c(-2.651961356835233492447,-1.673551628767471445032,-0.8162878828589646630387,0,0.8162878828589646630387,1.673551628767471445032,2.651961356835233492447), 46 | w=c(9.71781245099519154149E-4,0.05451558281912703059218,0.4256072526101278005203,0.810264617556807326765,0.4256072526101278005203,0.0545155828191270305922,9.71781245099519154149E-4))) 47 | } 48 | 49 | -------------------------------------------------------------------------------- /man/model_gpcm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module1_model_gpcm.R 3 | \name{model_gpcm} 4 | \alias{model_gpcm} 5 | \alias{model_gpcm_prob} 6 | \alias{model_gpcm_info} 7 | \alias{model_gpcm_lh} 8 | \alias{model_gpcm_gendata} 9 | \alias{model_gpcm_rescale} 10 | \alias{model_gpcm_plot} 11 | \alias{model_gpcm_plot_loglh} 12 | \title{Generalized Partial Credit Model} 13 | \usage{ 14 | model_gpcm_prob(t, a, b, d, D = 1.702, insert_d0 = NULL) 15 | 16 | model_gpcm_info(t, a, b, d, D = 1.702, insert_d0 = NULL) 17 | 18 | model_gpcm_lh(u, t, a, b, d, D = 1.702, insert_d0 = NULL, 19 | log = FALSE) 20 | 21 | model_gpcm_gendata(n_p, n_i, n_c, t = NULL, a = NULL, b = NULL, 22 | d = NULL, D = 1.702, sort_d = FALSE, t_dist = c(0, 1), 23 | a_dist = c(-0.1, 0.2), b_dist = c(0, 0.8), missing = NULL) 24 | 25 | model_gpcm_rescale(t, a, b, d, param = c("t", "b"), mean = 0, sd = 1) 26 | 27 | model_gpcm_plot(a, b, d, D = 1.702, insert_d0 = NULL, 28 | type = c("prob", "info"), by_item = FALSE, total = FALSE, 29 | xaxis = seq(-6, 6, 0.1)) 30 | 31 | model_gpcm_plot_loglh(u, a, b, d, D = 1.702, insert_d0 = NULL, 32 | xaxis = seq(-6, 6, 0.1), show_mle = FALSE) 33 | } 34 | \arguments{ 35 | \item{t}{ability parameters, 1d vector} 36 | 37 | \item{a}{discrimination parameters, 1d vector} 38 | 39 | \item{b}{item location parameters, 1d vector} 40 | 41 | \item{d}{item category parameters, 2d vector} 42 | 43 | \item{D}{the scaling constant, 1.702 by default} 44 | 45 | \item{insert_d0}{insert an initial category value} 46 | 47 | \item{u}{the observed scores (starting from 0), 2d matrix} 48 | 49 | \item{log}{TRUE to return log-likelihood} 50 | 51 | \item{n_p}{the number of people to be generated} 52 | 53 | \item{n_i}{the number of items to be generated} 54 | 55 | \item{n_c}{the number of score categories} 56 | 57 | \item{sort_d}{\code{TRUE} to sort d parameters for each item} 58 | 59 | \item{t_dist}{parameters of the normal distribution used to generate t-parameters} 60 | 61 | \item{a_dist}{parameters of the lognormal distribution parameters of a-parameters} 62 | 63 | \item{b_dist}{parameters of the normal distribution used to generate b-parameters} 64 | 65 | \item{missing}{the proportion or number of missing responses} 66 | 67 | \item{param}{the parameter of the new scale: 't' or 'b'} 68 | 69 | \item{mean}{the mean of the new scale} 70 | 71 | \item{sd}{the standard deviation of the new scale} 72 | 73 | \item{type}{the type of plot, prob for ICC and info for IIFC} 74 | 75 | \item{by_item}{TRUE to combine categories} 76 | 77 | \item{total}{TRUE to sum values over items} 78 | 79 | \item{xaxis}{the values of x-axis} 80 | 81 | \item{show_mle}{TRUE to print maximum likelihood values} 82 | } 83 | \description{ 84 | Routine functions for the GPCM 85 | } 86 | \details{ 87 | Use \code{NA} to represent unused category. 88 | } 89 | \examples{ 90 | with(model_gpcm_gendata(10, 5, 3), model_gpcm_prob(t, a, b, d)) 91 | with(model_gpcm_gendata(10, 5, 3), model_gpcm_info(t, a, b, d)) 92 | with(model_gpcm_gendata(10, 5, 3), model_gpcm_lh(u, t, a, b, d)) 93 | model_gpcm_gendata(10, 5, 3) 94 | model_gpcm_gendata(10, 5, 3, missing=.1) 95 | # Figure 1 in Muraki, 1992 (APM) 96 | b <- matrix(c(-2,0,2,-.5,0,2,-.5,0,2), nrow=3, byrow=TRUE) 97 | model_gpcm_plot(a=c(1,1,.7), b=rowMeans(b), d=rowMeans(b)-b, D=1.0, insert_d0=0) 98 | # Figure 2 in Muraki, 1992 (APM) 99 | b <- matrix(c(.5,0,NA,0,0,0), nrow=2, byrow=TRUE) 100 | model_gpcm_plot(a=.7, b=rowMeans(b, na.rm=TRUE), d=rowMeans(b, na.rm=TRUE)-b, D=1.0, insert_d0=0) 101 | # Figure 3 in Muraki, 1992 (APM) 102 | b <- matrix(c(1.759,-1.643,3.970,-2.764), nrow=2, byrow=TRUE) 103 | model_gpcm_plot(a=c(.778,.946), b=rowMeans(b), d=rowMeans(b)-b, D=1.0, insert_d0=0) 104 | # Figure 1 in Muraki, 1993 (APM) 105 | b <- matrix(c(0,-2,4,0,-2,2,0,-2,0,0,-2,-2,0,-2,-4), nrow=5, byrow=TRUE) 106 | model_gpcm_plot(a=1, b=rowMeans(b), d=rowMeans(b)-b, D=1.0) 107 | # Figure 2 in Muraki, 1993 (APM) 108 | b <- matrix(c(0,-2,4,0,-2,2,0,-2,0,0,-2,-2,0,-2,-4), nrow=5, byrow=TRUE) 109 | model_gpcm_plot(a=1, b=rowMeans(b), d=rowMeans(b)-b, D=1.0, type='info', by_item=TRUE) 110 | with(model_gpcm_gendata(5, 50, 3), model_gpcm_plot_loglh(u, a, b, d)) 111 | } 112 | -------------------------------------------------------------------------------- /man/estimate_grm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module2_estimate_grm.R 3 | \name{estimate_grm} 4 | \alias{estimate_grm} 5 | \alias{model_grm_eap_scoring} 6 | \alias{model_grm_map_scoring} 7 | \alias{model_grm_dv_Pt} 8 | \alias{model_grm_dv_Pa} 9 | \alias{model_grm_dv_Pb} 10 | \alias{model_grm_dv_jmle} 11 | \alias{model_grm_estimate_jmle} 12 | \alias{model_grm_dv_mmle} 13 | \alias{model_grm_estimate_mmle} 14 | \alias{model_grm_fitplot} 15 | \title{Estimate Graded Response Model} 16 | \usage{ 17 | model_grm_eap_scoring(u, a, b, D = 1.702, prior = c(0, 1), 18 | bound = c(-3, 3)) 19 | 20 | model_grm_map_scoring(u, a, b, D = 1.702, prior = NULL, bound = c(-3, 21 | 3), nr_iter = 30, nr_conv = 0.001) 22 | 23 | model_grm_dv_Pt(t, a, b, D) 24 | 25 | model_grm_dv_Pa(t, a, b, D) 26 | 27 | model_grm_dv_Pb(t, a, b, D) 28 | 29 | model_grm_dv_jmle(ix, dvp) 30 | 31 | model_grm_estimate_jmle(u, t = NA, a = NA, b = NA, D = 1.702, 32 | iter = 100, nr_iter = 10, conv = 1, nr_conv = 0.001, 33 | scale = c(0, 1), bounds_t = c(-4, 4), bounds_a = c(0.01, 2), 34 | bounds_b = c(-4, 4), priors = list(t = c(0, 1), a = c(-0.1, 0.2), b = 35 | c(0, 1)), decay = 1, debug = FALSE, true_params = NULL) 36 | 37 | model_grm_dv_mmle(u_ix, quad, pdv) 38 | 39 | model_grm_estimate_mmle(u, t = NA, a = NA, b = NA, d = NA, 40 | D = 1.702, iter = 100, nr_iter = 10, conv = 1, nr_conv = 0.001, 41 | bounds_t = c(-4, 4), bounds_a = c(0.01, 2), bounds_b = c(-4, 4), 42 | bounds_d = c(-4, 4), priors = list(t = c(0, 1), a = c(-0.1, 0.2), b = 43 | c(0, 1)), decay = 1, quad_degree = "11", scoring = c("eap", "map"), 44 | debug = FALSE, true_params = NULL) 45 | 46 | model_grm_fitplot(u, t, a, b, D = 1.702, index = NULL, 47 | intervals = seq(-3, 3, 0.5), show_points = TRUE) 48 | } 49 | \arguments{ 50 | \item{u}{the observed response matrix, 2d matrix} 51 | 52 | \item{a}{discrimination parameters, 1d vector (fixed value) or NA (freely estimate)} 53 | 54 | \item{b}{difficulty parameters, 2d matrix (fixed value) or NA (freely estimate)} 55 | 56 | \item{D}{the scaling constant, 1.702 by default} 57 | 58 | \item{prior}{the prior distribution} 59 | 60 | \item{nr_iter}{the maximum iterations of newton-raphson} 61 | 62 | \item{nr_conv}{the convegence criterion of newton-raphson} 63 | 64 | \item{t}{ability parameters, 1d vector (fixed value) or NA (freely estimate)} 65 | 66 | \item{ix}{the 3d indices} 67 | 68 | \item{dvp}{the derivatives of P} 69 | 70 | \item{iter}{the maximum iterations} 71 | 72 | \item{conv}{the convergence criterion for the -2 log-likelihood} 73 | 74 | \item{scale}{the scale of theta parameters} 75 | 76 | \item{bounds_t}{bounds of ability parameters} 77 | 78 | \item{bounds_a}{bounds of discrimination parameters} 79 | 80 | \item{bounds_b}{bounds of location parameters} 81 | 82 | \item{priors}{a list of prior distributions} 83 | 84 | \item{decay}{decay rate} 85 | 86 | \item{debug}{TRUE to print debuggin information} 87 | 88 | \item{true_params}{a list of true parameters for evaluating the estimation accuracy} 89 | 90 | \item{quad_degree}{the number of quadrature points} 91 | 92 | \item{scoring}{the scoring method: 'eap' or 'map'} 93 | 94 | \item{index}{the indices of items being plotted} 95 | 96 | \item{intervals}{intervals on the x-axis} 97 | 98 | \item{show_points}{TRUE to show points} 99 | } 100 | \description{ 101 | Estimate the GRM using the maximum likelihood estimation 102 | 103 | \code{model_grm_eap_scoring} scores response vectors using the EAP method 104 | 105 | \code{model_grm_map_scoring} scores response vectors using the MAP method 106 | 107 | \code{model_grm_estimate_jmle} estimates the parameters using the 108 | joint maximum likelihood estimation (JMLE) method 109 | 110 | \code{model_grm_estimate_mmle} estimates the parameters using the 111 | marginal maximum likelihood estimation (MMLE) method 112 | } 113 | \examples{ 114 | with(model_grm_gendata(10, 50, 3), cbind(true=t, est=model_grm_eap_scoring(u, a, b)$t)) 115 | with(model_grm_gendata(10, 50, 3), cbind(true=t, est=model_grm_map_scoring(u, a, b)$t)) 116 | \dontrun{ 117 | # generate data 118 | x <- model_grm_gendata(1000, 40, 3) 119 | # free calibration 120 | y <- model_grm_estimate_jmle(x$u, true_params=x) 121 | # no priors 122 | y <- model_grm_estimate_jmle(x$u, priors=NULL, true_params=x) 123 | } 124 | \dontrun{ 125 | # generate data 126 | x <- model_grm_gendata(1000, 40, 3) 127 | # free estimation 128 | y <- model_grm_estimate_mmle(x$u, true_params=x) 129 | # no priors 130 | y <- model_grm_estimate_mmle(x$u, priors=NULL, true_params=x) 131 | } 132 | with(model_grm_gendata(1000, 20, 3), model_grm_fitplot(u, t, a, b, index=c(1, 3, 5))) 133 | } 134 | \keyword{internal} 135 | -------------------------------------------------------------------------------- /man/estimate_gpcm.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module2_estimate_gpcm.R 3 | \name{estimate_gpcm} 4 | \alias{estimate_gpcm} 5 | \alias{model_gpcm_eap_scoring} 6 | \alias{model_gpcm_map_scoring} 7 | \alias{model_gpcm_dv_Pt} 8 | \alias{model_gpcm_dv_Pa} 9 | \alias{model_gpcm_dv_Pb} 10 | \alias{model_gpcm_dv_Pd} 11 | \alias{model_gpcm_dv_jmle} 12 | \alias{model_gpcm_estimate_jmle} 13 | \alias{model_gpcm_dv_mmle} 14 | \alias{model_gpcm_estimate_mmle} 15 | \alias{model_gpcm_fitplot} 16 | \title{Estimate Generalizaed Partial Credit Model} 17 | \usage{ 18 | model_gpcm_eap_scoring(u, a, b, d, D = 1.702, prior = c(0, 1), 19 | bound = c(-3, 3)) 20 | 21 | model_gpcm_map_scoring(u, a, b, d, D = 1.702, prior = NULL, 22 | bound = c(-3, 3), nr_iter = 30, nr_conv = 0.001) 23 | 24 | model_gpcm_dv_Pt(t, a, b, d, D) 25 | 26 | model_gpcm_dv_Pa(t, a, b, d, D) 27 | 28 | model_gpcm_dv_Pb(t, a, b, d, D) 29 | 30 | model_gpcm_dv_Pd(t, a, b, d, D) 31 | 32 | model_gpcm_dv_jmle(ix, dvp) 33 | 34 | model_gpcm_estimate_jmle(u, t = NA, a = NA, b = NA, d = NA, 35 | D = 1.702, iter = 100, nr_iter = 10, conv = 1, nr_conv = 0.001, 36 | scale = c(0, 1), bounds_t = c(-4, 4), bounds_a = c(0.01, 2), 37 | bounds_b = c(-4, 4), bounds_d = c(-4, 4), priors = list(t = c(0, 38 | 1), a = c(-0.1, 0.2), b = c(0, 1), d = c(0, 1)), decay = 1, 39 | debug = FALSE, true_params = NULL) 40 | 41 | model_gpcm_dv_mmle(u_ix, quad, pdv) 42 | 43 | model_gpcm_estimate_mmle(u, t = NA, a = NA, b = NA, d = NA, 44 | D = 1.702, iter = 100, nr_iter = 10, conv = 1, nr_conv = 0.001, 45 | bounds_t = c(-4, 4), bounds_a = c(0.01, 2), bounds_b = c(-4, 4), 46 | bounds_d = c(-4, 4), priors = list(t = c(0, 1), a = c(-0.1, 0.2), b = 47 | c(0, 1), d = c(0, 1)), decay = 1, quad_degree = "11", 48 | scoring = c("eap", "map"), debug = FALSE, true_params = NULL) 49 | 50 | model_gpcm_fitplot(u, t, a, b, d, D = 1.702, insert_d0 = NULL, 51 | index = NULL, intervals = seq(-3, 3, 0.5), show_points = TRUE) 52 | } 53 | \arguments{ 54 | \item{u}{the observed response matrix, 2d matrix} 55 | 56 | \item{a}{discrimination parameters, 1d vector (fixed value) or NA (freely estimate)} 57 | 58 | \item{b}{difficulty parameters, 1d vector (fixed value) or NA (freely estimate)} 59 | 60 | \item{d}{category parameters, 2d matrix (fixed value) or NA (freely estimate)} 61 | 62 | \item{D}{the scaling constant, 1.702 by default} 63 | 64 | \item{prior}{the prior distribution} 65 | 66 | \item{nr_iter}{the maximum iterations of newton-raphson} 67 | 68 | \item{nr_conv}{the convegence criterion for newton-raphson} 69 | 70 | \item{t}{ability parameters, 1d vector (fixed value) or NA (freely estimate)} 71 | 72 | \item{ix}{the 3d indices} 73 | 74 | \item{dvp}{the derivatives of P} 75 | 76 | \item{iter}{the maximum iterations} 77 | 78 | \item{conv}{the convergence criterion of the -2 log-likelihood} 79 | 80 | \item{scale}{the scale of theta parameters} 81 | 82 | \item{bounds_t}{bounds of ability parameters} 83 | 84 | \item{bounds_a}{bounds of discrimination parameters} 85 | 86 | \item{bounds_b}{bounds of location parameters} 87 | 88 | \item{bounds_d}{bounds of category parameters} 89 | 90 | \item{priors}{a list of prior distributions} 91 | 92 | \item{decay}{decay rate} 93 | 94 | \item{debug}{TRUE to print debuggin information} 95 | 96 | \item{true_params}{a list of true parameters for evaluating the estimation accuracy} 97 | 98 | \item{quad_degree}{the number of quadrature points} 99 | 100 | \item{scoring}{the scoring method: 'eap' or 'map'} 101 | 102 | \item{insert_d0}{insert an initial category value} 103 | 104 | \item{index}{the indices of items being plotted} 105 | 106 | \item{intervals}{intervals on the x-axis} 107 | 108 | \item{show_points}{TRUE to show points} 109 | } 110 | \description{ 111 | Estimate the GPCM using the maximum likelihood estimation 112 | 113 | \code{model_gpcm_eap_scoring} scores response vectors using the EAP method 114 | 115 | \code{model_gpcm_map_scoring} scores response vectors using maximum a posteriori 116 | 117 | \code{model_gpcm_estimate_jmle} estimates the parameters using the 118 | joint maximum likelihood estimation (JMLE) method 119 | 120 | \code{model_gpcm_estimate_mmle} estimates the parameters using the 121 | marginal maximum likelihood estimation (MMLE) method 122 | } 123 | \examples{ 124 | with(model_gpcm_gendata(10, 40, 3), cbind(true=t, est=model_gpcm_eap_scoring(u, a, b, d)$t)) 125 | with(model_gpcm_gendata(10, 40, 3), cbind(true=t, est=model_gpcm_map_scoring(u, a, b, d)$t)) 126 | \dontrun{ 127 | # generate data 128 | x <- model_gpcm_gendata(1000, 40, 3) 129 | # free calibration 130 | y <- model_gpcm_estimate_jmle(x$u, true_params=x) 131 | # no priors 132 | y <- model_gpcm_estimate_jmle(x$u, priors=NULL, true_params=x) 133 | } 134 | \dontrun{ 135 | # generate data 136 | x <- model_gpcm_gendata(1000, 40, 3) 137 | # free estimation 138 | y <- model_gpcm_estimate_mmle(x$u, true_params=x) 139 | # no priors 140 | y <- model_gpcm_estimate_mmle(x$u, priors=NULL, true_params=x) 141 | } 142 | with(model_gpcm_gendata(1000, 20, 3), model_gpcm_fitplot(u, t, a, b, d, index=c(1, 3, 5))) 143 | } 144 | \keyword{internal} 145 | -------------------------------------------------------------------------------- /R/module5_mst_sim.R: -------------------------------------------------------------------------------- 1 | #' Simulation of Multistage Testing 2 | #' @name mst_sim 3 | #' @examples 4 | #' \dontrun{ 5 | #' ## assemble a MST 6 | #' nitems <- 200 7 | #' pool <- with(model_3pl_gendata(1, nitems), data.frame(a=a, b=b, c=c)) 8 | #' pool$content <- sample(1:3, nrow(pool), replace=TRUE) 9 | #' x <- mst(pool, "1-2-2", 2, 'topdown', len=20, max_use=1) 10 | #' x <- mst_obj(x, theta=-1, indices=1) 11 | #' x <- mst_obj(x, theta=0, indices=2:3) 12 | #' x <- mst_obj(x, theta=1, indices=4) 13 | #' x <- mst_constraint(x, "content", 6, 6, level=1) 14 | #' x <- mst_constraint(x, "content", 6, 6, level=2) 15 | #' x <- mst_constraint(x, "content", 8, 8, level=3) 16 | #' x <- mst_stage_length(x, 1:2, min=5) 17 | #' x <- mst_assemble(x) 18 | #' 19 | #' ## ex. 1: administer the MST using fixed RDP for routing 20 | #' x_sim <- mst_sim(x, .5, list(stage1=0, stage2=0)) 21 | #' plot(x_sim) 22 | #' 23 | #' ## ex. 2: administer the MST using the max. info. for routing 24 | #' x_sim <- mst_sim(x, .5) 25 | #' plot(x_sim, ylim=c(-5, 5)) 26 | #' } 27 | NULL 28 | 29 | #' @description \code{mst_sim} simulates a MST administration 30 | #' @param x the assembled MST 31 | #' @param true the true theta parameter (numeric) 32 | #' @param rdp routing decision points (list) 33 | #' @param ... additional option/control parameters 34 | #' @importFrom stats runif 35 | #' @export 36 | mst_sim <- function(x, true, rdp=NULL, ...){ 37 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 38 | if(is.null(x$items)) stop("the mst has not been assembled yet") 39 | opts <- list(...) 40 | if(is.null(opts$t_prior)) prior <- NULL else prior <- list(t=opts$t_prior) 41 | 42 | # inits 43 | if(is.null(opts$panel)) opts$panel <- sample(1:x$num_panel, 1) 44 | panel_items <- mst_get_items(x, panel_ix=opts$panel) 45 | theta <- ifelse(is.null(opts$theta), 0, opts$theta) 46 | admin <- NULL 47 | stats <- matrix(nrow=x$num_stage, ncol=4, dimnames=list(NULL, c("route", "t", "info", "se"))) 48 | 49 | # routing decision points 50 | if(!is.null(rdp)) { 51 | if(length(rdp) != x$num_stage - 1) stop("invalid routing decision points.") 52 | rdp <- Reduce(rbind, lapply(rdp, function(x) data.frame(lower=c(-Inf, x), upper=c(x, Inf)))) 53 | rdp$index <- 2:x$num_module 54 | } 55 | 56 | # MST administration 57 | for(i in 1:x$num_stage){ 58 | # select module 59 | if(i == 1) { 60 | next_module <- unique(x$route[, i]) 61 | next_module <- sample(next_module, 1) 62 | } else { 63 | next_module <- x$route[x$route[, i-1] == stats[i-1, "route"], i] 64 | next_module <- sort(unique(next_module)) 65 | if(is.null(rdp)) { 66 | info <- model_3pl_info(theta, panel_items$a, panel_items$b, panel_items$c)[1, ] 67 | info <- aggregate(info, by=list(module=panel_items$module), sum) 68 | info <- info[info$module %in% next_module, ] 69 | next_module <- info$module[which.max(info$x)] 70 | } else { 71 | module_rdp <- subset(rdp, rdp$index %in% next_module) 72 | module_rdp$lower[1] <- -Inf 73 | module_rdp$upper[nrow(module_rdp)] <- Inf 74 | next_module <- min(subset(module_rdp, theta < module_rdp$upper)$index) 75 | } 76 | } 77 | 78 | # generate responses 79 | items <- subset(panel_items, panel_items$stage == i & panel_items$module == next_module) 80 | rsp <- as.integer(model_3pl_prob(true, items$a, items$b, items$c)[1, ] >= runif(nrow(items))) 81 | admin <- rbind(admin, cbind(items, rsp=rsp)) 82 | 83 | # estimate ability 84 | theta <- model_3pl_estimate_jmle(matrix(rep(admin$rsp, each=2), nrow=2), a=admin$a, b=admin$b, c=admin$c, scale=NULL, priors=prior)$t[1] 85 | info <- sum(model_3pl_info(theta, admin$a, admin$b, admin$c)) 86 | se <- 1 / sqrt(info) 87 | stats[i, c('route', 't', 'info', 'se')] <- c(next_module, theta, info, se) 88 | } 89 | 90 | stats <- as.data.frame(stats) 91 | stats$nitems <- sapply(stats$route, function(xx) sum(admin$module == xx)) 92 | rs <- list(panel=panel_items, admin=admin, stats=stats, true=true, theta=theta) 93 | class(rs) <- "mst_sim" 94 | rs 95 | } 96 | 97 | 98 | #' @rdname mst_sim 99 | #' @export 100 | print.mst_sim <- function(x, ...){ 101 | cat("mst simulation: true=", round(x$true, 2), 102 | ", est.=", round(x$theta, 2), ":\n", sep="") 103 | print(round(x$stats, 2)) 104 | cat("Call x$admin to see administered items ('x' is the mst_sim object).\n") 105 | } 106 | 107 | 108 | #' @rdname mst_sim 109 | #' @importFrom stats qnorm 110 | #' @import ggplot2 111 | #' @export 112 | plot.mst_sim <- function(x, ...) { 113 | opts <- list(...) 114 | if(is.null(opts$ci_width)) opts$ci_width <- qnorm(.975) 115 | if(is.null(opts$ylim)) opts$ylim <- c(-3, 3) 116 | x$admin$Position <- seq(nrow(x$admin)) 117 | x$admin$Responses <- factor(x$admin$rsp, levels=c(0, 1), labels=c('Wrong', 'Right')) 118 | x$stats$lb <- x$stats$t - opts$ci_width * x$stats$se 119 | x$stats$ub <- x$stats$t + opts$ci_width * x$stats$se 120 | x$stats$position <- cumsum(x$stats$nitems) 121 | 122 | ggplot(x$admin, aes_string(x="Position", y="b")) + 123 | geom_point(aes_string(size="a", color="Responses")) + 124 | geom_pointrange(data=x$stats, aes_string(x="position", y="t", ymin="lb", ymax="ub"), lty=2, pch=4, col="coral") + 125 | xlab("Position") + ylab("Item Difficulty") + guides(size=F, fill=F) + 126 | coord_cartesian(ylim=opts$ylim) + scale_size_continuous(range=c(1, 3)) + theme_bw() 127 | } 128 | 129 | -------------------------------------------------------------------------------- /man/estimate_3pl.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module2_estimate_3pl.R 3 | \name{estimate_3pl} 4 | \alias{estimate_3pl} 5 | \alias{model_3pl_eap_scoring} 6 | \alias{model_3pl_map_scoring} 7 | \alias{model_3pl_dv_Pt} 8 | \alias{model_3pl_dv_Pa} 9 | \alias{model_3pl_dv_Pb} 10 | \alias{model_3pl_dv_Pc} 11 | \alias{model_3pl_dv_jmle} 12 | \alias{model_3pl_estimate_jmle} 13 | \alias{model_3pl_dv_mmle} 14 | \alias{model_3pl_estimate_mmle} 15 | \alias{model_3pl_fitplot} 16 | \title{Estimate 3-parameter-logistic model} 17 | \usage{ 18 | model_3pl_eap_scoring(u, a, b, c, D = 1.702, prior = c(0, 1), 19 | bound = c(-3, 3)) 20 | 21 | model_3pl_map_scoring(u, a, b, c, D = 1.702, prior = c(0, 1), 22 | bound = c(-3, 3), nr_iter = 30, nr_conv = 0.001) 23 | 24 | model_3pl_dv_Pt(t, a, b, c, D) 25 | 26 | model_3pl_dv_Pa(t, a, b, c, D) 27 | 28 | model_3pl_dv_Pb(t, a, b, c, D) 29 | 30 | model_3pl_dv_Pc(t, a, b, c, D) 31 | 32 | model_3pl_dv_jmle(dv, u) 33 | 34 | model_3pl_estimate_jmle(u, t = NA, a = NA, b = NA, c = NA, 35 | D = 1.702, iter = 100, conv = 1, nr_iter = 10, nr_conv = 0.001, 36 | scale = c(0, 1), bounds_t = c(-3, 3), bounds_a = c(0.01, 2), 37 | bounds_b = c(-3, 3), bounds_c = c(0, 0.25), priors = list(t = c(0, 38 | 1), a = c(-0.1, 0.2), b = c(0, 1), c = c(4, 20)), decay = 1, 39 | debug = FALSE, true_params = NULL) 40 | 41 | model_3pl_dv_mmle(pdv_fn, u, quad, a, b, c, D) 42 | 43 | model_3pl_estimate_mmle(u, t = NA, a = NA, b = NA, c = NA, 44 | D = 1.702, iter = 100, conv = 1, nr_iter = 10, nr_conv = 0.001, 45 | bounds_t = c(-3, 3), bounds_a = c(0.01, 2), bounds_b = c(-3, 3), 46 | bounds_c = c(0, 0.25), priors = list(t = c(0, 1), a = c(-0.1, 0.2), b 47 | = c(0, 1), c = c(4, 20)), decay = 1, quad_degree = "11", 48 | scoring = c("eap", "map"), debug = FALSE, true_params = NULL) 49 | 50 | model_3pl_fitplot(u, t, a, b, c, D = 1.702, index = NULL, 51 | intervals = seq(-3, 3, 0.5), show_points = TRUE) 52 | } 53 | \arguments{ 54 | \item{u}{observed response matrix, 2d matrix} 55 | 56 | \item{a}{discrimination parameters, 1d vector (fixed value) or NA (freely estimate)} 57 | 58 | \item{b}{difficulty parameters, 1d vector (fixed value) or NA (freely estimate)} 59 | 60 | \item{c}{pseudo-guessing parameters, 1d vector (fixed value) or NA (freely estimate)} 61 | 62 | \item{D}{the scaling constant, 1.702 by default} 63 | 64 | \item{prior}{the prior distribution} 65 | 66 | \item{nr_iter}{the maximum iterations of newton-raphson} 67 | 68 | \item{nr_conv}{the convegence criterion for newton-raphson} 69 | 70 | \item{t}{ability parameters, 1d vector (fixed value) or NA (freely estimate)} 71 | 72 | \item{iter}{the maximum iterations} 73 | 74 | \item{conv}{the convergence criterion of the -2 log-likelihood} 75 | 76 | \item{scale}{the meand and SD of the theta scale, N(0, 1) for JMLE by default} 77 | 78 | \item{bounds_t}{bounds of ability parameters} 79 | 80 | \item{bounds_a}{bounds of discrimination parameters} 81 | 82 | \item{bounds_b}{bounds of difficulty parameters} 83 | 84 | \item{bounds_c}{bounds of guessing parameters} 85 | 86 | \item{priors}{a list of prior distributions} 87 | 88 | \item{decay}{decay rate} 89 | 90 | \item{debug}{TRUE to print debuggin information} 91 | 92 | \item{true_params}{a list of true parameters for evaluating the estimation accuracy} 93 | 94 | \item{pdv_fn}{the function to compute derivatives of P w.r.t the estimating parameters} 95 | 96 | \item{quad_degree}{the number of quadrature points} 97 | 98 | \item{scoring}{the scoring method: 'eap' or 'map'} 99 | 100 | \item{index}{the indices of items being plotted} 101 | 102 | \item{intervals}{intervals on the x-axis} 103 | 104 | \item{show_points}{TRUE to show points} 105 | } 106 | \description{ 107 | Estimate the 3PL model using the maximum likelihood estimation 108 | 109 | \code{model_3pl_eap_scoring} scores response vectors using the EAP method 110 | 111 | \code{model_3pl_map_scoring} scores response vectors using the MAP method 112 | 113 | \code{model_3pl_dv_jmle} calculates the first and second derivatives for 114 | the joint maximum likelihood estimation 115 | 116 | \code{model_3pl_estimate_jmle} estimates the parameters using the 117 | joint maximum likelihood estimation (JMLE) method 118 | 119 | \code{model_3pl_dv_mmle} calculates the first and second derivatives for 120 | the marginal maximum likelihood estimation 121 | 122 | \code{model_3pl_estimate_mmle} estimates the parameters using the 123 | marginal maximum likelihood estimation (MMLE) method 124 | } 125 | \examples{ 126 | with(model_3pl_gendata(10, 40), cbind(true=t, est=model_3pl_eap_scoring(u, a, b, c)$t)) 127 | with(model_3pl_gendata(10, 40), cbind(true=t, est=model_3pl_map_scoring(u, a, b, c)$t)) 128 | \dontrun{ 129 | # generate data 130 | x <- model_3pl_gendata(2000, 40) 131 | # free estimation 132 | y <- model_3pl_estimate_jmle(x$u, true_params=x) 133 | # fix c-parameters 134 | y <- model_3pl_estimate_jmle(x$u, c=0, true_params=x) 135 | # no priors 136 | y <- model_3pl_estimate_jmle(x$u, priors=NULL, iter=30, debug=T) 137 | } 138 | \dontrun{ 139 | # generate data 140 | x <- model_3pl_gendata(2000, 40) 141 | # free estimation 142 | y <- model_3pl_estimate_mmle(x$u, true_params=x) 143 | # fix c-parameters 144 | y <- model_3pl_estimate_mmle(x$u, c=0, true_params=x) 145 | # no priors 146 | y <- model_3pl_estimate_mmle(x$u, priors=NULL, iter=30, debug=T) 147 | } 148 | with(model_3pl_gendata(1000, 20), model_3pl_fitplot(u, t, a, b, c, index=c(1, 3, 5))) 149 | } 150 | \keyword{internal} 151 | -------------------------------------------------------------------------------- /R/module1_model_3pl.R: -------------------------------------------------------------------------------- 1 | #' 3-parameter-logistic model 2 | #' @description Routine functions for the 3PL model 3 | #' @name model_3pl 4 | NULL 5 | 6 | #' @rdname model_3pl 7 | #' @param t ability parameters, 1d vector 8 | #' @param a discrimination parameters, 1d vector 9 | #' @param b difficulty parameters, 1d vector 10 | #' @param c guessing parameters, 1d vector 11 | #' @param D the scaling constant, 1.702 by default 12 | #' @examples 13 | #' with(model_3pl_gendata(10, 5), model_3pl_prob(t, a, b, c)) 14 | #' @export 15 | model_3pl_prob <- function(t, a, b, c, D=1.702){ 16 | p <- c + (1 - c) / (1 + exp(D * a * outer(b, t, '-'))) 17 | t(p) 18 | } 19 | 20 | #' @rdname model_3pl 21 | #' @examples 22 | #' with(model_3pl_gendata(10, 5), model_3pl_info(t, a, b, c)) 23 | #' @export 24 | model_3pl_info <- function(t, a, b, c, D=1.702){ 25 | p <- t(model_3pl_prob(t, a, b, c, D)) 26 | i <- (D * a * (p - c) / (1 - c))^2 * (1 - p) / p 27 | t(i) 28 | } 29 | 30 | #' @rdname model_3pl 31 | #' @param u observed responses, 2d matrix 32 | #' @param log True to return log-likelihood 33 | #' @examples 34 | #' with(model_3pl_gendata(10, 5), model_3pl_lh(u, t, a, b, c)) 35 | #' @export 36 | model_3pl_lh <- function(u, t, a, b, c, D=1.702, log=FALSE){ 37 | p <- model_3pl_prob(t, a, b, c, D) 38 | lh <- p^u * (1-p)^(1-u) 39 | if(log) lh <- log(lh) 40 | lh 41 | } 42 | 43 | #' @rdname model_3pl 44 | #' @param param the parameter of the new scale: 't' or 'b' 45 | #' @param mean the mean of the new scale 46 | #' @param sd the standard deviation of the new scale 47 | #' @importFrom stats sd 48 | #' @export 49 | model_3pl_rescale <- function(t, a, b, c, param=c("t", "b"), mean=0, sd=1){ 50 | scale <- switch(match.arg(param), "t"=t, "b"=b) 51 | slope <- sd / sd(scale) 52 | intercept <- mean - slope * mean(scale) 53 | t <- slope * t + intercept 54 | b <- slope * b + intercept 55 | a <- a / slope 56 | list(t=t, a=a, b=b, c=c) 57 | } 58 | 59 | #' @rdname model_3pl 60 | #' @param n_p the number of people to be generated 61 | #' @param n_i the number of items to be generated 62 | #' @param t_dist parameters of the normal distribution used to generate t-parameters 63 | #' @param a_dist parameters of the lognormal distribution used to generate a-parameters 64 | #' @param b_dist parameters of the normal distribution used to generate b-parameters 65 | #' @param c_dist parameters of the beta distribution used to generate c-parameters 66 | #' @param missing the proportion or number of missing responses 67 | #' @examples 68 | #' model_3pl_gendata(10, 5) 69 | #' model_3pl_gendata(10, 5, a=1, c=0, missing=.1) 70 | #' @importFrom stats rnorm rlnorm rbeta runif 71 | #' @export 72 | model_3pl_gendata <- function(n_p, n_i, t=NULL, a=NULL, b=NULL, c=NULL, D=1.702, t_dist=c(0, 1), a_dist=c(-.1, .2), b_dist=c(0, .7), c_dist=c(5, 46), missing=NULL){ 73 | if(is.null(t)) t <- rnorm(n_p, mean=t_dist[1], sd=t_dist[2]) 74 | if(is.null(a)) a <- rlnorm(n_i, meanlog=a_dist[1], sdlog=a_dist[2]) 75 | if(is.null(b)) b <- rnorm(n_i, mean=b_dist[1], sd=b_dist[2]) 76 | if(is.null(c)) c <- rbeta(n_i, shape1=c_dist[1], shape2=c_dist[2]) 77 | if(length(t) == 1) t <- rep(t, n_p) 78 | if(length(a) == 1) a <- rep(a, n_i) 79 | if(length(b) == 1) b <- rep(b, n_i) 80 | if(length(c) == 1) c <- rep(c, n_i) 81 | if(length(t) != n_p) stop('wrong dimensions of t parameters') 82 | if(length(a) != n_i) stop('wrong dimensions of a parameters') 83 | if(length(b) != n_i) stop('wrong dimensions of b parameters') 84 | if(length(c) != n_i) stop('wrong dimensions of c parameters') 85 | 86 | p <- model_3pl_prob(t, a, b, c, D) 87 | x <- array(runif(length(p)), dim(p)) 88 | u <- (p >= x) * 1L 89 | if(!is.null(missing)){ 90 | missing <- floor(ifelse(missing < 1, missing * n_p * n_i, missing)) 91 | idx <- sample(length(u), missing) 92 | u[cbind(ceiling(idx/n_i), (idx-1)%%n_i+1)] <- NA 93 | } 94 | list(u=u, t=t, a=a, b=b, c=c) 95 | } 96 | 97 | 98 | #' @rdname model_3pl 99 | #' @param type the type of plot: 'prob' for item characteristic curve (ICC) and 100 | #' 'info' for item information function curve (IIFC) 101 | #' @param total TRUE to sum values over items 102 | #' @param xaxis the values of x-axis 103 | #' @examples 104 | #' with(model_3pl_gendata(10, 5), model_3pl_plot(a, b, c, type="prob")) 105 | #' with(model_3pl_gendata(10, 5), model_3pl_plot(a, b, c, type="info", total=TRUE)) 106 | #' @import ggplot2 107 | #' @importFrom reshape2 melt 108 | #' @export 109 | model_3pl_plot <- function(a, b, c, D=1.702, type=c('prob', 'info'), total=FALSE, xaxis=seq(-4, 4, .1)){ 110 | x <- switch(match.arg(type), "prob"=model_3pl_prob, "info"=model_3pl_info)(t=xaxis, a=a, b=b, c=c, D=D) 111 | if(total) x <- rowSums(x) 112 | x <- data.frame(theta=xaxis, x) 113 | x <- melt(x, id.vars="theta") 114 | ggplot(x, aes_string(x="theta", y="value", color="variable")) + 115 | geom_line() + xlab(expression(theta)) + ylab('') + 116 | guides(color=FALSE) + theme_bw() + theme(legend.key=element_blank()) 117 | } 118 | 119 | #' @rdname model_3pl 120 | #' @param show_mle TRUE to print maximum likelihood estimates 121 | #' @examples 122 | #' with(model_3pl_gendata(5, 50), model_3pl_plot_loglh(u, a, b, c, show_mle=TRUE)) 123 | #' @import ggplot2 124 | #' @importFrom reshape2 melt 125 | #' @export 126 | model_3pl_plot_loglh <- function(u, a, b, c, D=1.702, xaxis=seq(-4, 4, .1), show_mle=FALSE){ 127 | p <- model_3pl_prob(xaxis, a, b, c, D) 128 | lh <- log(p) %*% t(u) + log(1 - p) %*% t(1 - u) 129 | if(show_mle) print(apply(lh, 2, function(x){xaxis[which.max(x)]})) 130 | x <- data.frame(theta=xaxis, lh) 131 | x <- melt(x, id.vars="theta") 132 | ggplot(x, aes_string(x="theta", y="value", color="variable")) + 133 | geom_line() + xlab(expression(theta)) + ylab("Log-likelihood") + 134 | guides(color=FALSE) + theme_bw() 135 | } 136 | 137 | -------------------------------------------------------------------------------- /man/cat_sim.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module4_cat.R 3 | \name{cat_sim} 4 | \alias{cat_sim} 5 | \alias{cat_estimate_mle} 6 | \alias{cat_estimate_eap} 7 | \alias{cat_estimate_hybrid} 8 | \alias{cat_stop_default} 9 | \alias{cat_select_maxinfo} 10 | \alias{cat_select_ccat} 11 | \alias{cat_select_shadow} 12 | \alias{print.cat} 13 | \alias{plot.cat} 14 | \alias{cat_stop_projection} 15 | \title{Simulation of Computerized Adaptive Testing (CAT)} 16 | \usage{ 17 | cat_sim(true, pool, ...) 18 | 19 | cat_estimate_mle(len, theta, stats, admin, pool, opts) 20 | 21 | cat_estimate_eap(len, theta, stats, admin, pool, opts) 22 | 23 | cat_estimate_hybrid(len, theta, stats, admin, pool, opts) 24 | 25 | cat_stop_default(len, theta, stats, admin, pool, opts) 26 | 27 | cat_select_maxinfo(len, theta, stats, admin, pool, opts) 28 | 29 | cat_select_ccat(len, theta, stats, admin, pool, opts) 30 | 31 | cat_select_shadow(len, theta, stats, admin, pool, opts) 32 | 33 | \method{print}{cat}(x, ...) 34 | 35 | \method{plot}{cat}(x, ...) 36 | 37 | cat_stop_projection(len, theta, stats, admin, pool, opts) 38 | } 39 | \arguments{ 40 | \item{true}{the true theta} 41 | 42 | \item{pool}{the item pool (data.frame)} 43 | 44 | \item{...}{option/control parameters} 45 | 46 | \item{len}{the current test length} 47 | 48 | \item{theta}{the current theta estimate} 49 | 50 | \item{stats}{a matrix of responses, theta estimate, information and std error} 51 | 52 | \item{admin}{a data frame of administered items} 53 | 54 | \item{opts}{a list of option/control parameters} 55 | 56 | \item{x}{a \code{cat} object} 57 | } 58 | \value{ 59 | \code{cat_sim} returns a \code{cat} object 60 | 61 | an estimation rule should return a theta estimate 62 | 63 | a stopping rule should return a boolean: \code{TRUE} to stop the CAT, \code{FALSE} to continue 64 | 65 | a selection rule should return a list of (a) the selected item and (b) the updated pool 66 | } 67 | \description{ 68 | \code{cat_sim} runs a simulation of CAT. Use \code{theta} in options to set the starting 69 | value of theta estimate. 70 | 71 | \code{cat_estimate_mle} is the maximum likelihood estimation rule. Use 72 | \code{map_len} to apply MAP to the first K items and use \code{map_prior} to set the 73 | prior for MAP. 74 | 75 | \code{cat_estimate_eap} is the expected a posteriori estimation rule, 76 | using \code{eap_mean} and \code{eap_sd} option parameters as the prior 77 | 78 | \code{cat_estimate_hybrid} is a hybrid estimation rule, which uses MLE for 79 | mixed responses and EAP for all 1's or 0's responses 80 | 81 | \code{cat_stop_default} is a three-way stopping rule. When \code{stop_se} 82 | is set in the options, it uses the standard error stopping rule. When 83 | \code{stop_mi} is set in the options, it uses the minimum information stopping rule. When 84 | \code{stop_cut} is set in the options, it uses the confidence interval (set by \code{ci_width}) 85 | stopping rule. 86 | 87 | \code{cat_select_maxinfo} is the maximum information selection rule. Use \code{group} 88 | (a numeric vector) to group items belonging to the same set. Use \code{info_random} to implement 89 | the random-esque item exposure control method. 90 | 91 | \code{cat_select_ccat} is the constrained CAT selection rule. Use 92 | \code{ccat_var} to set the content variable in the pool. Use \code{ccat_perc} to set 93 | the desired content distribution, with the name of each element being the content code 94 | and tue value of each element being the percentage. Use \code{ccat_random} to add randomness 95 | to initial item selections. 96 | 97 | \code{cat_select_shadow} is the shadow-test selection rule. Use \code{shadow_id} 98 | to group item sets. Use \code{constraints} to set constraints. Constraints should be in a data.frame 99 | with four columns: var (variable name), level (variable level, \code{NA} for quantitative variable), 100 | min (lower bound), and max (upper bound). 101 | 102 | \code{cat_stop_projection} is the projection-based stopping rule. Use 103 | \code{projection_method} to choose the projection method ('info' or 'diff'). Use 104 | \code{stop_cut} to set the cut score. Use \code{constraints} to set the constraints. 105 | Constraints should be a data.frame with columns: var (variable name), 106 | level (variable level, \code{NA} for quantitative varialbe), min (lower bound), max (upper bound) 107 | } 108 | \details{ 109 | \code{...} takes a variety of option/control parameters for the simulations from users. 110 | \code{min} and {max} are mandatory for setting limits on the test length. User-defined 111 | selection, estimation, and stopping rules are also passed to the simulator via options.\cr 112 | To write a new rule, the function siganiture must be: \code{function(len, theta, stats, admin, pool, opts)}. 113 | See built-in rules for examples. 114 | } 115 | \examples{ 116 | \dontrun{ 117 | ## generate a 100-item pool 118 | num_items <- 100 119 | pool <- with(model_3pl_gendata(1, num_items), data.frame(a=a, b=b, c=c)) 120 | pool$set_id <- sample(1:30, num_items, replace=TRUE) 121 | pool$content <- sample(1:3, num_items, replace=TRUE) 122 | pool$time <- round(rlnorm(num_items, mean=4.1, sd=.2)) 123 | 124 | ## MLE, EAP, and hybrid estimation rule 125 | cat_sim(1.0, pool, min=10, max=20, estimate_rule=cat_estimate_mle) 126 | cat_sim(1.0, pool, min=10, max=20, estimate_rule=cat_estimate_eap) 127 | cat_sim(1.0, pool, min=10, max=20, estimate_rule=cat_estimate_hybrid) 128 | 129 | ## SE, MI, and CI stopping rule 130 | cat_sim(1.0, pool, min=10, max=20, stop_se=.3) 131 | cat_sim(1.0, pool, min=10, max=20, stop_mi=.6) 132 | cat_sim(1.0, pool, min=10, max=20, stop_cut=0) 133 | cat_sim(1.0, pool, min=10, max=20, stop_cut=0, ci_width=2.58) 134 | 135 | ## maximum information selection with item sets 136 | cat_sim(1.0, pool, min=10, max=20, group="set_id")$admin 137 | 138 | ## maximum information with item exposure control 139 | cat_sim(1.0, pool, min=10, max=20, info_random=5)$admin 140 | 141 | ## Constrained-CAT selection rule with and without initial randomness 142 | cat_sim(1.0, pool, min=10, max=20, select_rule=cat_select_ccat, 143 | ccat_var="content", ccat_perc=c("1"=.2, "2"=.3, "3"=.5)) 144 | cat_sim(1.0, pool, min=10, max=20, select_rule=cat_select_ccat, ccat_random=5, 145 | ccat_var="content", ccat_perc=c("1"=.2, "2"=.3, "3"=.5)) 146 | 147 | ## Shadow-test selection rule 148 | cons <- data.frame(var='content', level=1:3, min=c(3,3,4), max=c(3,3,4)) 149 | cons <- rbind(cons, data.frame(var='time', level=NA, min=55*10, max=65*10)) 150 | cat_sim(1.0, pool, min=10, max=10, select_rule=cat_select_shadow, constraints=cons) 151 | 152 | ## Projection-based stopping rule 153 | cons <- data.frame(var='content', level=1:3, min=5, max=15) 154 | cons <- rbind(cons, data.frame(var='time', level=NA, min=60*20, max=60*40)) 155 | cat_sim(1.0, pool, min=20, max=40, select_rule=cat_select_shadow, stop_rule=cat_stop_projection, 156 | projection_method="diff", stop_cut=0, constraints=cons) 157 | } 158 | } 159 | -------------------------------------------------------------------------------- /R/module1_model_grm.R: -------------------------------------------------------------------------------- 1 | #' Graded Response Model 2 | #' @description Routine functions for the GRM 3 | #' @name model_grm 4 | NULL 5 | 6 | #' @rdname model_grm 7 | #' @param t ability parameters, 1d vector 8 | #' @param a discrimination parameters, 1d vector 9 | #' @param b item location parameters, 2d matrix 10 | #' @param D the scaling constant, 1.702 by default 11 | #' @param raw TRUE to return P* 12 | #' @examples 13 | #' with(model_grm_gendata(10, 5, 3), model_grm_prob(t, a, b)) 14 | #' @export 15 | model_grm_prob <- function(t, a, b, D=1.702, raw=FALSE){ 16 | n_p <- length(t) 17 | n_i <- nrow(b) 18 | n_c <- ncol(b)+1 19 | p <- 1 / (1 + exp(D * a * outer(b, t, '-'))) 20 | if(raw) { 21 | p <- apply(p, 1, function(x) rbind(1, x, 0)) 22 | p <- aperm(array(p, dim=c(n_c+1, n_p, n_i)), c(2, 3, 1)) 23 | } else { 24 | p <- apply(p, 1, function(x) rbind(1, x) - rbind(x, 0)) 25 | p <- aperm(array(p, dim=c(n_c, n_p, n_i)), c(2, 3, 1)) 26 | } 27 | p 28 | } 29 | 30 | #' @rdname model_grm 31 | #' @examples 32 | #' with(model_grm_gendata(10, 5, 3), model_grm_info(t, a, b)) 33 | #' @export 34 | model_grm_info <- function(t, a, b, D=1.702){ 35 | p <- model_grm_prob(t, a, b, D) 36 | p_ <- aperm(apply(p, c(1, 2), function(x) rev(cumsum(c(0, rev(x))))), c(2, 3, 1)) 37 | num_cats <- dim(p)[3] 38 | dv1_p_ <- aperm(p_ * (1 - p_), c(2, 3, 1)) * D * a 39 | dv2_p_ <- aperm((1 - 2 * p_) * p_ * (1 - p_), c(2, 3, 1)) * (D * a)^2 40 | dv1_p <- dv1_p_[,1:num_cats,] - dv1_p_[,-1,] 41 | dv1_p <- aperm(dv1_p, c(3, 1, 2)) 42 | dv2_p <- dv2_p_[,1:num_cats,] - dv2_p_[,-1,] 43 | dv2_p <- aperm(dv2_p, c(3, 1, 2)) 44 | 1 / p * dv1_p^2 - dv2_p 45 | } 46 | 47 | #' @rdname model_grm 48 | #' @param u the observed scores (starting from 0), 2d matrix 49 | #' @param log TRUE to return log-likelihood 50 | #' @examples 51 | #' with(model_grm_gendata(10, 5, 3), model_grm_lh(u, t, a, b)) 52 | #' @export 53 | model_grm_lh <- function(u, t, a, b, D=1.702, log=FALSE){ 54 | p <- model_grm_prob(t, a, b, D) 55 | ix <- model_polytomous_3dindex(u) 56 | lh <- array(p[ix], dim=dim(u)) 57 | if(log) lh <- log(lh) 58 | lh 59 | } 60 | 61 | #' @rdname model_grm 62 | #' @param n_p the number of people to be generated 63 | #' @param n_i the number of items to be generated 64 | #' @param n_c the number of score categories 65 | #' @param t_dist parameters of the normal distribution used to generate t-parameters 66 | #' @param a_dist parameters of the lognormal distribution used to generate a-parameters 67 | #' @param b_dist parameters of the normal distribution used to generate b-parameters 68 | #' @param missing the proportion or number of missing responses 69 | #' @examples 70 | #' model_grm_gendata(10, 5, 3) 71 | #' model_grm_gendata(10, 5, 3, missing=.1) 72 | #' @importFrom stats rnorm rlnorm runif 73 | #' @export 74 | model_grm_gendata <- function(n_p, n_i, n_c, t=NULL, a=NULL, b=NULL, D=1.702, t_dist=c(0, 1), a_dist=c(-.1, .2), b_dist=c(0, .8), missing=NULL){ 75 | if(is.null(t)) t <- rnorm(n_p, mean=t_dist[1], sd=t_dist[2]) 76 | if(is.null(a)) a <- rlnorm(n_i, meanlog=a_dist[1], sdlog=a_dist[2]) 77 | if(is.null(b)) { 78 | b <- matrix(rnorm(n_i * (n_c - 1), mean=b_dist[1], sd=b_dist[2]), nrow=n_i) 79 | b <- t(apply(b, 1, sort)) 80 | b <- matrix(b, nrow=n_i, ncol=n_c-1) 81 | } 82 | 83 | if(length(t) == 1) t <- rep(t, n_p) 84 | if(length(a) == 1) a <- rep(a, n_i) 85 | if(length(t) != n_p) stop('wrong dimensions for t') 86 | if(length(a) != n_i) stop('wrong dimensions for a') 87 | if(nrow(b) != n_i || ncol(b) != n_c - 1) stop('wrong dimensions for b') 88 | 89 | p <- model_grm_prob(t, a, b, D) 90 | u <- apply(p, 2, function(x) rowSums(runif(n_p) >= t(apply(x, 1, cumsum)))) 91 | if(!is.null(missing)){ 92 | missing <- floor(ifelse(missing < 1, missing * n_p * n_i, missing)) 93 | idx <- sample(length(u), missing) 94 | u[cbind(ceiling(idx/n_i), (idx-1)%%n_i+1)] <- NA 95 | } 96 | list(u=u, t=t, a=a, b=b) 97 | } 98 | 99 | #' @rdname model_grm 100 | #' @param param the parameter of the new scale: 't' or 'b' 101 | #' @param mean the mean of the new scale 102 | #' @param sd the standard deviation of the new scale 103 | #' @importFrom stats sd 104 | #' @export 105 | model_grm_rescale <- function(t, a, b, param=c("t", "b"), mean=0, sd=1){ 106 | scale <- switch(match.arg(param), "t"=t, "b"=b) 107 | slope <- sd / sd(scale) 108 | intercept <- mean - slope * mean(scale) 109 | t <- slope * t + intercept 110 | b <- slope * b + intercept 111 | a <- a / slope 112 | list(t=t, a=a, b=b) 113 | } 114 | 115 | #' @rdname model_grm 116 | #' @param type the type of plot, prob for ICC and info for IIFC 117 | #' @param total TRUE to sum values over items 118 | #' @param by_item TRUE to combine categories 119 | #' @param xaxis the values of x-axis 120 | #' @examples 121 | #' with(model_grm_gendata(10, 5, 3), model_grm_plot(a, b, type='prob')) 122 | #' with(model_grm_gendata(10, 5, 3), model_grm_plot(a, b, type='info', by_item=TRUE)) 123 | #' @import ggplot2 124 | #' @importFrom stats aggregate 125 | #' @export 126 | model_grm_plot <- function(a, b, D=1.702, type=c('prob', 'info'), by_item=FALSE, total=FALSE, xaxis=seq(-6, 6, .1), raw=FALSE){ 127 | rs <- switch(match.arg(type), "prob"=model_grm_prob(xaxis, a, b, D, raw), "info"=model_grm_info(xaxis, a, b, D)) 128 | n_p <- dim(rs)[1] 129 | n_i <- dim(rs)[2] 130 | n_c <- dim(rs)[3] 131 | y <- NULL 132 | for(i in 1:n_i) 133 | y <- rbind(y, data.frame(theta=rep(xaxis, n_c), item=paste('Item', i), category=paste('Category', rep(1:n_c, each=n_p)), x=as.vector(rs[,i,]))) 134 | if(by_item) y <- rbind(y, cbind(aggregate(y$x, by=list(theta=y$theta, item=y$item), sum), category='Total')) 135 | if(total) y <- cbind(aggregate(y$x, by=list(theta=y$theta, category=y$category), sum), item='Total') 136 | 137 | y <- y[!is.na(y$x),] 138 | ggplot(y, aes_string(x="theta", y="x", color="category")) + 139 | geom_line() + facet_wrap(~item, scales='free') + 140 | xlab(expression(theta)) + ylab(type) + 141 | guides(color=FALSE) + theme_bw() + theme(legend.key=element_blank()) 142 | } 143 | 144 | #' @rdname model_grm 145 | #' @param show_mle TRUE to print maximum likelihood values 146 | #' @examples 147 | #' with(model_grm_gendata(5, 50, 3), model_grm_plot_loglh(u, a, b)) 148 | #' @import ggplot2 149 | #' @export 150 | model_grm_plot_loglh <- function(u, a, b, D=1.702, xaxis=seq(-6, 6, .1), show_mle=FALSE){ 151 | n_p <- dim(u)[1] 152 | n_i <- dim(u)[2] 153 | n_t <- length(xaxis) 154 | rs <- array(NA, dim=c(n_p, n_t)) 155 | for(i in 1:n_t) 156 | rs[, i] <- rowSums(model_grm_lh(u, rep(xaxis[i], n_p), a, b, D, log=TRUE)) 157 | if(show_mle) print(apply(rs, 1, function(x){xaxis[which.max(x)]})) 158 | 159 | rs <- data.frame(theta=rep(xaxis, each=n_p), people=rep(1:n_p, n_t), value=as.vector(rs)) 160 | rs$people <- factor(rs$people) 161 | ggplot(rs, aes_string(x="theta", y="value", color="people")) + 162 | geom_line() + xlab(expression(theta)) + ylab("Log-likelihood") + 163 | guides(color=FALSE) + theme_bw() 164 | } 165 | -------------------------------------------------------------------------------- /man/ata.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module3_ata.R 3 | \name{ata} 4 | \alias{ata} 5 | \alias{print.ata} 6 | \alias{plot.ata} 7 | \alias{ata_obj_relative} 8 | \alias{ata_obj_absolute} 9 | \alias{ata_constraint} 10 | \alias{ata_item_use} 11 | \alias{ata_item_enemy} 12 | \alias{ata_item_fixedvalue} 13 | \alias{ata_solve} 14 | \title{Automated Test Assembly (ATA)} 15 | \usage{ 16 | ata(pool, num_form = 1, len = NULL, max_use = NULL, ...) 17 | 18 | \method{print}{ata}(x, ...) 19 | 20 | \method{plot}{ata}(x, ...) 21 | 22 | ata_obj_relative(x, coef, mode = c("max", "min"), tol = NULL, 23 | negative = FALSE, forms = NULL, collapse = FALSE, 24 | internal_index = FALSE, ...) 25 | 26 | ata_obj_absolute(x, coef, target, equal_tol = FALSE, tol_up = NULL, 27 | tol_down = NULL, forms = NULL, collapse = FALSE, 28 | internal_index = FALSE, ...) 29 | 30 | ata_constraint(x, coef, min = NA, max = NA, level = NULL, 31 | forms = NULL, collapse = FALSE, internal_index = FALSE) 32 | 33 | ata_item_use(x, min = NA, max = NA, items = NULL) 34 | 35 | ata_item_enemy(x, items) 36 | 37 | ata_item_fixedvalue(x, items, min = NA, max = NA, forms) 38 | 39 | ata_solve(x, solver = c("lpsolve", "glpk"), as.list = TRUE, 40 | details = TRUE, time_limit = 10, message = FALSE, ...) 41 | } 42 | \arguments{ 43 | \item{pool}{item pool, a data.frame} 44 | 45 | \item{num_form}{number of forms to be assembled} 46 | 47 | \item{len}{test length of each form} 48 | 49 | \item{max_use}{maximum use of each item} 50 | 51 | \item{...}{options, e.g. group, common_items, overlap_items} 52 | 53 | \item{x}{an ATA object} 54 | 55 | \item{coef}{coefficients of the objective function} 56 | 57 | \item{mode}{optimization mode: 'max' for maximization and 'min' for minimization} 58 | 59 | \item{tol}{the tolerance paraemter} 60 | 61 | \item{negative}{\code{TRUE} when the objective function is expected to be negative} 62 | 63 | \item{forms}{forms where objectives are added. \code{NULL} for all forms} 64 | 65 | \item{collapse}{\code{TRUE} to collapse into one objective function} 66 | 67 | \item{internal_index}{\code{TRUE} to use internal form indices} 68 | 69 | \item{target}{the target values of the objective function} 70 | 71 | \item{equal_tol}{\code{TRUE} to force upward and downward tolerance to be equal} 72 | 73 | \item{tol_up}{the range of upward tolerance} 74 | 75 | \item{tol_down}{the range of downward tolerance} 76 | 77 | \item{min}{the lower bound of the constraint} 78 | 79 | \item{max}{the upper bound of the constraint} 80 | 81 | \item{level}{the level of a categorical variable to be constrained} 82 | 83 | \item{items}{a vector of item indices, \code{NULL} for all items} 84 | 85 | \item{solver}{use 'lpsolve' for lp_solve 5.5 or 'glpk' for GLPK} 86 | 87 | \item{as.list}{\code{TRUE} to return results in a list; otherwise, a data frame} 88 | 89 | \item{details}{\code{TRUE} to print detailed information} 90 | 91 | \item{time_limit}{the time limit in seconds passed along to solvers} 92 | 93 | \item{message}{\code{TRUE} to print messages from solvers} 94 | } 95 | \description{ 96 | \code{ata} initiates an ATA model 97 | 98 | \code{ata_obj_relative} adds a relative objective to the model 99 | 100 | \code{ata_obj_absolute} adds an absolute objective to the model 101 | 102 | \code{ata_constraint} adds a constraint to the model 103 | 104 | \code{ata_item_use} limits the minimum and maximum usage for items 105 | 106 | \code{ata_item_enemy} adds an enemy-item constraint to the model 107 | 108 | \code{ata_item_fixedvalue} forces an item to be selected or not selected 109 | 110 | \code{ata_solve} solves the MIP model 111 | } 112 | \details{ 113 | The ATA model stores the definition of a MIP model. \code{ata_solve} 114 | converts the model definition to a real MIP object and attempts to solve it. 115 | 116 | \code{ata_obj_relative}: 117 | when mode='max', maximize (y-tol), subject to y <= sum(x) <= y+tol; 118 | when mode='min', minimize (y+tol), subject to y-tol <= sum(x) <= y. 119 | When \code{negative} is \code{TRUE}, y < 0, tol > 0. 120 | \code{coef} can be a numeric vector that has the same length with the pool or forms, 121 | or a variable name in the pool, or a numeric vector of theta points. 122 | When \code{tol} is \code{NULL}, it is optimized; when \code{FALSE}, ignored; 123 | when a number, fixed; when a range, constrained with lower and upper bounds. 124 | 125 | \code{ata_obj_absolute} minimizes y0+y1 subject to t-y0 <= sum(x) <= t+y1. 126 | 127 | When \code{level} is \code{NA}, it is assumed that the constraint is on 128 | a quantitative item property; otherwise, a categorical item property. 129 | \code{coef} can be a variable name, a constant, or a numeric vector that has 130 | the same size as the pool. 131 | 132 | \code{ata_solve} takes control options in \code{...}. 133 | For lpsolve, see \code{lpSolveAPI::lp.control.options}. 134 | For glpk, see \code{glpkAPI::glpkConstants}\cr 135 | Once the model is solved, additional data are added to the model. 136 | \code{status} shows the status of the solution, \code{optimum} 137 | the optimal value of the objective fucntion found in the solution, 138 | \code{obj_vars} the values of two critical variables in the objective 139 | function, \code{result} the assembly results in a binary matrix, and 140 | \code{items} the assembled items 141 | } 142 | \examples{ 143 | \dontrun{ 144 | ## generate a pool of 100 items 145 | n_items <- 100 146 | pool <- with(model_3pl_gendata(1, nitems), data.frame(id=1:n_items, a=a, b=b, c=c)) 147 | pool$content <- sample(1:3, n_items, replace=TRUE) 148 | pool$time <- round(rlnorm(n_items, log(60), .2)) 149 | pool$group <- sort(sample(1:round(n_items/3), n_items, replace=TRUE)) 150 | 151 | ## ex. 1: four 10-item forms, maximize b parameter 152 | x <- ata(pool, 4, len=10, max_use=1) 153 | x <- ata_obj_relative(x, "b", "max") 154 | x <- ata_solve(x, timeout=5) 155 | data.frame(form=1:4, b=sapply(x$items, function(x) mean(x$b))) 156 | 157 | ## ex. 2: four 10-item forms, minimize b parameter 158 | x <- ata(pool, 4, len=10, max_use=1) 159 | x <- ata_obj_relative(x, "b", "min", negative=TRUE) 160 | x <- ata_solve(x, as.list=FALSE, timeout=5) 161 | with(x$items, aggregate(b, by=list(form=form), mean)) 162 | 163 | ## ex. 3: two 10-item forms, mean(b)=0, sd(b)=1 164 | ## content = (3, 3, 4), avg. time = 58--62 seconds 165 | constr <- data.frame(name='content',level=1:3, min=c(3,3,4), max=c(3,3,4), stringsAsFactors=F) 166 | constr <- rbind(constr, c('time', NA, 58*10, 62*10)) 167 | x <- ata(pool, 2, len=10, max_use=1) 168 | x <- ata_obj_absolute(x, pool$b, 0*10) 169 | x <- ata_obj_absolute(x, (pool$b-0)^2, 1*10) 170 | for(i in 1:nrow(constr)) 171 | x <- with(constr, ata_constraint(x, name[i], min[i], max[i], level=level[i])) 172 | x <- ata_solve(x, timeout=5) 173 | sapply(x$items, function(x) c(mean=mean(x$b), sd=sd(x$b))) 174 | 175 | ## ex. 4: two 10-item forms, max TIF over (-1, 1), consider item sets 176 | x <- ata(pool, 2, len=10, max_use=1, group="group") 177 | x <- ata_obj_relative(x, seq(-1, 1, .5), 'max') 178 | x <- ata_solve(x, timeout=5) 179 | plot(x) 180 | } 181 | } 182 | -------------------------------------------------------------------------------- /man/mst.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/module5_mst.R 3 | \name{mst} 4 | \alias{mst} 5 | \alias{mst_route} 6 | \alias{mst_get_indices} 7 | \alias{mst_obj} 8 | \alias{mst_constraint} 9 | \alias{mst_stage_length} 10 | \alias{mst_rdp} 11 | \alias{mst_module_info} 12 | \alias{mst_assemble} 13 | \alias{print.mst} 14 | \alias{plot.mst} 15 | \alias{mst_get_items} 16 | \title{Computerized Multistage Testing (MST)} 17 | \usage{ 18 | mst(pool, design, num_panel, method = c("topdown", "bottomup"), 19 | len = NULL, max_use = NULL, group = NULL, ...) 20 | 21 | mst_route(x, route, op = c("+", "-")) 22 | 23 | mst_get_indices(x, indices) 24 | 25 | mst_obj(x, theta, indices = NULL, target = NULL, ...) 26 | 27 | mst_constraint(x, coef, min = NA, max = NA, level = NULL, 28 | indices = NULL) 29 | 30 | mst_stage_length(x, stages, min = NA, max = NA) 31 | 32 | mst_rdp(x, theta, indices, tol = 0) 33 | 34 | mst_module_info(x, thetas, min, max, indices) 35 | 36 | mst_assemble(x, ...) 37 | 38 | \method{print}{mst}(x, ...) 39 | 40 | \method{plot}{mst}(x, ...) 41 | 42 | mst_get_items(x, panel_ix = NULL, stage_ix = NULL, module_ix = NULL, 43 | route_ix = NULL) 44 | } 45 | \arguments{ 46 | \item{pool}{the item pool (data.frame)} 47 | 48 | \item{design}{the MST design (string): e.g., "1-3", "1-2-2", "1-2-3"} 49 | 50 | \item{num_panel}{the number of panels (integer)} 51 | 52 | \item{method}{the design method (string): 'topdown' or 'bottomup'} 53 | 54 | \item{len}{the module/route length (integer)} 55 | 56 | \item{max_use}{the maximum selection of items (integer)} 57 | 58 | \item{group}{the grouping variable (string or vector)} 59 | 60 | \item{...}{further arguments} 61 | 62 | \item{x}{the MST object} 63 | 64 | \item{route}{a MST route represented by a vector of module indices} 65 | 66 | \item{op}{"+" to add a route and "-" to remove a route} 67 | 68 | \item{indices}{the indices of the route (topdown) or the module (bottomup) where objectives are added} 69 | 70 | \item{theta}{a theta point or interval over which the TIF is optimized} 71 | 72 | \item{target}{the target values of the TIF objectives. \code{NULL} for maximization} 73 | 74 | \item{coef}{the coefficients of the constraint} 75 | 76 | \item{min}{the lower bound of the constraint} 77 | 78 | \item{max}{the upper bound of the constraint} 79 | 80 | \item{level}{the constrained level, \code{NA} for quantitative variable} 81 | 82 | \item{stages}{the stage indices} 83 | 84 | \item{tol}{tolerance parameter (numeric)} 85 | 86 | \item{thetas}{theta points, a vector} 87 | 88 | \item{panel_ix}{the panel index, an int vector} 89 | 90 | \item{stage_ix}{the stage index, an int vector} 91 | 92 | \item{module_ix}{the module index, an int vector} 93 | 94 | \item{route_ix}{the route index, an integer} 95 | } 96 | \description{ 97 | \code{mst} creates a multistage (MST) object for assembly 98 | 99 | \code{mst_route} adds/removes a route to/from the MST 100 | 101 | \code{mst_get_indices} maps the input indices to the actual indices 102 | 103 | \code{mst_obj} adds objective functions to the MST 104 | 105 | \code{mst_constraint} adds constraints to the MST 106 | 107 | \code{mst_stage_length} sets length limits on stages 108 | 109 | \code{mst_rdp} anchors the routing decision point (rdp) between adjacent modules 110 | 111 | \code{mst_module_mininfo} sets the minimum information for modules 112 | 113 | \code{mst_assemble} assembles the mst 114 | 115 | \code{mst_get_items} extracts items from the assembly results 116 | } 117 | \details{ 118 | There are two methods for designing a MST. The bottom-up approach adds objectives 119 | and constraints on individual modules, whereas the topdown approach adds objectives 120 | and constraints directly on routes. 121 | 122 | \code{plot.mst} draws module information functions when \code{byroute=FALSE} 123 | and route information functions when \code{byroute=TRUE} 124 | } 125 | \examples{ 126 | \dontrun{ 127 | ## generate item pool 128 | num_item <- 300 129 | pool <- with(model_3pl_gendata(1, num_item), data.frame(a=a, b=b, c=c)) 130 | pool$id <- 1:num_item 131 | pool$content <- sample(1:3, num_item, replace=TRUE) 132 | pool$time <- round(rlnorm(num_item, 4, .3)) 133 | pool$group <- sort(sample(1:round(num_item/3), num_item, replace=TRUE)) 134 | 135 | ## ex. 1: 1-2-2 MST, 2 panels, topdown 136 | ## 20 items in total and 10 items in content area 1 in each route 137 | ## maximize info. at -1 and 1 for easy and hard routes 138 | x <- mst(pool, "1-2-2", 2, 'topdown', len=20, max_use=1) 139 | x <- mst_obj(x, theta=-1, indices=1:2) 140 | x <- mst_obj(x, theta=1, indices=3:4) 141 | x <- mst_constraint(x, "content", 10, 10, level=1) 142 | x <- mst_assemble(x, timeout=5) 143 | plot(x, byroute=TRUE) 144 | for(p in 1:x$num_panel) 145 | for(r in 1:x$num_route) { 146 | route <- paste(x$route[r, 1:x$num_stage], collapse='-') 147 | count <- sum(mst_get_items(x, panel_ix=p, route_ix=r)$content==1) 148 | cat('panel=', p, ', route=', route, ': ', count, ' items in content area #1\\n', sep='') 149 | } 150 | 151 | ## ex. 2: 1-2-3 MST, 2 panels, bottomup, 152 | ## remove two routes with large theta change: 1-2-6, 1-3-4 153 | ## 10 items in total and 4 items in content area 2 in each module 154 | ## maximize info. at -1, 0 and 1 for easy, medium, and hard modules 155 | x <- mst(pool, "1-2-3", 2, 'bottomup', len=10, max_use=1) 156 | x <- mst_route(x, c(1, 2, 6), "-") 157 | x <- mst_route(x, c(1, 3, 4), "-") 158 | x <- mst_obj(x, theta= 0, indices=c(1, 5)) 159 | x <- mst_obj(x, theta=-1, indices=c(2, 4)) 160 | x <- mst_obj(x, theta= 1, indices=c(3, 6)) 161 | x <- mst_constraint(x, "content", 4, 4, level=2) 162 | x <- mst_assemble(x, timeout=10) 163 | plot(x, byroute=FALSE) 164 | for(p in 1:x$num_panel) 165 | for(m in 1:x$num_module){ 166 | count <- sum(mst_get_items(x, panel_ix=p, module_ix=m)$content==2) 167 | cat('panel=', p, ', module=', m, ': ', count, ' items in content area #2\\n', sep='') 168 | } 169 | 170 | ## ex.3: same with ex.2 (w/o content constraints), but group-based 171 | x <- mst(pool, "1-2-3", 2, 'bottomup', len=12, max_use=1, group="group") 172 | x <- mst_route(x, c(1, 2, 6), "-") 173 | x <- mst_route(x, c(1, 3, 4), "-") 174 | x <- mst_obj(x, theta= 0, indices=c(1, 5)) 175 | x <- mst_obj(x, theta=-1, indices=c(2, 4)) 176 | x <- mst_obj(x, theta= 1, indices=c(3, 6)) 177 | x <- mst_assemble(x, timeout=10) 178 | plot(x, byroute=FALSE) 179 | for(p in 1:x$num_panel) 180 | for(m in 1:x$num_module){ 181 | items <- mst_get_items(x, panel_ix=p, module_ix=m) 182 | cat('panel=', p, ', module=', m, ': ', length(unique(items$id)), ' items from ', 183 | length(unique(items$group)), ' groups\\n', sep='') 184 | } 185 | 186 | ## ex.4: 2 panels of 1-2-3 top-down design 187 | ## 20 total items and 10 items in content area 3 188 | ## 6+ items in stage 1 & 2 189 | x <- mst(pool, "1-2-3", 2, "topdown", len=20, max_use=1) 190 | x <- mst_route(x, c(1, 2, 6), "-") 191 | x <- mst_route(x, c(1, 3, 4), "-") 192 | x <- mst_obj(x, theta=-1, indices=1) 193 | x <- mst_obj(x, theta=0, indices=2:3) 194 | x <- mst_obj(x, theta=1, indices=4) 195 | x <- mst_constraint(x, "content", 10, 10, level=3) 196 | x <- mst_stage_length(x, 1:2, min=6) 197 | x <- mst_assemble(x, timeout=15) 198 | head(x$items) 199 | plot(x, byroute=FALSE) 200 | for(p in 1:x$num_panel) 201 | for(s in 1:x$num_stage){ 202 | items <- mst_get_items(x, panel_ix=p, stage_ix=s) 203 | cat('panel=', p, ', stage=', s, ': ', length(unique(items$id)), ' items\\n', sep='') 204 | } 205 | 206 | ## ex.5: same with ex.4, but use RDP instead of stage length to control routing errors 207 | x <- mst(pool, "1-2-3", 2, "topdown", len=20, max_use=1) 208 | x <- mst_route(x, c(1, 2, 6), "-") 209 | x <- mst_route(x, c(1, 3, 4), "-") 210 | x <- mst_obj(x, theta=-1, indices=1) 211 | x <- mst_obj(x, theta=0, indices=2:3) 212 | x <- mst_obj(x, theta=1, indices=4) 213 | x <- mst_constraint(x, "content", 10, 10, level=3) 214 | x <- mst_rdp(x, 0, 2:3, .1) 215 | x <- mst_module_mininfo(x, 0, 5, 2:3) 216 | x <- mst_assemble(x, timeout=15) 217 | plot(x, byroute=FALSE) 218 | } 219 | } 220 | \keyword{internal} 221 | -------------------------------------------------------------------------------- /R/module1_model_gpcm.R: -------------------------------------------------------------------------------- 1 | #' Generalized Partial Credit Model 2 | #' @description Routine functions for the GPCM 3 | #' @name model_gpcm 4 | NULL 5 | 6 | #' @rdname model_gpcm 7 | #' @param t ability parameters, 1d vector 8 | #' @param a discrimination parameters, 1d vector 9 | #' @param b item location parameters, 1d vector 10 | #' @param d item category parameters, 2d vector 11 | #' @param D the scaling constant, 1.702 by default 12 | #' @param insert_d0 insert an initial category value 13 | #' @details 14 | #' Use \code{NA} to represent unused category. 15 | #' @examples 16 | #' with(model_gpcm_gendata(10, 5, 3), model_gpcm_prob(t, a, b, d)) 17 | #' @export 18 | model_gpcm_prob <- function(t, a, b, d, D=1.702, insert_d0=NULL){ 19 | if(!is.null(insert_d0)) d <- cbind(insert_d0, d) 20 | p <- -1 * outer(b - d, t, '-') * a * D 21 | p <- apply(p, c(1, 3), function(x) { 22 | x <- exp(cumsum(x)) 23 | x / sum(x, na.rm=TRUE) 24 | }) 25 | aperm(p, c(3, 2, 1)) 26 | } 27 | 28 | #' @rdname model_gpcm 29 | #' @examples 30 | #' with(model_gpcm_gendata(10, 5, 3), model_gpcm_info(t, a, b, d)) 31 | #' @export 32 | model_gpcm_info <- function(t, a, b, d, D=1.702, insert_d0=NULL){ 33 | p <- model_gpcm_prob(t, a, b, d, D, insert_d0) 34 | n_i <- dim(p)[2] 35 | n_c <- dim(p)[3] 36 | if(length(a) == 1) a <- rep(a, n_i) 37 | rs <- array(NA, dim=dim(p)) 38 | for(j in 1:n_i) 39 | rs[,j,] <- (D * a[j])^2 * p[,j,] * colSums(1:n_c * t(p[,j,]) * outer(1:n_c, colSums(t(p[,j,]) * 1:n_c), '-')) 40 | rs 41 | } 42 | 43 | #' @rdname model_gpcm 44 | #' @param u the observed scores (starting from 0), 2d matrix 45 | #' @param log TRUE to return log-likelihood 46 | #' @examples 47 | #' with(model_gpcm_gendata(10, 5, 3), model_gpcm_lh(u, t, a, b, d)) 48 | #' @export 49 | model_gpcm_lh <- function(u, t, a, b, d, D=1.702, insert_d0=NULL, log=FALSE){ 50 | p <- model_gpcm_prob(t, a, b, d, D, insert_d0) 51 | ix <- model_polytomous_3dindex(u) 52 | lh <- array(p[ix], dim=dim(u)) 53 | if(log) lh <- log(lh) 54 | lh 55 | } 56 | 57 | #' @rdname model_gpcm 58 | #' @param n_p the number of people to be generated 59 | #' @param n_i the number of items to be generated 60 | #' @param n_c the number of score categories 61 | #' @param sort_d \code{TRUE} to sort d parameters for each item 62 | #' @param t_dist parameters of the normal distribution used to generate t-parameters 63 | #' @param a_dist parameters of the lognormal distribution parameters of a-parameters 64 | #' @param b_dist parameters of the normal distribution used to generate b-parameters 65 | #' @param missing the proportion or number of missing responses 66 | #' @examples 67 | #' model_gpcm_gendata(10, 5, 3) 68 | #' model_gpcm_gendata(10, 5, 3, missing=.1) 69 | #' @importFrom stats rnorm rlnorm runif 70 | #' @export 71 | model_gpcm_gendata <- function(n_p, n_i, n_c, t=NULL, a=NULL, b=NULL, d=NULL, D=1.702, sort_d=FALSE, t_dist=c(0, 1), a_dist=c(-.1, .2), b_dist=c(0, .8), missing=NULL){ 72 | if(is.null(t)) t <- rnorm(n_p, mean=t_dist[1], sd=t_dist[2]) 73 | if(is.null(a)) a <- rlnorm(n_i, meanlog=a_dist[1], sdlog=a_dist[2]) 74 | if(is.null(b)) b <- rnorm(n_i, mean=b_dist[1], sd=b_dist[2]) 75 | if(is.null(d)) { 76 | d <- matrix(rnorm(n_i * n_c, mean=0, sd=1), nrow=n_i, ncol=n_c) 77 | d[, 1] <- 0 78 | d[, -1] <- d[, -1] - rowMeans(d[, -1]) 79 | if(sort_d) d[, -1] <- t(apply(d[, -1], 1, sort)) 80 | } 81 | 82 | if(length(t) == 1) t <- rep(t, n_p) 83 | if(length(a) == 1) a <- rep(a, n_i) 84 | if(length(t) != n_p) stop('wrong dimensions for t') 85 | if(length(a) != n_i) stop('wrong dimensions for a') 86 | if(length(b) != n_i) stop('wrong dimensions for b') 87 | if(nrow(d) != n_i || ncol(d) != n_c) stop('wrong dimensions for d') 88 | 89 | p <- model_gpcm_prob(t, a, b, d, D, NULL) 90 | u <-apply(p, 2, function(x) rowSums(runif(n_p) >= t(apply(x, 1, cumsum)))) 91 | if(!is.null(missing)){ 92 | missing <- floor(ifelse(missing < 1, missing * n_p * n_i, missing)) 93 | idx <- sample(length(u), missing) 94 | u[cbind(ceiling(idx/n_i), (idx-1)%%n_i+1)] <- NA 95 | } 96 | list(u=u, t=t, a=a, b=b, d=d) 97 | } 98 | 99 | 100 | #' @rdname model_gpcm 101 | #' @param param the parameter of the new scale: 't' or 'b' 102 | #' @param mean the mean of the new scale 103 | #' @param sd the standard deviation of the new scale 104 | #' @importFrom stats sd 105 | #' @export 106 | model_gpcm_rescale <- function(t, a, b, d, param=c("t", "b"), mean=0, sd=1){ 107 | scale <- switch(match.arg(param), "t"=t, "b"=b) 108 | slope <- sd / sd(scale) 109 | intercept <- mean - slope * mean(scale) 110 | t <- slope * t + intercept 111 | b <- slope * b + intercept 112 | a <- a / slope 113 | d <- d * slope 114 | list(t=t, a=a, b=b, d=d) 115 | } 116 | 117 | #' @rdname model_gpcm 118 | #' @param type the type of plot, prob for ICC and info for IIFC 119 | #' @param total TRUE to sum values over items 120 | #' @param by_item TRUE to combine categories 121 | #' @param xaxis the values of x-axis 122 | #' @examples 123 | #' # Figure 1 in Muraki, 1992 (APM) 124 | #' b <- matrix(c(-2,0,2,-.5,0,2,-.5,0,2), nrow=3, byrow=TRUE) 125 | #' model_gpcm_plot(a=c(1,1,.7), b=rowMeans(b), d=rowMeans(b)-b, D=1.0, insert_d0=0) 126 | #' # Figure 2 in Muraki, 1992 (APM) 127 | #' b <- matrix(c(.5,0,NA,0,0,0), nrow=2, byrow=TRUE) 128 | #' model_gpcm_plot(a=.7, b=rowMeans(b, na.rm=TRUE), d=rowMeans(b, na.rm=TRUE)-b, D=1.0, insert_d0=0) 129 | #' # Figure 3 in Muraki, 1992 (APM) 130 | #' b <- matrix(c(1.759,-1.643,3.970,-2.764), nrow=2, byrow=TRUE) 131 | #' model_gpcm_plot(a=c(.778,.946), b=rowMeans(b), d=rowMeans(b)-b, D=1.0, insert_d0=0) 132 | #' # Figure 1 in Muraki, 1993 (APM) 133 | #' b <- matrix(c(0,-2,4,0,-2,2,0,-2,0,0,-2,-2,0,-2,-4), nrow=5, byrow=TRUE) 134 | #' model_gpcm_plot(a=1, b=rowMeans(b), d=rowMeans(b)-b, D=1.0) 135 | #' # Figure 2 in Muraki, 1993 (APM) 136 | #' b <- matrix(c(0,-2,4,0,-2,2,0,-2,0,0,-2,-2,0,-2,-4), nrow=5, byrow=TRUE) 137 | #' model_gpcm_plot(a=1, b=rowMeans(b), d=rowMeans(b)-b, D=1.0, type='info', by_item=TRUE) 138 | #' @import ggplot2 139 | #' @importFrom stats aggregate 140 | #' @export 141 | model_gpcm_plot <- function(a, b, d, D=1.702, insert_d0=NULL, type=c('prob', 'info'), by_item=FALSE, total=FALSE, xaxis=seq(-6, 6, .1)){ 142 | rs <- switch(match.arg(type), "prob"=model_gpcm_prob, "info"=model_gpcm_info)(xaxis, a, b, d, D, insert_d0) 143 | n_p <- dim(rs)[1] 144 | n_i <- dim(rs)[2] 145 | n_c <- dim(rs)[3] 146 | y <- NULL 147 | for(i in 1:n_i) 148 | y <- rbind(y, data.frame(theta=rep(xaxis, n_c), item=paste('Item', i), category=paste('Category', rep(1:n_c, each=n_p)), x=as.vector(rs[, i, ]))) 149 | if(by_item) y <- rbind(y, cbind(aggregate(y$x, by=list(theta=y$theta, item=y$item), sum), category='Total')) 150 | if(total) y <- cbind(aggregate(y$x, by=list(theta=y$theta, category=y$category), sum), item='Total') 151 | 152 | y <- y[!is.na(y$x),] 153 | ggplot(y, aes_string(x="theta", y="x", color="category")) + 154 | geom_line() + facet_wrap(~item, scales='free') + 155 | xlab(expression(theta)) + ylab(type) + 156 | guides(color=FALSE) + theme_bw() + theme(legend.key=element_blank()) 157 | } 158 | 159 | #' @rdname model_gpcm 160 | #' @param show_mle TRUE to print maximum likelihood values 161 | #' @examples 162 | #' with(model_gpcm_gendata(5, 50, 3), model_gpcm_plot_loglh(u, a, b, d)) 163 | #' @import ggplot2 164 | #' @export 165 | model_gpcm_plot_loglh <- function(u, a, b, d, D=1.702, insert_d0=NULL, xaxis=seq(-6, 6, .1), show_mle=FALSE){ 166 | n_p <- dim(u)[1] 167 | n_i <- dim(u)[2] 168 | n_t <- length(xaxis) 169 | rs <- array(NA, dim=c(n_p, n_t)) 170 | for(i in 1:n_t) 171 | rs[, i] <- rowSums(model_gpcm_lh(u, rep(xaxis[i], n_p), a, b, d, D, insert_d0, log=TRUE)) 172 | if(show_mle) print(apply(rs, 1, function(x){xaxis[which.max(x)]})) 173 | 174 | rs <- data.frame(theta=rep(xaxis, each=n_p), people=rep(1:n_p, n_t), value=as.vector(rs)) 175 | rs$people <- factor(rs$people) 176 | ggplot(rs, aes_string(x="theta", y="value", color="people")) + 177 | geom_line() + xlab(expression(theta)) + ylab("Log-likelihood") + 178 | guides(color=FALSE) + theme_bw() 179 | } 180 | 181 | -------------------------------------------------------------------------------- /R/module3_ata_helpers.R: -------------------------------------------------------------------------------- 1 | #' Helper functions of ATA 2 | #' @description miscellaneous helper functions of ATA 3 | #' @name ata_helpers 4 | NULL 5 | 6 | #' @rdname ata_helpers 7 | #' @description \code{ata_append_constraints} appends constraint definitions to the model 8 | #' @param mat coefficient matrix 9 | #' @param dir direction 10 | #' @param rhs right-hand-side value 11 | #' @keywords internal 12 | ata_append_constraints <- function(x, mat, dir, rhs) { 13 | x$mat <- rbind(x$mat, mat) 14 | x$dir <- c(x$dir, dir) 15 | x$rhs <- c(x$rhs, rhs) 16 | x 17 | } 18 | 19 | #' @rdname ata_helpers 20 | #' @description \code{ata_form_index} converts input forms into actual form indices in the model 21 | #' @param forms indices of forms 22 | #' @param collapse \code{TRUE} to collaspe forms into one form 23 | #' @param internal_index \code{TRUE} to use internal form indices 24 | #' @keywords internal 25 | ata_form_index <- function(x, forms, collapse, internal_index){ 26 | if(internal_index){ 27 | if(is.null(forms)) 28 | forms <- 1:x$num_form 29 | if(any(!forms %in% 1:x$num_form)) 30 | stop('invalid form indices') 31 | forms <- as.matrix(forms) 32 | } else { 33 | if(is.null(forms)) 34 | forms <- 1:nrow(x$form_map) 35 | if(any(!forms %in% 1:nrow(x$form_map))) 36 | stop('invalid form indices') 37 | forms <- x$form_map[forms, , drop=FALSE] 38 | } 39 | if(collapse) forms <- matrix(unique(as.vector(forms)), nrow=1) 40 | forms 41 | } 42 | 43 | #' @rdname ata_helpers 44 | #' @description \code{ata_obj_coef} processes input coefficients of the objective functions 45 | #' @param coef coefficients 46 | #' @param compensate \code{TRUE} to combine coefficients 47 | #' @importFrom stats aggregate 48 | #' @keywords internal 49 | ata_obj_coef <- function(x, coef, compensate){ 50 | if(length(coef) == x$num_item){ 51 | # if a vector of given values (item-group-level), then convert to matrix 52 | coef <- matrix(coef, nrow=1) 53 | } else if(length(coef) == nrow(x$pool)) { 54 | # if a vector of given values (item-level), then aggregate and conver to matrix 55 | coef <- aggregate(coef, by=list(x$group), sum)[,-1] 56 | coef <- matrix(coef, nrow=1) 57 | } else if(is.numeric(coef)) { 58 | # if a vector of theta's, then compute infomation and aggregate 59 | coef <- with(x$pool, model_3pl_info(coef, a, b, c, D=x$opts$D)) 60 | coef <- aggregate(t(coef), by=list(group=x$group), sum)[,-1] 61 | coef <- t(as.matrix(coef)) 62 | } else if(is.character(coef) && all(coef %in% colnames(x$pool))) { 63 | # if a variable name, then retrieve value and aggregate 64 | coef <- aggregate(x$pool[,coef], by=list(group=x$group), sum)[,-1] 65 | coef <- t(as.matrix(coef)) 66 | } else { 67 | stop("invalid coefficients") 68 | } 69 | if(compensate) coef <- matrix(colSums(coef), nrow=1) 70 | round(coef, 2) 71 | } 72 | 73 | #' @rdname ata_helpers 74 | #' @description \code{ata_solve_lpsolve} solves the the MIP model using lp_solve 75 | #' @param time_limit the time limit in seconds passed along to solvers 76 | #' @param message \code{TRUE} to print messages from solvers 77 | #' @param ... additional control parameters for solvers 78 | #' @import lpSolveAPI 79 | #' @keywords internal 80 | ata_solve_lpsolve <- function(x, time_limit, message, ...) { 81 | if(class(x) != "ata") stop("not an 'ata' object") 82 | lp <- make.lp(0, x$num_lpvar) 83 | # (max): direction 84 | lp.control(lp, sense=ifelse(x$max, "max", "min")) 85 | # set bound for y: positive = (lb=0); negative = (ub = 0) 86 | if(x$negative) set.bounds(lp, lower=-Inf, upper=0, x$num_lpvar-1) 87 | # (obj): objective function 88 | set.objfn(lp, x$obj, seq_along(x$obj)) 89 | # (type): x's = binary, y = continuous 90 | types <- sapply(x$types, function(x) switch(x, "B"="binary", "I"="integer", "C"="real")) 91 | for(i in seq_along(types)) 92 | set.type(lp, i, types[i]) 93 | # (bounds): column bounds 94 | if(!is.null(x$bounds$idx)) 95 | with(x$bounds, for(i in 1:length(idx)) { 96 | set.bounds(lp, if(!is.na(lb[i])) lower=lb[i], if(!is.na(ub[i])) upper=ub[i], columns=idx[i]) 97 | }) 98 | # (mat): constraints 99 | for(i in 1:nrow(x$mat)) 100 | add.constraint(lp, x$mat[i,], x$dir[i], x$rhs[i]) 101 | # solve 102 | lp.control(lp, mip.gap=c(.01, .01), epsint=.10, presolve="lindep", timeout=time_limit) 103 | lp.control(lp, verbose=ifelse(message, 'normal', 'neutral')) 104 | lp.control(lp, ...) 105 | code <- solve(lp) 106 | status <- switch(as.character(code), 107 | '0'="optimal solution found", 108 | '1'="the model is sub-optimal", 109 | '2'="the model is infeasible", 110 | '3'="the model is unbounded", 111 | '4'="the model is degenerate", 112 | '5'="numerical failure encountered", 113 | '6'="process aborted", 114 | '7'="timeout", 115 | '9'="the model was solved by presolve", 116 | '10'="the branch and bound routine failed", 117 | '11'="the branch and bound was stopped because of a break-at-first or break-at-value", 118 | '12'="a feasible branch and bound solution was found", 119 | '13'="no feasible branch and bound solution was found") 120 | optimum <- get.objective(lp) 121 | result <- matrix(get.variables(lp)[1:(x$num_lpvar-2)], ncol=x$num_form, byrow=FALSE) 122 | obj_vars <- get.variables(lp)[(x$num_lpvar-1):x$num_lpvar] 123 | 124 | if(!code %in% c(0, 1, 9)) result <- matrix(0, nrow=nrow(result), ncol=ncol(result)) 125 | list(code=code, status=status, optimum=optimum, result=result, obj_vars=obj_vars) 126 | } 127 | 128 | #' @rdname ata_helpers 129 | #' @description \code{ata_solve_glpk} solves the the MIP model using GLPK 130 | #' @import glpkAPI 131 | #' @keywords internal 132 | ata_solve_glpk <- function(x, time_limit, message, ...) { 133 | if(class(x) != "ata") stop("not an 'ata' object") 134 | opts <- list(...) 135 | 136 | # set up the problem 137 | lp <- initProbGLPK() 138 | addRowsGLPK(lp, nrow(x$mat)) 139 | addColsGLPK(lp, ncol(x$mat)) 140 | # (max): optimization direction 141 | setObjDirGLPK(lp, ifelse(x$max, GLP_MAX, GLP_MIN)) 142 | # (obj): obj functions 143 | setObjCoefsGLPK(lp, seq(x$num_lpvar), x$obj) 144 | # (types): x's = binary, y's = continuous 145 | for(j in seq(x$num_lpvar)[x$types == 'B']) 146 | setColKindGLPK(lp, j, GLP_BV) 147 | for(j in seq(x$num_lpvar)[x$types == 'C']) 148 | setColBndGLPK(lp, j, GLP_LO, 0, 0) 149 | if(x$negative) setColBndGLPK(lp, x$num_lpvar-1, GLP_UP, 0, 0) 150 | ## fixed values 151 | if(!is.null(x$bounds$idx)) 152 | for(j in 1:length(x$bounds$idx)) 153 | if(is.na(x$bound$lb[j])){ 154 | setColBndGLPK(lp, x$bounds$idx[j], GLP_UP, 0, x$bounds$ub[j]) 155 | } else if(is.na(x$bound$ub[j])){ 156 | setColBndGLPK(lp, x$bounds$idx[j], GLP_LO, x$bounds$lb[j], 0) 157 | } else { 158 | setColBndGLPK(lp, x$bounds$idx[j], GLP_DB, x$bounds$lb[j], x$bounds$ub[j]) 159 | } 160 | # # check column bounds 161 | # cbind(getColsLowBndsGLPK(lp, 1:x$num_lpvar), getColsUppBndsGLPK(lp, 1:x$num_lpvar)) 162 | 163 | # (mat) 164 | ind <- x$mat != 0 165 | ia <- rep(1:nrow(x$mat), ncol(x$mat))[ind] 166 | ja <- rep(1:ncol(x$mat), each=nrow(x$mat))[ind] 167 | ar <- x$mat[ind] 168 | loadMatrixGLPK(lp, length(ar), ia, ja, ar) 169 | # (dir & rhs): row bounds 170 | dir <- sapply(x$dir, function(x) switch(x, '>='=GLP_LO, '<='=GLP_UP, '='=GLP_FX)) 171 | setRowsBndsGLPK(lp, 1:nrow(x$mat), x$rhs, x$rhs, dir) 172 | # # check row bounds 173 | # cbind(getRowsLowBndsGLPK(lp, 1:nrow(x$mat)), getRowsUppBndsGLPK(lp, 1:nrow(x$mat))) 174 | 175 | # solve 176 | setMIPParmGLPK(PRESOLVE, GLP_ON) 177 | setMIPParmGLPK(MIP_GAP, 0.01) 178 | setMIPParmGLPK(TM_LIM, 1000 * time_limit) 179 | setMIPParmGLPK(MSG_LEV, ifelse(message, GLP_MSG_ON, GLP_MSG_OFF)) 180 | for(i in seq_along(opts)) setMIPParmGLPK(get(names(opts)[i]), opts[[i]]) 181 | code <- solveMIPGLPK(lp) 182 | status <- switch(as.character(code), 183 | '0'="optimal solution found", 184 | '1'='invalid basis', 185 | '2'='singular matrix', 186 | '3'='ill-conditioned matrix', 187 | '4'='invalid bounds', 188 | '5'='solver failed', 189 | '6'='objective lower limit reached', 190 | '7'='objective upper limit reached', 191 | '8'='iteration limit exceeded', 192 | '9'='time limit exceeded', 193 | '10'='no primal feasible solution', 194 | '11'='no dual feasible solution', 195 | '12'='root LP optimum not provided', 196 | '13'='search terminated by application', 197 | '14'='relative mip gap tolerance reached', 198 | '15'='no primal/dual feasible solution', 199 | '16'='no convergence', 200 | '17'='numerical instability', 201 | '18'='invalid data', 202 | '19'='result out of range') 203 | optimum <- mipObjValGLPK(lp) 204 | result <- matrix(mipColsValGLPK(lp)[1:(x$num_lpvar-2)], ncol=x$num_form, byrow=FALSE) 205 | obj_vars <- mipColsValGLPK(lp)[(x$num_lpvar-1):x$num_lpvar] 206 | 207 | list(code=code, status=status, optimum=optimum, result=result, obj_vars=obj_vars) 208 | } 209 | -------------------------------------------------------------------------------- /R/module5_mst.R: -------------------------------------------------------------------------------- 1 | #' Computerized Multistage Testing (MST) 2 | #' @name mst 3 | #' @examples 4 | #' \dontrun{ 5 | #' ## generate item pool 6 | #' num_item <- 300 7 | #' pool <- with(model_3pl_gendata(1, num_item), data.frame(a=a, b=b, c=c)) 8 | #' pool$id <- 1:num_item 9 | #' pool$content <- sample(1:3, num_item, replace=TRUE) 10 | #' pool$time <- round(rlnorm(num_item, 4, .3)) 11 | #' pool$group <- sort(sample(1:round(num_item/3), num_item, replace=TRUE)) 12 | #' 13 | #' ## ex. 1: 1-2-2 MST, 2 panels, topdown 14 | #' ## 20 items in total and 10 items in content area 1 in each route 15 | #' ## maximize info. at -1 and 1 for easy and hard routes 16 | #' x <- mst(pool, "1-2-2", 2, 'topdown', len=20, max_use=1) 17 | #' x <- mst_obj(x, theta=-1, indices=1:2) 18 | #' x <- mst_obj(x, theta=1, indices=3:4) 19 | #' x <- mst_constraint(x, "content", 10, 10, level=1) 20 | #' x <- mst_assemble(x, timeout=5) 21 | #' plot(x, byroute=TRUE) 22 | #' for(p in 1:x$num_panel) 23 | #' for(r in 1:x$num_route) { 24 | #' route <- paste(x$route[r, 1:x$num_stage], collapse='-') 25 | #' count <- sum(mst_get_items(x, panel_ix=p, route_ix=r)$content==1) 26 | #' cat('panel=', p, ', route=', route, ': ', count, ' items in content area #1\n', sep='') 27 | #' } 28 | #' 29 | #' ## ex. 2: 1-2-3 MST, 2 panels, bottomup, 30 | #' ## remove two routes with large theta change: 1-2-6, 1-3-4 31 | #' ## 10 items in total and 4 items in content area 2 in each module 32 | #' ## maximize info. at -1, 0 and 1 for easy, medium, and hard modules 33 | #' x <- mst(pool, "1-2-3", 2, 'bottomup', len=10, max_use=1) 34 | #' x <- mst_route(x, c(1, 2, 6), "-") 35 | #' x <- mst_route(x, c(1, 3, 4), "-") 36 | #' x <- mst_obj(x, theta= 0, indices=c(1, 5)) 37 | #' x <- mst_obj(x, theta=-1, indices=c(2, 4)) 38 | #' x <- mst_obj(x, theta= 1, indices=c(3, 6)) 39 | #' x <- mst_constraint(x, "content", 4, 4, level=2) 40 | #' x <- mst_assemble(x, timeout=10) 41 | #' plot(x, byroute=FALSE) 42 | #' for(p in 1:x$num_panel) 43 | #' for(m in 1:x$num_module){ 44 | #' count <- sum(mst_get_items(x, panel_ix=p, module_ix=m)$content==2) 45 | #' cat('panel=', p, ', module=', m, ': ', count, ' items in content area #2\n', sep='') 46 | #' } 47 | #' 48 | #' ## ex.3: same with ex.2 (w/o content constraints), but group-based 49 | #' x <- mst(pool, "1-2-3", 2, 'bottomup', len=12, max_use=1, group="group") 50 | #' x <- mst_route(x, c(1, 2, 6), "-") 51 | #' x <- mst_route(x, c(1, 3, 4), "-") 52 | #' x <- mst_obj(x, theta= 0, indices=c(1, 5)) 53 | #' x <- mst_obj(x, theta=-1, indices=c(2, 4)) 54 | #' x <- mst_obj(x, theta= 1, indices=c(3, 6)) 55 | #' x <- mst_assemble(x, timeout=10) 56 | #' plot(x, byroute=FALSE) 57 | #' for(p in 1:x$num_panel) 58 | #' for(m in 1:x$num_module){ 59 | #' items <- mst_get_items(x, panel_ix=p, module_ix=m) 60 | #' cat('panel=', p, ', module=', m, ': ', length(unique(items$id)), ' items from ', 61 | #' length(unique(items$group)), ' groups\n', sep='') 62 | #' } 63 | #' 64 | #' ## ex.4: 2 panels of 1-2-3 top-down design 65 | #' ## 20 total items and 10 items in content area 3 66 | #' ## 6+ items in stage 1 & 2 67 | #' x <- mst(pool, "1-2-3", 2, "topdown", len=20, max_use=1) 68 | #' x <- mst_route(x, c(1, 2, 6), "-") 69 | #' x <- mst_route(x, c(1, 3, 4), "-") 70 | #' x <- mst_obj(x, theta=-1, indices=1) 71 | #' x <- mst_obj(x, theta=0, indices=2:3) 72 | #' x <- mst_obj(x, theta=1, indices=4) 73 | #' x <- mst_constraint(x, "content", 10, 10, level=3) 74 | #' x <- mst_stage_length(x, 1:2, min=6) 75 | #' x <- mst_assemble(x, timeout=15) 76 | #' head(x$items) 77 | #' plot(x, byroute=FALSE) 78 | #' for(p in 1:x$num_panel) 79 | #' for(s in 1:x$num_stage){ 80 | #' items <- mst_get_items(x, panel_ix=p, stage_ix=s) 81 | #' cat('panel=', p, ', stage=', s, ': ', length(unique(items$id)), ' items\n', sep='') 82 | #' } 83 | #' 84 | #' ## ex.5: same with ex.4, but use RDP instead of stage length to control routing errors 85 | #' x <- mst(pool, "1-2-3", 2, "topdown", len=20, max_use=1) 86 | #' x <- mst_route(x, c(1, 2, 6), "-") 87 | #' x <- mst_route(x, c(1, 3, 4), "-") 88 | #' x <- mst_obj(x, theta=-1, indices=1) 89 | #' x <- mst_obj(x, theta=0, indices=2:3) 90 | #' x <- mst_obj(x, theta=1, indices=4) 91 | #' x <- mst_constraint(x, "content", 10, 10, level=3) 92 | #' x <- mst_rdp(x, 0, 2:3, .1) 93 | #' x <- mst_module_mininfo(x, 0, 5, 2:3) 94 | #' x <- mst_assemble(x, timeout=15) 95 | #' plot(x, byroute=FALSE) 96 | #' } 97 | NULL 98 | 99 | #' @rdname mst 100 | #' @description \code{mst} creates a multistage (MST) object for assembly 101 | #' @param pool the item pool (data.frame) 102 | #' @param design the MST design (string): e.g., "1-3", "1-2-2", "1-2-3" 103 | #' @param num_panel the number of panels (integer) 104 | #' @param method the design method (string): 'topdown' or 'bottomup' 105 | #' @param len the module/route length (integer) 106 | #' @param max_use the maximum selection of items (integer) 107 | #' @param group the grouping variable (string or vector) 108 | #' @details 109 | #' There are two methods for designing a MST. The bottom-up approach adds objectives 110 | #' and constraints on individual modules, whereas the topdown approach adds objectives 111 | #' and constraints directly on routes. 112 | #' @export 113 | mst <- function(pool, design, num_panel, method=c('topdown', 'bottomup'), len=NULL, max_use=NULL, group=NULL, ...){ 114 | method <- match.arg(method) 115 | design <- as.integer(unlist(strsplit(design, split="-"))) 116 | num_stage <- length(design) 117 | num_module <- sum(design) 118 | opts <- list(...) 119 | if(is.null(opts$D)) opts$D <- 1.702 120 | 121 | # module-index map 122 | module <- NULL 123 | for(s in 1:num_stage) 124 | for(m in 1:design[s]) 125 | module <- rbind(module, c(stage=s, module=m)) 126 | module <- data.frame(module, index=1:nrow(module)) 127 | 128 | # route-index map 129 | route <- list() 130 | for(i in 1:num_stage) 131 | route[[i]] <- module[module$stage == i, "index"] 132 | route <- expand.grid(route) 133 | colnames(route) <- paste("stage", 1:num_stage, sep="") 134 | route$index <- 1:nrow(route) 135 | num_route <- nrow(route) 136 | 137 | # ata 138 | x <- list(pool=pool, design=design, method=method, num_item=nrow(pool), num_panel=num_panel, 139 | num_stage=num_stage, num_module=num_module, num_route=num_route, module=module, route=route, 140 | ata=ata(pool, num_form=num_panel*num_module, group=group), opts=opts) 141 | class(x) <- "mst" 142 | 143 | # constraint: test length 144 | if(!is.null(len) && length(len) == 1) x <- mst_constraint(x, 1, len, len) 145 | if(!is.null(len) && length(len) == 2) x <- mst_constraint(x, 1, len[1], len[2]) 146 | if(!is.null(len) && length(len) > 2) stop("the length argument is too long.") 147 | # constraint: max_use 148 | if(!is.null(max_use)) x$ata <- ata_item_use(x$ata, max=max_use) 149 | # constraint: minimum stage length 150 | x <- mst_stage_length(x, 1:num_stage, min=1) 151 | 152 | # constraint: no item reuse in the same route 153 | mat <- matrix(0, nrow=x$num_item*x$num_route*x$num_panel, ncol=x$ata$num_lpvar) 154 | for(p in 1:x$num_panel) 155 | for(i in 1:x$num_item){ 156 | ind <- as.matrix(i + (x$route[,1:x$num_stage] - 1) * x$num_item + (p - 1) * x$num_module * x$num_item) 157 | for(j in 1:nrow(ind)) 158 | mat[j+(i-1)*nrow(ind), ind[j,]] <- 1 159 | } 160 | dir <- rep('<=', nrow(mat)) 161 | rhs <- rep(1, nrow(mat)) 162 | x$ata <- ata_append_constraints(x$ata, mat, dir, rhs) 163 | 164 | x 165 | } 166 | 167 | #' @rdname mst 168 | #' @description \code{mst_route} adds/removes a route to/from the MST 169 | #' @param x the MST object 170 | #' @param route a MST route represented by a vector of module indices 171 | #' @param op "+" to add a route and "-" to remove a route 172 | #' @export 173 | mst_route <- function(x, route, op=c("+", "-")){ 174 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 175 | op <- match.arg(op) 176 | index <- apply(x$route[, 1:x$num_stage], 1, function(r) all(r == route)) 177 | 178 | if(op == "+") { 179 | if(any(index)) stop("the route already exists") 180 | if(!all(route %in% 1:x$num_module)) stop("invalid route: module index is out of bound.") 181 | x$route <- rbind(x$route, c(route, NA)) 182 | } else if(op == "-") { 183 | if(!any(index)) stop("the route hasn't been added yet") 184 | x$route <- x$route[!index, ] 185 | } 186 | 187 | # reindex routes by stages 188 | index <- apply(x$route[, 1:x$num_stage], 1, function(r) sum(r * 10^(x$num_stage - 1:x$num_stage))) 189 | x$route <- x$route[order(index), ] 190 | x$route$index <- 1:nrow(x$route) 191 | x$num_route <- nrow(x$route) 192 | 193 | x 194 | } 195 | 196 | #' @rdname mst 197 | #' @description \code{mst_get_indices} maps the input indices to the actual indices 198 | #' @keywords internal 199 | mst_get_indices <- function(x, indices){ 200 | if(x$method == 'topdown'){ 201 | if(is.null(indices)) indices <- x$route[, 1:x$num_stage] else indices <- subset(x$route, x$route$index %in% indices)[, 1:x$num_stage] 202 | } else if(x$method == 'bottomup') { 203 | if(is.null(indices)) indices <- data.frame(module=1:x$num_module) else indices <- data.frame(module=indices) 204 | } 205 | indices 206 | } 207 | 208 | #' @rdname mst 209 | #' @description \code{mst_obj} adds objective functions to the MST 210 | #' @param theta a theta point or interval over which the TIF is optimized 211 | #' @param indices the indices of the route (topdown) or the module (bottomup) where objectives are added 212 | #' @param target the target values of the TIF objectives. \code{NULL} for maximization 213 | #' @export 214 | mst_obj <- function(x, theta, indices=NULL, target=NULL, ...) { 215 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 216 | indices <- mst_get_indices(x, indices) 217 | theta <- round(theta, 2) 218 | 219 | for(i in 1:x$num_panel) { 220 | for(j in 1:nrow(indices)) { 221 | f <- unlist(indices[j, ]) + (i - 1) * x$num_module 222 | if(is.null(target) || is.na(target)) { 223 | x$ata <- ata_obj_relative(x$ata, theta, mode="max", forms=f, collapse=TRUE, ...) 224 | } else { 225 | x$ata <- ata_obj_absolute(x$ata, theta, target=target, forms=f, collapse=TRUE, ...) 226 | } 227 | } 228 | } 229 | 230 | x 231 | } 232 | 233 | #' @rdname mst 234 | #' @description \code{mst_constraint} adds constraints to the MST 235 | #' @param coef the coefficients of the constraint 236 | #' @param level the constrained level, \code{NA} for quantitative variable 237 | #' @param min the lower bound of the constraint 238 | #' @param max the upper bound of the constraint 239 | #' @export 240 | mst_constraint <- function(x, coef, min=NA, max=NA, level=NULL, indices=NULL){ 241 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 242 | indices <- mst_get_indices(x, indices) 243 | 244 | for(i in 1:x$num_panel){ 245 | for(j in 1:nrow(indices)){ 246 | f <- unlist(indices[j,] + (i - 1) * x$num_module) 247 | x$ata <- ata_constraint(x$ata, coef, min, max, level, forms=f, collapse=TRUE) 248 | } 249 | } 250 | 251 | x 252 | } 253 | 254 | 255 | #' @rdname mst 256 | #' @description \code{mst_stage_length} sets length limits on stages 257 | #' @param stages the stage indices 258 | #' @export 259 | mst_stage_length <- function(x, stages, min=NA, max=NA){ 260 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 261 | if(length(min) == 1) min <- rep(min, length(stages)) 262 | if(length(max) == 1) max <- rep(max, length(stages)) 263 | if(length(stages) != length(min) || length(stages) != length(max)) 264 | stop("different lengths in stage, min and max") 265 | 266 | for(i in 1:length(stages)){ 267 | if(!stages[i] %in% 1:x$num_stage) stop("invalid stage input") 268 | f <- subset(x$module, x$module$stage == stages[i])$index 269 | f <- as.vector(outer(f, (1:x$num_panel - 1) * x$num_module, "+")) 270 | x$ata <- ata_constraint(x$ata, 1, min[i], max[i], forms=f, collapse=FALSE) 271 | } 272 | 273 | x 274 | } 275 | 276 | 277 | #' @rdname mst 278 | #' @description \code{mst_rdp} anchors the routing decision point (rdp) between adjacent modules 279 | #' @param tol tolerance parameter (numeric) 280 | #' @importFrom stats aggregate 281 | #' @export 282 | mst_rdp <- function(x, theta, indices, tol=0) { 283 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 284 | if(length(theta) != 1) stop("rdp is not a single theta point") 285 | if(length(indices) != 2 || abs(indices[1] - indices[2]) != 1) stop("modules are not adjacent") 286 | 287 | info <- round(aggregate(model_3pl_info(theta, x$pool$a, x$pool$b, x$pool$c, D=x$opts$D)[1, ], by=list(group=x$ata$group), sum)[, 2], 2) 288 | coef <- c(info, -1 * info) 289 | for(i in 1:x$num_panel) 290 | x$ata <- ata_constraint(x$ata, coef, -tol, tol, forms=indices + (i - 1) * x$num_module, collapse=TRUE) 291 | 292 | x 293 | } 294 | 295 | 296 | #' @rdname mst 297 | #' @description \code{mst_module_mininfo} sets the minimum information for modules 298 | #' @param thetas theta points, a vector 299 | #' @importFrom stats aggregate 300 | #' @export 301 | mst_module_info <- function(x, thetas, min, max, indices) { 302 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 303 | if(any(indices < 1 | indices > x$num_module)) stop("invalid module index") 304 | if(length(min) == 1) min <- rep(min, length(thetas)) 305 | if(length(max) == 1) max <- rep(max, length(thetas)) 306 | if(length(min) != length(thetas) || length(max) != length(thetas)) stop('min/max has a different length from thetas') 307 | 308 | for(i in 1:length(thetas)){ 309 | info <- with(x$pool, model_3pl_info(thetas[i], a, b, c, D=x$opts$D))[1, ] 310 | coef <- aggregate(info, by=list(group=x$ata$group), sum)[, 2] 311 | coef <- round(coef, 2) 312 | for(j in 1:x$num_panel) 313 | x$ata <- ata_constraint(x$ata, coef, min=min[i], max=max[i], forms=indices+(j-1)*x$num_module) 314 | } 315 | 316 | x 317 | } 318 | 319 | 320 | #' @rdname mst 321 | #' @description \code{mst_assemble} assembles the mst 322 | #' @export 323 | mst_assemble <- function(x, ...){ 324 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 325 | opts <- list(...) 326 | 327 | solver <- ifelse(is.null(opts$solver), 'lpsolve', opts$solver) 328 | x$ata <- ata_solve(x$ata, as.list=FALSE, ...) 329 | 330 | if(!is.null(x$ata$items)) { 331 | items <- x$ata$items 332 | items$module <- (items$form - 1) %% x$num_module + 1 333 | items$panel <- ceiling(items$form / x$num_module) 334 | items$stage <- x$module$stage[match(items$module, x$module$index)] 335 | items$form <- NULL 336 | x$items <- items 337 | } 338 | 339 | x 340 | } 341 | 342 | 343 | #' @rdname mst 344 | #' @param ... further arguments 345 | #' @export 346 | print.mst <- function(x, ...){ 347 | cat("The MST design has", x$num_stage, "stages,", x$num_module, "modules, and", x$num_route, "routes:\n") 348 | cat("route map:\n") 349 | print(x$route) 350 | if(!is.null(x$items)){ 351 | cat("\nAssembled forms:\n") 352 | items <- x$items 353 | if(!is.data.frame(x$items)) items <- Reduce(rbind, items, NULL) 354 | if(nrow(items) > 10){ 355 | print(items[1:5, ]) 356 | cat("...\n") 357 | print(items[-4:0 + nrow(items),]) 358 | } else { 359 | print(items) 360 | } 361 | cat("See more results in 'items'.") 362 | } else { 363 | cat("MST hasn't been assembled yet.") 364 | } 365 | invisible(x) 366 | } 367 | 368 | 369 | #' @rdname mst 370 | #' @details 371 | #' \code{plot.mst} draws module information functions when \code{byroute=FALSE} 372 | #' and route information functions when \code{byroute=TRUE} 373 | #' @import ggplot2 374 | #' @export 375 | plot.mst <- function(x, ...){ 376 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 377 | if(is.null(x$items)) stop('the mst has not been assembled yet.') 378 | 379 | opts <- list(...) 380 | if(is.null(opts$byroute)) opts$byroute <- FALSE 381 | if(is.null(opts$theta)) opts$theta <- round(seq(-3, 3, .1), 1) 382 | 383 | data <- NULL 384 | if(opts$byroute) { 385 | for(i in 1:x$num_route){ 386 | for(j in 1:x$num_panel){ 387 | items <- mst_get_items(x, panel_ix=j, route_ix=i) 388 | info <- with(items, rowSums(model_3pl_info(opts$theta, a, b, c, D=x$opts$D))) 389 | data <- rbind(data, data.frame(t=opts$theta, info=info, panel=j, route=i)) 390 | } 391 | } 392 | data$panel <- factor(paste("Panel", data$panel)) 393 | data$route <- factor(data$route, levels=1:x$num_route, labels=apply(x$route[, 1:x$num_stage], 1, paste, collapse="-")) 394 | g <- ggplot(data, aes_string(x="t", y="info", color="route")) + 395 | geom_line() + xlab(expression(theta)) + ylab("Information") + 396 | theme_bw() + theme(legend.key=element_blank()) + 397 | guides(color=guide_legend("Routes")) + 398 | facet_grid(. ~ panel) 399 | } else { 400 | for(i in 1:x$num_panel){ 401 | for(j in 1:x$num_module){ 402 | items <- mst_get_items(x, panel_ix=i, module_ix=j) 403 | info <- with(items, rowSums(model_3pl_info(opts$theta, a, b, c, D=x$opts$D))) 404 | data <- rbind(data, data.frame(t=opts$theta, info=info, panel=items$panel[1], stage=items$stage[1], module=items$module[1])) 405 | } 406 | } 407 | data$panel <- factor(paste("Panel", data$panel)) 408 | data$stage <- factor(paste("Stage", data$stage)) 409 | data$module <- factor(paste("Module", data$module)) 410 | g <- ggplot(data, aes_string(x="t", y="info", color="module")) + 411 | geom_line() + xlab(expression(theta)) + ylab("Information") + 412 | theme_bw() + theme(legend.key=element_blank()) + 413 | guides(color=guide_legend("Modules")) + 414 | facet_grid(panel ~ stage) 415 | } 416 | 417 | g 418 | } 419 | 420 | 421 | #' @rdname mst 422 | #' @description \code{mst_get_items} extracts items from the assembly results 423 | #' @param panel_ix the panel index, an int vector 424 | #' @param stage_ix the stage index, an int vector 425 | #' @param module_ix the module index, an int vector 426 | #' @param route_ix the route index, an integer 427 | #' @export 428 | mst_get_items <- function(x, panel_ix=NULL, stage_ix=NULL, module_ix=NULL, route_ix=NULL){ 429 | if(class(x) != "mst") stop("not a 'mst' object: ", class(x)) 430 | if(is.null(x$items)) stop('the mst has not been assembled yet.') 431 | items <- x$items 432 | if(!is.null(panel_ix)) 433 | items <- subset(items, items$panel %in% panel_ix) 434 | if(!is.null(stage_ix)) 435 | items <- subset(items, items$stage %in% stage_ix) 436 | if(!is.null(module_ix)) 437 | items <- subset(items, items$module %in% module_ix) 438 | if(!is.null(route_ix)) 439 | items <- subset(items, items$module %in% unlist(x$route[x$route$index == route_ix, 1:x$num_stage])) 440 | items 441 | } 442 | -------------------------------------------------------------------------------- /R/module4_cat.R: -------------------------------------------------------------------------------- 1 | #' Simulation of Computerized Adaptive Testing (CAT) 2 | #' @name cat_sim 3 | #' @examples 4 | #' \dontrun{ 5 | #' ## generate a 100-item pool 6 | #' num_items <- 100 7 | #' pool <- with(model_3pl_gendata(1, num_items), data.frame(a=a, b=b, c=c)) 8 | #' pool$set_id <- sample(1:30, num_items, replace=TRUE) 9 | #' pool$content <- sample(1:3, num_items, replace=TRUE) 10 | #' pool$time <- round(rlnorm(num_items, mean=4.1, sd=.2)) 11 | #' 12 | #' ## MLE, EAP, and hybrid estimation rule 13 | #' cat_sim(1.0, pool, min=10, max=20, estimate_rule=cat_estimate_mle) 14 | #' cat_sim(1.0, pool, min=10, max=20, estimate_rule=cat_estimate_eap) 15 | #' cat_sim(1.0, pool, min=10, max=20, estimate_rule=cat_estimate_hybrid) 16 | #' 17 | #' ## SE, MI, and CI stopping rule 18 | #' cat_sim(1.0, pool, min=10, max=20, stop_se=.3) 19 | #' cat_sim(1.0, pool, min=10, max=20, stop_mi=.6) 20 | #' cat_sim(1.0, pool, min=10, max=20, stop_cut=0) 21 | #' cat_sim(1.0, pool, min=10, max=20, stop_cut=0, ci_width=2.58) 22 | #' 23 | #' ## maximum information selection with item sets 24 | #' cat_sim(1.0, pool, min=10, max=20, group="set_id")$admin 25 | #' 26 | #' ## maximum information with item exposure control 27 | #' cat_sim(1.0, pool, min=10, max=20, info_random=5)$admin 28 | #' 29 | #' ## Constrained-CAT selection rule with and without initial randomness 30 | #' cat_sim(1.0, pool, min=10, max=20, select_rule=cat_select_ccat, 31 | #' ccat_var="content", ccat_perc=c("1"=.2, "2"=.3, "3"=.5)) 32 | #' cat_sim(1.0, pool, min=10, max=20, select_rule=cat_select_ccat, ccat_random=5, 33 | #' ccat_var="content", ccat_perc=c("1"=.2, "2"=.3, "3"=.5)) 34 | #' 35 | #' ## Shadow-test selection rule 36 | #' cons <- data.frame(var='content', level=1:3, min=c(3,3,4), max=c(3,3,4)) 37 | #' cons <- rbind(cons, data.frame(var='time', level=NA, min=55*10, max=65*10)) 38 | #' cat_sim(1.0, pool, min=10, max=10, select_rule=cat_select_shadow, constraints=cons) 39 | #' 40 | #' ## Projection-based stopping rule 41 | #' cons <- data.frame(var='content', level=1:3, min=5, max=15) 42 | #' cons <- rbind(cons, data.frame(var='time', level=NA, min=60*20, max=60*40)) 43 | #' cat_sim(1.0, pool, min=20, max=40, select_rule=cat_select_shadow, stop_rule=cat_stop_projection, 44 | #' projection_method="diff", stop_cut=0, constraints=cons) 45 | #' } 46 | NULL 47 | 48 | 49 | #' @rdname cat_sim 50 | #' @description \code{cat_sim} runs a simulation of CAT. Use \code{theta} in options to set the starting 51 | #' value of theta estimate. 52 | #' @param true the true theta 53 | #' @param pool the item pool (data.frame) 54 | #' @param ... option/control parameters 55 | #' @return \code{cat_sim} returns a \code{cat} object 56 | #' @details 57 | #' \code{...} takes a variety of option/control parameters for the simulations from users. 58 | #' \code{min} and {max} are mandatory for setting limits on the test length. User-defined 59 | #' selection, estimation, and stopping rules are also passed to the simulator via options.\cr 60 | #' To write a new rule, the function siganiture must be: \code{function(len, theta, stats, admin, pool, opts)}. 61 | #' See built-in rules for examples. 62 | #' @importFrom stats runif 63 | #' @export 64 | cat_sim <- function(true, pool, ...){ 65 | if(!is.data.frame(pool)) pool <- as.data.frame(pool, stringsAsFactors=FALSE) 66 | if(!all(c("a", "b", "c") %in% colnames(pool))) stop("cannot find a-, b-, or c-parameters in item pool") 67 | 68 | opts <- list(...) 69 | if(is.null(opts$min)) stop("minimum length is missing") 70 | if(is.null(opts$max)) stop("maximum length is missing") 71 | if(opts$min < 0 || opts$min > opts$max) stop("invalid min/max length values: ", opts$min, " -- ", opts$max) 72 | if(nrow(pool) < opts$max) stop("insufficient items in item pool: ", nrow(pool)) 73 | 74 | theta <- ifelse(is.null(opts$theta), 0, opts$theta) 75 | if(is.null(opts$D)) opts$D <- 1.702 76 | if(is.null(opts$select_rule)) select_rule <- cat_select_maxinfo else select_rule <- opts$select_rule 77 | if(is.null(opts$estimate_rule)) estimate_rule <- cat_estimate_mle else estimate_rule <- opts$estimate_rule 78 | if(is.null(opts$stop_rule)) stop_rule <- cat_stop_default else stop_rule <- opts$stop_rule 79 | 80 | len <- 0 81 | stats <- matrix(nrow=opts$max, ncol=4, dimnames=list(NULL, c("u", "t", "se", "info"))) 82 | admin <- NULL 83 | 84 | while(len < opts$max){ 85 | # select items and update pool 86 | selection <- select_rule(len, theta, stats, admin, pool, opts) 87 | item <- selection$item 88 | item <- item[0:min(nrow(item), opts$max - len), ] 89 | pool <- selection$pool 90 | n <- nrow(item) 91 | len <- len + n 92 | admin <- rbind(admin, item) 93 | # generate responses 94 | p <- model_3pl_prob(true, item$a, item$b, item$c, opts$D)[1, ] 95 | u <- as.integer(p > runif(n)) 96 | stats[1:n + (len - n), "u"] <- u 97 | # estimate 98 | theta <- estimate_rule(len, theta, stats, admin, pool, opts) 99 | info <- sum(model_3pl_info(theta, admin$a, admin$b, admin$c, opts$D)) 100 | se <- 1 / sqrt(info) 101 | stats[1:n + (len - n), "t"] <- theta 102 | stats[1:n + (len - n), "se"] <- se 103 | stats[1:n + (len - n), "info"] <- info 104 | # stop? 105 | if(stop_rule(len, theta, stats, admin, pool, opts)) break 106 | } 107 | 108 | admin <- cbind(stats[1:len, ], admin) 109 | rs <- list(pool=pool, admin=admin, true=true, theta=theta) 110 | class(rs) <- "cat" 111 | rs 112 | } 113 | 114 | 115 | #' @rdname cat_sim 116 | #' @description \code{cat_estimate_mle} is the maximum likelihood estimation rule. Use 117 | #' \code{map_len} to apply MAP to the first K items and use \code{map_prior} to set the 118 | #' prior for MAP. 119 | #' @param len the current test length 120 | #' @param theta the current theta estimate 121 | #' @param stats a matrix of responses, theta estimate, information and std error 122 | #' @param admin a data frame of administered items 123 | #' @param opts a list of option/control parameters 124 | #' @return an estimation rule should return a theta estimate 125 | #' @export 126 | cat_estimate_mle <- function(len, theta, stats, admin, pool, opts){ 127 | u <- stats[1:len, "u"] 128 | u <- matrix(rep(u, each=2), nrow=2) 129 | if(is.null(opts$map_len)) opts$map_len <- 10 130 | if(is.null(opts$map_prior)) opts$map_prior <- c(0, 1) 131 | if (len < opts$map_len) priors <- list(t=opts$map_prior) else priors <- NULL 132 | with(admin, model_3pl_estimate_jmle(u=u, a=a[1:len], b=b[1:len], c=c[1:len], D=opts$D, scale=NULL, priors=priors))$t[1] 133 | } 134 | 135 | #' @rdname cat_sim 136 | #' @description \code{cat_estimate_eap} is the expected a posteriori estimation rule, 137 | #' using \code{eap_mean} and \code{eap_sd} option parameters as the prior 138 | #' @export 139 | cat_estimate_eap <- function(len, theta, stats, admin, pool, opts){ 140 | eap_mean <- ifelse(is.null(opts$eap_mean), 0, opts$eap_mean) 141 | eap_sd <- ifelse(is.null(opts$eap_sd), 1, opts$eap_sd) 142 | u <- stats[1:len, "u"] 143 | u <- matrix(rep(u, each=2), nrow=2) 144 | with(admin, model_3pl_eap_scoring(u=u, a=a[1:len], b=b[1:len], c=c[1:len], D=opts$D))$t[1] 145 | } 146 | 147 | #' @rdname cat_sim 148 | #' @description \code{cat_estimate_hybrid} is a hybrid estimation rule, which uses MLE for 149 | #' mixed responses and EAP for all 1's or 0's responses 150 | #' @export 151 | cat_estimate_hybrid <- function(len, theta, stats, admin, pool, opts){ 152 | u <- stats[1:len, "u"] 153 | if(all(u==0) || all(u==1)){ 154 | theta <- cat_estimate_eap(len, theta, stats, admin, pool, opts) 155 | } else { 156 | theta <- cat_estimate_mle(len, theta, stats, admin, pool, opts) 157 | } 158 | theta 159 | } 160 | 161 | 162 | #' @rdname cat_sim 163 | #' @description \code{cat_stop_default} is a three-way stopping rule. When \code{stop_se} 164 | #' is set in the options, it uses the standard error stopping rule. When 165 | #' \code{stop_mi} is set in the options, it uses the minimum information stopping rule. When 166 | #' \code{stop_cut} is set in the options, it uses the confidence interval (set by \code{ci_width}) 167 | #' stopping rule. 168 | #' @return a stopping rule should return a boolean: \code{TRUE} to stop the CAT, \code{FALSE} to continue 169 | #' @importFrom stats qnorm 170 | #' @export 171 | cat_stop_default <- function(len, theta, stats, admin, pool, opts){ 172 | if(len < opts$min) return(FALSE) 173 | if(len > opts$max) return(TRUE) 174 | if(!is.null(opts$stop_se)){ 175 | se <- stats[len, "se"] 176 | return(se <= opts$stop_se) 177 | } else if(!is.null(opts$stop_mi)){ 178 | info <- model_3pl_info(theta, pool$a, pool$b, pool$c, opts$D)[1, ] 179 | return(max(info) <= opts$stop_mi) 180 | } else if(!is.null(opts$stop_cut)){ 181 | se <- stats[len, "se"] 182 | ci_width <- ifelse(is.null(opts$ci_width), qnorm(.975), opts$ci_width) 183 | lb <- theta - ci_width * se 184 | ub <- theta + ci_width * se 185 | return(lb > opts$stop_cut || ub < opts$stop_cut) 186 | } 187 | FALSE 188 | } 189 | 190 | 191 | #' @rdname cat_sim 192 | #' @description \code{cat_select_maxinfo} is the maximum information selection rule. Use \code{group} 193 | #' (a numeric vector) to group items belonging to the same set. Use \code{info_random} to implement 194 | #' the random-esque item exposure control method. 195 | #' @return a selection rule should return a list of (a) the selected item and (b) the updated pool 196 | #' @export 197 | cat_select_maxinfo <- function(len, theta, stats, admin, pool, opts){ 198 | if(is.null(opts$group)) group <- 1:nrow(pool) else group <- pool[, opts$group] 199 | info <- model_3pl_info(theta, pool$a, pool$b, pool$c, opts$D)[1, ] 200 | info <- aggregate(info, by=list(group), mean) 201 | colnames(info) <- c("group", "info") 202 | random <- min(ifelse(is.null(opts$info_random), 1, opts$info_random), nrow(info)) 203 | 204 | index <-info$group[order(-info$info)[1:random]] 205 | if(length(index) > 1) index <- sample(index, 1) 206 | index <- group %in% index 207 | list(item=pool[index,], pool=pool[!index,]) 208 | } 209 | 210 | #' @rdname cat_sim 211 | #' @description \code{cat_select_ccat} is the constrained CAT selection rule. Use 212 | #' \code{ccat_var} to set the content variable in the pool. Use \code{ccat_perc} to set 213 | #' the desired content distribution, with the name of each element being the content code 214 | #' and tue value of each element being the percentage. Use \code{ccat_random} to add randomness 215 | #' to initial item selections. 216 | #' @export 217 | cat_select_ccat <- function(len, theta, stats, admin, pool, opts){ 218 | if(is.null(opts$ccat_var)) stop("ccat_var is misisng") 219 | if(is.null(opts$ccat_perc)) stop("ccat_perc is missing") 220 | initial_random <- ifelse(is.null(opts$ccat_random), 0, opts$ccat_random) 221 | 222 | info <- data.frame(id=1:nrow(pool), domain=pool[,opts$ccat_var]) 223 | info$info <- with(pool, model_3pl_info(theta, a, b, c, opts$D))[1, ] 224 | 225 | if(len == 0) curr_perc <- rep(0, length(opts$ccat_perc)) else curr_perc <- freq(admin[1:len, opts$ccat_var], names(opts$ccat_perc))$perc 226 | if(len < initial_random) domain <- sample(names(opts$ccat_perc), 1) else domain <- names(opts$ccat_perc)[which.max(opts$ccat_perc - curr_perc)] 227 | 228 | info <- info[info$domain == domain, ] 229 | random <- min(nrow(info), ifelse(is.null(opts$info_random), 1, opts$info_random)) 230 | index <- info$id[order(-info$info)[1:random]] 231 | if(length(index) > 1) index <- sample(index, 1) 232 | list(item=pool[index, ], pool=pool[-index, ]) 233 | } 234 | 235 | #' @rdname cat_sim 236 | #' @description \code{cat_select_shadow} is the shadow-test selection rule. Use \code{shadow_id} 237 | #' to group item sets. Use \code{constraints} to set constraints. Constraints should be in a data.frame 238 | #' with four columns: var (variable name), level (variable level, \code{NA} for quantitative variable), 239 | #' min (lower bound), and max (upper bound). 240 | #' @export 241 | cat_select_shadow <- function(len, theta, stats, admin, pool, opts){ 242 | if(!"shadow_id" %in% colnames(pool)) pool$shadow_id <- 1:nrow(pool) 243 | if(is.null(opts$constraints)) stop("constraints is missing in the options") 244 | if(!all(colnames(opts$constraints) %in% c("var", "level", "min", "max"))) 245 | stop("shadow_constr should be a data.frame with 4 columns: var, level, min, and max") 246 | if(is.factor(opts$constraints$var)) opts$constraints$var <- levels(opts$constraints$var)[opts$constraints$var] 247 | if(is.factor(opts$constraints$level)) opts$constraints$level <- levels(opts$constraints$level)[opts$constraints$level] 248 | 249 | x <- ata(pool, 1, len=c(opts$min, opts$max), 1) 250 | x <- ata_obj_relative(x, theta, "max") 251 | for(i in 1:nrow(opts$constraints)) 252 | x <- with(opts$constraints[i,], ata_constraint(x, var, min=min, max=max, level=level)) 253 | if(!is.null(admin)) x <- ata_item_fixedvalue(x, match(admin$shadow_id, pool$shadow_id), min=1, forms=1) 254 | x <- ata_solve(x, as.list=FALSE, details=F) 255 | if(is.null(x$items)) stop("Failed to assemble a shadow test") 256 | x$items <- x$items[!x$items$shadow_id %in% admin$shadow_id, ] 257 | 258 | info <- data.frame(id=x$items$shadow_id, info=with(x$items, model_3pl_info(theta, a, b, c, opts$D))[1,]) 259 | random <- min(nrow(info), ifelse(is.null(opts$info_random), 1, opts$info_random)) 260 | index <- info$id[order(-info$info)[1:random]] 261 | if(length(index) > 1) index <- sample(index, 1) 262 | list(item=pool[index, ], pool=pool) 263 | } 264 | 265 | 266 | #' @rdname cat_sim 267 | #' @param x a \code{cat} object 268 | #' @export 269 | print.cat <- function(x, ...){ 270 | if(class(x) != "cat") stop("Not a 'cat' object.") 271 | 272 | len <- nrow(x$admin) 273 | cat("true=", round(x$true, 2), ", est.=", round(x$theta, 2), 274 | ", se=", round(x$admin$se[len], 2), ", p=", round(mean(x$admin$u), 2), 275 | ", used ", len, " items (", sum(x$admin$u)," correct).\n", sep="") 276 | cat("Belows is a history of the CAT:\n") 277 | if(len <= 10) { 278 | print(x$admin) 279 | } else { 280 | print(x$admin[1:5, ]) 281 | cat("...\n") 282 | print(x$admin[1:5 + len - 5, ]) 283 | } 284 | 285 | invisible(x) 286 | } 287 | 288 | 289 | #' @rdname cat_sim 290 | #' @import ggplot2 291 | #' @export 292 | plot.cat <- function(x, ...){ 293 | if(class(x) != "cat") stop("Not a 'cat' object.") 294 | 295 | opts <- list(...) 296 | if(is.null(opts$ylim)) opts$ylimc <- c(-3, 3) 297 | len <- nrow(x$admin) 298 | x$admin$lb <- x$admin$t - 1.96 * x$admin$se 299 | x$admin$ub <- x$admin$t + 1.96 * x$admin$se 300 | x$admin$pos <- 1:len 301 | x$admin$Responses <- factor(x$admin$u, levels=c(0, 1), labels=c("Wrong", "Right")) 302 | 303 | ggplot(data=x$admin, aes_string(x="pos", y="t", color="Responses")) + 304 | geom_point(aes_string(size="se")) + 305 | geom_linerange(aes_string(ymin="lb", ymax="ub"), linetype=3) + 306 | geom_point(aes(x=len, y=x$true), color="coral", pch=4, size=3) + 307 | coord_cartesian(ylim=opts$ylim) + scale_size_continuous(range=c(1, 3)) + 308 | xlab("Position") + ylab(expression(paste("Est. ", theta))) + 309 | guides(size=F, alpha=F) + theme_bw() + theme(legend.key=element_blank()) 310 | } 311 | 312 | 313 | #' @rdname cat_sim 314 | #' @description \code{cat_stop_projection} is the projection-based stopping rule. Use 315 | #' \code{projection_method} to choose the projection method ('info' or 'diff'). Use 316 | #' \code{stop_cut} to set the cut score. Use \code{constraints} to set the constraints. 317 | #' Constraints should be a data.frame with columns: var (variable name), 318 | #' level (variable level, \code{NA} for quantitative varialbe), min (lower bound), max (upper bound) 319 | #' @export 320 | cat_stop_projection <- function(len, theta, stats, admin, pool, opts){ 321 | if(len < opts$min) return(FALSE) 322 | if(len >= opts$max) return(TRUE) 323 | 324 | method <- match.arg(opts$projection_method, c('info', 'diff')) 325 | if(is.null(opts$stop_cut)) stop('stop_cut is missing in the options') 326 | if(is.null(opts$constraints)) stop("constraints is missing in the options") 327 | if(!all(colnames(opts$constraints) %in% c("var", "level", "min", "max"))) 328 | stop("shadow_constr should be a data.frame with 4 columns: var, level, min, and max") 329 | if(is.factor(opts$constraints$var)) opts$constraints$var <- levels(opts$constraints$var)[opts$constraints$var] 330 | if(is.factor(opts$constraints$level)) opts$constraints$level <- levels(opts$constraints$level)[opts$constraints$level] 331 | pool <- unique(rbind(pool, admin)) 332 | 333 | if(method == 'info'){ 334 | x <- ata(pool, 1, len=opts$max, 1) 335 | x <- ata_obj_relative(x, theta, "max") 336 | for(i in 1:nrow(opts$constraints)) 337 | x <- with(opts$constraints, ata_constraint(x, var[i], min=min[i], max=max[i], level=level[i])) 338 | x <- ata_item_fixedvalue(x, admin$shadow_id, min=1, forms=1) 339 | x <- ata_solve(x, as.list=FALSE, details=F) 340 | if(is.null(x$items)) stop("Failed to assemble a projection test") 341 | 342 | u <- c(stats[1:len, "u"], rep(1, opts$max - len)) 343 | u <- matrix(rep(u, each=2), nrow=2) 344 | theta_ub <- with(x$items, model_3pl_estimate_jmle(u, a=a, b=b, c=c, D=opts$D, scale=NULL, priors=NULL))$t[1] 345 | u <- c(stats[1:len, "u"], rep(0, opts$max - len)) 346 | u <- matrix(rep(u, each=2), nrow=2) 347 | theta_lb <- with(x$items, model_3pl_estimate_jmle(u, a=a, b=b, c=c, D=opts$D, scale=NULL, priors=NULL))$t[1] 348 | } else if(method == 'diff'){ 349 | if(is.null(opts$proj_width)) opts$proj_width <- 1.96 350 | 351 | x <- ata(pool, 1, len=opts$max, 1) 352 | x <- ata_obj_absolute(x, "b", (theta + opts$proj_width * stats[len, "se"]) * opts$max) 353 | for(i in 1:nrow(opts$constraints)) 354 | x <- with(opts$constraints, ata_constraint(x, var[i], min=min[i], max=max[i], level=level[i])) 355 | x <- ata_item_fixedvalue(x, admin$shadow_id, min=1, forms=1) 356 | x <- ata_solve(x, as.list=FALSE, details=F) 357 | if(is.null(x$items)) stop("Failed to assemble a projection test") 358 | u <- c(stats[1:len, "u"], rep(1, opts$max - len)) 359 | u <- matrix(rep(u, each=2), nrow=2) 360 | theta_ub <- with(x$items, model_3pl_estimate_jmle(u, a=a, b=b, c=c, D=opts$D, scale=NULL, priors=NULL))$t[1] 361 | 362 | x <- ata(pool, 1, len=opts$max, 1) 363 | x <- ata_obj_absolute(x, "b", (theta - opts$proj_width * stats[len, "se"]) * opts$max) 364 | for(i in 1:nrow(opts$constraints)) 365 | x <- with(opts$constraints, ata_constraint(x, var[i], min=min[i], max=max[i], level=level[i])) 366 | x <- ata_item_fixedvalue(x, admin$shadow_id, min=1, forms=1) 367 | x <- ata_solve(x, as.list=FALSE, details=F) 368 | if(is.null(x$items)) stop("Failed to assemble a projection test") 369 | u <- c(stats[1:len, "u"], rep(0, opts$max - len)) 370 | u <- matrix(rep(u, each=2), nrow=2) 371 | theta_lb <- with(x$items, model_3pl_estimate_jmle(u, a=a, b=b, c=c, D=opts$D, scale=NULL, priors=NULL))$t[1] 372 | } 373 | 374 | (theta_lb > opts$stop_cut || theta_ub < opts$stop_cut) 375 | } 376 | -------------------------------------------------------------------------------- /R/module2_estimate_grm.R: -------------------------------------------------------------------------------- 1 | #' Estimate Graded Response Model 2 | #' @description Estimate the GRM using the maximum likelihood estimation 3 | #' @name estimate_grm 4 | NULL 5 | 6 | #' @rdname estimate_grm 7 | #' @description \code{model_grm_eap_scoring} scores response vectors using the EAP method 8 | #' @param prior the prior distribution 9 | #' @examples 10 | #' with(model_grm_gendata(10, 50, 3), cbind(true=t, est=model_grm_eap_scoring(u, a, b)$t)) 11 | #' @importFrom stats dnorm 12 | #' @export 13 | model_grm_eap_scoring <- function(u, a, b, D=1.702, prior=c(0, 1), bound=c(-3, 3)){ 14 | quad <- hermite_gauss('11') 15 | quad$w <- quad$w * exp(quad$t^2) * dnorm(quad$t, prior[1], prior[2]) 16 | n_p <- dim(u)[1] 17 | n_i <- dim(u)[2] 18 | n_q <- length(quad$t) 19 | 20 | p <- model_grm_prob(quad$t, a, b, D) 21 | ix <- model_polytomous_3dindex(u) 22 | lh <- array(NA, c(n_p, n_i, n_q)) 23 | for(q in 1:n_q) 24 | lh[,,q] <- array(p[q,,][ix[,-1]], c(n_p, n_i)) 25 | lh <- apply(lh, c(1, 3), prod, na.rm=T) 26 | t <- ((lh / (lh %*% quad$w)[,1]) %*% (quad$w * quad$t))[,1] 27 | t_sd <- ((lh / (lh %*% quad$w)[,1] * outer(t, quad$t, '-')^2) %*% quad$w)[,1] 28 | t_sd <- sqrt(t_sd) 29 | list(t=t, sd=t_sd) 30 | } 31 | 32 | #' @rdname estimate_grm 33 | #' @description \code{model_grm_map_scoring} scores response vectors using the MAP method 34 | #' @examples 35 | #' with(model_grm_gendata(10, 50, 3), cbind(true=t, est=model_grm_map_scoring(u, a, b)$t)) 36 | #' @export 37 | model_grm_map_scoring <- function(u, a, b, D=1.702, prior=NULL, bound=c(-3, 3), nr_iter=30, nr_conv=1e-3){ 38 | ix <- model_polytomous_3dindex(u) 39 | t <- rnorm(dim(u)[1], 0, .01) 40 | t_free <- rep(T, length(t)) 41 | for(m in 1:nr_iter){ 42 | dv <- model_grm_dv_jmle(ix, model_grm_dv_Pt(t, a, b, D)) 43 | dv$dv1 <- rowSums(dv$dv1, na.rm=T) 44 | dv$dv2 <- rowSums(dv$dv2, na.rm=T) 45 | if(!is.null(prior)){ 46 | dv$dv1 <- dv$dv1 - (t - prior[1]) / prior[2]^2 47 | dv$dv2 <- dv$dv2 - 1 / prior[2]^2 48 | } 49 | nr <- estimate_nr_iteration(t, t_free, dv, 1.0, 1.0, bound) 50 | t <- nr$param 51 | if(max(abs(nr$h)) < nr_conv) break 52 | } 53 | list(t=t) 54 | } 55 | 56 | #' @rdname estimate_grm 57 | #' @keywords internal 58 | model_grm_dv_Pt <- function(t, a, b, D){ 59 | n_c <- ncol(b) + 1 60 | p <- model_grm_prob(t, a, b, D, raw=T) 61 | dv1 <- aperm(aperm(p*(1-p), c(2,1,3)) * D * a, c(2,1,3)) 62 | dv1 <- dv1[,,1:n_c] - dv1[,,-1] 63 | dv2 <- aperm(aperm(p*(1-p)*(1-2*p), c(2,1,3)) * (D * a)^2, c(2,1,3)) 64 | dv2 <- dv2[,,1:n_c] - dv2[,,-1] 65 | p <- p[,,1:n_c] - p[,,-1] 66 | list(p=p, dv1=dv1, dv2=dv2) 67 | } 68 | 69 | #' @rdname estimate_grm 70 | #' @keywords internal 71 | model_grm_dv_Pa <- function(t, a, b, D){ 72 | n_c <- ncol(b) + 1 73 | p <- model_grm_prob(t, a, b, D, raw=T) 74 | term0 <- D * outer(t, cbind(0, b, 0), '-') 75 | dv1 <- p * (1-p) * term0 76 | dv1 <- dv1[,,1:n_c] - dv1[,,-1] 77 | dv2 <- p * (1-p) * (1-2*p) * term0^2 78 | dv2 <- dv2[,,1:n_c] - dv2[,,-1] 79 | p <- p[,,1:n_c] - p[,,-1] 80 | list(p=p, dv1=dv1, dv2=dv2) 81 | } 82 | 83 | #' @rdname estimate_grm 84 | #' @keywords internal 85 | model_grm_dv_Pb <- function(t, a, b, D){ 86 | n_p <- length(t) 87 | n_i <- nrow(b) 88 | n_c <- ncol(b) + 1 89 | p <- model_grm_prob(t, a, b, D, raw=T) 90 | dv1 <- dv2 <- array(0, c(n_p, n_i, n_c, n_c-1)) 91 | for(k in 1:(n_c-1)){ 92 | term0<- t(t(p[,,k+1]*(1-p[,,k+1])) * (-D * a)) 93 | dv1[,,k,k] <- -1 * term0 94 | dv1[,,k+1,k] <- term0 95 | term1<- t(t(p[,,k+1]*(1-p[,,k+1])*(1-2*p[,,k+1])) * (D*a)^2) 96 | dv2[,,k,k] <- -1 * term1 97 | dv2[,,k+1,k] <- term1 98 | } 99 | p <- p[,,1:n_c] - p[,,-1] 100 | list(p=p, dv1=dv1, dv2=dv2) 101 | } 102 | 103 | #' @rdname estimate_grm 104 | #' @param ix the 3d indices 105 | #' @param dvp the derivatives of P 106 | #' @keywords internal 107 | model_grm_dv_jmle <- function(ix, dvp){ 108 | n_p <- max(ix[,1]) 109 | n_i <- max(ix[,2]) 110 | dv1 <- array(with(dvp, dv1[ix]/p[ix]), c(n_p, n_i)) 111 | dv2 <- array(with(dvp, dv2[ix]/p[ix]), c(n_p, n_i)) - dv1^2 112 | list(dv1=dv1, dv2=dv2) 113 | } 114 | 115 | #' @rdname estimate_grm 116 | #' @description \code{model_grm_estimate_jmle} estimates the parameters using the 117 | #' joint maximum likelihood estimation (JMLE) method 118 | #' @param u the observed response matrix, 2d matrix 119 | #' @param t ability parameters, 1d vector (fixed value) or NA (freely estimate) 120 | #' @param a discrimination parameters, 1d vector (fixed value) or NA (freely estimate) 121 | #' @param b difficulty parameters, 2d matrix (fixed value) or NA (freely estimate) 122 | #' @param D the scaling constant, 1.702 by default 123 | #' @param iter the maximum iterations 124 | #' @param conv the convergence criterion for the -2 log-likelihood 125 | #' @param nr_iter the maximum iterations of newton-raphson 126 | #' @param nr_conv the convegence criterion of newton-raphson 127 | #' @param scale the scale of theta parameters 128 | #' @param bounds_t bounds of ability parameters 129 | #' @param bounds_a bounds of discrimination parameters 130 | #' @param bounds_b bounds of location parameters 131 | #' @param priors a list of prior distributions 132 | #' @param decay decay rate 133 | #' @param debug TRUE to print debuggin information 134 | #' @param true_params a list of true parameters for evaluating the estimation accuracy 135 | #' @examples 136 | #' \dontrun{ 137 | #' # generate data 138 | #' x <- model_grm_gendata(1000, 40, 3) 139 | #' # free calibration 140 | #' y <- model_grm_estimate_jmle(x$u, true_params=x) 141 | #' # no priors 142 | #' y <- model_grm_estimate_jmle(x$u, priors=NULL, true_params=x) 143 | #' } 144 | #' @importFrom stats cor 145 | #' @importFrom reshape2 melt 146 | #' @import ggplot2 147 | #' @export 148 | model_grm_estimate_jmle <- function(u, t=NA, a=NA, b=NA, D=1.702, iter=100, nr_iter=10, conv=1e-0, nr_conv=1e-3, scale=c(0, 1), bounds_t=c(-4, 4), bounds_a=c(.01, 2), bounds_b=c(-4, 4), priors=list(t=c(0, 1), a=c(-.1, .2), b=c(0, 1)), decay=1, debug=FALSE, true_params=NULL){ 149 | # configuration 150 | h_max <- 1.0 151 | tracking <- list(fit=rep(NA, iter), t=rep(NA, iter), a=rep(NA, iter), b=rep(NA, iter)) 152 | 153 | # initial values 154 | n_p <- dim(u)[1] 155 | n_i <- dim(u)[2] 156 | n_c <- max(u) + 1 157 | u_ix <- model_polytomous_3dindex(u) 158 | if(length(t) == 1) t <- rep(t, n_p) 159 | t[t_free <- is.na(t)] <- rnorm(sum(is.na(t)), 0, .01) 160 | if(length(a) == 1) a <- rep(a, n_i) 161 | a[a_free <- is.na(a)] <- rlnorm(sum(is.na(a)), -.1, .01) 162 | if(length(b) == 1) b <- array(b, c(n_i, n_c-1)) 163 | b[b_free <- is.na(b)] <- rnorm(sum(is.na(b)), 0, .1) 164 | b <- t(apply(b, 1, sort)) 165 | 166 | # estimate parameters 167 | for (k in 1:iter){ 168 | # t parameters 169 | if(any(t_free)){ 170 | for(j in 1:nr_iter){ 171 | dv_t <- model_grm_dv_jmle(u_ix, model_grm_dv_Pt(t, a, b, D)) 172 | dv_t$dv1 <- rowSums(dv_t$dv1, na.rm=T) 173 | dv_t$dv2 <- rowSums(dv_t$dv2, na.rm=T) 174 | if(!is.null(priors$t)){ 175 | dv_t$dv1 <- dv_t$dv1 - (t - priors$t[1]) / priors$t[2]^2 176 | dv_t$dv2 <- dv_t$dv2 - 1 / priors$t[2]^2 177 | } 178 | nr_t <- estimate_nr_iteration(t, t_free, dv_t, h_max, decay, bounds_t) 179 | t <- nr_t$param 180 | if(max(abs(nr_t$h)) < nr_conv) break 181 | } 182 | # rescale theta 183 | if(!is.null(scale)) t <- (t - mean(t)) / sd(t) * scale[2] + scale[1] 184 | } 185 | 186 | # b parameters 187 | if(any(b_free)){ 188 | for(j in 1:nr_iter){ 189 | dv_b <- model_grm_dv_Pb(t, a, b, D) 190 | dv_bh <- array(0, c(n_i, n_c-1)) 191 | for(m in 1:(n_c-1)){ 192 | dv <- model_grm_dv_jmle(u_ix, with(dv_b, list(p=p, dv1=dv1[,,,m], dv2=dv2[,,,m]))) 193 | dv$dv1 <- colSums(dv$dv1, na.rm=T) 194 | dv$dv2 <- colSums(dv$dv2, na.rm=T) 195 | if(!is.null(priors$b)){ 196 | dv$dv1 <- dv$dv1 - (b[,m] - priors$b[1]) / priors$b[2]^2 197 | dv$dv2 <- dv$dv2 - 1 / priors$b[2]^2 198 | } 199 | nr <- estimate_nr_iteration(b[,m], b_free[,m], dv, h_max, decay, bounds_b) 200 | b[,m] <- nr$param 201 | dv_bh[,m] <- nr$h 202 | } 203 | b <- t(apply(b, 1, sort)) 204 | if(max(abs(dv_bh)) < nr_conv) break 205 | } 206 | } 207 | 208 | # a parameters 209 | if(any(a_free)){ 210 | for(j in 1:nr_iter){ 211 | dv_a <- model_grm_dv_jmle(u_ix, model_grm_dv_Pa(t, a, b, D)) 212 | dv_a$dv1 <- colSums(dv_a$dv1, na.rm=T) 213 | dv_a$dv2 <- colSums(dv_a$dv2, na.rm=T) 214 | if(!is.null(priors$a)){ 215 | dv_a$dv1 <- dv_a$dv1 - 1/a * (1 + (log(a)-priors$a[1])/priors$a[2]^2) 216 | dv_a$dv2 <- dv_a$dv2 - 1/a^2 * (1/priors$a[2]^2 - (1 + (log(a)-priors$a[1])/priors$a[2]^2)) 217 | } 218 | nr_a <- estimate_nr_iteration(a, a_free, dv_a, h_max, decay, bounds_a) 219 | a <- nr_a$param 220 | if(max(abs(nr_a$h)) < nr_conv) break 221 | } 222 | } 223 | 224 | decay <- decay * decay 225 | 226 | # model fit 227 | loglh <- -2 * sum(model_grm_lh(u, t, a, b, D, log=T), na.rm=T) 228 | if(debug) cat('iter #', k, ': -2 log-likelihood = ', round(loglh, 2), '\n', sep='') 229 | if(k > 1 && tracking$fit[k-1] - loglh < conv) break 230 | tracking$fit[k] <- loglh 231 | if(any(t_free)) tracking$t[k] <- mean(abs(nr_t$h[t_free])) 232 | if(any(a_free)) tracking$a[k] <- mean(abs(nr_a$h[a_free])) 233 | if(any(b_free)) tracking$b[k] <- mean(abs(dv_bh[b_free])) 234 | } 235 | 236 | # debugging 237 | if(debug){ 238 | xx <- with(tracking, data.frame(iteration=1:iter, fit=fit, t=t, a=a, b=b))[1:k,] 239 | xx <- melt(xx, id.vars='iteration') 240 | xx <- xx[!is.na(xx$value), ] 241 | g <- ggplot(xx, aes_string(x="iteration", y="value", color="variable")) + 242 | geom_line() + facet_wrap(~variable, scales="free") + guides(color=F) + 243 | xlab('Iterations') + ylab('') + theme_bw() 244 | print(g) 245 | } 246 | 247 | # compare with true parameters 248 | if(!is.null(true_params)){ 249 | xx <- rbind(data.frame(true=true_params$t, est=t, params='t'), 250 | data.frame(true=true_params$a, est=a, params='a')) 251 | for(i in 1:(n_c-1)) 252 | xx <- rbind(xx, data.frame(true=true_params$b[,i], est=b[,i], params=paste('b',i,sep=''))) 253 | g <- ggplot(xx, aes_string(x="true", y="est", color="params")) + 254 | geom_point(alpha=.3) + geom_smooth(method='gam', se=F) + 255 | facet_wrap(~params, nrow=1, scales='free') + guides(color=F) + 256 | xlab('True Parameters') + ylab('Est. Parameters') + theme_bw() 257 | print(g) 258 | if(any(t_free)) cat('t: corr = ', round(cor(t, true_params$t), 3), ', rmse = ', round(rmse(t, true_params$t), 3),'\n', sep='') 259 | if(any(a_free)) cat('a: corr = ', round(cor(a, true_params$a), 3), ', rmse = ', round(rmse(a, true_params$a), 3),'\n', sep='') 260 | for(i in 1:(n_c-1)) if(any(b_free[,i])) cat('b_', i, ': corr = ', round(cor(b[,i], true_params$b[,i]), 3), ', rmse = ', round(rmse(b[,i], true_params$b[,i]), 3),'\n', sep='') 261 | } 262 | 263 | list(t=t, a=a, b=b) 264 | } 265 | 266 | #' @rdname estimate_grm 267 | #' @keywords internal 268 | model_grm_dv_mmle <- function(u_ix, quad, pdv){ 269 | n_p <- max(u_ix[,1]) 270 | n_i <- max(u_ix[,2]) 271 | n_q <- length(quad$t) 272 | p0 <- array(NA, c(n_p, n_i, n_q)) 273 | for(q in 1:n_q) 274 | p0[,,q] <- array(pdv$p[q,,][u_ix[,-1]], c(n_p, n_i)) 275 | p1 <- apply(p0, c(1, 3), prod, na.rm=T) 276 | p2 <- (p1 %*% quad$w)[,1] 277 | 278 | dv1 <- dv2 <- array(0, c(n_p, n_i)) 279 | dv_common <- t(t(p1 / p2) * quad$w) 280 | for(q in 1:n_q) 281 | dv1 <- dv1 + dv_common[,q] / p0[,,q] * array(pdv$dv1[q,,][u_ix[,-1]], c(n_p, n_i)) 282 | for(q in 1:n_q) 283 | dv2 <- dv2 + dv_common[,q] / p0[,,q] * (array(pdv$dv2[q,,][u_ix[,-1]], c(n_p, n_i)) - array(pdv$dv1[q,,][u_ix[,-1]], c(n_p, n_i)) * dv1) 284 | list(dv1=dv1, dv2=dv2) 285 | } 286 | 287 | 288 | #' @rdname estimate_grm 289 | #' @description \code{model_grm_estimate_mmle} estimates the parameters using the 290 | #' marginal maximum likelihood estimation (MMLE) method 291 | #' @param quad_degree the number of quadrature points 292 | #' @param scoring the scoring method: 'eap' or 'map' 293 | #' @examples 294 | #' \dontrun{ 295 | #' # generate data 296 | #' x <- model_grm_gendata(1000, 40, 3) 297 | #' # free estimation 298 | #' y <- model_grm_estimate_mmle(x$u, true_params=x) 299 | #' # no priors 300 | #' y <- model_grm_estimate_mmle(x$u, priors=NULL, true_params=x) 301 | #' } 302 | #' @importFrom stats cor 303 | #' @importFrom reshape2 melt 304 | #' @import ggplot2 305 | #' @export 306 | model_grm_estimate_mmle <- function(u, t=NA, a=NA, b=NA, d=NA, D=1.702, iter=100, nr_iter=10, conv=1e-0, nr_conv=1e-3, bounds_t=c(-4, 4), bounds_a=c(.01, 2), bounds_b=c(-4, 4), bounds_d=c(-4, 4), priors=list(t=c(0, 1), a=c(-.1, .2), b=c(0, 1)), decay=1, quad_degree='11', scoring=c('eap', 'map'), debug=FALSE, true_params=NULL){ 307 | # configuration 308 | h_max <- 1.0 309 | if(is.null(priors$t)) priors$t <- c(0, 1) 310 | quad <- hermite_gauss(quad_degree) 311 | quad$w <- quad$w * exp(quad$t^2) * dnorm(quad$t, priors$t[1], priors$t[2]) 312 | tracking <- list(fit=rep(NA, iter), t=rep(NA, iter), a=rep(NA, iter), b=rep(NA, iter), d=rep(NA, iter)) 313 | 314 | # initial values 315 | n_p <- dim(u)[1] 316 | n_i <- dim(u)[2] 317 | n_c <- max(u) + 1 318 | u_ix <- model_polytomous_3dindex(u) 319 | if(length(t) == 1) t <- rep(t, n_p) 320 | t[t_free <- is.na(t)] <- rnorm(sum(is.na(t)), 0, .01) 321 | if(length(a) == 1) a <- rep(a, n_i) 322 | a[a_free <- is.na(a)] <- rlnorm(sum(is.na(a)), -.1, .01) 323 | if(length(b) == 1) b <- array(b, c(n_i, n_c-1)) 324 | b[b_free <- is.na(b)] <- rnorm(sum(is.na(b)), 0, .1) 325 | b <- t(apply(b, 1, sort)) 326 | 327 | # estimate parameters 328 | for (k in 1:iter){ 329 | # b parameters 330 | if(any(b_free)){ 331 | for(j in 1:nr_iter){ 332 | dv_b <- model_grm_dv_Pb(t, a, b, D) 333 | dv_bh <- array(0, c(n_i, n_c-1)) 334 | for(m in 2:n_c-1){ 335 | dv <- model_grm_dv_mmle(u_ix, quad, with(dv_b, list(p=p, dv1=dv1[,,,m], dv2=dv2[,,,m]))) 336 | dv$dv1 <- colSums(dv$dv1, na.rm=T) 337 | dv$dv2 <- colSums(dv$dv2, na.rm=T) 338 | if(!is.null(priors$b)){ 339 | dv$dv1 <- dv$dv1 - (b[,m] - priors$b[1]) / priors$b[2]^2 340 | dv$dv2 <- dv$dv2 - 1 / priors$b[2]^2 341 | } 342 | nr <- estimate_nr_iteration(b[,m], b_free[,m], dv, h_max, decay, bounds_b) 343 | b[,m] <- nr$param 344 | dv_bh[,m] <- nr$h 345 | } 346 | b <- t(apply(b, 1, sort)) 347 | if(max(abs(dv_bh)) < nr_conv) break 348 | } 349 | } 350 | 351 | # a parameters 352 | if(any(a_free)){ 353 | for(j in 1:nr_iter){ 354 | dv_a <- model_grm_dv_mmle(u_ix, quad, model_grm_dv_Pa(quad$t, a, b, D)) 355 | dv_a$dv1 <- colSums(dv_a$dv1, na.rm=T) 356 | dv_a$dv2 <- colSums(dv_a$dv2, na.rm=T) 357 | if(!is.null(priors$a)){ 358 | dv_a$dv1 <- dv_a$dv1 - 1/a * (1 + (log(a)-priors$a[1])/priors$a[2]^2) 359 | dv_a$dv2 <- dv_a$dv2 - 1/a^2 * (1/priors$a[2]^2 - (1 + (log(a)-priors$a[1])/priors$a[2]^2)) 360 | } 361 | nr_a <- estimate_nr_iteration(a, a_free, dv_a, h_max, decay, bounds_a) 362 | a <- nr_a$param 363 | if(max(abs(nr_a$h)) < nr_conv) break 364 | } 365 | } 366 | 367 | # scoring 368 | if(any(t_free)) 369 | t[t_free] <- switch(match.arg(scoring, scoring), 'eap'=model_grm_eap_scoring, 'map'=model_grm_map_scoring)(u, a, b, D, prior=priors$t, bound=bounds_t)$t[t_free] 370 | 371 | decay <- decay * decay 372 | 373 | # model fit 374 | loglh <- -2 * sum(model_grm_lh(u, t, a, b, D, log=T), na.rm=T) 375 | if(debug) cat('iter #', k, ': -2 log-likelihood = ', round(loglh, 2), '\n', sep='') 376 | if(k > 1 && tracking$fit[k-1] - loglh < conv) break 377 | tracking$fit[k] <- loglh 378 | if(any(a_free)) tracking$a[k] <- mean(abs(nr_a$h[a_free])) 379 | if(any(b_free)) tracking$d[k] <- mean(abs(dv_bh[b_free])) 380 | } 381 | 382 | # debugging 383 | if(debug){ 384 | xx <- with(tracking, data.frame(iteration=1:iter, fit=fit, t=t, a=a, b=b))[1:k, ] 385 | xx <- melt(xx, id.vars='iteration') 386 | xx <- xx[!is.na(xx$value), ] 387 | g <- ggplot(xx, aes_string(x="iteration", y="value", color="variable")) + 388 | geom_line() + facet_wrap(~variable, scales="free") + guides(color=F) + 389 | xlab('Iterations') + ylab('') + theme_bw() 390 | print(g) 391 | } 392 | 393 | # compare with true parameters 394 | if(!is.null(true_params)){ 395 | xx <- rbind(data.frame(true=true_params$t, est=t, params='t'), 396 | data.frame(true=true_params$a, est=a, params='a')) 397 | for(i in 2:n_c-1) 398 | xx <- rbind(xx, data.frame(true=true_params$b[,i], est=b[,i], params=paste('b',i,sep=''))) 399 | g <- ggplot(xx, aes_string(x="true", y="est", color="params")) + 400 | geom_point(alpha=.3) + geom_smooth(method='gam', se=F) + 401 | facet_wrap(~params, nrow=1, scales='free') + guides(color=F) + 402 | xlab('True Parameters') + ylab('Est. Parameters') + theme_bw() 403 | print(g) 404 | if(any(t_free)) cat('t: corr = ', round(cor(t, true_params$t), 3), ', rmse = ', round(rmse(t, true_params$t), 3),'\n', sep='') 405 | if(any(a_free)) cat('a: corr = ', round(cor(a, true_params$a), 3), ', rmse = ', round(rmse(a, true_params$a), 3),'\n', sep='') 406 | for(i in 2:n_c-1) if(any(b_free[,i])) cat('b_', i, ': corr = ', round(cor(b[,i], true_params$b[,i]), 3), ', rmse = ', round(rmse(b[,i], true_params$b[,i]), 3),'\n', sep='') 407 | } 408 | 409 | list(t=t, a=a, b=b) 410 | } 411 | 412 | #' @rdname estimate_grm 413 | #' @param index the indices of items being plotted 414 | #' @param intervals intervals on the x-axis 415 | #' @param show_points TRUE to show points 416 | #' @examples 417 | #' with(model_grm_gendata(1000, 20, 3), model_grm_fitplot(u, t, a, b, index=c(1, 3, 5))) 418 | #' @importFrom reshape2 melt 419 | #' @import ggplot2 420 | #' @export 421 | model_grm_fitplot <- function(u, t, a, b, D=1.702, index=NULL, intervals=seq(-3, 3, .5), show_points=TRUE){ 422 | if(is.null(index)) index <- seq(b) 423 | groups <- cut(t, intervals, labels=(intervals[-length(intervals)] + intervals[-1]) / 2) 424 | 425 | obs <- aggregate(u, by=list(intervals=groups), mean, na.rm=TRUE)[, c(1, index+1)] 426 | obs <- melt(obs, id.vars='intervals', variable.name='items') 427 | obs[, 'type'] <- 'Observed' 428 | p <- model_grm_prob(t, a, b, D) 429 | p <- apply(p, 1:2, function(x) sum(x * (seq(x)-1), na.rm=T)) 430 | exp <- aggregate(p, by=list(intervals=groups), mean, na.rm=TRUE)[, c(1, index+1)] 431 | exp <- melt(exp, id.vars='intervals', variable.name='items') 432 | exp[, 'type'] <- 'Expected' 433 | data <- rbind(obs, exp) 434 | data$intervals <- as.numeric(levels(data$intervals)[data$intervals]) 435 | levels(data$items) <- gsub('V', 'Item ', levels(data$items)) 436 | 437 | g <- ggplot(data, aes_string('intervals', 'value', color='type', group='type')) + 438 | geom_line() + facet_wrap(~items) + xlab(expression(theta)) + ylab('Probability') + 439 | scale_color_discrete(guide=guide_legend("")) + theme_bw() 440 | if(show_points) g <- g + geom_point(fill='white', pch=1) 441 | g 442 | } 443 | -------------------------------------------------------------------------------- /R/module2_estimate_3pl.R: -------------------------------------------------------------------------------- 1 | #' Estimate 3-parameter-logistic model 2 | #' @description Estimate the 3PL model using the maximum likelihood estimation 3 | #' @name estimate_3pl 4 | NULL 5 | 6 | #' @rdname estimate_3pl 7 | #' @description \code{model_3pl_eap_scoring} scores response vectors using the EAP method 8 | #' @param prior the prior distribution 9 | #' @examples 10 | #' with(model_3pl_gendata(10, 40), cbind(true=t, est=model_3pl_eap_scoring(u, a, b, c)$t)) 11 | #' @importFrom stats dnorm 12 | #' @export 13 | model_3pl_eap_scoring <- function(u, a, b, c, D=1.702, prior=c(0, 1), bound=c(-3, 3)){ 14 | if(is.null(prior)) prior <- c(0, 1) 15 | quad <- hermite_gauss('11') 16 | quad$w <- quad$w * exp(quad$t^2) * dnorm(quad$t, prior[1], prior[2]) 17 | p <- model_3pl_prob(quad$t, a, b, c, D) 18 | lh <- exp(ifelse(is.na(u), 0, u) %*% t(log(p)) + ifelse(is.na(1 - u), 0, 1 - u) %*% t(log(1 - p))) 19 | t <- colSums(t(lh) * quad$w * quad$t) / colSums(t(lh) * quad$w) 20 | t[t < bound[1]] <- bound[1] 21 | t[t > bound[2]] <- bound[2] 22 | t_sd <- colSums(t(lh) * quad$w * outer(quad$t, t, '-')^2) / colSums(t(lh) * quad$w) 23 | t_sd <- sqrt(t_sd) 24 | list(t=t, sd=t_sd) 25 | } 26 | 27 | #' @rdname estimate_3pl 28 | #' @description \code{model_3pl_map_scoring} scores response vectors using the MAP method 29 | #' @examples 30 | #' with(model_3pl_gendata(10, 40), cbind(true=t, est=model_3pl_map_scoring(u, a, b, c)$t)) 31 | #' @export 32 | model_3pl_map_scoring <- function(u, a, b, c, D=1.702, prior=c(0, 1), bound=c(-3, 3), nr_iter=30, nr_conv=1e-3){ 33 | t <- rnorm(dim(u)[1], 0, .01) 34 | t_free <- rep(T, length(t)) 35 | for(m in 1:nr_iter){ 36 | dv_t <- model_3pl_dv_jmle(model_3pl_dv_Pt(t, a, b, c, D), u) 37 | dv_t$dv1 <- colSums(dv_t$dv1, na.rm=T) 38 | dv_t$dv2 <- colSums(dv_t$dv2, na.rm=T) 39 | if(!is.null(prior)){ 40 | dv_t$dv1 <- dv_t$dv1 - (t - prior[1]) / prior[2]^2 41 | dv_t$dv2 <- dv_t$dv2 - 1 / prior[2]^2 42 | } 43 | nr_t <- estimate_nr_iteration(t, t_free, dv_t, 1.0, 1.0, bound) 44 | t <- nr_t$param 45 | if(max(abs(nr_t$h)) < nr_conv) break 46 | } 47 | list(t=t) 48 | } 49 | 50 | #' @rdname estimate_3pl 51 | #' @keywords internal 52 | model_3pl_dv_Pt <- function(t, a, b, c, D){ 53 | p <- t(model_3pl_prob(t, a, b, c, D)) 54 | dv1 <- D * a * (p - c) * (1 - p) / (1 - c) 55 | dv2 <- (D * a / (1 - c))^2 * (p - c) * (1 - p) * (1 + c - 2*p) 56 | list(dv1=dv1, dv2=dv2, p=p) 57 | } 58 | 59 | #' @rdname estimate_3pl 60 | #' @keywords internal 61 | model_3pl_dv_Pa <- function(t, a, b, c, D){ 62 | p <- t(model_3pl_prob(t, a, b, c, D)) 63 | dv1 <- D * t(outer(t, b, '-')) * (p - c) * (1 - p) / (1 - c) 64 | dv2 <- (D * t(outer(t, b, '-')) / (1 - c))^2 * (p - c) * (1 - p) * (1 + c - 2*p) 65 | list(dv1=dv1, dv2=dv2, p=p) 66 | } 67 | 68 | #' @rdname estimate_3pl 69 | #' @keywords internal 70 | model_3pl_dv_Pb <- function(t, a, b, c, D){ 71 | p <- t(model_3pl_prob(t, a, b, c, D)) 72 | dv1 <- - D * a * (p - c) * (1 - p) / (1 - c) 73 | dv2 <- (D * a / (1 - c))^2 * (p - c) * (1 - p) * (1 + c - 2*p) 74 | list(dv1=dv1, dv2=dv2, p=p) 75 | } 76 | 77 | #' @rdname estimate_3pl 78 | #' @keywords internal 79 | model_3pl_dv_Pc <- function(t, a, b, c, D){ 80 | p <- t(model_3pl_prob(t, a, b, c, D)) 81 | dv1 <- (1 - p) / (1 - c) 82 | dv2 <- array(0, dim=dim(dv1)) 83 | list(dv1=dv1, dv2=dv2, p=p) 84 | } 85 | 86 | #' @rdname estimate_3pl 87 | #' @description \code{model_3pl_dv_jmle} calculates the first and second derivatives for 88 | #' the joint maximum likelihood estimation 89 | #' @keywords internal 90 | model_3pl_dv_jmle <- function(dv, u){ 91 | dv1 <- (t(u) - dv$p) / dv$p / (1 - dv$p) * dv$dv1 92 | dv2 <- (t(u) - dv$p) / dv$p / (1 - dv$p) * dv$dv2 - ((t(u) - dv$p) / dv$p / (1 - dv$p) * dv$dv1)^2 93 | list(dv1=dv1, dv2=dv2) 94 | } 95 | 96 | 97 | #' @rdname estimate_3pl 98 | #' @description \code{model_3pl_estimate_jmle} estimates the parameters using the 99 | #' joint maximum likelihood estimation (JMLE) method 100 | #' @param u observed response matrix, 2d matrix 101 | #' @param t ability parameters, 1d vector (fixed value) or NA (freely estimate) 102 | #' @param a discrimination parameters, 1d vector (fixed value) or NA (freely estimate) 103 | #' @param b difficulty parameters, 1d vector (fixed value) or NA (freely estimate) 104 | #' @param c pseudo-guessing parameters, 1d vector (fixed value) or NA (freely estimate) 105 | #' @param D the scaling constant, 1.702 by default 106 | #' @param iter the maximum iterations 107 | #' @param conv the convergence criterion of the -2 log-likelihood 108 | #' @param nr_iter the maximum iterations of newton-raphson 109 | #' @param nr_conv the convegence criterion for newton-raphson 110 | #' @param scale the meand and SD of the theta scale, N(0, 1) for JMLE by default 111 | #' @param bounds_t bounds of ability parameters 112 | #' @param bounds_a bounds of discrimination parameters 113 | #' @param bounds_b bounds of difficulty parameters 114 | #' @param bounds_c bounds of guessing parameters 115 | #' @param priors a list of prior distributions 116 | #' @param decay decay rate 117 | #' @param debug TRUE to print debuggin information 118 | #' @param true_params a list of true parameters for evaluating the estimation accuracy 119 | #' @examples 120 | #' \dontrun{ 121 | #' # generate data 122 | #' x <- model_3pl_gendata(2000, 40) 123 | #' # free estimation 124 | #' y <- model_3pl_estimate_jmle(x$u, true_params=x) 125 | #' # fix c-parameters 126 | #' y <- model_3pl_estimate_jmle(x$u, c=0, true_params=x) 127 | #' # no priors 128 | #' y <- model_3pl_estimate_jmle(x$u, priors=NULL, iter=30, debug=T) 129 | #' } 130 | #' @importFrom stats cor 131 | #' @importFrom reshape2 melt 132 | #' @import ggplot2 133 | #' @export 134 | model_3pl_estimate_jmle <- function(u, t=NA, a=NA, b=NA, c=NA, D=1.702, iter=100, conv=1e-0, nr_iter=10, nr_conv=1e-3, scale=c(0, 1), bounds_t=c(-3, 3), bounds_a=c(.01, 2), bounds_b=c(-3, 3), bounds_c=c(0, .25), priors=list(t=c(0, 1), a=c(-.1, .2), b=c(0, 1), c=c(4, 20)), decay=1, debug=FALSE, true_params=NULL){ 135 | # internal config 136 | h_max <- 1 137 | tracking <- list(fit=rep(NA, iter), t=rep(NA, iter), a=rep(NA, iter), b=rep(NA, iter), c=rep(NA, iter)) 138 | 139 | # initial values 140 | n_p <- nrow(u) 141 | n_i <- ncol(u) 142 | if(length(t) == 1) t <- rep(t, n_p) 143 | t[t_free <- is.na(t)] <- rnorm(sum(is.na(t)), 0, .01) 144 | if(length(a) == 1) a <- rep(a, n_i) 145 | a[a_free <- is.na(a)] <- rlnorm(sum(is.na(a)), -.1, .01) 146 | if(length(b) == 1) b <- rep(b, n_i) 147 | b[b_free <- is.na(b)] <- rnorm(sum(is.na(b)), 0, .01) 148 | if(length(c) == 1) c <- rep(c, n_i) 149 | c[c_free <- is.na(c)] <- rbeta(sum(is.na(c)), 4, 20) 150 | 151 | for(k in 1:iter){ 152 | # t parameters 153 | if(any(t_free)){ 154 | for(m in 1:nr_iter){ 155 | dv_t <- model_3pl_dv_jmle(model_3pl_dv_Pt(t, a, b, c, D), u) 156 | dv_t$dv1 <- colSums(dv_t$dv1, na.rm=T) 157 | dv_t$dv2 <- colSums(dv_t$dv2, na.rm=T) 158 | if(!is.null(priors$t)){ 159 | dv_t$dv1 <- dv_t$dv1 - (t - priors$t[1]) / priors$t[2]^2 160 | dv_t$dv2 <- dv_t$dv2 - 1 / priors$t[2]^2 161 | } 162 | nr_t <- estimate_nr_iteration(t, t_free, dv_t, h_max, decay, bounds_t) 163 | t <- nr_t$param 164 | if(max(abs(nr_t$h)) < nr_conv) break 165 | } 166 | # rescale thetas 167 | if(!is.null(scale)) t <- (t - mean(t)) / sd(t) * scale[2] + scale[1] 168 | } 169 | 170 | # b parameters 171 | if(any(b_free)){ 172 | for(m in 1:nr_iter){ 173 | dv_b <- model_3pl_dv_jmle(model_3pl_dv_Pb(t, a, b, c, D), u) 174 | dv_b$dv1 <- rowSums(dv_b$dv1, na.rm=T) 175 | dv_b$dv2 <- rowSums(dv_b$dv2, na.rm=T) 176 | if(!is.null(priors$b)){ 177 | dv_b$dv1 <- dv_b$dv1 - (b - priors$b[1]) / priors$b[2]^2 178 | dv_b$dv2 <- dv_b$dv2 - 1 / priors$b[2]^2 179 | } 180 | nr_b <- estimate_nr_iteration(b, b_free, dv_b, h_max, decay, bounds_b) 181 | b <- nr_b$param 182 | if(max(abs(nr_b$h)) < nr_conv) break 183 | } 184 | } 185 | 186 | # a parameters 187 | if(any(a_free)){ 188 | for(m in 1:nr_iter){ 189 | dv_a <- model_3pl_dv_jmle(model_3pl_dv_Pa(t, a, b, c, D), u) 190 | dv_a$dv1 <- rowSums(dv_a$dv1, na.rm=T) 191 | dv_a$dv2 <- rowSums(dv_a$dv2, na.rm=T) 192 | if(!is.null(priors$a)){ 193 | dv_a$dv1 <- dv_a$dv1 - 1/a * (1 + (log(a)-priors$a[1])/priors$a[2]^2) 194 | dv_a$dv2 <- dv_a$dv2 - 1/a^2 * (1/priors$a[2]^2 - (1 + (log(a)-priors$a[1])/priors$a[2]^2)) 195 | } 196 | nr_a <- estimate_nr_iteration(a, a_free, dv_a, h_max, decay, bounds_a) 197 | a <- nr_a$param 198 | if(max(abs(nr_a$h)) < nr_conv) break 199 | } 200 | } 201 | 202 | # estimate c parameters 203 | if(any(c_free)){ 204 | for(m in 1:nr_iter){ 205 | dv_c <- model_3pl_dv_jmle(model_3pl_dv_Pc(t, a, b, c, D), u) 206 | dv_c$dv1 <- rowSums(dv_c$dv1, na.rm=T) 207 | dv_c$dv2 <- rowSums(dv_c$dv2, na.rm=T) 208 | if(!is.null(priors$c)){ 209 | dv_c$dv1 <- dv_c$dv1 - ((priors$c[2]-1)/(1-c) - (priors$c[1]-1)/c) 210 | dv_c$dv2 <- dv_c$dv2 - ((priors$c[1]-1)/c^2 + (priors$c[2]-1)/(1-c)^2) 211 | } 212 | nr_c <- estimate_nr_iteration(c, c_free, dv_c, h_max, decay, bounds_c) 213 | c <- nr_c$param 214 | if(max(abs(nr_c$h)) < nr_conv) break 215 | } 216 | } 217 | 218 | decay <- decay * decay 219 | 220 | # model fit 221 | loglh <- -2 * sum(model_3pl_lh(u, t, a, b, c, D, log=TRUE), na.rm=T) 222 | if(debug) cat('iter #', k, ': -2 log-likelihood = ', round(loglh, 2), '\n', sep='') 223 | if(k > 1 && tracking$fit[k-1] - loglh < conv) break 224 | tracking$fit[k] <- loglh 225 | if(any(t_free)) tracking$t[k] <- mean(abs(nr_t$h[t_free])) 226 | if(any(a_free)) tracking$a[k] <- mean(abs(nr_a$h[a_free])) 227 | if(any(b_free)) tracking$b[k] <- mean(abs(nr_b$h[b_free])) 228 | if(any(c_free)) tracking$c[k] <- mean(abs(nr_c$h[c_free])) 229 | } 230 | 231 | # debugging 232 | if(debug){ 233 | xx <- with(tracking, data.frame(iteration=1:iter, fit=fit, t=t, a=a, b=b, c=c))[1:k, ] 234 | xx <- melt(xx, id.vars='iteration') 235 | xx <- xx[!is.na(xx$value), ] 236 | g <- ggplot(xx, aes_string(x="iteration", y="value", color="variable")) + 237 | geom_line() + facet_wrap(~variable, scales="free") + guides(color=F) + 238 | xlab('Iterations') + ylab('') + theme_bw() 239 | print(g) 240 | } 241 | 242 | # compare with true parameters 243 | if(!is.null(true_params)){ 244 | xx <- rbind(data.frame(true=true_params$t, est=t, params='t'), 245 | data.frame(true=true_params$a, est=a, params='a'), 246 | data.frame(true=true_params$b, est=b, params='b'), 247 | data.frame(true=true_params$c, est=c, params='c')) 248 | g <- ggplot(xx, aes_string(x="true", y="est", color="params")) + 249 | geom_point(alpha=.3) + geom_smooth(method='gam', se=F) + 250 | facet_wrap(~params, nrow=1, scales='free') + guides(color=F) + 251 | xlab('True Parameters') + ylab('Est. Parameters') + theme_bw() 252 | print(g) 253 | if(any(t_free)) cat('t: corr = ', round(cor(t, true_params$t), 3), ', rmse = ', round(rmse(t, true_params$t), 3),'\n', sep='') 254 | if(any(a_free)) cat('a: corr = ', round(cor(a, true_params$a), 3), ', rmse = ', round(rmse(a, true_params$a), 3),'\n', sep='') 255 | if(any(b_free)) cat('b: corr = ', round(cor(b, true_params$b), 3), ', rmse = ', round(rmse(b, true_params$b), 3),'\n', sep='') 256 | if(any(c_free)) cat('c: corr = ', round(cor(c, true_params$c), 3), ', rmse = ', round(rmse(c, true_params$c), 3),'\n', sep='') 257 | } 258 | 259 | list(t=t, a=a, b=b, c=c) 260 | } 261 | 262 | 263 | #' @rdname estimate_3pl 264 | #' @description \code{model_3pl_dv_mmle} calculates the first and second derivatives for 265 | #' the marginal maximum likelihood estimation 266 | #' @param pdv_fn the function to compute derivatives of P w.r.t the estimating parameters 267 | #' @keywords internal 268 | model_3pl_dv_mmle <- function(pdv_fn, u, quad, a, b, c, D){ 269 | n_p <- dim(u)[1] 270 | n_i <- dim(u)[2] 271 | n_q <- length(quad$t) 272 | 273 | p <- model_3pl_prob(quad$t, a, b, c, D) 274 | p_u1 <- t(ifelse(is.na(u), 0, u)) 275 | p_u0 <- t(ifelse(is.na(u), 0, 1-u)) 276 | ln_p <- log(p) 277 | ln_q <- log(1-p) 278 | p0 <- array(NA, c(n_i, n_p, n_q)) 279 | p1 <- array(NA, c(n_p, n_q)) 280 | for(q in 1:n_q){ 281 | p0[,,q] <- p_u1*ln_p[q,] + p_u0*ln_q[q,] 282 | p1[,q] <- colSums(p0[,,q], na.rm=T) 283 | } 284 | p0 <- aperm(exp(p0), c(2,1,3)) 285 | p1 <- exp(p1) 286 | p2 <- (p1 %*% quad$w)[,1] 287 | pdv <- pdv_fn(quad$t, a, b, c, D) 288 | 289 | dv_common <- t(quad$w * t(p1 / p2)) 290 | dv_u0 <- t((-1)^(u+1)) 291 | dv1 <- dv2 <- array(0, c(n_p, n_i)) 292 | for(q in 1:n_q) 293 | dv1 <- dv1 + dv_common[,q] / p0[,,q] * t(dv_u0*pdv$dv1[,q]) 294 | for(q in 1:n_q) 295 | dv2 <- dv2 + dv_common[,q] / p0[,,q] * t(dv_u0*pdv$dv2[,q]) 296 | dv2 <- dv2 - dv1^2 297 | dv1 <- colSums(dv1, na.rm=T) 298 | dv2 <- colSums(dv2, na.rm=T) 299 | list(dv1=dv1, dv2=dv2) 300 | } 301 | 302 | #' @rdname estimate_3pl 303 | #' @description \code{model_3pl_estimate_mmle} estimates the parameters using the 304 | #' marginal maximum likelihood estimation (MMLE) method 305 | #' @param quad_degree the number of quadrature points 306 | #' @param scoring the scoring method: 'eap' or 'map' 307 | #' @examples 308 | #' \dontrun{ 309 | #' # generate data 310 | #' x <- model_3pl_gendata(2000, 40) 311 | #' # free estimation 312 | #' y <- model_3pl_estimate_mmle(x$u, true_params=x) 313 | #' # fix c-parameters 314 | #' y <- model_3pl_estimate_mmle(x$u, c=0, true_params=x) 315 | #' # no priors 316 | #' y <- model_3pl_estimate_mmle(x$u, priors=NULL, iter=30, debug=T) 317 | #' } 318 | #' @importFrom stats cor 319 | #' @importFrom reshape2 melt 320 | #' @import ggplot2 321 | #' @export 322 | model_3pl_estimate_mmle <- function(u, t=NA, a=NA, b=NA, c=NA, D=1.702, iter=100, conv=1e-0, nr_iter=10, nr_conv=1e-3, bounds_t=c(-3, 3), bounds_a=c(.01, 2), bounds_b=c(-3, 3), bounds_c=c(0, .25), priors=list(t=c(0, 1), a=c(-.1, .2), b=c(0, 1), c=c(4, 20)), decay=1, quad_degree='11', scoring=c('eap', 'map'), debug=FALSE, true_params=NULL){ 323 | # internal config 324 | h_max <- 1 325 | if(is.null(priors$t)) priors$t <- c(0, 1) 326 | quad <- hermite_gauss(quad_degree) 327 | quad$w <- quad$w * exp(quad$t^2) * dnorm(quad$t, priors$t[1], priors$t[2]) 328 | tracking <- list(fit=rep(NA, iter), t=rep(NA, iter), a=rep(NA, iter), b=rep(NA, iter), c=rep(NA, iter)) 329 | 330 | # initial values 331 | n_p <- nrow(u) 332 | n_i <- ncol(u) 333 | if(length(t) == 1) t <- rep(t, n_p) 334 | t[t_free <- is.na(t)] <- rnorm(sum(is.na(t)), 0, .01) 335 | if(length(a) == 1) a <- rep(a, n_i) 336 | a[a_free <- is.na(a)] <- rlnorm(sum(is.na(a)), -.1, .01) 337 | if(length(b) == 1) b <- rep(b, n_i) 338 | b[b_free <- is.na(b)] <- rnorm(sum(is.na(b)), 0, .01) 339 | if(length(c) == 1) c <- rep(c, n_i) 340 | c[c_free <- is.na(c)] <- rbeta(sum(is.na(c)), 4, 20) 341 | 342 | for(k in 1:iter){ 343 | # b parameters 344 | if(any(b_free)){ 345 | for(m in 1:nr_iter){ 346 | dv_b <- model_3pl_dv_mmle(model_3pl_dv_Pb, u, quad, a, b, c, D) 347 | if(!is.null(priors$b)){ 348 | dv_b$dv1 <- dv_b$dv1 - (b - priors$b[1]) / priors$b[2]^2 349 | dv_b$dv2 <- dv_b$dv2 - 1 / priors$b[2]^2 350 | } 351 | nr_b <- estimate_nr_iteration(b, b_free, dv_b, h_max, decay, bounds_b) 352 | b <- nr_b$param 353 | if(max(abs(nr_b$h)) < nr_conv) break 354 | } 355 | } 356 | 357 | # a parameters 358 | if(any(a_free)){ 359 | for(m in 1:nr_iter){ 360 | dv_a <- model_3pl_dv_mmle(model_3pl_dv_Pa, u, quad, a, b, c, D) 361 | if(!is.null(priors$a)){ 362 | dv_a$dv1 <- dv_a$dv1 - 1/a * (1 + (log(a)-priors$a[1])/priors$a[2]^2) 363 | dv_a$dv2 <- dv_a$dv2 - 1/a^2 * (1/priors$a[2]^2 - (1 + (log(a)-priors$a[1])/priors$a[2]^2)) 364 | } 365 | nr_a <- estimate_nr_iteration(a, a_free, dv_a, h_max, decay * .2, bounds_a) 366 | a <- nr_a$param 367 | if(max(abs(nr_a$h)) < nr_conv) break 368 | } 369 | } 370 | 371 | # estimate c parameters 372 | if(any(c_free)){ 373 | for(m in 1:nr_iter){ 374 | dv_c <- model_3pl_dv_mmle(model_3pl_dv_Pc, u, quad, a, b, c, D) 375 | if(!is.null(priors$c)){ 376 | dv_c$dv1 <- dv_c$dv1 - ((priors$c[2]-1)/(1-c) - (priors$c[1]-1)/c) 377 | dv_c$dv2 <- dv_c$dv2 - ((priors$c[1]-1)/c^2 + (priors$c[2]-1)/(1-c)^2) 378 | } 379 | nr_c <- estimate_nr_iteration(c, c_free, dv_c, h_max, decay, bounds_c) 380 | c <- nr_c$param 381 | if(max(abs(nr_c$h)) < nr_conv) break 382 | } 383 | } 384 | 385 | decay <- decay * decay 386 | 387 | # scoring 388 | if(any(t_free)) 389 | t[t_free] <- switch(match.arg(scoring, scoring), 'eap'=model_3pl_eap_scoring, 'map'=model_3pl_map_scoring)(u, a, b, c, D, prior=priors$t, bound=bounds_t)$t[t_free] 390 | 391 | # model fit 392 | loglik <- -2 * sum(model_3pl_lh(u, t, a, b, c, D, log=TRUE), na.rm=T) 393 | if(debug) cat('iter #', k, ': -2 log-likelihood = ', round(loglik, 2), '\n', sep='') 394 | if(k > 1 && tracking$fit[k-1] - loglik < conv) break 395 | tracking$fit[k] <- loglik 396 | if(any(a_free)) tracking$a[k] <- mean(abs(nr_a$h[a_free])) 397 | if(any(b_free)) tracking$b[k] <- mean(abs(nr_b$h[b_free])) 398 | if(any(c_free)) tracking$c[k] <- mean(abs(nr_c$h[c_free])) 399 | } 400 | 401 | # debugging 402 | if(debug){ 403 | xx <- with(tracking, data.frame(iteration=1:iter, fit=fit, a=a, b=b, c=c))[1:k, ] 404 | xx <- melt(xx, id.vars='iteration') 405 | xx <- xx[!is.na(xx$value), ] 406 | g <- ggplot(xx, aes_string(x="iteration", y="value", color="variable")) + 407 | geom_line() + facet_wrap(~variable, scales="free") + guides(color=F) + 408 | xlab('Iterations') + ylab('') + theme_bw() 409 | print(g) 410 | } 411 | 412 | # compare with true parameters 413 | if(!is.null(true_params)){ 414 | xx <- rbind(data.frame(true=true_params$t, est=t, params='t'), 415 | data.frame(true=true_params$a, est=a, params='a'), 416 | data.frame(true=true_params$b, est=b, params='b'), 417 | data.frame(true=true_params$c, est=c, params='c')) 418 | g <- ggplot(xx, aes_string(x="true", y="est", color="params")) + 419 | geom_point(alpha=.3) + geom_smooth(method='gam', se=F) + 420 | facet_wrap(~params, nrow=1, scales='free') + guides(color=F) + 421 | xlab('True Parameters') + ylab('Est. Parameters') + theme_bw() 422 | print(g) 423 | if(any(t_free)) cat('t: corr = ', round(cor(t, true_params$t), 3), ', rmse = ', round(rmse(t, true_params$t), 3),'\n', sep='') 424 | if(any(a_free)) cat('a: corr = ', round(cor(a, true_params$a), 3), ', rmse = ', round(rmse(a, true_params$a), 3),'\n', sep='') 425 | if(any(b_free)) cat('b: corr = ', round(cor(b, true_params$b), 3), ', rmse = ', round(rmse(b, true_params$b), 3),'\n', sep='') 426 | if(any(c_free)) cat('c: corr = ', round(cor(c, true_params$c), 3), ', rmse = ', round(rmse(c, true_params$c), 3),'\n', sep='') 427 | } 428 | 429 | list(t=t, a=a, b=b, c=c) 430 | } 431 | 432 | 433 | #' @rdname estimate_3pl 434 | #' @param index the indices of items being plotted 435 | #' @param intervals intervals on the x-axis 436 | #' @param show_points TRUE to show points 437 | #' @examples 438 | #' with(model_3pl_gendata(1000, 20), model_3pl_fitplot(u, t, a, b, c, index=c(1, 3, 5))) 439 | #' @importFrom reshape2 melt 440 | #' @import ggplot2 441 | #' @export 442 | model_3pl_fitplot <- function(u, t, a, b, c, D=1.702, index=NULL, intervals=seq(-3, 3, .5), show_points=TRUE){ 443 | if(is.null(index)) index <- seq(b) 444 | groups <- cut(t, intervals, labels=(intervals[-length(intervals)] + intervals[-1]) / 2) 445 | 446 | obs <- aggregate(u, by=list(intervals=groups), mean, na.rm=TRUE)[, c(1, index+1)] 447 | obs <- melt(obs, id.vars='intervals', variable.name='items') 448 | obs[, 'type'] <- 'Observed' 449 | p <- model_3pl_prob(t, a, b, c, D) 450 | exp <- aggregate(p, by=list(intervals=groups), mean, na.rm=TRUE)[, c(1, index+1)] 451 | exp <- melt(exp, id.vars='intervals', variable.name='items') 452 | exp[, 'type'] <- 'Expected' 453 | data <- rbind(obs, exp) 454 | data$intervals <- as.numeric(levels(data$intervals)[data$intervals]) 455 | levels(data$items) <- gsub('V', 'Item ', levels(data$items)) 456 | 457 | g <- ggplot(data, aes_string('intervals', 'value', color='type', group='type')) + 458 | geom_line() + facet_wrap(~items) + xlab(expression(theta)) + ylab('Probability') + 459 | scale_color_discrete(guide=guide_legend("")) + theme_bw() 460 | if(show_points) g <- g + geom_point(fill='white', pch=1) 461 | g 462 | } 463 | --------------------------------------------------------------------------------