├── .Rbuildignore ├── .gitattributes ├── .gitignore ├── .travis.yml ├── CRAN-SUBMISSION ├── DESCRIPTION ├── LICENSE ├── NAMESPACE ├── NEWS.md ├── R ├── TIRTfit-methods.R ├── data-helpers.R ├── datasets.R ├── lavaan.R ├── misc.R ├── mplus.R ├── simulations.R ├── stan.R ├── stanmodels.R └── thurstonianIRT-package.R ├── README.Rmd ├── README.md ├── configure ├── configure.win ├── data └── triplets.rda ├── doc ├── TIRT_sim_tests.R ├── TIRT_sim_tests.Rmd └── TIRT_sim_tests.html ├── inst ├── include │ └── stan_meta_header.hpp └── stan │ ├── include │ ├── data-shared.stan │ ├── functions-cumulative_Phi_lpmf.stan │ ├── license.stan │ └── model-likelihood.stan │ ├── thurstonian_irt_model.stan │ └── thurstonian_irt_model_newdata.stan ├── man ├── cor_matrix.Rd ├── fit_TIRT_lavaan.Rd ├── fit_TIRT_mplus.Rd ├── fit_TIRT_stan.Rd ├── gof.TIRTfit.Rd ├── make_TIRT_data.Rd ├── make_lavaan_code.Rd ├── make_mplus_code.Rd ├── make_sem_data.Rd ├── make_stan_data.Rd ├── predict.TIRTfit.Rd ├── set_block.Rd ├── set_blocks_from_df.Rd ├── sim_TIRT_data.Rd ├── thurstonianIRT-package.Rd └── triplets.Rd ├── paper ├── paper.bib └── paper.md ├── src ├── Makevars ├── Makevars.win ├── RcppExports.cpp ├── RcppExports.o ├── stanExports_thurstonian_irt_model.cc ├── stanExports_thurstonian_irt_model_newdata.cc └── thurstonianIRT.so ├── tests ├── testthat.R └── testthat │ ├── tests.lavaan.R │ ├── tests.make_TIRT_data.R │ ├── tests.mplus.R │ └── tests.stan.R ├── thurstonianIRT.Rproj └── vignettes └── TIRT_sim_tests.Rmd /.Rbuildignore: -------------------------------------------------------------------------------- 1 | ^\.travis\.yml$ 2 | ^.*\.Rproj$ 3 | ^thurstonianIRT\.Rproj$ 4 | ^\.Rproj\.user$ 5 | ^\.travis\.yml$ 6 | ^README\.Rmd$ 7 | ^LICENSE$ 8 | ^cran-comments\.md$ 9 | ^CRAN-RELEASE$ 10 | ^paper$ 11 | ^doc$ 12 | ^Meta$ 13 | ^CRAN-SUBMISSION$ 14 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | 7 | # Standard to msysgit 8 | *.doc diff=astextplain 9 | *.DOC diff=astextplain 10 | *.docx diff=astextplain 11 | *.DOCX diff=astextplain 12 | *.dot diff=astextplain 13 | *.DOT diff=astextplain 14 | *.pdf diff=astextplain 15 | *.PDF diff=astextplain 16 | *.rtf diff=astextplain 17 | *.RTF diff=astextplain 18 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .Rproj.user 2 | .Rhistory 3 | .RData 4 | src-x64/ 5 | src-i386/ 6 | src/init.o 7 | src/thurstonianIRT.dll 8 | src/stanExports_thurstonian_irt_model.o 9 | src/stanExports_thurstonian_irt_model.h 10 | src/stanExports_thurstonian_irt_model.hpp 11 | src/stanExports_thurstonian_irt_model_newdata.o 12 | src/stanExports_thurstonian_irt_model_newdata.h 13 | src/stanExports_thurstonian_irt_model_newdata.hpp 14 | CRAN-release 15 | cran-comments.md 16 | paper/paper.html 17 | paper/paper.pdf 18 | Meta 19 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: r 2 | sudo: false 3 | r: devel 4 | cache: packages 5 | 6 | latex: true 7 | 8 | 9 | env: 10 | matrix: 11 | - CXX_OLEVEL=2 CXX=clang++ 12 | 13 | before_install: 14 | - mkdir -p ~/.R/ 15 | - echo "CXX = `R CMD config CXX`" >> ~/.R/Makevars 16 | - echo "CXXFLAGS = `R CMD config CXXFLAGS` -pedantic -g0" >> ~/.R/Makevars 17 | - export CLANG_EXTRA_ARG="" 18 | - if [[ $CXX = "clang++" ]] ; then export CLANG_EXTRA_ARG=" -Qunused-arguments -fcolor-diagnostics " ; fi 19 | - sed -i.bak "s/ g++/ ${CXX}${CLANG_EXTRA_ARG}/" ~/.R/Makevars 20 | - sed -i.bak "s/O[0-3]/O$CXX_OLEVEL/" ~/.R/Makevars 21 | 22 | script: 23 | - | 24 | travis_wait 42 R CMD build . 25 | travis_wait 59 R CMD check thurstonianIRT*tar.gz 26 | 27 | after_script: 28 | - tar -ztvf thurstonianIRT_*.tar.gz 29 | - echo ${NOT_CRAN} 30 | 31 | after_success: 32 | - travis_wait 40 tar -C .. -xf $PKG_TARBALL 33 | 34 | after_failure: 35 | - cat thurstonianIRT.Rcheck/00* 36 | -------------------------------------------------------------------------------- /CRAN-SUBMISSION: -------------------------------------------------------------------------------- 1 | Version: 0.12.5 2 | Date: 2024-04-17 10:19:21 UTC 3 | SHA: 79fb14a363ca341cc282bcc08164a9ce5ef44d90 4 | -------------------------------------------------------------------------------- /DESCRIPTION: -------------------------------------------------------------------------------- 1 | Package: thurstonianIRT 2 | Encoding: UTF-8 3 | Type: Package 4 | Title: Thurstonian IRT Models 5 | Version: 0.12.6 6 | Date: 2024-04-29 7 | Authors@R: c(person("Paul-Christian", "Bürkner", 8 | email = "paul.buerkner@gmail.com", 9 | role = c("aut", "cre")), 10 | person("Angus", "Hughes", role = c("ctb")), 11 | person("Trustees of Columbia University", 12 | role = "cph")) 13 | Description: Fit Thurstonian Item Response Theory (IRT) models in R. This 14 | package supports fitting Thurstonian IRT models and its extensions using 15 | 'Stan', 'lavaan', or 'Mplus' for the model estimation. Functionality for 16 | extracting results, making predictions, and simulating data is provided as 17 | well. References: 18 | Brown & Maydeu-Olivares (2011) ; 19 | Bürkner et al. (2019) . 20 | License: GPL (>=3) 21 | LazyData: true 22 | ByteCompile: true 23 | Depends: 24 | R (>= 3.5.0), 25 | Rcpp (>= 0.12.16), 26 | methods 27 | Imports: 28 | dplyr (>= 0.6.0), 29 | magrittr, 30 | mvtnorm, 31 | RcppParallel (>= 5.0.1), 32 | rlang, 33 | rstan (>= 2.26.0), 34 | rstantools (>= 2.1.1), 35 | stats, 36 | tibble (>= 1.3.1), 37 | tidyr, 38 | lavaan (>= 0.6-1), 39 | utils 40 | Suggests: 41 | MplusAutomation, 42 | knitr, 43 | testthat (>= 0.9.1), 44 | rmarkdown 45 | LinkingTo: 46 | BH (>= 1.66.0-1), 47 | Rcpp (>= 0.12.16), 48 | RcppEigen (>= 0.3.3.4.0), 49 | RcppParallel (>= 5.0.1), 50 | rstan (>= 2.26.0), 51 | StanHeaders (>= 2.26.0) 52 | VignetteBuilder: 53 | knitr 54 | SystemRequirements: GNU make 55 | URL: https://github.com/paul-buerkner/thurstonianIRT 56 | BugReports: https://github.com/paul-buerkner/thurstonianIRT/issues 57 | NeedsCompilation: yes 58 | RoxygenNote: 7.3.1 59 | Biarch: true 60 | -------------------------------------------------------------------------------- /NAMESPACE: -------------------------------------------------------------------------------- 1 | # Generated by roxygen2: do not edit by hand 2 | 3 | S3method("+",TIRTblocks) 4 | S3method(gof,TIRTfit) 5 | S3method(predict,TIRTfit) 6 | S3method(print,TIRTfit) 7 | S3method(print,mplusObjectTIRT) 8 | S3method(summary,TIRTfit) 9 | S3method(summary,mplusObjectTIRT) 10 | export(cor_matrix) 11 | export(empty_block) 12 | export(fit_TIRT_lavaan) 13 | export(fit_TIRT_mplus) 14 | export(fit_TIRT_stan) 15 | export(gof) 16 | export(make_TIRT_data) 17 | export(make_lavaan_code) 18 | export(make_mplus_code) 19 | export(make_sem_data) 20 | export(make_stan_data) 21 | export(set_block) 22 | export(set_blocks_from_df) 23 | export(sim_TIRT_data) 24 | import(Rcpp) 25 | import(dplyr) 26 | import(methods) 27 | import(rstantools) 28 | importFrom(RcppParallel,RcppParallelLibs) 29 | importFrom(magrittr,'%>%') 30 | importFrom(rlang,.data) 31 | importFrom(rstan,sampling) 32 | importFrom(stats,rbeta) 33 | importFrom(stats,rnorm) 34 | importFrom(stats,sd) 35 | importFrom(stats,setNames) 36 | importMethodsFrom(lavaan,summary) 37 | useDynLib(thurstonianIRT, .registration = TRUE) 38 | -------------------------------------------------------------------------------- /NEWS.md: -------------------------------------------------------------------------------- 1 | # thurstonianIRT 0.12.5 2 | 3 | * Fix some starting values for lavaan and Mplus models thanks to Anna Brown. 4 | 5 | # thurstonianIRT 0.12.5 6 | 7 | * Fix some documentation and references thanks to Anna Brown. 8 | 9 | # thurstonianIRT 0.12.4 10 | 11 | * Fix issues with starting value syntax in lavaan models thanks to Yves Rosseel. (#42) 12 | 13 | # thurstonianIRT 0.12.3 14 | 15 | * Avoid a CRAN check warning. 16 | 17 | # thurstonianIRT 0.12.2 18 | 19 | * Fix line-length issues in Mplus code generation. (#34) 20 | 21 | # thurstonianIRT 0.12.1 22 | 23 | * Fix data simulations via `sim_TIRT_data` for non-triplet formats. 24 | * Ensure compatibility with both rstan versions 2.21 and 2.26. 25 | 26 | # thurstonianIRT 0.12.0 27 | 28 | * Switch to the latest `rstantools` toolchain. 29 | * Add a `gof` method to compute goodness-of-fit measures 30 | for lavaan-fitted models thanks to Angus Hughes. (#19) 31 | 32 | 33 | # thurstonianIRT 0.11.1 34 | 35 | * Fix tests failing after an update of `lavaan`. (#25) 36 | 37 | 38 | # thurstonianIRT 0.11.0 39 | 40 | ## Bug Fixes 41 | 42 | * Fix usage of `gamma` parameters in `sim_TIRT_data` 43 | thanks to @IanEisenberg. (#13) 44 | * Prevent impossible rankings from being sampled in 45 | `sim_TIRT_data` thanks to Susanne Frick. 46 | 47 | ## New Features 48 | 49 | * Support predictions of trait scores for new persons. (#12, #15) 50 | * Specify multiple blocks at once via `set_blocks_from_df` 51 | thanks to @awhug. (#11) 52 | 53 | 54 | # thurstonianIRT 0.10.0 55 | 56 | ## Bug Fixes 57 | 58 | * Correctly handle standard errors of trait scores as returned by Mplus. 59 | * Fix the `triplets` example data to work with lavaan and Mplus without 60 | convergence issues. (#3) 61 | 62 | ## New Features 63 | 64 | * Support family `gaussian` when using lavaan as the model fitting engine. 65 | 66 | ## Other Changes 67 | 68 | * Improve the documentation and presentation of the package across the board 69 | thanks to Russell S. Pierce, Thomas J. Faulkenberry, and Daniel S. Katz. 70 | (#2, #5, #7, #8, #9) 71 | 72 | 73 | # thurstonianIRT 0.9.0 74 | 75 | * Initial release version 76 | -------------------------------------------------------------------------------- /R/TIRTfit-methods.R: -------------------------------------------------------------------------------- 1 | TIRTfit <- function(fit, data) { 2 | version <- utils::packageVersion("thurstonianIRT") 3 | structure(nlist(fit, data, version), class = "TIRTfit") 4 | } 5 | 6 | is.TIRTfit <- function(x) { 7 | inherits(x, "TIRTfit") 8 | } 9 | 10 | #' @export 11 | print.TIRTfit <- function(x, ...) { 12 | print(x$fit, ...) 13 | } 14 | 15 | #' @method summary TIRTfit 16 | #' @importMethodsFrom lavaan summary 17 | #' @export 18 | summary.TIRTfit <- function(object, ...) { 19 | summary(object$fit, ...) 20 | } 21 | 22 | #' Predict trait scores of Thurstonian IRT models 23 | #' 24 | #' @param object An object of class \code{TIRTfit}. 25 | #' @param newdata Optional \code{TIRTdata} object (created via 26 | #' \code{\link{make_TIRT_data}}) containing data of new persons 27 | #' for which trait scores should be predicted based on the fitted 28 | #' model. If \code{NULL} (the default), trait scores are predicted 29 | #' for the persons whose data was used to originally fit the model. 30 | #' @param ... Further arguments passed to the underlying methods. 31 | #' 32 | #' @details When predicting trait scores of new persons (via \code{newdata}), 33 | #' posterior medians of item parameters are used for predictions. This implies 34 | #' that the uncertainty in the new trait scores is underestimated as the 35 | #' uncertainty in the (posterior distribution of) item parameters is ignored. 36 | #' 37 | #' @return A data frame with predicted trait scores. 38 | #' 39 | #' @export 40 | predict.TIRTfit <- function(object, newdata = NULL, ...) { 41 | if (inherits(object$fit, "stanfit")) { 42 | out <- predict_stan(object, newdata = newdata, ...) 43 | } else if (inherits(object$fit, "mplusObjectTIRT")) { 44 | out <- predict_mplus(object, newdata = newdata, ...) 45 | } else if (inherits(object$fit, "lavaan")) { 46 | out <- predict_lavaan(object, newdata = newdata, ...) 47 | } 48 | out 49 | } 50 | 51 | #' Extract corrected goodness of fit statistics 52 | #' 53 | #' By default \pkg{lavaan} will return a value for degrees of 54 | #' freedom that ignores redundancies amongst the estimated model 55 | #' thresholds. This function corrects the degrees of freedom, and 56 | #' then recalculates the associated chi-square test statistic 57 | #' p-value and root mean square error of approximation (RMSEA). 58 | #' 59 | #' Note this function is currently only implemented for \pkg{lavaan}. 60 | #' 61 | #' @param object A \code{TIRTfit} object. 62 | #' @param ... currently unused. 63 | #' 64 | #' @return A vector containing the chi-square value, adjusted degrees of 65 | #' freedom, p-value, and RMSEA. 66 | #' 67 | #' @examples 68 | #' # load the data 69 | #' data("triplets") 70 | #' 71 | #' # define the blocks of items 72 | #' blocks <- 73 | #' set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 74 | #' signs = c(1, 1, 1)) + 75 | #' set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 76 | #' signs = c(-1, 1, 1)) + 77 | #' set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 78 | #' signs = c(1, 1, -1)) + 79 | #' set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 80 | #' signs = c(1, -1, 1)) 81 | #' 82 | #' # generate the data to be understood by 'thurstonianIRT' 83 | #' triplets_long <- make_TIRT_data( 84 | #' data = triplets, blocks = blocks, direction = "larger", 85 | #' format = "pairwise", family = "bernoulli", range = c(0, 1) 86 | #' ) 87 | #' 88 | #' # fit the data using lavaan 89 | #' fit <- fit_TIRT_lavaan(triplets_long) 90 | #' gof(fit) 91 | #' 92 | #' @export 93 | gof.TIRTfit <- function(object, ...) { 94 | if (!inherits(object$fit, "lavaan")) { 95 | stop("gof.TIRTfit currently only works for lavaan fitted TIRT models.") 96 | } 97 | 98 | # Extract N, chi_sq, and unadjusted DF 99 | N <- length(unique(object$data$person)) 100 | chi_sq <- object$fit@test$scaled.shifted$stat 101 | if (is.null(chi_sq)) { 102 | chi_sq <- NA 103 | } 104 | df <- object$fit@test$scaled.shifted$df 105 | if (is.null(df)) { 106 | df <- NA 107 | } 108 | 109 | # Get number of items per block to calculate redundancies 110 | blocks <- unique(object$data$block) 111 | redundancies <- rep(NA, length(blocks)) 112 | for (i in seq_along(blocks)) { 113 | sel_items <- unique(object$data$itemC[object$data$block == blocks[i]]) 114 | n_items <- length(sel_items) 115 | redundancies[i] <- n_items * (n_items - 1) * (n_items - 2) / 6 116 | } 117 | 118 | # Adjust the DF, p-value, and recalculate the RMSEA 119 | df <- df - sum(redundancies) 120 | p_val <- 1 - stats::pchisq(chi_sq, df) 121 | RMSEA <- ifelse(df > chi_sq, 0, sqrt((chi_sq - df)/(df * (N - 1)))) 122 | gof <- c(chi_sq = chi_sq, df = df, p_val = p_val, RMSEA = RMSEA) 123 | gof 124 | } 125 | 126 | #' @rdname gof.TIRTfit 127 | #' @export 128 | gof <- function(object, ...) { 129 | UseMethod("gof") 130 | } 131 | -------------------------------------------------------------------------------- /R/data-helpers.R: -------------------------------------------------------------------------------- 1 | #' Prepare data for Thurstonian IRT models 2 | #' 3 | #' @param data An object of class \code{data.frame} containing data of all 4 | #' variables used in the model. 5 | #' @param blocks Object of class \code{TIRTblocks} generated by 6 | #' \code{\link{set_block}} indicating which items belong to which block, trait 7 | #' and more. Ignored if data already contains information on the blocks. 8 | #' @param direction Indicates if \code{"larger"} (the default) or 9 | #' \code{"smaller"} input values are considered as indicating the favored 10 | #' answer. 11 | #' @param format Format of the item responses. Either \code{"ranks"} for 12 | #' responses in ranked format or \code{"pairwise"} for responses in pairwise 13 | #' comparison format. If \code{"ranks"}, each item must have its own 14 | #' column in the data frame which contains its ranks within the block. 15 | #' If \code{"pairwise"}, each existing item combination must have its 16 | #' own column named after the combination of the two compared items. 17 | #' @param family Name of assumed the response distribution. Either 18 | #' \code{"bernoulli"}, \code{"cumulative"}, or \code{"gaussian"}. 19 | #' @param partial A flag to indicate whether partial comparisons are allowed 20 | #' for responses stored in the \code{"ranks"} format. 21 | #' @param range Numeric vector of length two giving the range of the 22 | #' responses when using the \code{"pairwise"} format. Defaults 23 | #' to \code{c(0, 1)} for use with dichotomous responses. 24 | #' 25 | #' @return A \code{data.frame} in a specific format and with attributes ready 26 | #' for use with other functions of the \pkg{ThurstonianIRT} package. 27 | #' 28 | #' @examples 29 | #' # load the data 30 | #' data("triplets") 31 | #' 32 | #' # define the blocks of items 33 | #' blocks <- 34 | #' set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 35 | #' signs = c(1, 1, 1)) + 36 | #' set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 37 | #' signs = c(-1, 1, 1)) + 38 | #' set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 39 | #' signs = c(1, 1, -1)) + 40 | #' set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 41 | #' signs = c(1, -1, 1)) 42 | #' 43 | #' # generate the data to be understood by 'thurstonianIRT' 44 | #' triplets_long <- make_TIRT_data( 45 | #' data = triplets, blocks = blocks, direction = "larger", 46 | #' format = "pairwise", family = "bernoulli", range = c(0, 1) 47 | #' ) 48 | #' 49 | #' \donttest{ 50 | #' # fit the data using Stan 51 | #' fit <- fit_TIRT_stan(triplets_long, chains = 1) 52 | #' print(fit) 53 | #' predict(fit) 54 | #' } 55 | #' 56 | #' @export 57 | make_TIRT_data <- function(data, blocks, direction = c("larger", "smaller"), 58 | format = c("ranks", "pairwise"), 59 | family = "bernoulli", partial = FALSE, 60 | range = c(0, 1)) { 61 | if (is.TIRTdata(data)) { 62 | return(data) 63 | } 64 | direction <- match.arg(direction) 65 | format <- match.arg(format) 66 | family <- check_family(family) 67 | stopifnot(is.TIRTblocks(blocks)) 68 | blocks <- blocks$blocks 69 | data <- as.data.frame(data) 70 | npersons <- nrow(data) 71 | nblocks <- length(blocks) 72 | nitems_per_block <- length(blocks[[1]]$items) 73 | ncat <- 2L 74 | if (format == "ranks") { 75 | if (family != "bernoulli") { 76 | stop("Format 'ranks' requires family 'bernoulli'.") 77 | } 78 | partial <- as_one_logical(partial) 79 | # range is only meaningful for pairwise comparisons 80 | range <- c(0, 1) 81 | } else if (format == "pairwise") { 82 | if (length(range) != 2L) { 83 | stop("Argument 'range' must be of length 2.") 84 | } 85 | if (family == "cumulative") { 86 | ncat <- as.integer(range[2] - range[1] + 1) 87 | } 88 | # partial is only meaningful for ranked comparisons 89 | partial <- FALSE 90 | } 91 | ncomparisons <- (nitems_per_block * (nitems_per_block - 1)) / 2 92 | items_all <- ulapply(blocks, "[[", "items") 93 | if (any(duplicated(items_all))) { 94 | stop("Item variables in different blocks needs to have different names. ", 95 | "Use the 'names' argument in 'set_block' to equate item ", 96 | "parameters across blocks.") 97 | } 98 | nitems <- length(items_all) 99 | if (nitems != nitems_per_block * nblocks) { 100 | stop("All blocks should contain the same number of items.") 101 | } 102 | traits_all <- unique(ulapply(blocks, "[[", "traits")) 103 | ntraits <- length(traits_all) 104 | 105 | out <- tibble::tibble( 106 | person = rep(1:npersons, ncomparisons * nblocks), 107 | block = rep(1:nblocks, each = npersons * ncomparisons), 108 | comparison = rep(rep(1:ncomparisons, each = npersons), nblocks) 109 | ) 110 | for (i in seq_len(nblocks)) { 111 | items <- blocks[[i]]$items 112 | item1 <- rep_comp(items, 1, nitems_per_block) 113 | item2 <- rep_comp(items, 2, nitems_per_block) 114 | traits <- blocks[[i]]$traits 115 | trait1 <- rep_comp(traits, 1, nitems_per_block) 116 | trait2 <- rep_comp(traits, 2, nitems_per_block) 117 | signs <- blocks[[i]]$signs 118 | sign1 <- rep_comp(signs, 1, nitems_per_block) 119 | sign2 <- rep_comp(signs, 2, nitems_per_block) 120 | 121 | rows <- out$block == i 122 | comparison <- out[rows, ]$comparison 123 | out[rows, "itemC"] <- comparison + (i - 1) * ncomparisons 124 | out[rows, "trait1"] <- trait1[comparison] 125 | out[rows, "trait2"] <- trait2[comparison] 126 | out[rows, "item1"] <- item1[comparison] 127 | out[rows, "item2"] <- item2[comparison] 128 | out[rows, "sign1"] <- sign1[comparison] 129 | out[rows, "sign2"] <- sign2[comparison] 130 | 131 | if (format == "ranks") { 132 | response1 <- unname(do.call(c, data[, item1, drop = FALSE])) 133 | response2 <- unname(do.call(c, data[, item2, drop = FALSE])) 134 | out[rows, "response1"] <- response1 135 | out[rows, "response2"] <- response2 136 | if (direction == "smaller") { 137 | response <- as.numeric(case_when( 138 | response1 < response2 ~ 1, 139 | response1 > response2 ~ 0, 140 | TRUE ~ NaN 141 | )) 142 | } else if (direction == "larger") { 143 | response <- as.numeric(case_when( 144 | response1 > response2 ~ 1, 145 | response1 < response2 ~ 0, 146 | TRUE ~ NaN 147 | )) 148 | } 149 | } else if (format == "pairwise") { 150 | item_comb_names <- paste0(item1, item2) 151 | response <- unname(do.call(c, data[, item_comb_names, drop = FALSE])) 152 | if (any(response < range[1] | response > range[2])) { 153 | stop("Responses must be within [", range[1], ", ", range[2], "].") 154 | } 155 | if (direction == "smaller") { 156 | # invert item responses 157 | response <- range[2] - response + range[1] 158 | } 159 | # the smallest value should be 0 160 | response <- response - range[1] 161 | if (family == "bernoulli") { 162 | # ensure dichotomous response format 163 | response <- ifelse(response > 0, 1, 0) 164 | } 165 | } 166 | out[rows, "response"] <- response 167 | } 168 | out$item1 <- factor(out$item1, levels = items_all) 169 | out$item2 <- factor(out$item2, levels = items_all) 170 | out$trait1 <- factor(out$trait1, levels = traits_all) 171 | out$trait2 <- factor(out$trait2, levels = traits_all) 172 | 173 | # check for partial comparisons 174 | if (format == "ranks") { 175 | is_nan <- is.nan(out$response) 176 | any_nan <- any(is_nan) 177 | if (any_nan) { 178 | if (!partial) { 179 | stop("Please set 'partial = TRUE' when using partial comparisons.") 180 | } 181 | out <- filter(out, !is_nan) 182 | } else { 183 | partial <- FALSE 184 | } 185 | } 186 | 187 | # check for items being used multiple times in the test 188 | item_names <- ulapply(blocks, "[[", "names") 189 | dupl_item_nums <- which(duplicated(item_names)) 190 | dupl_item_names <- unique(item_names[dupl_item_nums]) 191 | dupl_items <- named_list(dupl_item_names) 192 | for (i in seq_along(dupl_items)) { 193 | dupl_items[[i]] <- which(item_names == dupl_item_names[i]) 194 | } 195 | # add attributes to the returned object 196 | structure(out, 197 | npersons = npersons, 198 | ntraits = ntraits, 199 | nblocks = nblocks, 200 | nitems = nitems, 201 | nitems_per_block = nitems_per_block, 202 | signs = ulapply(blocks, "[[", "signs"), 203 | dupl_items = dupl_items, 204 | traits = unique(ulapply(blocks, "[[", "traits")), 205 | format = format, 206 | family = family, 207 | partial = partial, 208 | range = range, 209 | ncat = ncat, 210 | class = c("TIRTdata", class(out)) 211 | ) 212 | } 213 | 214 | #' Prepare data for Thurstonian IRT models fitted with 215 | #' lavaan or Mplus 216 | #' 217 | #' @inheritParams fit_TIRT_stan 218 | #' 219 | #' @return A \code{data.frame} ready to be passed to \pkg{lavaan} 220 | #' or \pkg{Mplus}. 221 | #' 222 | #' @examples 223 | #' # simulate some data 224 | #' sdata <- sim_TIRT_data( 225 | #' npersons = 100, 226 | #' ntraits = 3, 227 | #' nblocks_per_trait = 4, 228 | #' gamma = 0, 229 | #' lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 230 | #' Phi = diag(3) 231 | #' ) 232 | #' 233 | #' # create data ready for use in SEM software 234 | #' sem_data <- make_sem_data(sdata) 235 | #' head(sem_data) 236 | #' 237 | #' @import dplyr 238 | #' @importFrom magrittr '%>%' 239 | #' @export 240 | make_sem_data <- function(data) { 241 | if (!is.TIRTdata(data)) { 242 | stop("'data' should be of class 'TIRTdata'. See ?make_TIRT_data") 243 | } 244 | data <- convert_factors(data) 245 | att <- attributes(data) 246 | npersons <- att[["npersons"]] 247 | ntraits <- att[["ntraits"]] 248 | nblocks <- att[["nblocks"]] 249 | ncols <- ntraits * (ntraits - 1) / 2 * nblocks 250 | data %>% 251 | mutate(itemC = paste0("i", .data$item1, "i", .data$item2)) %>% 252 | mutate(itemC = factor(.data$itemC, levels = unique(.data$itemC))) %>% 253 | select("person", "itemC", "response") %>% 254 | tidyr::spread(key = "itemC", value = "response") %>% 255 | select(-.data$person) 256 | } 257 | 258 | convert_factors <- function(data) { 259 | # data and code generating functions require 260 | # items and traits to be numeric 261 | stopifnot(is.TIRTdata(data)) 262 | for (v in c("item1", "item2", "trait1", "trait2")) { 263 | data[[v]] <- as.integer(data[[v]]) 264 | } 265 | data 266 | } 267 | 268 | #' Prepare blocks of items 269 | #' 270 | #' Prepare blocks of items and incorporate information 271 | #' about which item belongs to which trait. A block 272 | #' of items is a set of two or more items presented and answered together 273 | #' by fully ranking them or selecting the most and/or least favorit 274 | #' in a forced choice format. A whole test usually contains 275 | #' several blocks and items may reappear in different blocks. 276 | #' 277 | #' @param items Names of item comparisons to be combined 278 | #' into one block. Should correspond to variables in the data. 279 | #' @param traits Names of the traits to which each item belongs 280 | #' @param names Optional names of the items in the output. 281 | #' Can be used to equate parameters of items across blocks, 282 | #' if the same item was used in different blocks. 283 | #' @param signs Expected signs of the item loadings (1 or -1). 284 | #' 285 | #' @examples 286 | #' set_block( 287 | #' items = c("i1", "i2", "i3"), 288 | #' traits = c("A", "B", "C") 289 | #' ) + 290 | #' set_block( 291 | #' items = c("i4", "i5", "i6"), 292 | #' traits = c("A", "B", "C") 293 | #' ) 294 | #' 295 | #' # Support items i1 and i4 were the same so that they have the same parameters 296 | #' set_block( 297 | #' items = c("i1", "i2", "i3"), 298 | #' traits = c("A", "B", "C"), 299 | #' names = c("item1", "item2", "item3") 300 | #' ) + 301 | #' set_block( 302 | #' items = c("i4", "i5", "i6"), 303 | #' traits = c("A", "B", "C"), 304 | #' names = c("item1", "item5", "item6") 305 | #' ) 306 | #' 307 | #' @seealso \code{\link{set_blocks_from_df}} 308 | #' @export 309 | set_block <- function(items, traits, names = items, signs = 1) { 310 | stopifnot(length(items) == length(traits)) 311 | items <- as.character(items) 312 | traits <- as.character(traits) 313 | names <- as.character(names) 314 | if (length(signs) == 1L) { 315 | signs <- rep(signs, length(items)) 316 | } 317 | stopifnot(length(items) == length(signs)) 318 | signs <- sign(signs) 319 | out <- list(blocks = list(nlist(items, traits, names, signs))) 320 | structure(out, class = "TIRTblocks") 321 | } 322 | 323 | #' @rdname set_block 324 | #' @export 325 | empty_block <- function() { 326 | structure(list(blocks = list()), class = "TIRTblocks") 327 | } 328 | 329 | #' @export 330 | "+.TIRTblocks" <- function(e1, e2) { 331 | stopifnot(is.TIRTblocks(e2)) 332 | e1$blocks <- c(e1$blocks, e2$blocks) 333 | e1 334 | } 335 | 336 | #' Prepare blocks of items from a data frame 337 | #' 338 | #' Prepare blocks of items and incorporate information 339 | #' about which item belongs to which trait from a pre-existing dataframe. 340 | #' This is a wrapper function for \code{\link{set_block}}, eliminating the need 341 | #' to manually set each item, trait, name and sign (loading) info per block. 342 | #' 343 | #' A block of items is a set of two or more items presented and answered 344 | #' together by fully ranking them or selecting the most and/or least favorite 345 | #' in a forced choice format. A whole test usually contains 346 | #' several blocks and items may reappear in different blocks. 347 | #' 348 | #' @param data A \code{data.frame} containing all the required columns 349 | #' (see the arguments below) to specify the item blocks. 350 | #' @param blocks Name of column vector denoting the block each item 351 | #' corresponds to. Each block must have an equal number of items. 352 | #' @param items Name of column vector denoting items to be combined into 353 | #' one block. Should correspond to variables in the data. 354 | #' @param traits Names of column vector denoting the traits to which each 355 | #' item belongs. 356 | #' @param names Optional column vector of item names in the output. 357 | #' Can be used to equate parameters of items across blocks, 358 | #' if the same item was used in different blocks. 359 | #' @param signs Name of column vector with expected signs of the 360 | #' item loadings (1 or -1). 361 | #' 362 | #' @examples 363 | #' block_info <- data.frame( 364 | #' block = rep(1:4, each = 3), 365 | #' items = c("i1", "i2", "i3", "i4", "i5", "i6", 366 | #' "i7", "i8", "i9", "i10", "i11", "i12"), 367 | #' traits = rep(c("t1", "t2", "t3"), times = 4), 368 | #' signs = c(1, 1, 1, -1, 1, 1, 1, 1, -1, 1, -1, 1) 369 | #' ) 370 | #' 371 | #' blocks <- set_blocks_from_df( 372 | #' data = block_info, 373 | #' blocks = "block", 374 | #' items = "items", 375 | #' traits = "traits", 376 | #' signs = "signs" 377 | #' ) 378 | #' 379 | #' @seealso \code{\link{set_block}} 380 | #' @export 381 | set_blocks_from_df <- function(data, blocks = "block", items = "item", 382 | traits = "trait", names = items, 383 | signs = "sign") { 384 | # input checks 385 | data <- as.data.frame(data) 386 | blocks <- as_one_character(blocks) 387 | items <- as_one_character(items) 388 | traits <- as_one_character(traits) 389 | names <- as_one_character(names) 390 | signs <- as_one_character(signs) 391 | # check each block has the same number of items 392 | block_ids <- as.character(data[[blocks]]) 393 | nitems_per_block <- table(as.character(data[[blocks]])) 394 | if (length(unique(nitems_per_block)) > 1L) { 395 | stop("All blocks should contain the same number of items.") 396 | } 397 | if (any(nitems_per_block < 2)) { 398 | stop("Blocks should contain more than one item.") 399 | } 400 | # save unique block_ids and number of blocks 401 | block_ids <- unique(block_ids) 402 | nblocks <- length(block_ids) 403 | # fill list with the set_block call for each block 404 | block_list <- list() 405 | for(i in seq_along(block_ids)) { 406 | sel <- data[[blocks]] == block_ids[i] 407 | block_list[[i]] <- set_block( 408 | items = data[sel, items], traits = data[sel, traits], 409 | names = data[sel, names], signs = data[sel, signs] 410 | ) 411 | } 412 | # concatenate blocks 413 | Reduce("+", block_list) 414 | } 415 | 416 | is.TIRTdata <- function(x) { 417 | inherits(x, "TIRTdata") 418 | } 419 | 420 | is.TIRTblocks <- function(x) { 421 | inherits(x, "TIRTblocks") 422 | } 423 | 424 | rep_comp <- function(x, comp, nitems_per_block) { 425 | # generate comparisons of first vs. second items, traits etc. 426 | # Args: 427 | # x: vector of names of items, traits, etc. 428 | # comp: first or second comparison? 429 | stopifnot(comp %in% 1:2) 430 | if (comp == 1) { 431 | out <- rep(x[1:(nitems_per_block - 1)], (nitems_per_block - 1):1) 432 | } else { 433 | out <- ulapply(2:nitems_per_block, function(y) x[y:nitems_per_block]) 434 | } 435 | out 436 | } 437 | 438 | check_family <- function(family, software = NULL) { 439 | options <- family_options(software) 440 | match.arg(family, options) 441 | } 442 | 443 | family_options <- function(software = NULL) { 444 | if (is.null(software)) { 445 | # TODO: the 'beta' family is implemented in Stan but still 446 | # needs to be understood theoretically before exporting it 447 | all_ops <- c("bernoulli", "cumulative", "gaussian") 448 | return(all_ops) 449 | } 450 | software <- match.arg(software, c("stan", "lavaan", "mplus")) 451 | if (software == "stan") { 452 | out <- c("bernoulli", "cumulative", "gaussian") 453 | } else if (software == "lavaan") { 454 | out <- c("bernoulli", "gaussian") 455 | } else if (software == "mplus") { 456 | out <- c("bernoulli", "gaussian") 457 | } 458 | out 459 | } 460 | -------------------------------------------------------------------------------- /R/datasets.R: -------------------------------------------------------------------------------- 1 | #' Triplets of Pairwise Comparisons 2 | #' 3 | #' @description This data set contains synthetic data 4 | #' of the first 200 out of a total of 2000 participants on 4 triplets, 5 | #' originally generated as part of Brown and Maydeu-Olivares (2012). 6 | #' In each triplet, 7 | #' participants had to rank the three alternative items according 8 | #' to their preference. Responses were then converted into 9 | #' a set of dichotomous pairwise responses between all the 10 | #' three alternatives. More details can be found in 11 | #' Brown and Maydeu-Olivares (2012). 12 | #' 13 | #' @format A data frame of 200 observations containing 14 | #' information on 12 variables. 15 | #' Overall, the 12 items measure 3 different traits. 16 | #' Items 1, 4, 7, and 10 load on trait 1, 17 | #' items 2, 5, 8, and 11 load on trait 2, and 18 | #' items 3, 6, 9, and 12 load on trait 3. 19 | #' Moreover, items 4, 9, and 11 are inverted. 20 | #' \describe{ 21 | #' \item{i1i2}{Response preferences between item 1 and 2.} 22 | #' \item{i1i3}{Response preferences between item 1 and 3.} 23 | #' \item{i2i3}{Response preferences between item 2 and 3.} 24 | #' \item{i4i5}{Response preferences between item 4 and 5.} 25 | #' \item{i4i6}{Response preferences between item 4 and 6.} 26 | #' \item{i5i6}{Response preferences between item 5 and 6.} 27 | #' \item{i7i8}{Response preferences between item 7 and 8.} 28 | #' \item{i7i9}{Response preferences between item 7 and 9.} 29 | #' \item{i8i9}{Response preferences between item 8 and 9.} 30 | #' \item{i10i11}{Response preferences between item 10 and 11.} 31 | #' \item{i10i12}{Response preferences between item 10 and 12.} 32 | #' \item{i11i12}{Response preferences between item 11 and 12.} 33 | #' } 34 | #' 35 | #' @examples 36 | #' # load the data 37 | #' data("triplets") 38 | #' 39 | #' # define the blocks of items 40 | #' blocks <- 41 | #' set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 42 | #' signs = c(1, 1, 1)) + 43 | #' set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 44 | #' signs = c(-1, 1, 1)) + 45 | #' set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 46 | #' signs = c(1, 1, -1)) + 47 | #' set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 48 | #' signs = c(1, -1, 1)) 49 | #' 50 | #' # generate the data to be understood by 'thurstonianIRT' 51 | #' tdat <- make_TIRT_data( 52 | #' triplets, blocks, direction = "larger", 53 | #' format = "pairwise", family = "bernoulli", range = c(0, 1) 54 | #' ) 55 | #' 56 | #' \donttest{ 57 | #' # fit the data using Stan 58 | #' fit <- fit_TIRT_stan(tdat, chains = 1) 59 | #' print(fit) 60 | #' predict(fit) 61 | #' } 62 | #' 63 | #' @source 64 | #' Brown, A. & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model to 65 | #' forced-choice data using Mplus. Behavior Research Methods, 44, 1135–1147. 66 | #' DOI: 10.3758/s13428-012-0217-x 67 | "triplets" 68 | -------------------------------------------------------------------------------- /R/lavaan.R: -------------------------------------------------------------------------------- 1 | #' Generate lavaan code for Thurstonian IRT models 2 | #' 3 | #' @inheritParams fit_TIRT_stan 4 | #' 5 | #' @return A character string of lavaan code 6 | #' for a Thurstonian IRT model. 7 | #' 8 | #' @examples 9 | #' lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 10 | #' sim_data <- sim_TIRT_data( 11 | #' npersons = 100, 12 | #' ntraits = 3, 13 | #' nblocks_per_trait = 4, 14 | #' gamma = 0, 15 | #' lambda = lambdas, 16 | #' Phi = diag(3) 17 | #' ) 18 | #' cat(make_lavaan_code(sim_data)) 19 | #' 20 | #' @export 21 | make_lavaan_code <- function(data) { 22 | if (!is.TIRTdata(data)) { 23 | stop("'data' should be of class 'TIRTdata'. See ?make_TIRT_data") 24 | } 25 | data <- convert_factors(data) 26 | data <- filter(data, .data$person == unique(.data$person)[1]) 27 | att <- attributes(data) 28 | family <- check_family(att$family, "lavaan") 29 | nitems <- att[["nitems"]] 30 | nitems_per_block <- att[["nitems_per_block"]] 31 | ntraits <- att[["ntraits"]] 32 | traits <- seq_len(ntraits) 33 | if (isTRUE(att[["partial"]])) { 34 | stop("Cannot yet handle partial comparisons when using lavaan.") 35 | } 36 | 37 | # define factor loadings (lambda) 38 | lav_loadings <- vector("list", ntraits) 39 | for (i in traits) { 40 | for (n in seq_len(nrow(data))) { 41 | if (data$trait1[n] == i) { 42 | .modifiers <- c(paste0("start(", data$sign1[n], ")"), 43 | paste0("L", data$item1[n])) 44 | lav_loadings[[i]] <- c(lav_loadings[[i]], with(data, 45 | paste0(.modifiers, " * i", item1[n], "i", item2[n]) 46 | )) 47 | } else if (data$trait2[n] == i) { 48 | .modifiers <- c(paste0("start(", -data$sign2[n], ")"), 49 | paste0("L", data$item2[n], "n")) 50 | lav_loadings[[i]] <- c(lav_loadings[[i]], with(data, 51 | paste0(.modifiers, " * i", item1[n], "i", item2[n]) 52 | )) 53 | } 54 | } 55 | lav_loadings[[i]] <- paste0( 56 | "trait", i, " =~ ", 57 | paste0(lav_loadings[[i]], collapse = " + ") 58 | ) 59 | } 60 | lav_loadings <- collapse(unlist(lav_loadings), "\n") 61 | 62 | # fix factor variances to 1 63 | lav_fix_factor_variances <- 64 | collapse("trait", traits, " ~~ 1 * trait", traits, "\n") 65 | 66 | # factor correlations 67 | lav_factor_correlations <- collapse( 68 | sapply(1:(ntraits - 1), 69 | function(i) paste0( 70 | "trait", i, " ~~ ", 71 | paste0("trait", (i + 1):ntraits, collapse = " + "), 72 | "\n" 73 | ) 74 | ) 75 | ) 76 | 77 | # fix factor loadings of the same item to the same value 78 | lav_fix_factor_loadings <- "" 79 | items_both_dir <- which(1:nitems %in% data$item1 & 1:nitems %in% data$item2) 80 | if (length(items_both_dir)) { 81 | lav_fix_factor_loadings <- collapse( 82 | "L", items_both_dir, " == -L", items_both_dir, "n\n" 83 | ) 84 | } 85 | 86 | # declare uniquenesses (psi) 87 | lav_uniqueness <- with(data, collapse( 88 | "i", item1, "i", item2, 89 | " ~~ P", item1, "P", item2, 90 | " * i", item1, "i", item2, "\n" 91 | )) 92 | 93 | # correlated uniqunesses 94 | lav_cor_uniqueness <- "" 95 | for (n in 1:(nrow(data) - 1)) { 96 | for (m in (n + 1):nrow(data)) { 97 | pos_psi1 <- with(data, item1[n] == item1[m]) 98 | pos_psi2 <- with(data, item2[n] == item2[m]) 99 | neg_psi <- with(data, item2[n] == item1[m]) 100 | if (pos_psi1) { 101 | .modifiers <- c("start(1)", paste0("P", data$item1[n])) 102 | lav_cor_uniqueness <- with(data, 103 | paste0(lav_cor_uniqueness, 104 | "i", item1[n], "i", item2[n], " ~~ ", 105 | paste0(.modifiers, " * i", item1[m], "i", item2[m], collapse = " + "), 106 | "\n" 107 | ) 108 | ) 109 | } else if (pos_psi2) { 110 | .modifiers <- c("start(1)", paste0("P", data$item2[n])) 111 | lav_cor_uniqueness <- with(data, 112 | paste0(lav_cor_uniqueness, 113 | "i", item1[n], "i", item2[n], " ~~ ", 114 | paste0(.modifiers, " * i", item1[m], "i", item2[m], collapse = " + "), 115 | "\n" 116 | ) 117 | ) 118 | } else if (neg_psi) { 119 | .modifiers <- c("start(-1)", paste0("P", data$item2[n], "n")) 120 | lav_cor_uniqueness <- with(data, 121 | paste0(lav_cor_uniqueness, 122 | "i", item1[n], "i", item2[n], " ~~ ", 123 | paste0(.modifiers, " * i", item1[m], "i", item2[m], collapse = " + "), 124 | "\n" 125 | ) 126 | ) 127 | } 128 | } 129 | } 130 | 131 | # pair's uniqueness is equal to sum of 2 utility uniqunesses 132 | lav_equal_uniqueness <- "" 133 | if (nitems_per_block > 2) { 134 | psi_item1 <- paste0("P", data$item1) 135 | psi_item2 <- paste0("P", data$item2) 136 | neg_psi1 <- sapply(paste0(" ", psi_item1, "n "), grepl, lav_cor_uniqueness) 137 | neg_psi2 <- sapply(paste0(" ", psi_item2, "n "), grepl, lav_cor_uniqueness) 138 | lav_equal_uniqueness <- with(data, collapse( 139 | psi_item1, psi_item2, " == ", 140 | ifelse(neg_psi1, paste0(" - ", psi_item1, "n"), psi_item1), 141 | ifelse(neg_psi2, paste0(" - ", psi_item2, "n"), paste0(" + ", psi_item2)), 142 | "\n" 143 | )) 144 | } 145 | 146 | # fix certain uniquenesses for identification 147 | lav_fix_uniqueness <- "" 148 | if (family %in% "bernoulli") { 149 | if (nitems_per_block > 2) { 150 | # fix one uniqueness per block for identification 151 | lav_fix_uniqueness <- collapse( 152 | "P", seq(1, nitems, nitems_per_block), " == 1\n" 153 | ) 154 | } else { 155 | # fix all uniquenesses for identification 156 | psi_item1 <- paste0("P", data$item1) 157 | psi_item2 <- paste0("P", data$item2) 158 | lav_fix_uniqueness <- collapse(psi_item1, psi_item2, " == 1\n") 159 | } 160 | } 161 | 162 | # force item parameters of the same item to be equal 163 | # this happens if the same items is applied in multiple blocks 164 | lav_equal_items <- "" 165 | for (i in seq_along(att$dupl_items)) { 166 | first <- att$dupl_items[[i]][1] 167 | dup <- att$dupl_items[[i]][-1] 168 | lav_equal_items <- paste0(lav_equal_items, 169 | collapse("L", first, " == L", dup, "\n"), 170 | collapse("P", first, " == P", dup, "\n") 171 | ) 172 | } 173 | 174 | # combine all lavaan code snippets 175 | collapse_lines( 176 | "# factor loadings (lambda)", 177 | lav_loadings, 178 | "# fix factor variances to 1", 179 | lav_fix_factor_variances, 180 | "# factor correlations", 181 | lav_factor_correlations, 182 | "# fix factor loadings of the same item to the same value", 183 | lav_fix_factor_loadings, 184 | "# declare uniquenesses (psi)", 185 | lav_uniqueness, 186 | "# correlated uniqunesses", 187 | lav_cor_uniqueness, 188 | "# pair's uniqueness is equal to sum of 2 utility uniqunesses", 189 | lav_equal_uniqueness, 190 | "# fix certain uniquenesses for identification", 191 | lav_fix_uniqueness, 192 | "# force item parameters of the same item to be equal", 193 | lav_equal_items 194 | ) 195 | } 196 | 197 | #' Fit Thurstonian IRT models in lavaan 198 | #' 199 | #' @inheritParams fit_TIRT_stan 200 | #' @param estimator Name of the estimator that should be used. 201 | #' See \code{\link[lavaan:lavOptions]{lavOptions}}. 202 | #' @param ... Further arguments passed to 203 | #' \code{\link[lavaan:lavaan]{lavaan}}. 204 | #' 205 | #' @return A \code{'TIRTfit'} object. 206 | #' 207 | #' @examples 208 | #' # load the data 209 | #' data("triplets") 210 | #' 211 | #' # define the blocks of items 212 | #' blocks <- 213 | #' set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 214 | #' signs = c(1, 1, 1)) + 215 | #' set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 216 | #' signs = c(-1, 1, 1)) + 217 | #' set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 218 | #' signs = c(1, 1, -1)) + 219 | #' set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 220 | #' signs = c(1, -1, 1)) 221 | #' 222 | #' # generate the data to be understood by 'thurstonianIRT' 223 | #' triplets_long <- make_TIRT_data( 224 | #' data = triplets, blocks = blocks, direction = "larger", 225 | #' format = "pairwise", family = "bernoulli", range = c(0, 1) 226 | #' ) 227 | #' 228 | #' \donttest{ 229 | #' # fit the data using lavaan 230 | #' fit <- fit_TIRT_lavaan(triplets_long) 231 | #' print(fit) 232 | #' predict(fit) 233 | #' } 234 | #' 235 | #' @export 236 | fit_TIRT_lavaan <- function(data, estimator = "ULSMV", ...) { 237 | require_package("lavaan") 238 | lavaan_data <- make_sem_data(data) 239 | lavaan_model <- make_lavaan_code(data) 240 | 241 | att <- attributes(data) 242 | family <- check_family(att$family, "lavaan") 243 | if (family %in% "bernoulli") { 244 | ordered <- names(lavaan_data) 245 | } else if (family %in% "gaussian") { 246 | ordered <- NULL 247 | } 248 | fit <- lavaan::lavaan( 249 | lavaan_model, data = lavaan_data, ordered = ordered, 250 | auto.fix.first = FALSE, auto.th = TRUE, 251 | parameterization = "theta", estimator = estimator, 252 | ... 253 | ) 254 | TIRTfit(fit, data) 255 | } 256 | 257 | # predict trait scores using lavaan 258 | predict_lavaan <- function(object, newdata = NULL, ...) { 259 | require_package("lavaan") 260 | if (!is.null(newdata)) { 261 | # TODO: check 'newdata' for validity 262 | newdata <- make_sem_data(newdata) 263 | } 264 | fit <- object$fit 265 | traits <- attributes(object$data)$traits 266 | out <- as.data.frame(lavaan::lavPredict(fit, newdata = newdata, ...)) 267 | if (NROW(out)) { 268 | ntraits <- ncol(out) 269 | out <- out %>% 270 | tidyr::gather("trait", "estimate", everything()) %>% 271 | mutate(id = rep(seq_len(n() / ntraits), ntraits)) %>% 272 | arrange(.data$id) %>% 273 | select("id", "trait", "estimate") 274 | } 275 | as_tibble(out) 276 | } 277 | -------------------------------------------------------------------------------- /R/misc.R: -------------------------------------------------------------------------------- 1 | bias <- function(x, y) { 2 | colMeans(x - y) 3 | } 4 | 5 | RMSE <- function(x, y) { 6 | sqrt(colMeans((x - y)^2)) 7 | } 8 | 9 | scale2 <- function(x, center = FALSE) { 10 | if (center) { 11 | means <- colMeans(x) 12 | x <- sweep(x, 2, means, "-") 13 | } 14 | sds <- apply(x, 2, sd) 15 | sweep(x, 2, sds, "/") 16 | } 17 | 18 | collapse <- function(..., sep = "") { 19 | # wrapper for paste with collapse = "" 20 | paste(..., sep = sep, collapse = "") 21 | } 22 | 23 | is_wholenumber <- function(x, tol = .Machine$double.eps) { 24 | # check if x is a whole number (integer) 25 | if (!is.numeric(x)) { 26 | out <- FALSE 27 | } else { 28 | out <- abs(x - round(x)) < tol 29 | } 30 | out 31 | } 32 | 33 | is_equal <- function(x, y, ...) { 34 | isTRUE(all.equal(x, y, ...)) 35 | } 36 | 37 | #' Set up Correlation Matrices 38 | #' 39 | #' @param cors vector of unique correlations 40 | #' @param dim Dimension of the correlation matrix 41 | #' @param dimnames Optional dimnames of the correlation matrix 42 | #' 43 | #' @return A correlation \code{matrix} of dimension \code{dim}. 44 | #' 45 | #' @examples 46 | #' cor_matrix(c(0.2, 0.3, 0.5), dim = 3) 47 | #' 48 | #' @export 49 | cor_matrix <- function(cors, dim, dimnames = NULL) { 50 | out <- diag(dim) 51 | out[lower.tri(out)] <- cors 52 | out[upper.tri(out)] <- t(out)[upper.tri(out)] 53 | if (!is.null(dimnames)) { 54 | dimnames(out) <- list(dimnames, dimnames) 55 | } 56 | out 57 | } 58 | 59 | collapse_lines <- function(...) { 60 | dots <- c(...) 61 | paste0(dots, collapse = "\n") 62 | } 63 | 64 | nlist <- function(...) { 65 | # create a named list using object names 66 | m <- match.call() 67 | dots <- list(...) 68 | no_names <- is.null(names(dots)) 69 | has_name <- if (no_names) FALSE 70 | else nzchar(names(dots)) 71 | if (all(has_name)) return(dots) 72 | nms <- as.character(m)[-1] 73 | if (no_names) { 74 | names(dots) <- nms 75 | } else { 76 | names(dots)[!has_name] <- nms[!has_name] 77 | } 78 | dots 79 | } 80 | 81 | ulapply <- function(X, FUN, ...) { 82 | # short for unlist(lapply(.)) 83 | unlist(lapply(X = X, FUN = FUN, ...)) 84 | } 85 | 86 | named_list <- function(names, values = NULL) { 87 | # initialize a named list 88 | # Args: 89 | # names: names of the elements 90 | # values: values of the elements 91 | if (!is.null(values)) { 92 | if (length(values) <= 1L) { 93 | values <- replicate(length(names), values) 94 | } 95 | values <- as.list(values) 96 | stopifnot(length(values) == length(names)) 97 | } else { 98 | values <- vector("list", length(names)) 99 | } 100 | setNames(values, names) 101 | } 102 | 103 | # coerce 'x' to a single character string 104 | as_one_character <- function(x, allow_na = FALSE) { 105 | s <- substitute(x) 106 | x <- as.character(x) 107 | if (length(x) != 1L || anyNA(x) && !allow_na) { 108 | s <- deparse_combine(s, max_char = 100L) 109 | stop("Cannot coerce ", s, " to a single character value.") 110 | } 111 | x 112 | } 113 | 114 | # coerce 'x' to a signle number value 115 | as_one_numeric <- function(x, allow_na = FALSE) { 116 | s <- substitute(x) 117 | x <- suppressWarnings(as.numeric(x)) 118 | if (length(x) != 1L || anyNA(x) && !allow_na) { 119 | s <- substr(deparse_combine(s), 1L, 100L) 120 | stop("Cannot coerce ", s, " to a single numeric value.") 121 | } 122 | x 123 | } 124 | 125 | # coerce 'x' to TRUE or FALSE if possible 126 | as_one_logical <- function(x, allow_na = FALSE) { 127 | s <- substitute(x) 128 | x <- as.logical(x) 129 | if (length(x) != 1L || anyNA(x) && !allow_na) { 130 | s <- substr(deparse_combine(s), 1L, 100L) 131 | stop("Cannot coerce ", s, " to a single logical value.") 132 | } 133 | x 134 | } 135 | 136 | # combine deparse lines into one string 137 | deparse_combine <- function(x, max_char = 100) { 138 | out <- collapse(deparse(x)) 139 | if (isTRUE(max_char > 0)) { 140 | out <- substr(out, 1, max_char) 141 | } 142 | out 143 | } 144 | 145 | # check if a certain package is installed 146 | # @param package package name 147 | # @param version optional minimal version number to require 148 | require_package <- function(package, version = NULL) { 149 | if (!requireNamespace(package, quietly = TRUE)) { 150 | stop("Please install the '", package, "' package.") 151 | } 152 | if (!is.null(version)) { 153 | version <- as.package_version(version) 154 | if (utils::packageVersion(package) < version) { 155 | stop("Please install package '", package, 156 | "' version ", version, " or higher.") 157 | } 158 | } 159 | invisible(TRUE) 160 | } 161 | -------------------------------------------------------------------------------- /R/mplus.R: -------------------------------------------------------------------------------- 1 | #' Generate Mplus code for Thurstonian IRT models 2 | #' 3 | #' @inheritParams fit_TIRT_stan 4 | #' @param eta_file optional file name in which predicted 5 | #' trait scores should be stored. 6 | #' @param iter Maximum number of iterations of the 7 | #' model fitting algorithm. 8 | #' 9 | #' @return A list of Mplus code snippets to be 10 | #' interpreted by the \pkg{MplusAutomation} package. 11 | #' 12 | #' @examples 13 | #' sim_data <- sim_TIRT_data( 14 | #' npersons = 100, 15 | #' ntraits = 3, 16 | #' nblocks_per_trait = 4, 17 | #' gamma = 0, 18 | #' lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 19 | #' Phi = diag(3) 20 | #' ) 21 | #' 22 | #' # show the created Mplus code 23 | #' lapply(make_mplus_code(sim_data), cat) 24 | #' 25 | #' @export 26 | make_mplus_code <- function(data, iter = 1000, 27 | eta_file = "eta.csv") { 28 | # TODO: make better interface to Mplus' control parameters 29 | if (!is.TIRTdata(data)) { 30 | stop("'data' should be of class 'TIRTdata'. See ?make_TIRT_data") 31 | } 32 | iter <- round(as_one_numeric(iter)) 33 | data <- convert_factors(data) 34 | data <- filter(data, .data$person == unique(.data$person)[1]) 35 | att <- attributes(data) 36 | family <- check_family(att$family, "mplus") 37 | nitems <- att[["nitems"]] 38 | nitems_per_block <- att[["nitems_per_block"]] 39 | ntraits <- att[["ntraits"]] 40 | traits <- seq_len(ntraits) 41 | if (isTRUE(att[["partial"]])) { 42 | stop("Cannot yet handle partial comparisons when using Mplus.") 43 | } 44 | 45 | mplus_variable <- "" 46 | if (family %in% c("bernoulli", "cumulative")) { 47 | mplus_variable <- "CATEGORICAL ARE ALL;\n" 48 | } 49 | 50 | # define factor loadings (lambda) 51 | mplus_loadings <- vector("list", ntraits) 52 | for (i in traits) { 53 | for (n in seq_len(nrow(data))) { 54 | if (data$trait1[n] == i) { 55 | mplus_loadings[[i]] <- c(mplus_loadings[[i]], with(data, 56 | paste0("i", item1[n], "i", item2[n], "*", data$sign1[n], " (L", item1[n], ")") 57 | )) 58 | } else if (data$trait2[n] == i) { 59 | mplus_loadings[[i]] <- c(mplus_loadings[[i]], with(data, 60 | paste0("i", item1[n], "i", item2[n], "*", -data$sign2[n], " (L", item2[n], "n)") 61 | )) 62 | } 63 | } 64 | mplus_loadings[[i]] <- paste0( 65 | "trait", i, " BY\n", 66 | paste0(mplus_loadings[[i]], collapse = "\n"), 67 | ";\n" 68 | ) 69 | } 70 | mplus_loadings <- collapse(unlist(mplus_loadings), "\n") 71 | 72 | # fix factor varianaces to 1 73 | mplus_fix_factor_variances <- collapse("trait", traits, "@1\n") 74 | 75 | # factor correlations 76 | mplus_factor_correlations <- collapse( 77 | sapply(1:(ntraits - 1), 78 | function(i) paste0( 79 | "trait", i, " WITH\n ", 80 | paste0("trait", (i+1):ntraits, "*0", collapse = "\n "), 81 | ";\n" 82 | ) 83 | ) 84 | ) 85 | 86 | # fix factor loadings of the same item to the same value 87 | mplus_fix_factor_loadings <- "" 88 | items_both_dir <- which(1:nitems %in% data$item1 & 1:nitems %in% data$item2) 89 | if (length(items_both_dir)) { 90 | mplus_fix_factor_loadings <- collapse( 91 | "L", items_both_dir, " = -L", items_both_dir, "n;\n" 92 | ) 93 | } 94 | 95 | # declare uniquenesses (psi) 96 | mplus_uniqueness <- with(data, collapse( 97 | "i", item1, "i", item2, "*1 (P", item1, "P", item2, ");\n" 98 | )) 99 | 100 | # correlated uniqunesses 101 | mplus_cor_uniqueness <- "" 102 | for (n in 1:(nrow(data) - 1)) { 103 | for (m in (n+1):nrow(data)) { 104 | pos_psi1 <- with(data, item1[n] == item1[m]) 105 | pos_psi2 <- with(data, item2[n] == item2[m]) 106 | neg_psi <- with(data, item2[n] == item1[m]) 107 | if (pos_psi1) { 108 | mplus_cor_uniqueness <- with(data, 109 | paste0(mplus_cor_uniqueness, 110 | "i", item1[n], "i", item2[n], " WITH ", 111 | "i", item1[m], "i", item2[m], "*1 ", 112 | "(P", item1[n], ");\n" 113 | ) 114 | ) 115 | } else if (pos_psi2) { 116 | mplus_cor_uniqueness <- with(data, 117 | paste0(mplus_cor_uniqueness, 118 | "i", item1[n], "i", item2[n], " WITH ", 119 | "i", item1[m], "i", item2[m], "*1 ", 120 | "(P", item2[n], ");\n" 121 | ) 122 | ) 123 | } else if (neg_psi) { 124 | mplus_cor_uniqueness <- with(data, 125 | paste0(mplus_cor_uniqueness, 126 | "i", item1[n], "i", item2[n], " WITH ", 127 | "i", item1[m], "i", item2[m], "*-1 ", 128 | "(P", item2[n], "n);\n" 129 | ) 130 | ) 131 | } 132 | } 133 | } 134 | 135 | # pair's uniqueness is equal to sum of 2 utility uniqunesses 136 | mplus_equal_uniqueness <- "" 137 | if (nitems_per_block > 2) { 138 | psi_item1 <- paste0("P", data$item1) 139 | psi_item2 <- paste0("P", data$item2) 140 | neg_psi1 <- sapply( 141 | paste0(" \\(", psi_item1, "n\\);"), 142 | grepl, mplus_cor_uniqueness 143 | ) 144 | neg_psi2 <- sapply( 145 | paste0(" \\(", psi_item2, "n\\);"), 146 | grepl, mplus_cor_uniqueness 147 | ) 148 | mplus_equal_uniqueness <- with(data, collapse( 149 | psi_item1, psi_item2, " = ", 150 | ifelse(neg_psi1, paste0("- ", psi_item1, "n"), psi_item1), 151 | ifelse(neg_psi2, paste0("- ", psi_item2, "n"), paste0(" + ", psi_item2)), 152 | ";\n" 153 | )) 154 | } 155 | 156 | mplus_fix_uniqueness <- "" 157 | if (family %in% "bernoulli") { 158 | if (nitems_per_block > 2) { 159 | # fix one uniqueness per block for identification 160 | mplus_fix_uniqueness <- collapse( 161 | "P", seq(1, nitems, nitems_per_block), " = 1;\n" 162 | ) 163 | } else { 164 | # fix all uniquenesses for identification 165 | psi_item1 <- paste0("P", data$item1) 166 | psi_item2 <- paste0("P", data$item2) 167 | mplus_fix_uniqueness <- collapse(psi_item1, psi_item2, " = 1;\n") 168 | } 169 | } 170 | 171 | # force item parameters of the same item to be equal 172 | # this happens if the same items is applied in multiple blocks 173 | mplus_equal_items <- "" 174 | for (i in seq_along(att$dupl_items)) { 175 | first <- att$dupl_items[[i]][1] 176 | dup <- att$dupl_items[[i]][-1] 177 | mplus_equal_items <- paste0(mplus_equal_items, 178 | collapse("L", first, " = L", dup, ";\n"), 179 | collapse("P", first, " = P", dup, ";\n") 180 | ) 181 | } 182 | 183 | # combine all mplus code snippets into a list 184 | list( 185 | TITLE = "Thurstonian IRT model", 186 | DATA = collapse_lines( 187 | "! It is assumed that the input file contains only item responses", 188 | "! Any additional variables should be added below" 189 | ), 190 | VARIABLE = collapse_lines( 191 | mplus_variable 192 | ), 193 | ANALYSIS = collapse_lines( 194 | " ESTIMATOR = ulsmv;", 195 | paste0(" ITERATIONS = ", iter, ";"), 196 | " PARAMETERIZATION = theta;\n" 197 | ), 198 | MODEL = collapse_lines( 199 | "! factor loadings (lambda)", 200 | mplus_loadings, 201 | "! fix factor variances to 1", 202 | mplus_fix_factor_variances, 203 | "! factor correlations", 204 | mplus_factor_correlations, 205 | "! declare uniquenesses (psi)", 206 | mplus_uniqueness, 207 | "! correlated uniqunesses", 208 | mplus_cor_uniqueness 209 | ), 210 | MODELCONSTRAINT = collapse_lines( 211 | "! fix factor loadings of the same item to the same value", 212 | mplus_fix_factor_loadings, 213 | "! pair's uniqueness is equal to sum of 2 utility uniqunesses", 214 | mplus_equal_uniqueness, 215 | "! fix certain uniquenesses for identification", 216 | mplus_fix_uniqueness, 217 | "! force item parameters of the same item to be equal", 218 | mplus_equal_items, 219 | "! trait scores for individuals are estimated and saved in a file" 220 | ), 221 | SAVEDATA = collapse_lines( 222 | paste0(" FILE IS '", eta_file, "';"), 223 | " SAVE = FSCORES;" 224 | ) 225 | ) 226 | } 227 | 228 | #' Fit Thurstonian IRT models in Mplus 229 | #' 230 | #' @inheritParams fit_TIRT_stan 231 | #' @param ... Further arguments passed to 232 | #' \code{\link[MplusAutomation:mplusModeler]{mplusModeler}}. 233 | #' 234 | #' @return A \code{'TIRTfit'} object. 235 | #' 236 | #' @examples 237 | #' # load the data 238 | #' data("triplets") 239 | #' 240 | #' # define the blocks of items 241 | #' blocks <- 242 | #' set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 243 | #' signs = c(1, 1, 1)) + 244 | #' set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 245 | #' signs = c(-1, 1, 1)) + 246 | #' set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 247 | #' signs = c(1, 1, -1)) + 248 | #' set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 249 | #' signs = c(1, -1, 1)) 250 | #' 251 | #' # generate the data to be understood by 'thurstonianIRT' 252 | #' triplets_long <- make_TIRT_data( 253 | #' data = triplets, blocks = blocks, direction = "larger", 254 | #' format = "pairwise", family = "bernoulli", range = c(0, 1) 255 | #' ) 256 | #' 257 | #' \dontrun{ 258 | #' # fit the data using Mplus 259 | #' fit <- fit_TIRT_mplus(triplets_long) 260 | #' print(fit) 261 | #' predict(fit) 262 | #' } 263 | #' 264 | #' @export 265 | fit_TIRT_mplus <- function(data, ...) { 266 | require_package("MplusAutomation") 267 | file_name <- collapse(sample(0:9, 10, TRUE)) 268 | mplus_data <- make_sem_data(data) 269 | mplus_model <- make_mplus_code( 270 | data, eta_file = paste0(file_name, ".csv"), ... 271 | ) 272 | mplus_object <- suppressMessages( 273 | do.call( 274 | MplusAutomation::mplusObject, 275 | c(mplus_model, list(rdata = mplus_data)) 276 | ) 277 | ) 278 | inp_file <- paste0(file_name, ".inp") 279 | out_file <- paste0(file_name, ".out") 280 | fit <- MplusAutomation::mplusModeler( 281 | mplus_object, modelout = inp_file, 282 | run = 1L, writeData = "always" 283 | ) 284 | fit$model_code <- readChar(inp_file, file.info(inp_file)$size) 285 | # cleanup 286 | unlink(inp_file) 287 | unlink(paste0(file_name, ".out")) 288 | unlink(gsub("\"", "", fit$results$input$data$file, fixed = TRUE)) 289 | unlink(fit$results$savedata_info$fileName) 290 | # save only the trait scores and their SEs 291 | npersons <- attr(data, "npersons") 292 | traits <- attr(data, "traits") 293 | savedata <- fit$results[["savedata"]] 294 | fit$results[["savedata"]] <- NULL 295 | ncol_save <- ncol(savedata) 296 | trait_scores <- trait_scores_se <- 297 | matrix(NA, ncol = length(traits), nrow = npersons) 298 | if (is.numeric(ncol_save) && length(ncol_save) > 0) { 299 | cnames <- colnames(savedata) 300 | tnames <- cnames[grepl("^TRAIT[[:digit:]]+$", cnames)] 301 | if (length(tnames)) { 302 | trait_scores <- savedata[, tnames, drop = FALSE] 303 | } 304 | tnames_se <- cnames[grepl("^TRAIT[[:digit:]]+_SE$", cnames)] 305 | if (length(tnames)) { 306 | trait_scores_se <- savedata[, tnames_se, drop = FALSE] 307 | } 308 | } 309 | colnames(trait_scores) <- colnames(trait_scores_se) <- traits 310 | fit$results$trait_scores <- trait_scores 311 | fit$results$trait_scores_se <- trait_scores_se 312 | class(fit) <- c("mplusObjectTIRT", class(fit)) 313 | TIRTfit(fit, data) 314 | } 315 | 316 | is.mplusObjectTIRT <- function(x) { 317 | inherits(x, "mplusObjectTIRT") 318 | } 319 | 320 | #' @export 321 | print.mplusObjectTIRT <- function(x, digits = 2, ...) { 322 | cat("Model Name:", x$TITLE, "\n") 323 | cat("Results:\n") 324 | print(x$results$parameters$unstandardized, digits = digits) 325 | invisible(x) 326 | } 327 | 328 | #' @method summary mplusObjectTIRT 329 | #' @export 330 | summary.mplusObjectTIRT <- function(object, ...) { 331 | object$results$parameters$unstandardized 332 | } 333 | 334 | # predict trait scores using Mplus 335 | predict_mplus <- function(object, newdata = NULL, ...) { 336 | if (!is.null(newdata)) { 337 | stop("'newdata' is not supported for models fit with Mplus.") 338 | } 339 | fit <- object$fit 340 | traits <- attributes(object$data)$traits 341 | out <- fit$results[["trait_scores"]] 342 | if (is.null(out)) { 343 | # for backwards compatibility with version < 0.9.3 344 | out <- fit$results[["savedata"]] 345 | } 346 | out <- as.data.frame(out) 347 | if (NROW(out)) { 348 | ntraits <- ncol(out) 349 | out <- out %>% 350 | tidyr::gather("trait", "estimate", everything()) %>% 351 | mutate(id = rep(seq_len(n() / ntraits), ntraits)) %>% 352 | arrange(.data$id) %>% 353 | select("id", "trait", "estimate") 354 | } 355 | se <- as.data.frame(fit$results[["trait_scores_se"]]) 356 | if (NROW(se)) { 357 | ntraits <- ncol(se) 358 | se <- se %>% 359 | tidyr::gather("trait", "se", everything()) %>% 360 | mutate(id = rep(seq_len(n() / ntraits), ntraits)) %>% 361 | arrange(.data$id) %>% 362 | select("id", "trait", "se") 363 | } 364 | out %>% 365 | inner_join(se, by = c("id", "trait")) %>% 366 | as_tibble() 367 | } 368 | -------------------------------------------------------------------------------- /R/simulations.R: -------------------------------------------------------------------------------- 1 | #' Simulate Thurstonian IRT data 2 | #' 3 | #' @param npersons Number of persons. 4 | #' @param ntraits Number of traits. 5 | #' @param lambda Item factor loadings. 6 | #' @param gamma Baseline attractiveness parameters of the 7 | #' first item versus the second item in the pairwise comparisons. 8 | #' Can be thought of as intercept parameters. 9 | #' @param psi Optional item uniquenesses. If not provided, 10 | #' they will be computed as \code{psi = 1 - lambda^2} in which 11 | #' case lambda are taken to be the standardized factor loadings. 12 | #' @param Phi Optional trait correlation matrix from which to sample 13 | #' person factor scores. Only used if \code{eta} is not provided. 14 | #' @param eta Optional person factor scores. If provided, argument 15 | #' \code{Phi} will be ignored. 16 | #' @param family Name of assumed the response distribution. Either 17 | #' \code{"bernoulli"}, \code{"cumulative"}, or \code{"gaussian"}. 18 | #' @param nblocks_per_trait Number of blocks per trait. 19 | #' @param nitems_per_block Number of items per block. 20 | #' @param comb_blocks Indicates how to combine traits to blocks. 21 | #' \code{"fixed"} implies a simple non-random design that may combine 22 | #' certain traits which each other disproportionally often. We thus 23 | #' recommend to use a \code{"random"} block design (the default) that 24 | #' combines all traits with all other traits equally often on average. 25 | #' 26 | #' @return A \code{data.frame} of the same structure 27 | #' as returned by \code{\link{make_TIRT_data}}. Parameter values 28 | #' from which the data were simulated are stored as attributes 29 | #' of the returned object. 30 | #' 31 | #' @examples 32 | #' # simulate some data 33 | #' sdata <- sim_TIRT_data( 34 | #' npersons = 100, 35 | #' ntraits = 3, 36 | #' nblocks_per_trait = 4, 37 | #' gamma = 0, 38 | #' lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 39 | #' Phi = diag(3) 40 | #' ) 41 | #' 42 | #' # take a look at the data 43 | #' head(sdata) 44 | #' str(attributes(sdata)) 45 | #' 46 | #' \donttest{ 47 | #' # fit a Thurstonian IRT model using lavaan 48 | #' fit <- fit_TIRT_lavaan(sdata) 49 | #' print(fit) 50 | #' } 51 | #' 52 | #' @importFrom stats sd setNames rnorm rbeta 53 | #' @importFrom rlang .data 54 | #' @export 55 | sim_TIRT_data <- function(npersons, ntraits, lambda, gamma, 56 | psi = NULL, Phi = NULL, eta = NULL, 57 | family = "bernoulli", 58 | nblocks_per_trait = 5, nitems_per_block = 3, 59 | comb_blocks = c("random", "fixed")) { 60 | # prepare data in long format to which responses may be added 61 | if ((ntraits * nblocks_per_trait) %% nitems_per_block != 0L) { 62 | stop("The number of items per block must divide ", 63 | "the number of total items.") 64 | } 65 | family <- check_family(family) 66 | comb_blocks <- match.arg(comb_blocks) 67 | nblocks <- ntraits * nblocks_per_trait / nitems_per_block 68 | nitems <- nitems_per_block * nblocks 69 | ncomparisons <- (nitems_per_block * (nitems_per_block - 1)) / 2 70 | data <- tibble::tibble( 71 | person = rep(1:npersons, ncomparisons * nblocks), 72 | block = rep(1:nblocks, each = npersons * ncomparisons), 73 | comparison = rep(rep(1:ncomparisons, each = npersons), nblocks) 74 | ) 75 | # select traits for each block 76 | trait_combs <- make_trait_combs( 77 | ntraits, nblocks_per_trait, nitems_per_block, 78 | comb_blocks = comb_blocks 79 | ) 80 | items_per_trait <- vector("list", ntraits) 81 | for (i in seq_len(nblocks)) { 82 | traits <- trait_combs[i, ] 83 | trait1 <- rep_comp(traits, 1, nitems_per_block) 84 | trait2 <- rep_comp(traits, 2, nitems_per_block) 85 | fblock <- (i - 1) * nitems_per_block 86 | item1 <- match(trait1, traits) + fblock 87 | item2 <- match(trait2, traits) + fblock 88 | sign1 <- sign(lambda[item1]) 89 | sign2 <- sign(lambda[item2]) 90 | comparison <- data[data$block == i, ]$comparison 91 | data[data$block == i, "itemC"] <- comparison + (i - 1) * ncomparisons 92 | data[data$block == i, "trait1"] <- trait1[comparison] 93 | data[data$block == i, "trait2"] <- trait2[comparison] 94 | data[data$block == i, "item1"] <- item1[comparison] 95 | data[data$block == i, "item2"] <- item2[comparison] 96 | data[data$block == i, "sign1"] <- sign1[comparison] 97 | data[data$block == i, "sign2"] <- sign2[comparison] 98 | # save item numbers per trait 99 | for (t in unique(trait1)) { 100 | items_per_trait[[t]] <- union( 101 | items_per_trait[[t]], item1[match(t, trait1)] 102 | ) 103 | } 104 | for (t in unique(trait2)) { 105 | items_per_trait[[t]] <- union( 106 | items_per_trait[[t]], item2[match(t, trait2)] 107 | ) 108 | } 109 | } 110 | 111 | # prepare parameters 112 | if (is.null(eta)) { 113 | eta <- sim_eta(npersons, Phi) 114 | } 115 | if (length(gamma) == 1L) { 116 | gamma <- rep(gamma, ncomparisons * nblocks) 117 | } 118 | if (!is.list(lambda) && length(lambda) == 1L) { 119 | lambda <- rep(lambda, nitems) 120 | } 121 | if (is.null(psi)) { 122 | message("Computing standardized psi^2 as 1 - lambda^2") 123 | psi <- lambda2psi(lambda) 124 | } else if (!is.list(psi) && length(psi) == 1L) { 125 | psi <- rep(psi, nitems) 126 | } 127 | if (NROW(gamma) != ncomparisons * nblocks) { 128 | stop("gamma should contain ", ncomparisons * nblocks, " rows.") 129 | } 130 | if (sum(lengths(lambda)) != nitems) { 131 | stop("lambda should contain ", nitems, " values.") 132 | } 133 | if (sum(lengths(psi)) != nitems) { 134 | stop("psi should contain ", nitems, " values.") 135 | } 136 | dim_eta_exp <- c(length(unique(data$person)), ntraits) 137 | if (!is_equal(dim(eta), dim_eta_exp)) { 138 | stop("eta should be of dimension (", dim_eta_exp[1], 139 | ", ", dim_eta_exp[2], ").") 140 | } 141 | if (family == "cumulative") { 142 | stopifnot(NCOL(gamma) > 1L) 143 | data$gamma <- gamma[data$itemC, , drop = FALSE] 144 | } else { 145 | stopifnot(NCOL(gamma) == 1L) 146 | data$gamma <- as.vector(gamma)[data$itemC] 147 | } 148 | if (is.list(lambda)) { 149 | if (length(lambda) != ntraits) { 150 | stop("lambda should contain ", ntraits, " list elements.") 151 | } 152 | lambda_order <- order(unlist(items_per_trait)) 153 | lambda <- unlist(lambda)[lambda_order] 154 | } 155 | data$lambda1 <- lambda[data$item1] 156 | data$lambda2 <- lambda[data$item2] 157 | if (is.list(psi)) { 158 | if (length(psi) != ntraits) { 159 | stop("psi should contain ", ntraits, " list elements.") 160 | } 161 | psi_order <- order(unlist(items_per_trait)) 162 | psi <- unlist(psi)[psi_order] 163 | } 164 | data$psi1 <- psi[data$item1] 165 | data$psi2 <- psi[data$item2] 166 | for (p in seq_len(npersons)) { 167 | take <- data$person == p 168 | pdat <- data[take, ] 169 | data[take, "eta1"] <- eta[p, pdat$trait1] 170 | data[take, "eta2"] <- eta[p, pdat$trait2] 171 | # sample errors to make them item-person specific 172 | # but constant for each item per person 173 | errors <- rnorm(nitems, 0, psi) 174 | data[take, "error1"] <- errors[pdat$item1] 175 | data[take, "error2"] <- errors[pdat$item2] 176 | } 177 | 178 | data <- add_response(data, family = family) 179 | structure(data, 180 | npersons = npersons, ntraits = ntraits, nblocks = nblocks, 181 | nitems = nitems, nblocks_per_trait = nblocks_per_trait, 182 | nitems_per_block = nitems_per_block, 183 | signs = sign(lambda), lambda = lambda, psi = psi, eta = eta, 184 | traits = paste0("trait", seq_len(ntraits)), 185 | family = family, ncat = NCOL(data$gamma) + 1, 186 | class = c("TIRTdata", class(data)) 187 | ) 188 | } 189 | 190 | sim_eta <- function(npersons, Phi) { 191 | mu <- rep(0, nrow(Phi)) 192 | mvtnorm::rmvnorm(npersons, mu, Phi) 193 | } 194 | 195 | add_response <- function(data, family) { 196 | # add columns related to the response 197 | # compute the latent mean 'mu' 198 | if (family %in% c("bernoulli", "gaussian", "beta")) { 199 | data$mu <- with(data, -gamma + lambda1 * eta1 - lambda2 * eta2) 200 | } else if (family %in% "cumulative") { 201 | # do not include 'gamma' here as it serves as the thresholds 202 | data$mu <- with(data, lambda1 * eta1 - lambda2 * eta2) 203 | } 204 | 205 | # deterministically include error sampled earlier 206 | mu_error <- with(data, mu + error1 - error2) 207 | data$error1 <- data$error2 <- NULL 208 | sum_psi <- with(data, sqrt(psi1^2 + psi2^2)) 209 | 210 | # compute the actual response values 211 | if (family == "bernoulli") { 212 | data$response <- as.integer(mu_error >= 0) 213 | } else if (family == "cumulative") { 214 | data$response <- rep(NA, nrow(data)) 215 | thres <- cbind(-Inf, data$gamma, Inf) 216 | for (i in seq_len(nrow(data))) { 217 | # 'cut' is not vectorized over 'breaks' 218 | data$response[i] <- cut(mu_error[i], breaks = thres[i, ]) 219 | } 220 | # start counting at 0 221 | data$response <- as.integer(data$response) - 1 222 | } else if (family == "gaussian") { 223 | # do not use 'error' but sample directly from the latent distribution 224 | data$response <- rnorm(data$mu, sum_psi) 225 | } else if (family == "beta") { 226 | # mean parameterization of the beta distribution 227 | # do not use 'error' but sample directly from the latent distribution 228 | pr <- stats::pnorm(data$mu / sum_psi) 229 | data$response <- rbeta(length(pr), pr * data$disp, (1 - pr) * data$disp) 230 | # truncate distribution at the extremes 231 | data$response[data$response < 0.001] <- 0.001 232 | data$response[data$response > 0.999] <- 0.999 233 | } 234 | data 235 | } 236 | 237 | make_trait_combs <- function(ntraits, nblocks_per_trait, nitems_per_block, 238 | comb_blocks = c("fixed", "random"), 239 | maxtrys_outer = 100, maxtrys_inner = 1e6) { 240 | comb_blocks <- match.arg(comb_blocks) 241 | stopifnot((ntraits * nblocks_per_trait) %% nitems_per_block == 0L) 242 | if (comb_blocks == "fixed") { 243 | # use comb_blocks == "random" for a better balanced design 244 | traits <- rep(seq_len(ntraits), nblocks_per_trait) 245 | out <- matrix(traits, ncol = nitems_per_block, byrow = TRUE) 246 | } else if (comb_blocks == "random") { 247 | nblocks <- (ntraits * nblocks_per_trait) %/% nitems_per_block 248 | traits <- seq_len(ntraits) 249 | out <- replicate(nitems_per_block, traits, simplify = FALSE) 250 | out <- as.matrix(expand.grid(out)) 251 | rownames(out) <- NULL 252 | remove <- rep(FALSE, nrow(out)) 253 | for (i in seq_len(nrow(out))) { 254 | if (length(unique(out[i, ])) < ncol(out)) { 255 | remove[i] <- TRUE 256 | } 257 | } 258 | out <- out[!remove, ] 259 | all_rows <- seq_len(nrow(out)) 260 | nbpt_chosen <- rep(0, ntraits) 261 | 262 | .choose <- function(nblocks, maxtrys, all_rows) { 263 | # finds suitable blocks 264 | chosen <- rep(NA, nblocks) 265 | possible_rows <- all_rows 266 | i <- ntrys <- 1 267 | while (i <= nblocks && ntrys <= maxtrys) { 268 | if (!length(possible_rows)) { 269 | # all rows were selected already; start fresh 270 | possible_rows <- all_rows 271 | } 272 | ntrys <- ntrys + 1 273 | chosen[i] <- possible_rows[sample(seq_along(possible_rows), 1)] 274 | traits_chosen <- out[chosen[i], ] 275 | nbpt_chosen[traits_chosen] <- nbpt_chosen[traits_chosen] + 1 276 | valid <- max(nbpt_chosen) <= min(nbpt_chosen) + 1 && 277 | !any(nbpt_chosen[traits_chosen] > nblocks_per_trait) 278 | possible_rows <- setdiff(possible_rows, chosen[i]) 279 | if (valid) { 280 | i <- i + 1 281 | } else { 282 | # revert number of blocks per trait chosen 283 | # and try finding traits for block i again 284 | nbpt_chosen[traits_chosen] <- nbpt_chosen[traits_chosen] - 1 285 | } 286 | } 287 | return(chosen) 288 | } 289 | 290 | i <- 1 291 | chosen <- rep(NA, nblocks) 292 | while (anyNA(chosen) && i <= maxtrys_outer) { 293 | i <- i + 1 294 | chosen <- .choose(nblocks, maxtrys = maxtrys_inner, 295 | all_rows = all_rows) 296 | } 297 | if (anyNA(chosen)) { 298 | stop("Could not find a set of suitable blocks.") 299 | } 300 | out <- out[chosen, ] 301 | } 302 | out 303 | } 304 | 305 | lambda2psi <- function(lambda) { 306 | # according to Brown et al. 2011 for std lambda: psi^2 = 1 - lambda^2 307 | # psi is the SD and psi^2 is the variance 308 | # Ideas for lambda if unstandardized: 309 | # multiply std lambda with sqrt(2) 310 | # create simulated data based on std factor scores 311 | .lambda2psi <- function(x) { 312 | x <- as.numeric(x) 313 | if (any(abs(x) > 1)) { 314 | stop("standardized lambdas are expect to be between -1 and 1.") 315 | } 316 | sqrt(1 - x^2) 317 | } 318 | if (is.list(lambda)) { 319 | psi <- lapply(lambda, .lambda2psi) 320 | } else { 321 | psi <- .lambda2psi(lambda) 322 | } 323 | psi 324 | } 325 | -------------------------------------------------------------------------------- /R/stan.R: -------------------------------------------------------------------------------- 1 | #' Prepare data for Thurstonian IRT models fitted with Stan 2 | #' 3 | #' @inheritParams make_TIRT_data 4 | #' 5 | #' @return A list of data ready to be passed to \pkg{Stan}. 6 | #' 7 | #' #' @examples 8 | #' # simulate some data 9 | #' sim_data <- sim_TIRT_data( 10 | #' npersons = 100, 11 | #' ntraits = 3, 12 | #' nblocks_per_trait = 4, 13 | #' gamma = 0, 14 | #' lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 15 | #' Phi = diag(3) 16 | #' ) 17 | #' 18 | #' # create data ready for use in Stan 19 | #' stan_data <- make_stan_data(sim_data) 20 | #' str(stan_data) 21 | #' 22 | #' @useDynLib thurstonianIRT, .registration = TRUE 23 | #' @import Rcpp 24 | #' @importFrom RcppParallel RcppParallelLibs 25 | #' @import methods 26 | #' @export 27 | make_stan_data <- function(data) { 28 | if (!is.TIRTdata(data)) { 29 | stop("'data' should be of class 'TIRTdata'. See ?make_TIRT_data") 30 | } 31 | data <- convert_factors(data) 32 | att <- attributes(data) 33 | # should be 2 for all non-ordinal families 34 | ncat <- if (!is.null(att$ncat)) att$ncat else 2L 35 | out = list( 36 | N = nrow(data), 37 | N_item = length(unique(c(data$item1, data$item2))), 38 | N_itemC = length(unique(data$itemC)), 39 | N_person = length(unique(data$person)), 40 | N_trait = length(unique(c(data$trait1, data$trait2))), 41 | J_item1 = as.array(as.numeric(data$item1)), 42 | J_item2 = as.array(as.numeric(data$item2)), 43 | J_itemC = as.array(as.numeric(data$itemC)), 44 | J_person = as.array(as.numeric(data$person)), 45 | J_trait1 = as.array(as.numeric(data$trait1)), 46 | J_trait2 = as.array(as.numeric(data$trait2)), 47 | J_item_pos = as.array(which(att[["signs"]] >= 0)), 48 | J_item_neg = as.array(which(att[["signs"]] < 0)), 49 | ncat = ncat 50 | ) 51 | 52 | # prepare family and response values 53 | family <- check_family(att$family, "stan") 54 | options <- family_options("stan") 55 | out$family <- as.numeric(factor(family, options)) 56 | if (family %in% c("bernoulli", "cumulative")) { 57 | out$Yint <- as.array(data$response) 58 | out$Yreal <- numeric(0) 59 | } else if (family %in% c("gaussian", "beta")) { 60 | out$Yint <- integer(0) 61 | out$Yreal <- as.array(data$response) 62 | } 63 | 64 | nitems_per_block <- att[["nitems_per_block"]] 65 | nitems <- att[["nitems"]] 66 | if (family %in% c("bernoulli", "cumulative", "beta")) { 67 | # fix first item uniqueness per block for identification 68 | # TODO: figure out if 'beta' really needs this 69 | out$J_item_fix <- as.array(seq(1, nitems, nitems_per_block)) 70 | } else { 71 | out$J_item_fix <- integer(0) 72 | } 73 | out$J_item_est <- as.array(setdiff(1:nitems, out$J_item_fix)) 74 | if (length(att$dupl_items)) { 75 | # force item parameters of the same item to be equal 76 | # this happens if the same items is applied in multiple blocks 77 | J_item_equal <- J_item_orig <- vector("list", length(att$dupl_items)) 78 | for (i in seq_along(att$dupl_items)) { 79 | first <- att$dupl_items[[i]][1] 80 | dup <- att$dupl_items[[i]][-1] 81 | J_item_equal[[i]] <- dup 82 | J_item_orig[[i]] <- rep(first, length(dup)) 83 | } 84 | out$J_item_equal <- as.array(unlist(J_item_equal)) 85 | out$J_item_orig <- as.array(unlist(J_item_orig)) 86 | # duplicated items should not be part of the other index variables 87 | out$J_item_pos <- as.array(with(out, setdiff(J_item_pos, J_item_equal))) 88 | out$J_item_neg <- as.array(with(out, setdiff(J_item_neg, J_item_equal))) 89 | out$J_item_fix <- as.array(with(out, setdiff(J_item_fix, J_item_equal))) 90 | out$J_item_est <- as.array(with(out, setdiff(J_item_est, J_item_equal))) 91 | } else { 92 | out$J_item_equal <- out$J_item_orig <- integer(0) 93 | } 94 | out$N_item_pos = length(out$J_item_pos) 95 | out$N_item_neg = length(out$J_item_neg) 96 | out$N_item_fix = length(out$J_item_fix) 97 | out$N_item_est = length(out$J_item_est) 98 | out$N_item_equal <- length(out$J_item_equal) 99 | out$N_item_orig <- length(out$J_item_orig) 100 | out 101 | } 102 | 103 | #' Fit Thurstonian IRT models in Stan 104 | #' 105 | #' @param data An object of class \code{'TIRTdata'}. see 106 | #' \code{\link{make_TIRT_data}} for documentation on how to create one. 107 | #' @param init Initial values of the parameters. 108 | #' Defaults to \code{0} as it proved to be most stable. 109 | #' @param ... Further arguments passed to 110 | #' \code{\link[rstan:sampling]{rstan::sampling}}. 111 | #' 112 | #' @return A \code{'TIRTfit'} object. 113 | #' 114 | #' @examples 115 | #' # load the data 116 | #' data("triplets") 117 | #' 118 | #' # define the blocks of items 119 | #' blocks <- 120 | #' set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 121 | #' signs = c(1, 1, 1)) + 122 | #' set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 123 | #' signs = c(-1, 1, 1)) + 124 | #' set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 125 | #' signs = c(1, 1, -1)) + 126 | #' set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 127 | #' signs = c(1, -1, 1)) 128 | #' 129 | #' # generate the data to be understood by 'thurstonianIRT' 130 | #' triplets_long <- make_TIRT_data( 131 | #' data = triplets, blocks = blocks, direction = "larger", 132 | #' format = "pairwise", family = "bernoulli", range = c(0, 1) 133 | #' ) 134 | #' 135 | #' \donttest{ 136 | #' # fit the data using Stan 137 | #' fit <- fit_TIRT_stan(triplets_long, chains = 1) 138 | #' print(fit) 139 | #' predict(fit) 140 | #' } 141 | #' 142 | #' @export 143 | fit_TIRT_stan <- function(data, init = 0, ...) { 144 | stan_data <- make_stan_data(data) 145 | stan_pars <- c( 146 | "Cor_trait", "lambda", "psi", "gamma", 147 | "gamma_ord", "disp", "r", "eta" 148 | ) 149 | fit <- rstan::sampling( 150 | stanmodels$thurstonian_irt_model, 151 | data = stan_data, pars = stan_pars, 152 | init = init, ... 153 | ) 154 | TIRTfit(fit, data) 155 | } 156 | 157 | # predict trait scores using Stan 158 | predict_stan <- function(object, newdata = NULL, ...) { 159 | if (is.null(newdata)) { 160 | out <- predict_stan_old_data(object, ...) 161 | } else { 162 | out <- predict_stan_new_data(object, newdata, ...) 163 | } 164 | out 165 | } 166 | 167 | # predict trait scores of existing persons using Stan 168 | predict_stan_old_data <- function(object, ...) { 169 | fit <- object$fit 170 | traits <- attributes(object$data)$traits 171 | out <- as.data.frame(summary(fit, "eta")$summary) 172 | if (NROW(out)) { 173 | out <- out %>% 174 | tibble::rownames_to_column(var = "par") %>% 175 | rename( 176 | estimate = "mean", se = "sd", 177 | lower_ci = "2.5%", upper_ci = "97.5%" 178 | ) %>% 179 | select("par", "estimate", "se", "lower_ci", "upper_ci") %>% 180 | tidyr::extract( 181 | col = "par", into = c("par", "id", "trait"), 182 | regex = "(eta)\\[([[:digit:]]+),([[:digit:]]+)\\]" 183 | ) %>% 184 | mutate( 185 | id = as.integer(.data$id), 186 | trait = as.integer(.data$trait) 187 | ) %>% 188 | select(-"par") %>% 189 | mutate(trait = as.character(factor(.data$trait, labels = traits))) %>% 190 | arrange(.data$id) 191 | } 192 | as_tibble(out) 193 | } 194 | 195 | # predict trait scores of new persons using Stan 196 | predict_stan_new_data <- function(object, newdata, inits = 0, ...) { 197 | # TODO: check 'newdata' for validity 198 | stan_data <- make_stan_data(newdata) 199 | 200 | # extract (medians of) item parameters and person hyperparameters 201 | # to be used as data in the predictions for new data 202 | par_dims <- object$fit@par_dims 203 | pars <- c("Cor_trait", "lambda", "psi", "r", "gamma", "gamma_ord", "disp") 204 | stan_data_pars <- named_list(pars) 205 | for (par in pars) { 206 | if (prod(par_dims[[par]]) > 0) { 207 | samples <- as.matrix(object$fit, par) 208 | stan_data_pars[[par]] <- apply(samples, 2, stats::median) 209 | } else { 210 | stan_data_pars[[par]] <- numeric(0) 211 | } 212 | dim(stan_data_pars[[par]]) <- par_dims[[par]] 213 | } 214 | # TODO: is there a more consistent approach to extract 215 | # the median cholesky factor of the trait correlation matrix? 216 | stan_data_pars$L_trait <- t(chol(stan_data_pars$Cor_trait)) 217 | stan_data <- c(stan_data, stan_data_pars) 218 | 219 | # fit the model to obtain predictions for new persons 220 | fit <- rstan::sampling( 221 | stanmodels$thurstonian_irt_model_newdata, 222 | data = stan_data, pars = "eta", 223 | init = inits, ... 224 | ) 225 | predict_stan_old_data(TIRTfit(fit, newdata), ...) 226 | } 227 | -------------------------------------------------------------------------------- /R/stanmodels.R: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | # names of stan models 4 | stanmodels <- c("thurstonian_irt_model", "thurstonian_irt_model_newdata") 5 | 6 | # load each stan module 7 | Rcpp::loadModule("stan_fit4thurstonian_irt_model_mod", what = TRUE) 8 | Rcpp::loadModule("stan_fit4thurstonian_irt_model_newdata_mod", what = TRUE) 9 | 10 | # instantiate each stanmodel object 11 | stanmodels <- sapply(stanmodels, function(model_name) { 12 | # create C++ code for stan model 13 | stan_file <- if(dir.exists("stan")) "stan" else file.path("inst", "stan") 14 | stan_file <- file.path(stan_file, paste0(model_name, ".stan")) 15 | stanfit <- rstan::stanc_builder(stan_file, 16 | allow_undefined = TRUE, 17 | obfuscate_model_name = FALSE) 18 | stanfit$model_cpp <- list(model_cppname = stanfit$model_name, 19 | model_cppcode = stanfit$cppcode) 20 | # create stanmodel object 21 | methods::new(Class = "stanmodel", 22 | model_name = stanfit$model_name, 23 | model_code = stanfit$model_code, 24 | model_cpp = stanfit$model_cpp, 25 | mk_cppmodule = function(x) get(paste0("rstantools_model_", model_name))) 26 | }) 27 | -------------------------------------------------------------------------------- /R/thurstonianIRT-package.R: -------------------------------------------------------------------------------- 1 | #' The 'thurstonianIRT' package. 2 | #' 3 | #' @description This package fits Thurstonian Item Response Theory (IRT) models 4 | #' using 'Stan', 'lavaan', or 'Mplus'. To bring your data into the right 5 | #' format, use the \code{\link{make_TIRT_data}} function. Models can then be 6 | #' fitted via \code{\link{fit_TIRT_stan}}, \code{\link{fit_TIRT_lavaan}}, or 7 | #' \code{\link{fit_TIRT_mplus}} depending on the desired model fitting engine. 8 | #' Data from Thurstonian IRT models can be simulated via 9 | #' \code{\link{sim_TIRT_data}}. 10 | #' 11 | #' @docType package 12 | #' @name thurstonianIRT-package 13 | #' @aliases thurstonianIRT 14 | #' @useDynLib thurstonianIRT, .registration = TRUE 15 | #' @import methods 16 | #' @import Rcpp 17 | #' @import rstantools 18 | #' @importFrom rstan sampling 19 | #' 20 | #' @references 21 | #' Brown, A., & Maydeu-Olivares, A. (2011). Item response modeling of 22 | #' forced-choice questionnaires. Educational and Psychological Measurement, 23 | #' 71(3), 460-502. doi:10.1177/0013164410375112 24 | #' 25 | #' Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and 26 | #' Practical Limitations of Thurstonian IRT Models. Educational and 27 | #' Psychological Measurement. doi:10.1177/0013164419832063 28 | #' 29 | NULL 30 | -------------------------------------------------------------------------------- /README.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | output: 3 | md_document: 4 | variant: markdown_github 5 | editor_options: 6 | chunk_output_type: console 7 | --- 8 | 9 | ```{r, include=FALSE} 10 | stopifnot(require(knitr)) 11 | options(width = 90) 12 | knitr::opts_chunk$set( 13 | collapse = TRUE, 14 | comment = "#>", 15 | fig.path = "man/figures/README-", 16 | dev = "png", 17 | dpi = 150, 18 | fig.asp = 0.8, 19 | fig.width = 5, 20 | out.width = "60%", 21 | fig.align = "center" 22 | ) 23 | library(thurstonianIRT) 24 | set.seed(1234) 25 | ``` 26 | 27 | # thurstonianIRT 28 | 29 | [![DOI](https://joss.theoj.org/papers/10.21105/joss.01662/status.svg)](https://doi.org/10.21105/joss.01662) 30 | [![Build Status](https://api.travis-ci.com/paul-buerkner/thurstonianIRT.svg?branch=master)](https://app.travis-ci.com/paul-buerkner/thurstonianIRT) 31 | [![CRAN Version](http://www.r-pkg.org/badges/version/thurstonianIRT)](https://cran.r-project.org/package=thurstonianIRT) 32 | 33 | ## Overview 34 | 35 | The **thurstonianIRT** package allows to fit various models from [Item Response 36 | Theory (IRT)](https://en.wikipedia.org/wiki/Item_response_theory) for 37 | forced-choice questionnaires, most notably the Thurstonian IRT model originally 38 | proposed by (Brown & Maydeu-Olivares, 2011). IRT in general comes with several 39 | advantages over classical test theory, for instance, the ability to model 40 | varying item difficulties as well as item factor loadings on the participants' 41 | traits they are supposed to measure. Moreover, if multiple traits are modeled 42 | at the same time, their correlation can be incorporated into an IRT model to 43 | improve the overall estimation accuracy. The key characteristic of 44 | forced-choice questionnaires is that participants cannot endorse all items at 45 | the same time and instead have to make a comparative judgment between two or 46 | more items. Such a format comes with the hope of providing more valid inference 47 | in situation where participants have motivation to not answer honestly (e.g., 48 | in personnel selection), but instead respond in a way that appears favorable in 49 | the given situation. Whether forced-choice questionnaires and the corresponding 50 | IRT models live up to this hope remains a topic of debate (e.g., see Bürkner, 51 | Schulte, & Holling, 2019) but it is in any case necessary to provide software 52 | for fitting these statistical models both for practical and research purposes. 53 | 54 | In the original formulation, the Thurstonian IRT model works on dichotomous 55 | pairwise comparisons and models the probability of endorsing one versus the 56 | other item. This probability depends on parameters related to the items under 57 | comparison as well as on parameters related to the participants' latent traits 58 | which are assumed to be measured by the items. For more details see Brown and 59 | Maydeu-Olivares (2011), Brown and Maydeu-Olivares (2012), and Bürkner et al. 60 | (2019). 61 | 62 | ## How to use thurstonianIRT 63 | 64 | ```{r} 65 | library(thurstonianIRT) 66 | ``` 67 | 68 | As a simple example consider a data set of 4 blocks each 69 | containing 3 items (i.e., triplets) answered by 200 participants. 70 | 71 | ```{r} 72 | data("triplets") 73 | head(triplets) 74 | ``` 75 | 76 | In the data set, a 1 indicates that the first item has been selected over the 77 | second item while a 0 indicates that the second items has been selected 78 | over the first item. In order to fit a Thurstonian IRT model on this data, 79 | we have to tell **thurstonianIRT** about the block structure of the items, 80 | the traits on which the items load, and the sign of these loadings, that is, 81 | whether items have been inverted. For the present data, we specify 82 | this as follows: 83 | 84 | ```{r} 85 | blocks <- 86 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 87 | signs = c(1, 1, 1)) + 88 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 89 | signs = c(-1, 1, 1)) + 90 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 91 | signs = c(1, 1, -1)) + 92 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 93 | signs = c(1, -1, 1)) 94 | ``` 95 | 96 | Next, we transform the data into a format that **thurstonianIRT** understands. 97 | 98 | ```{r} 99 | triplets_long <- make_TIRT_data( 100 | data = triplets, blocks = blocks, direction = "larger", 101 | format = "pairwise", family = "bernoulli", range = c(0, 1) 102 | ) 103 | head(triplets_long) 104 | ``` 105 | 106 | Finally, we can fit the model using several model fitting engines. Currently 107 | supported are [Stan](https://mc-stan.org/), [lavaan](https://lavaan.ugent.be/), 108 | and [Mplus](http://www.statmodel.com/). Here, we choose Stan to fit the 109 | Thurstonian IRT model in a Bayesian framework. 110 | 111 | ```{r, results="hide"} 112 | fit <- fit_TIRT_stan(triplets_long, chains = 1) 113 | ``` 114 | 115 | As basic summary and convergence checks can be obtained via 116 | 117 | ```{r, eval=FALSE} 118 | print(fit) 119 | ``` 120 | 121 | Finally, we obtain predictions of participants' trait scores in a tidy 122 | data format via 123 | 124 | ```{r} 125 | pr <- predict(fit) 126 | head(pr) 127 | ``` 128 | 129 | The thurstonianIRT package not only comes with model fitting functions but 130 | also with the possibility to simulate data from Thurstonian IRT models. 131 | Below we simulate data with a very similar structure to the `triplets` 132 | data set we have used above. 133 | 134 | ```{r} 135 | sim_data <- sim_TIRT_data( 136 | npersons = 200, 137 | ntraits = 3, 138 | nblocks_per_trait = 4, 139 | gamma = 0, 140 | lambda = runif(12, 0.5, 1), 141 | Phi = diag(3) 142 | ) 143 | head(sim_data) 144 | ``` 145 | 146 | The structure of the data is the same as what we obtain via 147 | the `make_TIRT_data` function and can readily be passed to the model 148 | fitting functions. 149 | 150 | ## FAQ 151 | 152 | ### How to install thurstonianIRT 153 | 154 | To install the latest release version from CRAN use 155 | 156 | ```{r, eval = FALSE} 157 | install.packages("thurstonianIRT") 158 | ``` 159 | 160 | The current developmental version can be downloaded from github via 161 | 162 | ```{r, eval = FALSE} 163 | if (!requireNamespace("remotes")) { 164 | install.packages("remotes") 165 | } 166 | remotes::install_github("paul-buerkner/thurstonianIRT") 167 | ``` 168 | 169 | ### I am new to thurstonianIRT. Where can I start? 170 | 171 | After reading the README, you probably have a good overview already over the 172 | packages purporse and main functionality. You can dive deeper by reading the 173 | package's documentation perhaps starting with `help("thurstonianIRT")`. If you 174 | want to perform a simulation study with the package, I recommend you take a look 175 | at `vignette("TIRT_sim_tests")`. 176 | 177 | ### Where do I ask questions, propose a new feature, or report a bug? 178 | 179 | To ask a question, propose a new feature or report a bug, please open an 180 | issue on [GitHub](https://github.com/paul-buerkner/thurstonianIRT). 181 | 182 | ### How can I contribute to thurstonianIRT? 183 | 184 | If you want to contribute to thurstonianIRT, you can best do this via the 185 | package's [GitHub](https://github.com/paul-buerkner/thurstonianIRT) page. There, 186 | you can fork the repository, open new issues (e.g., to report a bug), or make 187 | pull requests to improve the software and documentation. I am grateful for all 188 | kinds of contributions, even if they are just as small as fixing a typo in the 189 | documentation. 190 | 191 | 192 | ## References 193 | 194 | Brown, A., & Maydeu-Olivares, A. (2011). Item response modeling of forced-choice questionnaires. *Educational and Psychological Measurement*, 71(3), 460-502. 195 | https://journals.sagepub.com/doi/10.1177/0013164410375112 196 | 197 | Brown, A., & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model to forced-choice data using Mplus. *Behavior Research Methods*, 44(4), 1135-1147. 198 | https://link.springer.com/article/10.3758/s13428-012-0217-x 199 | 200 | Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and Practical Limitations of Thurstonian IRT Models. *Educational and Psychological Measurement.* https://journals.sagepub.com/doi/10.1177/0013164419832063 201 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # thurstonianIRT 2 | 3 | [![DOI](https://joss.theoj.org/papers/10.21105/joss.01662/status.svg)](https://doi.org/10.21105/joss.01662) 4 | [![Build 5 | Status](https://api.travis-ci.com/paul-buerkner/thurstonianIRT.svg?branch=master)](https://app.travis-ci.com/paul-buerkner/thurstonianIRT) 6 | [![CRAN 7 | Version](http://www.r-pkg.org/badges/version/thurstonianIRT)](https://cran.r-project.org/package=thurstonianIRT) 8 | 9 | ## Overview 10 | 11 | The **thurstonianIRT** package allows to fit various models from [Item 12 | Response Theory 13 | (IRT)](https://en.wikipedia.org/wiki/Item_response_theory) for 14 | forced-choice questionnaires, most notably the Thurstonian IRT model 15 | originally proposed by (Brown & Maydeu-Olivares, 2011). IRT in general 16 | comes with several advantages over classical test theory, for instance, 17 | the ability to model varying item difficulties as well as item factor 18 | loadings on the participants’ traits they are supposed to measure. 19 | Moreover, if multiple traits are modeled at the same time, their 20 | correlation can be incorporated into an IRT model to improve the overall 21 | estimation accuracy. The key characteristic of forced-choice 22 | questionnaires is that participants cannot endorse all items at the same 23 | time and instead have to make a comparative judgment between two or more 24 | items. Such a format comes with the hope of providing more valid 25 | inference in situation where participants have motivation to not answer 26 | honestly (e.g., in personnel selection), but instead respond in a way 27 | that appears favorable in the given situation. Whether forced-choice 28 | questionnaires and the corresponding IRT models live up to this hope 29 | remains a topic of debate (e.g., see Bürkner, Schulte, & Holling, 2019) 30 | but it is in any case necessary to provide software for fitting these 31 | statistical models both for practical and research purposes. 32 | 33 | In the original formulation, the Thurstonian IRT model works on 34 | dichotomous pairwise comparisons and models the probability of endorsing 35 | one versus the other item. This probability depends on parameters 36 | related to the items under comparison as well as on parameters related 37 | to the participants’ latent traits which are assumed to be measured by 38 | the items. For more details see Brown and Maydeu-Olivares (2011), Brown 39 | and Maydeu-Olivares (2012), and Bürkner et al. (2019). 40 | 41 | ## How to use thurstonianIRT 42 | 43 | ``` r 44 | library(thurstonianIRT) 45 | ``` 46 | 47 | As a simple example consider a data set of 4 blocks each containing 3 48 | items (i.e., triplets) answered by 200 participants. 49 | 50 | ``` r 51 | data("triplets") 52 | head(triplets) 53 | #> i1i2 i1i3 i2i3 i4i5 i4i6 i5i6 i7i8 i7i9 i8i9 i10i11 i10i12 i11i12 54 | #> 1 1 0 0 1 0 0 1 1 1 0 1 1 55 | #> 2 0 0 1 0 0 0 0 0 1 0 0 0 56 | #> 3 0 0 1 0 0 1 0 1 1 0 0 0 57 | #> 4 0 0 1 1 1 0 1 1 0 0 0 0 58 | #> 5 1 1 1 0 0 1 1 1 0 1 0 0 59 | #> 6 1 1 1 0 0 1 1 0 0 0 1 1 60 | ``` 61 | 62 | In the data set, a 1 indicates that the first item has been selected 63 | over the second item while a 0 indicates that the second items has been 64 | selected over the first item. In order to fit a Thurstonian IRT model on 65 | this data, we have to tell **thurstonianIRT** about the block structure 66 | of the items, the traits on which the items load, and the sign of these 67 | loadings, that is, whether items have been inverted. For the present 68 | data, we specify this as follows: 69 | 70 | ``` r 71 | blocks <- 72 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 73 | signs = c(1, 1, 1)) + 74 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 75 | signs = c(-1, 1, 1)) + 76 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 77 | signs = c(1, 1, -1)) + 78 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 79 | signs = c(1, -1, 1)) 80 | ``` 81 | 82 | Next, we transform the data into a format that **thurstonianIRT** 83 | understands. 84 | 85 | ``` r 86 | triplets_long <- make_TIRT_data( 87 | data = triplets, blocks = blocks, direction = "larger", 88 | format = "pairwise", family = "bernoulli", range = c(0, 1) 89 | ) 90 | head(triplets_long) 91 | #> # A tibble: 6 × 11 92 | #> person block comparison itemC trait1 trait2 item1 item2 sign1 sign2 response 93 | #> 94 | #> 1 1 1 1 1 t1 t2 i1 i2 1 1 1 95 | #> 2 2 1 1 1 t1 t2 i1 i2 1 1 0 96 | #> 3 3 1 1 1 t1 t2 i1 i2 1 1 0 97 | #> 4 4 1 1 1 t1 t2 i1 i2 1 1 0 98 | #> 5 5 1 1 1 t1 t2 i1 i2 1 1 1 99 | #> 6 6 1 1 1 t1 t2 i1 i2 1 1 1 100 | ``` 101 | 102 | Finally, we can fit the model using several model fitting engines. 103 | Currently supported are [Stan](https://mc-stan.org/), 104 | [lavaan](https://lavaan.ugent.be/), and 105 | [Mplus](http://www.statmodel.com/). Here, we choose Stan to fit the 106 | Thurstonian IRT model in a Bayesian framework. 107 | 108 | ``` r 109 | fit <- fit_TIRT_stan(triplets_long, chains = 1) 110 | ``` 111 | 112 | As basic summary and convergence checks can be obtained via 113 | 114 | ``` r 115 | print(fit) 116 | ``` 117 | 118 | Finally, we obtain predictions of participants’ trait scores in a tidy 119 | data format via 120 | 121 | ``` r 122 | pr <- predict(fit) 123 | head(pr) 124 | #> # A tibble: 6 × 6 125 | #> id trait estimate se lower_ci upper_ci 126 | #> 127 | #> 1 1 t1 0.302 0.515 -0.607 1.36 128 | #> 2 1 t2 -1.26 0.548 -2.38 -0.197 129 | #> 3 1 t3 0.338 0.502 -0.685 1.33 130 | #> 4 2 t1 -0.966 0.532 -2.04 0.0653 131 | #> 5 2 t2 0.881 0.598 -0.174 2.05 132 | #> 6 2 t3 0.703 0.596 -0.401 1.92 133 | ``` 134 | 135 | The thurstonianIRT package not only comes with model fitting functions 136 | but also with the possibility to simulate data from Thurstonian IRT 137 | models. Below we simulate data with a very similar structure to the 138 | `triplets` data set we have used above. 139 | 140 | ``` r 141 | sim_data <- sim_TIRT_data( 142 | npersons = 200, 143 | ntraits = 3, 144 | nblocks_per_trait = 4, 145 | gamma = 0, 146 | lambda = runif(12, 0.5, 1), 147 | Phi = diag(3) 148 | ) 149 | #> Computing standardized psi^2 as 1 - lambda^2 150 | head(sim_data) 151 | #> # A tibble: 6 × 19 152 | #> person block comparison itemC trait1 trait2 item1 item2 sign1 sign2 gamma lambda1 153 | #> 154 | #> 1 1 1 1 1 3 1 1 2 1 1 0 0.970 155 | #> 2 2 1 1 1 3 1 1 2 1 1 0 0.970 156 | #> 3 3 1 1 1 3 1 1 2 1 1 0 0.970 157 | #> 4 4 1 1 1 3 1 1 2 1 1 0 0.970 158 | #> 5 5 1 1 1 3 1 1 2 1 1 0 0.970 159 | #> 6 6 1 1 1 3 1 1 2 1 1 0 0.970 160 | #> # ℹ 7 more variables: lambda2 , psi1 , psi2 , eta1 , eta2 , 161 | #> # mu , response 162 | ``` 163 | 164 | The structure of the data is the same as what we obtain via the 165 | `make_TIRT_data` function and can readily be passed to the model fitting 166 | functions. 167 | 168 | ## FAQ 169 | 170 | ### How to install thurstonianIRT 171 | 172 | To install the latest release version from CRAN use 173 | 174 | ``` r 175 | install.packages("thurstonianIRT") 176 | ``` 177 | 178 | The current developmental version can be downloaded from github via 179 | 180 | ``` r 181 | if (!requireNamespace("remotes")) { 182 | install.packages("remotes") 183 | } 184 | remotes::install_github("paul-buerkner/thurstonianIRT") 185 | ``` 186 | 187 | ### I am new to thurstonianIRT. Where can I start? 188 | 189 | After reading the README, you probably have a good overview already over 190 | the packages purporse and main functionality. You can dive deeper by 191 | reading the package’s documentation perhaps starting with 192 | `help("thurstonianIRT")`. If you want to perform a simulation study with 193 | the package, I recommend you take a look at 194 | `vignette("TIRT_sim_tests")`. 195 | 196 | ### Where do I ask questions, propose a new feature, or report a bug? 197 | 198 | To ask a question, propose a new feature or report a bug, please open an 199 | issue on [GitHub](https://github.com/paul-buerkner/thurstonianIRT). 200 | 201 | ### How can I contribute to thurstonianIRT? 202 | 203 | If you want to contribute to thurstonianIRT, you can best do this via 204 | the package’s [GitHub](https://github.com/paul-buerkner/thurstonianIRT) 205 | page. There, you can fork the repository, open new issues (e.g., to 206 | report a bug), or make pull requests to improve the software and 207 | documentation. I am grateful for all kinds of contributions, even if 208 | they are just as small as fixing a typo in the documentation. 209 | 210 | ## References 211 | 212 | Brown, A., & Maydeu-Olivares, A. (2011). Item response modeling of 213 | forced-choice questionnaires. *Educational and Psychological 214 | Measurement*, 71(3), 460-502. 215 | 216 | 217 | Brown, A., & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model 218 | to forced-choice data using Mplus. *Behavior Research Methods*, 44(4), 219 | 1135-1147. 220 | 221 | Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and 222 | Practical Limitations of Thurstonian IRT Models. *Educational and 223 | Psychological Measurement.* 224 | 225 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | #! /bin/sh 4 | "${R_HOME}/bin/Rscript" -e "rstantools::rstan_config()" 5 | -------------------------------------------------------------------------------- /configure.win: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | #! /bin/sh 4 | "${R_HOME}/bin${R_ARCH_BIN}/Rscript.exe" -e "rstantools::rstan_config()" 5 | -------------------------------------------------------------------------------- /data/triplets.rda: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/paul-buerkner/thurstonianIRT/fd7f134a7308cd69dc94a3030413baa3359347e9/data/triplets.rda -------------------------------------------------------------------------------- /doc/TIRT_sim_tests.R: -------------------------------------------------------------------------------- 1 | params <- 2 | list(EVAL = TRUE) 3 | 4 | ## ---- SETTINGS-knitr, include=FALSE----------------------------------------------------- 5 | stopifnot(require(knitr)) 6 | options(width = 90) 7 | opts_chunk$set( 8 | comment = NA, 9 | message = FALSE, 10 | warning = FALSE, 11 | eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, 12 | dev = "png", 13 | dpi = 150, 14 | fig.asp = 0.8, 15 | fig.width = 5, 16 | out.width = "60%", 17 | fig.align = "center" 18 | ) 19 | 20 | ## --------------------------------------------------------------------------------------- 21 | library(thurstonianIRT) 22 | library(dplyr) 23 | library(tidyr) 24 | 25 | ## --------------------------------------------------------------------------------------- 26 | set.seed(1234) 27 | npersons <- 500 28 | ntraits <- 5 29 | nitems_per_block <- 3 30 | nblocks_per_trait <- 9 31 | nblocks <- ntraits * nblocks_per_trait / nitems_per_block 32 | nitems <- ntraits * nblocks_per_trait 33 | ncomparisons <- (nitems_per_block * (nitems_per_block - 1)) / 2 * nblocks 34 | 35 | ## --------------------------------------------------------------------------------------- 36 | set.seed(1234) 37 | lambda <- runif(nitems, 0.65, 0.96) 38 | signs <- c(rep(1, ceiling(nitems / 2)), rep(-1, floor(nitems / 2))) 39 | lambda <- lambda * signs[sample(seq_len(nitems))] 40 | gamma <- runif(nitems, -1, 1) 41 | Phi <- diag(5) 42 | 43 | ## --------------------------------------------------------------------------------------- 44 | sdata <- sim_TIRT_data( 45 | npersons = npersons, 46 | ntraits = ntraits, 47 | nitems_per_block = nitems_per_block, 48 | nblocks_per_trait = nblocks_per_trait, 49 | gamma = gamma, 50 | lambda = lambda, 51 | Phi = Phi 52 | ) 53 | 54 | ## ---- results="hide"-------------------------------------------------------------------- 55 | fit_stan <- fit_TIRT_stan(sdata, chains = 1, iter = 1000, warmup = 500) 56 | fit_lavaan <- fit_TIRT_lavaan(sdata) 57 | fit_mplus <- fit_TIRT_mplus(sdata) 58 | 59 | ## --------------------------------------------------------------------------------------- 60 | eta <- as_tibble(as.data.frame(attributes(sdata)$eta)) 61 | names(eta) <- paste0("trait", 1:ncol(eta)) 62 | true_scores <- eta %>% 63 | mutate(id = 1:n()) %>% 64 | gather(key = "trait", value = "truth", -id) 65 | true_summaries <- true_scores %>% 66 | group_by(trait) %>% 67 | summarise(true_mean = mean(truth), true_sd = sd(truth)) 68 | 69 | pred <- predict(fit_stan) %>% 70 | bind_rows(predict(fit_lavaan), predict(fit_mplus), .id = "source") %>% 71 | mutate( 72 | source = as.character(factor( 73 | source, levels = 1:3, labels = c("stan", "lavaan", "mplus") 74 | )), 75 | trait = tolower(trait) 76 | ) %>% 77 | inner_join(true_scores, by = c("id", "trait")) 78 | 79 | pred <- pred %>% 80 | inner_join( 81 | pred %>% 82 | group_by(trait, source) %>% 83 | summarise(cor_est_truth = cor(estimate, truth)), 84 | by = c("trait", "source") 85 | ) %>% 86 | mutate( 87 | sign = sign(cor_est_truth), 88 | estimate = ifelse(sign %in% -1, -estimate, estimate) 89 | ) %>% 90 | inner_join(true_summaries, by = "trait") %>% 91 | group_by(trait, source) %>% 92 | mutate( 93 | est_mean = mean(estimate), 94 | est_sd = sd(estimate) 95 | ) %>% 96 | ungroup() %>% 97 | mutate( 98 | ztruth = (truth - true_mean) / true_sd, 99 | zestimate = (estimate - est_mean) / est_sd 100 | ) 101 | 102 | ## --------------------------------------------------------------------------------------- 103 | res <- pred %>% 104 | group_by(trait, source) %>% 105 | summarise(rel = cor(estimate, truth)^2) 106 | 107 | res 108 | 109 | ## ---- include = FALSE------------------------------------------------------------------- 110 | testthat::expect_true(all(res$rel > 0.84)) 111 | 112 | ## --------------------------------------------------------------------------------------- 113 | cor_matrix <- pred %>% 114 | mutate( 115 | # ensure correct ordering of traits 116 | SC = paste0(source, "_", trait), 117 | SC = factor(SC, levels = unique(SC)) 118 | ) %>% 119 | select(id, SC, estimate) %>% 120 | spread(key = "SC", value = "estimate") %>% 121 | bind_cols(eta, .) %>% 122 | select(-id) %>% 123 | cor() 124 | 125 | ## --------------------------------------------------------------------------------------- 126 | trait1 <- paste0(c("stan", "lavaan", "mplus"), "_trait1") 127 | round(cor_matrix[trait1, trait1], 2) 128 | 129 | ## ---- include = FALSE------------------------------------------------------------------- 130 | for (i in 1:ntraits) { 131 | trait_cols <- paste0(c("stan", "lavaan", "mplus"), "_trait", i) 132 | testthat::expect_true(all(cor_matrix[trait_cols, trait_cols] > 0.97)) 133 | } 134 | 135 | -------------------------------------------------------------------------------- /doc/TIRT_sim_tests.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Test parameter recovery via simulations with thurstonianIRT" 3 | author: "Paul Bürkner" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | toc: yes 8 | vignette: > 9 | %\VignetteIndexEntry{Test parameter recovery via simulations with thurstonianIRT} 10 | \usepackage[utf8]{inputenc} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | params: 13 | EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") 14 | editor_options: 15 | chunk_output_type: console 16 | --- 17 | 18 | ```{r, SETTINGS-knitr, include=FALSE} 19 | stopifnot(require(knitr)) 20 | options(width = 90) 21 | opts_chunk$set( 22 | comment = NA, 23 | message = FALSE, 24 | warning = FALSE, 25 | eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, 26 | dev = "png", 27 | dpi = 150, 28 | fig.asp = 0.8, 29 | fig.width = 5, 30 | out.width = "60%", 31 | fig.align = "center" 32 | ) 33 | ``` 34 | 35 | # Introduction 36 | 37 | In this vignette, we will perform a small simulation study to 38 | test whether the model fitting engines implemented in the thurstonianIRT 39 | package are able to recover known parameter values from a simulated data set. 40 | This also extends the automated unit tests implemented in the package 41 | to check the correctness of the software. The simulation design used below 42 | was inspired by Brown and Maydeu-Olivares (2012). For a more extensive simulation 43 | study using thurstonianIRT, see Bürkner, Schulte, and Holling (2019). 44 | 45 | First, we will load a bunch of packages required in the vignette. 46 | ```{r} 47 | library(thurstonianIRT) 48 | library(dplyr) 49 | library(tidyr) 50 | ``` 51 | 52 | Next, we will set up the simulation condition. 53 | ```{r} 54 | set.seed(1234) 55 | npersons <- 500 56 | ntraits <- 5 57 | nitems_per_block <- 3 58 | nblocks_per_trait <- 9 59 | nblocks <- ntraits * nblocks_per_trait / nitems_per_block 60 | nitems <- ntraits * nblocks_per_trait 61 | ncomparisons <- (nitems_per_block * (nitems_per_block - 1)) / 2 * nblocks 62 | ``` 63 | 64 | Now, we will choose a set of true parameter values. 65 | ```{r} 66 | set.seed(1234) 67 | lambda <- runif(nitems, 0.65, 0.96) 68 | signs <- c(rep(1, ceiling(nitems / 2)), rep(-1, floor(nitems / 2))) 69 | lambda <- lambda * signs[sample(seq_len(nitems))] 70 | gamma <- runif(nitems, -1, 1) 71 | Phi <- diag(5) 72 | ``` 73 | 74 | Finally, we put all of this together and simulate a data set based 75 | on the condion and true parameter values. 76 | ```{r} 77 | sdata <- sim_TIRT_data( 78 | npersons = npersons, 79 | ntraits = ntraits, 80 | nitems_per_block = nitems_per_block, 81 | nblocks_per_trait = nblocks_per_trait, 82 | gamma = gamma, 83 | lambda = lambda, 84 | Phi = Phi 85 | ) 86 | ``` 87 | 88 | We know that the chosen simulation condition and parameter values are well 89 | behaved (this may not be the case in all situations; see Bürkner, Schulte, & 90 | Holling, 2019). Accordingly, the model fitting engines should show good 91 | parameter recovery given that they are correctly implemented. We will now go 92 | ahead and fit the model with all three engines. 93 | ```{r, results="hide"} 94 | fit_stan <- fit_TIRT_stan(sdata, chains = 1, iter = 1000, warmup = 500) 95 | fit_lavaan <- fit_TIRT_lavaan(sdata) 96 | fit_mplus <- fit_TIRT_mplus(sdata) 97 | ``` 98 | 99 | We can now predict the trait scores of all persons and compare them 100 | to the true scores, which are stored in the simulated data set. 101 | ```{r} 102 | eta <- as_tibble(as.data.frame(attributes(sdata)$eta)) 103 | names(eta) <- paste0("trait", 1:ncol(eta)) 104 | true_scores <- eta %>% 105 | mutate(id = 1:n()) %>% 106 | gather(key = "trait", value = "truth", -id) 107 | true_summaries <- true_scores %>% 108 | group_by(trait) %>% 109 | summarise(true_mean = mean(truth), true_sd = sd(truth)) 110 | 111 | pred <- predict(fit_stan) %>% 112 | bind_rows(predict(fit_lavaan), predict(fit_mplus), .id = "source") %>% 113 | mutate( 114 | source = as.character(factor( 115 | source, levels = 1:3, labels = c("stan", "lavaan", "mplus") 116 | )), 117 | trait = tolower(trait) 118 | ) %>% 119 | inner_join(true_scores, by = c("id", "trait")) 120 | 121 | pred <- pred %>% 122 | inner_join( 123 | pred %>% 124 | group_by(trait, source) %>% 125 | summarise(cor_est_truth = cor(estimate, truth)), 126 | by = c("trait", "source") 127 | ) %>% 128 | mutate( 129 | sign = sign(cor_est_truth), 130 | estimate = ifelse(sign %in% -1, -estimate, estimate) 131 | ) %>% 132 | inner_join(true_summaries, by = "trait") %>% 133 | group_by(trait, source) %>% 134 | mutate( 135 | est_mean = mean(estimate), 136 | est_sd = sd(estimate) 137 | ) %>% 138 | ungroup() %>% 139 | mutate( 140 | ztruth = (truth - true_mean) / true_sd, 141 | zestimate = (estimate - est_mean) / est_sd 142 | ) 143 | ``` 144 | 145 | Various measures of model predictive accuracy can be computed, for instance, 146 | the reliability. For the present simulation condition, we would expect 147 | the reliability to be roughly between 0.85 and 0.9 for all traits. 148 | By looking at the results below, we can verify that this is indeed that case. 149 | ```{r} 150 | res <- pred %>% 151 | group_by(trait, source) %>% 152 | summarise(rel = cor(estimate, truth)^2) 153 | 154 | res 155 | ``` 156 | 157 | ```{r, include = FALSE} 158 | testthat::expect_true(all(res$rel > 0.84)) 159 | ``` 160 | 161 | Lastly, we can also compute and investigate the trait correlations between 162 | different engines so check whether they really estimate equivalent trait scores. 163 | ```{r} 164 | cor_matrix <- pred %>% 165 | mutate( 166 | # ensure correct ordering of traits 167 | SC = paste0(source, "_", trait), 168 | SC = factor(SC, levels = unique(SC)) 169 | ) %>% 170 | select(id, SC, estimate) %>% 171 | spread(key = "SC", value = "estimate") %>% 172 | bind_cols(eta, .) %>% 173 | select(-id) %>% 174 | cor() 175 | ``` 176 | 177 | We would expect the correlations of the estimates of the same trait across 178 | engines to be very high, that is, higher than 0.95 at least. 179 | We can verify that this is indeed the case as exemplified for `trait1` below. 180 | ```{r} 181 | trait1 <- paste0(c("stan", "lavaan", "mplus"), "_trait1") 182 | round(cor_matrix[trait1, trait1], 2) 183 | ``` 184 | 185 | ```{r, include = FALSE} 186 | for (i in 1:ntraits) { 187 | trait_cols <- paste0(c("stan", "lavaan", "mplus"), "_trait", i) 188 | testthat::expect_true(all(cor_matrix[trait_cols, trait_cols] > 0.97)) 189 | } 190 | ``` 191 | 192 | Taken together, we have seen how to set up and perform a simple simulation 193 | study to test the parameter recovery of Thurstonian IRT models and, at the 194 | same time, test the correctness of the thurstonianIRT software. 195 | 196 | # References 197 | 198 | Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and Practical 199 | Limitations of Thurstonian IRT Models. *Educational and Psychological 200 | Measurement*. 79(5). 827–854. 201 | 202 | Brown, A. & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model to forced-choice data using Mplus. Behavior Research Methods, 44, 1135–1147. DOI: 10.3758/s13428-012-0217-x 203 | -------------------------------------------------------------------------------- /doc/TIRT_sim_tests.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | Test parameter recovery via simulations with thurstonianIRT 19 | 20 | 21 | 22 | 23 | 87 | 108 | 109 | 110 | 111 | 294 | 295 | 296 | 297 | 298 | 299 | 300 | 301 | 302 | 303 | 304 | 305 |

Test parameter recovery via simulations with thurstonianIRT

306 |

Paul Bürkner

307 |

2019-10-04

308 | 309 | 310 | 311 |
312 |

Introduction

313 |

In this vignette, we will perform a small simulation study to test whether the model fitting engines implemented in the thurstonianIRT package are able to recover known parameter values from a simulated data set. This also extends the automated unit tests implemented in the package to check the correctness of the software. he simulation design used below was inspired by Brown and Maydeu-Olivares (2012). For a more extensive simulation study using thurstonianIRT, see Bürkner, Schulte, and Holling (2019).

314 |

First, we will load a bunch of packages required in the vignette.

315 | 318 |

Next, we will set up the simulation condition.

319 | 327 |

Now, we will choose a set of true parameter values.

328 | 334 |

Finally, we put all of this together and simulate a data set based on the condion and true parameter values.

335 | 344 |

We know that the chosen simulation condition and parameter values are well behaved (this may not be the case in all situations; see Bürkner, Schulte, & Holling, 2019). Accordingly, the model fitting engines should show good parameter recovery given that they are correctly implemented. We will now go ahead and fit the model with all three engines.

345 | 348 |

We can now predict the trait scores of all persons and compare them to the true scores, which are stored in the simulated data set.

349 | 390 |

Various measures of model predictive accuracy can be computed, for instance, the reliability. For the present simulation condition, we would expect the reliability to be roughly between 0.85 and 0.9 for all traits. By looking at the results below, we can verify that this is indeed that case.

391 | 396 | 
# A tibble: 15 x 3
397 | # Groups:   trait [5]
398 |    trait  source   rel
399 |    <chr>  <chr>  <dbl>
400 |  1 trait1 lavaan 0.857
401 |  2 trait1 mplus  0.889
402 |  3 trait1 stan   0.890
403 |  4 trait2 lavaan 0.852
404 |  5 trait2 mplus  0.871
405 |  6 trait2 stan   0.873
406 |  7 trait3 lavaan 0.888
407 |  8 trait3 mplus  0.902
408 |  9 trait3 stan   0.902
409 | 10 trait4 lavaan 0.877
410 | 11 trait4 mplus  0.899
411 | 12 trait4 stan   0.900
412 | 13 trait5 lavaan 0.873
413 | 14 trait5 mplus  0.887
414 | 15 trait5 stan   0.889
415 |

Lastly, we can also compute and investigate the trait correlations between different engines so check whether they really estimate equivalent trait scores.

416 | 427 |

We would expect the correlations of the estimates of the same trait across engines to be very high, that is, higher than 0.95 at least. We can verify that this is indeed the case as exemplified for trait1 below.

428 | 430 | 
              stan_trait1 lavaan_trait1 mplus_trait1
431 | stan_trait1          1.00          0.98         1.00
432 | lavaan_trait1        0.98          1.00         0.98
433 | mplus_trait1         1.00          0.98         1.00
434 |

Taken together, we have seen how to set up and perform a simple simulation study to test the parameter recovery of Thurstonian IRT models and, at the same time, test the correctness of the thurstonianIRT software.

435 |
436 |
437 |

References

438 |

Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and Practical Limitations of Thurstonian IRT Models. Educational and Psychological Measurement. 79(5). 827–854.

439 |

Brown, A. & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model to forced-choice data using Mplus. Behavior Research Methods, 44, 1135–1147. DOI: 10.3758/s13428-012-0217-x

440 |
441 | 442 | 443 | 444 | 445 | 446 | 447 | 448 | 456 | 457 | 458 | 459 | -------------------------------------------------------------------------------- /inst/include/stan_meta_header.hpp: -------------------------------------------------------------------------------- 1 | // Insert all #include statements here 2 | -------------------------------------------------------------------------------- /inst/stan/include/data-shared.stan: -------------------------------------------------------------------------------- 1 | // model type 2 | int family; 3 | // family == 1: bernoulli 4 | // family == 2: cumulative 5 | // family == 3: gaussian 6 | // family == 4: beta 7 | int N; // total number of observations 8 | // response variable 9 | array[family == 1 || family == 2 ? N : 0] int Yint; 10 | array[family == 3 || family == 4 ? N : 0] real Yreal; 11 | int N_item; 12 | int N_itemC; // item pairs 13 | int N_person; 14 | int N_trait; 15 | int N_item_fix; 16 | int N_item_est; 17 | // indices over N 18 | array[N] int J_item1; 19 | array[N] int J_item2; 20 | array[N] int J_itemC; 21 | array[N] int J_person; 22 | array[N] int J_trait1; 23 | array[N] int J_trait2; 24 | array[N_item_fix] int J_item_fix; 25 | array[N_item_est] int J_item_est; 26 | // indicate inverted items 27 | int N_item_pos; 28 | int N_item_neg; 29 | array[N_item_pos] int J_item_pos; 30 | array[N_item_neg] int J_item_neg; 31 | // indicate items used in multiple blocks 32 | int N_item_equal; 33 | array[N_item_equal] int J_item_equal; 34 | array[N_item_equal] int J_item_orig; 35 | // number of response categories in ordinal models 36 | // should be set to 2 for other families 37 | int ncat; 38 | -------------------------------------------------------------------------------- /inst/stan/include/functions-cumulative_Phi_lpmf.stan: -------------------------------------------------------------------------------- 1 | /* cumulative log-PDF for a single response 2 | * assumes the latent variable to be normal 3 | * Args: 4 | * y: response category 5 | * mu: linear predictor 6 | * thres: ordinal thresholds 7 | * Returns: 8 | * a scalar to be added to the log posterior 9 | */ 10 | real cumulative_Phi_lpmf(int y, real mu, vector thres) { 11 | int ncat = num_elements(thres) + 1; 12 | real p; 13 | if (y == 0) { 14 | p = Phi(thres[1] - mu); 15 | } else if (y == ncat - 1) { 16 | p = 1 - Phi(thres[ncat - 1] - mu); 17 | } else { 18 | p = Phi(thres[y + 1] - mu) - Phi(thres[y] - mu); 19 | } 20 | return log(p); 21 | } 22 | -------------------------------------------------------------------------------- /inst/stan/include/license.stan: -------------------------------------------------------------------------------- 1 | /* 2 | thurstonianIRT is free software: you can redistribute it and/or modify 3 | it under the terms of the GNU General Public License as published by 4 | the Free Software Foundation, either version 3 of the License, or 5 | (at your option) any later version. 6 | 7 | thurstonianIRT is distributed in the hope that it will be useful, 8 | but WITHOUT ANY WARRANTY; without even the implied warranty of 9 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 10 | GNU General Public License for more details. 11 | 12 | You should have received a copy of the GNU General Public License 13 | along with thurstonianIRT. If not, see . 14 | */ 15 | -------------------------------------------------------------------------------- /inst/stan/include/model-likelihood.stan: -------------------------------------------------------------------------------- 1 | vector[N] mu; 2 | vector[N] sum_psi; 3 | for (n in 1:N) { 4 | // compute linear predictor 5 | mu[n] = r[J_item1[n]] - r[J_item2[n]] + 6 | lambda[J_item1[n]] * eta[J_person[n], J_trait1[n]] - 7 | lambda[J_item2[n]] * eta[J_person[n], J_trait2[n]]; 8 | // compute item-comparison standard deviations 9 | sum_psi[n] = sqrt(psi[J_item1[n]]^2 + psi[J_item2[n]]^2); 10 | } 11 | // likelihood contributions 12 | if (family == 1) { 13 | // bernoulli models 14 | for (n in 1:N) { 15 | // use - gamma for consistency with Brown et al. 2011 16 | mu[n] = Phi((mu[n] - gamma[J_itemC[n]]) / sum_psi[n]); 17 | } 18 | Yint ~ bernoulli(mu); 19 | } else if (family == 2) { 20 | // cumulative models 21 | for (n in 1:N) { 22 | // scale quantities 23 | vector[ncat - 1] thres = gamma_ord[J_itemC[n]] / sum_psi[n]; 24 | mu[n] /= sum_psi[n]; 25 | // likelihood contribution 26 | Yint[n] ~ cumulative_Phi(mu[n], thres); 27 | } 28 | } else if (family == 3) { 29 | // gaussian models 30 | for (n in 1:N) { 31 | mu[n] = mu[n] - gamma[J_itemC[n]]; 32 | } 33 | // SD = 1 is arbitrary as the residuals r are already part of mu 34 | Yreal ~ normal(mu, 1); 35 | } else if (family == 4) { 36 | // beta models 37 | for (n in 1:N) { 38 | mu[n] = Phi((mu[n] - gamma[J_itemC[n]]) / sum_psi[n]); 39 | } 40 | Yreal ~ beta(mu * disp[1], (1 - mu) * disp[1]); 41 | } 42 | // prior specifications 43 | if (family == 2) { 44 | for (i in 1:N_itemC) { 45 | gamma_ord[i] ~ normal(0, 3); 46 | } 47 | } else { 48 | gamma ~ normal(0, 3); 49 | } 50 | -------------------------------------------------------------------------------- /inst/stan/thurstonian_irt_model.stan: -------------------------------------------------------------------------------- 1 | functions { 2 | #include /include/functions-cumulative_Phi_lpmf.stan 3 | } 4 | data { 5 | #include /include/data-shared.stan 6 | } 7 | transformed data { 8 | vector[N_item_fix] psi_fix; // fixed item SDs 9 | psi_fix = rep_vector(1.0, N_item_fix); 10 | } 11 | parameters { 12 | // item thresholds depend on the family 13 | vector[family == 1 || family == 3 || family == 4 ? N_itemC : 0] gamma; 14 | array[family == 2 ? N_itemC : 0] ordered[ncat - 1] gamma_ord; 15 | vector[N_item_pos] lambda_pos; // item loadings 16 | vector[N_item_neg] lambda_neg; // item loadings 17 | vector[N_item_est] psi_est; // estimated item SDs 18 | // unscaled group level effects of traits within persons 19 | matrix[N_trait, N_person] z_trait; 20 | // cholesky factor of correlation matrix of traits 21 | cholesky_factor_corr[N_trait] L_trait; 22 | vector[N_item] z; // unscaled random effects 23 | // dispersion parameter of the beta family 24 | // TODO: make comparison-specific? 25 | vector[family == 4 ? 1 : 0] disp; 26 | } 27 | transformed parameters { 28 | // latent traits per person 29 | matrix[N_person, N_trait] eta; 30 | vector[N_item] lambda; // item loadings 31 | vector[N_item] psi; // item SDs 32 | vector[N_item] r; // item random effects (residuals) 33 | eta = (L_trait * z_trait)'; 34 | psi[J_item_fix] = psi_fix; 35 | psi[J_item_est] = psi_est; 36 | psi[J_item_equal] = psi[J_item_orig]; 37 | lambda[J_item_pos] = lambda_pos; 38 | lambda[J_item_neg] = lambda_neg; 39 | lambda[J_item_equal] = lambda[J_item_orig]; 40 | // accounts for the correlations within the same block 41 | r = psi .* z; 42 | } 43 | model { 44 | #include /include/model-likelihood.stan 45 | lambda_pos ~ normal(1, 0.5); 46 | lambda_neg ~ normal(-1, 0.5); 47 | psi_est ~ normal(1, 0.3); 48 | L_trait ~ lkj_corr_cholesky(1); 49 | to_vector(z_trait) ~ normal(0, 1); 50 | z ~ normal(0, 1); 51 | } 52 | generated quantities { 53 | // Cor_trait is Phi 54 | corr_matrix[N_trait] Cor_trait; 55 | Cor_trait = multiply_lower_tri_self_transpose(L_trait); 56 | } 57 | -------------------------------------------------------------------------------- /inst/stan/thurstonian_irt_model_newdata.stan: -------------------------------------------------------------------------------- 1 | functions { 2 | #include /include/functions-cumulative_Phi_lpmf.stan 3 | } 4 | data { 5 | #include /include/data-shared.stan 6 | // fix item parameters and person hyperparameters 7 | // for predictions of parameters for new persons 8 | vector[N_item] lambda; // item loadings 9 | vector[N_item] psi; // item SDs 10 | vector[N_item] r; // item random effects (residuals) 11 | // item thresholds depend on the family 12 | vector[family == 1 || family == 3 || family == 4 ? N_itemC : 0] gamma; 13 | array[family == 2 ? N_itemC : 0] ordered[ncat - 1] gamma_ord; 14 | // dispersion parameter of the beta family 15 | vector[family == 4 ? 1 : 0] disp; 16 | // cholesky factor of correlation matrix of traits 17 | cholesky_factor_corr[N_trait] L_trait; 18 | } 19 | transformed data { 20 | } 21 | parameters { 22 | // unscaled group level effects of traits within persons 23 | matrix[N_trait, N_person] z_trait; 24 | } 25 | transformed parameters { 26 | // latent traits per person 27 | matrix[N_person, N_trait] eta; 28 | eta = (L_trait * z_trait)'; 29 | } 30 | model { 31 | #include /include/model-likelihood.stan 32 | to_vector(z_trait) ~ normal(0, 1); 33 | } 34 | generated quantities { 35 | } 36 | -------------------------------------------------------------------------------- /man/cor_matrix.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/misc.R 3 | \name{cor_matrix} 4 | \alias{cor_matrix} 5 | \title{Set up Correlation Matrices} 6 | \usage{ 7 | cor_matrix(cors, dim, dimnames = NULL) 8 | } 9 | \arguments{ 10 | \item{cors}{vector of unique correlations} 11 | 12 | \item{dim}{Dimension of the correlation matrix} 13 | 14 | \item{dimnames}{Optional dimnames of the correlation matrix} 15 | } 16 | \value{ 17 | A correlation \code{matrix} of dimension \code{dim}. 18 | } 19 | \description{ 20 | Set up Correlation Matrices 21 | } 22 | \examples{ 23 | cor_matrix(c(0.2, 0.3, 0.5), dim = 3) 24 | 25 | } 26 | -------------------------------------------------------------------------------- /man/fit_TIRT_lavaan.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lavaan.R 3 | \name{fit_TIRT_lavaan} 4 | \alias{fit_TIRT_lavaan} 5 | \title{Fit Thurstonian IRT models in lavaan} 6 | \usage{ 7 | fit_TIRT_lavaan(data, estimator = "ULSMV", ...) 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{'TIRTdata'}. see 11 | \code{\link{make_TIRT_data}} for documentation on how to create one.} 12 | 13 | \item{estimator}{Name of the estimator that should be used. 14 | See \code{\link[lavaan:lavOptions]{lavOptions}}.} 15 | 16 | \item{...}{Further arguments passed to 17 | \code{\link[lavaan:lavaan]{lavaan}}.} 18 | } 19 | \value{ 20 | A \code{'TIRTfit'} object. 21 | } 22 | \description{ 23 | Fit Thurstonian IRT models in lavaan 24 | } 25 | \examples{ 26 | # load the data 27 | data("triplets") 28 | 29 | # define the blocks of items 30 | blocks <- 31 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 32 | signs = c(1, 1, 1)) + 33 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 34 | signs = c(-1, 1, 1)) + 35 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 36 | signs = c(1, 1, -1)) + 37 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 38 | signs = c(1, -1, 1)) 39 | 40 | # generate the data to be understood by 'thurstonianIRT' 41 | triplets_long <- make_TIRT_data( 42 | data = triplets, blocks = blocks, direction = "larger", 43 | format = "pairwise", family = "bernoulli", range = c(0, 1) 44 | ) 45 | 46 | \donttest{ 47 | # fit the data using lavaan 48 | fit <- fit_TIRT_lavaan(triplets_long) 49 | print(fit) 50 | predict(fit) 51 | } 52 | 53 | } 54 | -------------------------------------------------------------------------------- /man/fit_TIRT_mplus.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mplus.R 3 | \name{fit_TIRT_mplus} 4 | \alias{fit_TIRT_mplus} 5 | \title{Fit Thurstonian IRT models in Mplus} 6 | \usage{ 7 | fit_TIRT_mplus(data, ...) 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{'TIRTdata'}. see 11 | \code{\link{make_TIRT_data}} for documentation on how to create one.} 12 | 13 | \item{...}{Further arguments passed to 14 | \code{\link[MplusAutomation:mplusModeler]{mplusModeler}}.} 15 | } 16 | \value{ 17 | A \code{'TIRTfit'} object. 18 | } 19 | \description{ 20 | Fit Thurstonian IRT models in Mplus 21 | } 22 | \examples{ 23 | # load the data 24 | data("triplets") 25 | 26 | # define the blocks of items 27 | blocks <- 28 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 29 | signs = c(1, 1, 1)) + 30 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 31 | signs = c(-1, 1, 1)) + 32 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 33 | signs = c(1, 1, -1)) + 34 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 35 | signs = c(1, -1, 1)) 36 | 37 | # generate the data to be understood by 'thurstonianIRT' 38 | triplets_long <- make_TIRT_data( 39 | data = triplets, blocks = blocks, direction = "larger", 40 | format = "pairwise", family = "bernoulli", range = c(0, 1) 41 | ) 42 | 43 | \dontrun{ 44 | # fit the data using Mplus 45 | fit <- fit_TIRT_mplus(triplets_long) 46 | print(fit) 47 | predict(fit) 48 | } 49 | 50 | } 51 | -------------------------------------------------------------------------------- /man/fit_TIRT_stan.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stan.R 3 | \name{fit_TIRT_stan} 4 | \alias{fit_TIRT_stan} 5 | \title{Fit Thurstonian IRT models in Stan} 6 | \usage{ 7 | fit_TIRT_stan(data, init = 0, ...) 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{'TIRTdata'}. see 11 | \code{\link{make_TIRT_data}} for documentation on how to create one.} 12 | 13 | \item{init}{Initial values of the parameters. 14 | Defaults to \code{0} as it proved to be most stable.} 15 | 16 | \item{...}{Further arguments passed to 17 | \code{\link[rstan:sampling]{rstan::sampling}}.} 18 | } 19 | \value{ 20 | A \code{'TIRTfit'} object. 21 | } 22 | \description{ 23 | Fit Thurstonian IRT models in Stan 24 | } 25 | \examples{ 26 | # load the data 27 | data("triplets") 28 | 29 | # define the blocks of items 30 | blocks <- 31 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 32 | signs = c(1, 1, 1)) + 33 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 34 | signs = c(-1, 1, 1)) + 35 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 36 | signs = c(1, 1, -1)) + 37 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 38 | signs = c(1, -1, 1)) 39 | 40 | # generate the data to be understood by 'thurstonianIRT' 41 | triplets_long <- make_TIRT_data( 42 | data = triplets, blocks = blocks, direction = "larger", 43 | format = "pairwise", family = "bernoulli", range = c(0, 1) 44 | ) 45 | 46 | \donttest{ 47 | # fit the data using Stan 48 | fit <- fit_TIRT_stan(triplets_long, chains = 1) 49 | print(fit) 50 | predict(fit) 51 | } 52 | 53 | } 54 | -------------------------------------------------------------------------------- /man/gof.TIRTfit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TIRTfit-methods.R 3 | \name{gof.TIRTfit} 4 | \alias{gof.TIRTfit} 5 | \alias{gof} 6 | \title{Extract corrected goodness of fit statistics} 7 | \usage{ 8 | \method{gof}{TIRTfit}(object, ...) 9 | 10 | gof(object, ...) 11 | } 12 | \arguments{ 13 | \item{object}{A \code{TIRTfit} object.} 14 | 15 | \item{...}{currently unused.} 16 | } 17 | \value{ 18 | A vector containing the chi-square value, adjusted degrees of 19 | freedom, p-value, and RMSEA. 20 | } 21 | \description{ 22 | By default \pkg{lavaan} will return a value for degrees of 23 | freedom that ignores redundancies amongst the estimated model 24 | thresholds. This function corrects the degrees of freedom, and 25 | then recalculates the associated chi-square test statistic 26 | p-value and root mean square error of approximation (RMSEA). 27 | } 28 | \details{ 29 | Note this function is currently only implemented for \pkg{lavaan}. 30 | } 31 | \examples{ 32 | # load the data 33 | data("triplets") 34 | 35 | # define the blocks of items 36 | blocks <- 37 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 38 | signs = c(1, 1, 1)) + 39 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 40 | signs = c(-1, 1, 1)) + 41 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 42 | signs = c(1, 1, -1)) + 43 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 44 | signs = c(1, -1, 1)) 45 | 46 | # generate the data to be understood by 'thurstonianIRT' 47 | triplets_long <- make_TIRT_data( 48 | data = triplets, blocks = blocks, direction = "larger", 49 | format = "pairwise", family = "bernoulli", range = c(0, 1) 50 | ) 51 | 52 | # fit the data using lavaan 53 | fit <- fit_TIRT_lavaan(triplets_long) 54 | gof(fit) 55 | 56 | } 57 | -------------------------------------------------------------------------------- /man/make_TIRT_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data-helpers.R 3 | \name{make_TIRT_data} 4 | \alias{make_TIRT_data} 5 | \title{Prepare data for Thurstonian IRT models} 6 | \usage{ 7 | make_TIRT_data( 8 | data, 9 | blocks, 10 | direction = c("larger", "smaller"), 11 | format = c("ranks", "pairwise"), 12 | family = "bernoulli", 13 | partial = FALSE, 14 | range = c(0, 1) 15 | ) 16 | } 17 | \arguments{ 18 | \item{data}{An object of class \code{data.frame} containing data of all 19 | variables used in the model.} 20 | 21 | \item{blocks}{Object of class \code{TIRTblocks} generated by 22 | \code{\link{set_block}} indicating which items belong to which block, trait 23 | and more. Ignored if data already contains information on the blocks.} 24 | 25 | \item{direction}{Indicates if \code{"larger"} (the default) or 26 | \code{"smaller"} input values are considered as indicating the favored 27 | answer.} 28 | 29 | \item{format}{Format of the item responses. Either \code{"ranks"} for 30 | responses in ranked format or \code{"pairwise"} for responses in pairwise 31 | comparison format. If \code{"ranks"}, each item must have its own 32 | column in the data frame which contains its ranks within the block. 33 | If \code{"pairwise"}, each existing item combination must have its 34 | own column named after the combination of the two compared items.} 35 | 36 | \item{family}{Name of assumed the response distribution. Either 37 | \code{"bernoulli"}, \code{"cumulative"}, or \code{"gaussian"}.} 38 | 39 | \item{partial}{A flag to indicate whether partial comparisons are allowed 40 | for responses stored in the \code{"ranks"} format.} 41 | 42 | \item{range}{Numeric vector of length two giving the range of the 43 | responses when using the \code{"pairwise"} format. Defaults 44 | to \code{c(0, 1)} for use with dichotomous responses.} 45 | } 46 | \value{ 47 | A \code{data.frame} in a specific format and with attributes ready 48 | for use with other functions of the \pkg{ThurstonianIRT} package. 49 | } 50 | \description{ 51 | Prepare data for Thurstonian IRT models 52 | } 53 | \examples{ 54 | # load the data 55 | data("triplets") 56 | 57 | # define the blocks of items 58 | blocks <- 59 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 60 | signs = c(1, 1, 1)) + 61 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 62 | signs = c(-1, 1, 1)) + 63 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 64 | signs = c(1, 1, -1)) + 65 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 66 | signs = c(1, -1, 1)) 67 | 68 | # generate the data to be understood by 'thurstonianIRT' 69 | triplets_long <- make_TIRT_data( 70 | data = triplets, blocks = blocks, direction = "larger", 71 | format = "pairwise", family = "bernoulli", range = c(0, 1) 72 | ) 73 | 74 | \donttest{ 75 | # fit the data using Stan 76 | fit <- fit_TIRT_stan(triplets_long, chains = 1) 77 | print(fit) 78 | predict(fit) 79 | } 80 | 81 | } 82 | -------------------------------------------------------------------------------- /man/make_lavaan_code.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/lavaan.R 3 | \name{make_lavaan_code} 4 | \alias{make_lavaan_code} 5 | \title{Generate lavaan code for Thurstonian IRT models} 6 | \usage{ 7 | make_lavaan_code(data) 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{'TIRTdata'}. see 11 | \code{\link{make_TIRT_data}} for documentation on how to create one.} 12 | } 13 | \value{ 14 | A character string of lavaan code 15 | for a Thurstonian IRT model. 16 | } 17 | \description{ 18 | Generate lavaan code for Thurstonian IRT models 19 | } 20 | \examples{ 21 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 22 | sim_data <- sim_TIRT_data( 23 | npersons = 100, 24 | ntraits = 3, 25 | nblocks_per_trait = 4, 26 | gamma = 0, 27 | lambda = lambdas, 28 | Phi = diag(3) 29 | ) 30 | cat(make_lavaan_code(sim_data)) 31 | 32 | } 33 | -------------------------------------------------------------------------------- /man/make_mplus_code.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/mplus.R 3 | \name{make_mplus_code} 4 | \alias{make_mplus_code} 5 | \title{Generate Mplus code for Thurstonian IRT models} 6 | \usage{ 7 | make_mplus_code(data, iter = 1000, eta_file = "eta.csv") 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{'TIRTdata'}. see 11 | \code{\link{make_TIRT_data}} for documentation on how to create one.} 12 | 13 | \item{iter}{Maximum number of iterations of the 14 | model fitting algorithm.} 15 | 16 | \item{eta_file}{optional file name in which predicted 17 | trait scores should be stored.} 18 | } 19 | \value{ 20 | A list of Mplus code snippets to be 21 | interpreted by the \pkg{MplusAutomation} package. 22 | } 23 | \description{ 24 | Generate Mplus code for Thurstonian IRT models 25 | } 26 | \examples{ 27 | sim_data <- sim_TIRT_data( 28 | npersons = 100, 29 | ntraits = 3, 30 | nblocks_per_trait = 4, 31 | gamma = 0, 32 | lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 33 | Phi = diag(3) 34 | ) 35 | 36 | # show the created Mplus code 37 | lapply(make_mplus_code(sim_data), cat) 38 | 39 | } 40 | -------------------------------------------------------------------------------- /man/make_sem_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data-helpers.R 3 | \name{make_sem_data} 4 | \alias{make_sem_data} 5 | \title{Prepare data for Thurstonian IRT models fitted with 6 | lavaan or Mplus} 7 | \usage{ 8 | make_sem_data(data) 9 | } 10 | \arguments{ 11 | \item{data}{An object of class \code{'TIRTdata'}. see 12 | \code{\link{make_TIRT_data}} for documentation on how to create one.} 13 | } 14 | \value{ 15 | A \code{data.frame} ready to be passed to \pkg{lavaan} 16 | or \pkg{Mplus}. 17 | } 18 | \description{ 19 | Prepare data for Thurstonian IRT models fitted with 20 | lavaan or Mplus 21 | } 22 | \examples{ 23 | # simulate some data 24 | sdata <- sim_TIRT_data( 25 | npersons = 100, 26 | ntraits = 3, 27 | nblocks_per_trait = 4, 28 | gamma = 0, 29 | lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 30 | Phi = diag(3) 31 | ) 32 | 33 | # create data ready for use in SEM software 34 | sem_data <- make_sem_data(sdata) 35 | head(sem_data) 36 | 37 | } 38 | -------------------------------------------------------------------------------- /man/make_stan_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/stan.R 3 | \name{make_stan_data} 4 | \alias{make_stan_data} 5 | \title{Prepare data for Thurstonian IRT models fitted with Stan} 6 | \usage{ 7 | make_stan_data(data) 8 | } 9 | \arguments{ 10 | \item{data}{An object of class \code{data.frame} containing data of all 11 | variables used in the model.} 12 | } 13 | \value{ 14 | A list of data ready to be passed to \pkg{Stan}. 15 | 16 | #' @examples 17 | # simulate some data 18 | sim_data <- sim_TIRT_data( 19 | npersons = 100, 20 | ntraits = 3, 21 | nblocks_per_trait = 4, 22 | gamma = 0, 23 | lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 24 | Phi = diag(3) 25 | ) 26 | 27 | # create data ready for use in Stan 28 | stan_data <- make_stan_data(sim_data) 29 | str(stan_data) 30 | } 31 | \description{ 32 | Prepare data for Thurstonian IRT models fitted with Stan 33 | } 34 | -------------------------------------------------------------------------------- /man/predict.TIRTfit.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/TIRTfit-methods.R 3 | \name{predict.TIRTfit} 4 | \alias{predict.TIRTfit} 5 | \title{Predict trait scores of Thurstonian IRT models} 6 | \usage{ 7 | \method{predict}{TIRTfit}(object, newdata = NULL, ...) 8 | } 9 | \arguments{ 10 | \item{object}{An object of class \code{TIRTfit}.} 11 | 12 | \item{newdata}{Optional \code{TIRTdata} object (created via 13 | \code{\link{make_TIRT_data}}) containing data of new persons 14 | for which trait scores should be predicted based on the fitted 15 | model. If \code{NULL} (the default), trait scores are predicted 16 | for the persons whose data was used to originally fit the model.} 17 | 18 | \item{...}{Further arguments passed to the underlying methods.} 19 | } 20 | \value{ 21 | A data frame with predicted trait scores. 22 | } 23 | \description{ 24 | Predict trait scores of Thurstonian IRT models 25 | } 26 | \details{ 27 | When predicting trait scores of new persons (via \code{newdata}), 28 | posterior medians of item parameters are used for predictions. This implies 29 | that the uncertainty in the new trait scores is underestimated as the 30 | uncertainty in the (posterior distribution of) item parameters is ignored. 31 | } 32 | -------------------------------------------------------------------------------- /man/set_block.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data-helpers.R 3 | \name{set_block} 4 | \alias{set_block} 5 | \alias{empty_block} 6 | \title{Prepare blocks of items} 7 | \usage{ 8 | set_block(items, traits, names = items, signs = 1) 9 | 10 | empty_block() 11 | } 12 | \arguments{ 13 | \item{items}{Names of item comparisons to be combined 14 | into one block. Should correspond to variables in the data.} 15 | 16 | \item{traits}{Names of the traits to which each item belongs} 17 | 18 | \item{names}{Optional names of the items in the output. 19 | Can be used to equate parameters of items across blocks, 20 | if the same item was used in different blocks.} 21 | 22 | \item{signs}{Expected signs of the item loadings (1 or -1).} 23 | } 24 | \description{ 25 | Prepare blocks of items and incorporate information 26 | about which item belongs to which trait. A block 27 | of items is a set of two or more items presented and answered together 28 | by fully ranking them or selecting the most and/or least favorit 29 | in a forced choice format. A whole test usually contains 30 | several blocks and items may reappear in different blocks. 31 | } 32 | \examples{ 33 | set_block( 34 | items = c("i1", "i2", "i3"), 35 | traits = c("A", "B", "C") 36 | ) + 37 | set_block( 38 | items = c("i4", "i5", "i6"), 39 | traits = c("A", "B", "C") 40 | ) 41 | 42 | # Support items i1 and i4 were the same so that they have the same parameters 43 | set_block( 44 | items = c("i1", "i2", "i3"), 45 | traits = c("A", "B", "C"), 46 | names = c("item1", "item2", "item3") 47 | ) + 48 | set_block( 49 | items = c("i4", "i5", "i6"), 50 | traits = c("A", "B", "C"), 51 | names = c("item1", "item5", "item6") 52 | ) 53 | 54 | } 55 | \seealso{ 56 | \code{\link{set_blocks_from_df}} 57 | } 58 | -------------------------------------------------------------------------------- /man/set_blocks_from_df.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/data-helpers.R 3 | \name{set_blocks_from_df} 4 | \alias{set_blocks_from_df} 5 | \title{Prepare blocks of items from a data frame} 6 | \usage{ 7 | set_blocks_from_df( 8 | data, 9 | blocks = "block", 10 | items = "item", 11 | traits = "trait", 12 | names = items, 13 | signs = "sign" 14 | ) 15 | } 16 | \arguments{ 17 | \item{data}{A \code{data.frame} containing all the required columns 18 | (see the arguments below) to specify the item blocks.} 19 | 20 | \item{blocks}{Name of column vector denoting the block each item 21 | corresponds to. Each block must have an equal number of items.} 22 | 23 | \item{items}{Name of column vector denoting items to be combined into 24 | one block. Should correspond to variables in the data.} 25 | 26 | \item{traits}{Names of column vector denoting the traits to which each 27 | item belongs.} 28 | 29 | \item{names}{Optional column vector of item names in the output. 30 | Can be used to equate parameters of items across blocks, 31 | if the same item was used in different blocks.} 32 | 33 | \item{signs}{Name of column vector with expected signs of the 34 | item loadings (1 or -1).} 35 | } 36 | \description{ 37 | Prepare blocks of items and incorporate information 38 | about which item belongs to which trait from a pre-existing dataframe. 39 | This is a wrapper function for \code{\link{set_block}}, eliminating the need 40 | to manually set each item, trait, name and sign (loading) info per block. 41 | } 42 | \details{ 43 | A block of items is a set of two or more items presented and answered 44 | together by fully ranking them or selecting the most and/or least favorite 45 | in a forced choice format. A whole test usually contains 46 | several blocks and items may reappear in different blocks. 47 | } 48 | \examples{ 49 | block_info <- data.frame( 50 | block = rep(1:4, each = 3), 51 | items = c("i1", "i2", "i3", "i4", "i5", "i6", 52 | "i7", "i8", "i9", "i10", "i11", "i12"), 53 | traits = rep(c("t1", "t2", "t3"), times = 4), 54 | signs = c(1, 1, 1, -1, 1, 1, 1, 1, -1, 1, -1, 1) 55 | ) 56 | 57 | blocks <- set_blocks_from_df( 58 | data = block_info, 59 | blocks = "block", 60 | items = "items", 61 | traits = "traits", 62 | signs = "signs" 63 | ) 64 | 65 | } 66 | \seealso{ 67 | \code{\link{set_block}} 68 | } 69 | -------------------------------------------------------------------------------- /man/sim_TIRT_data.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/simulations.R 3 | \name{sim_TIRT_data} 4 | \alias{sim_TIRT_data} 5 | \title{Simulate Thurstonian IRT data} 6 | \usage{ 7 | sim_TIRT_data( 8 | npersons, 9 | ntraits, 10 | lambda, 11 | gamma, 12 | psi = NULL, 13 | Phi = NULL, 14 | eta = NULL, 15 | family = "bernoulli", 16 | nblocks_per_trait = 5, 17 | nitems_per_block = 3, 18 | comb_blocks = c("random", "fixed") 19 | ) 20 | } 21 | \arguments{ 22 | \item{npersons}{Number of persons.} 23 | 24 | \item{ntraits}{Number of traits.} 25 | 26 | \item{lambda}{Item factor loadings.} 27 | 28 | \item{gamma}{Baseline attractiveness parameters of the 29 | first item versus the second item in the pairwise comparisons. 30 | Can be thought of as intercept parameters.} 31 | 32 | \item{psi}{Optional item uniquenesses. If not provided, 33 | they will be computed as \code{psi = 1 - lambda^2} in which 34 | case lambda are taken to be the standardized factor loadings.} 35 | 36 | \item{Phi}{Optional trait correlation matrix from which to sample 37 | person factor scores. Only used if \code{eta} is not provided.} 38 | 39 | \item{eta}{Optional person factor scores. If provided, argument 40 | \code{Phi} will be ignored.} 41 | 42 | \item{family}{Name of assumed the response distribution. Either 43 | \code{"bernoulli"}, \code{"cumulative"}, or \code{"gaussian"}.} 44 | 45 | \item{nblocks_per_trait}{Number of blocks per trait.} 46 | 47 | \item{nitems_per_block}{Number of items per block.} 48 | 49 | \item{comb_blocks}{Indicates how to combine traits to blocks. 50 | \code{"fixed"} implies a simple non-random design that may combine 51 | certain traits which each other disproportionally often. We thus 52 | recommend to use a \code{"random"} block design (the default) that 53 | combines all traits with all other traits equally often on average.} 54 | } 55 | \value{ 56 | A \code{data.frame} of the same structure 57 | as returned by \code{\link{make_TIRT_data}}. Parameter values 58 | from which the data were simulated are stored as attributes 59 | of the returned object. 60 | } 61 | \description{ 62 | Simulate Thurstonian IRT data 63 | } 64 | \examples{ 65 | # simulate some data 66 | sdata <- sim_TIRT_data( 67 | npersons = 100, 68 | ntraits = 3, 69 | nblocks_per_trait = 4, 70 | gamma = 0, 71 | lambda = c(runif(6, 0.5, 1), runif(6, -1, -0.5)), 72 | Phi = diag(3) 73 | ) 74 | 75 | # take a look at the data 76 | head(sdata) 77 | str(attributes(sdata)) 78 | 79 | \donttest{ 80 | # fit a Thurstonian IRT model using lavaan 81 | fit <- fit_TIRT_lavaan(sdata) 82 | print(fit) 83 | } 84 | 85 | } 86 | -------------------------------------------------------------------------------- /man/thurstonianIRT-package.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/thurstonianIRT-package.R 3 | \docType{package} 4 | \name{thurstonianIRT-package} 5 | \alias{thurstonianIRT-package} 6 | \alias{thurstonianIRT} 7 | \title{The 'thurstonianIRT' package.} 8 | \description{ 9 | This package fits Thurstonian Item Response Theory (IRT) models 10 | using 'Stan', 'lavaan', or 'Mplus'. To bring your data into the right 11 | format, use the \code{\link{make_TIRT_data}} function. Models can then be 12 | fitted via \code{\link{fit_TIRT_stan}}, \code{\link{fit_TIRT_lavaan}}, or 13 | \code{\link{fit_TIRT_mplus}} depending on the desired model fitting engine. 14 | Data from Thurstonian IRT models can be simulated via 15 | \code{\link{sim_TIRT_data}}. 16 | } 17 | \references{ 18 | Brown, A., & Maydeu-Olivares, A. (2011). Item response modeling of 19 | forced-choice questionnaires. Educational and Psychological Measurement, 20 | 71(3), 460-502. doi:10.1177/0013164410375112 21 | 22 | Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and 23 | Practical Limitations of Thurstonian IRT Models. Educational and 24 | Psychological Measurement. doi:10.1177/0013164419832063 25 | } 26 | \seealso{ 27 | Useful links: 28 | \itemize{ 29 | \item \url{https://github.com/paul-buerkner/thurstonianIRT} 30 | \item Report bugs at \url{https://github.com/paul-buerkner/thurstonianIRT/issues} 31 | } 32 | 33 | } 34 | \author{ 35 | \strong{Maintainer}: Paul-Christian Bürkner \email{paul.buerkner@gmail.com} 36 | 37 | Other contributors: 38 | \itemize{ 39 | \item Angus Hughes [contributor] 40 | \item Trustees of Columbia University [copyright holder] 41 | } 42 | 43 | } 44 | -------------------------------------------------------------------------------- /man/triplets.Rd: -------------------------------------------------------------------------------- 1 | % Generated by roxygen2: do not edit by hand 2 | % Please edit documentation in R/datasets.R 3 | \docType{data} 4 | \name{triplets} 5 | \alias{triplets} 6 | \title{Triplets of Pairwise Comparisons} 7 | \format{ 8 | A data frame of 200 observations containing 9 | information on 12 variables. 10 | Overall, the 12 items measure 3 different traits. 11 | Items 1, 4, 7, and 10 load on trait 1, 12 | items 2, 5, 8, and 11 load on trait 2, and 13 | items 3, 6, 9, and 12 load on trait 3. 14 | Moreover, items 4, 9, and 11 are inverted. 15 | \describe{ 16 | \item{i1i2}{Response preferences between item 1 and 2.} 17 | \item{i1i3}{Response preferences between item 1 and 3.} 18 | \item{i2i3}{Response preferences between item 2 and 3.} 19 | \item{i4i5}{Response preferences between item 4 and 5.} 20 | \item{i4i6}{Response preferences between item 4 and 6.} 21 | \item{i5i6}{Response preferences between item 5 and 6.} 22 | \item{i7i8}{Response preferences between item 7 and 8.} 23 | \item{i7i9}{Response preferences between item 7 and 9.} 24 | \item{i8i9}{Response preferences between item 8 and 9.} 25 | \item{i10i11}{Response preferences between item 10 and 11.} 26 | \item{i10i12}{Response preferences between item 10 and 12.} 27 | \item{i11i12}{Response preferences between item 11 and 12.} 28 | } 29 | } 30 | \source{ 31 | Brown, A. & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model to 32 | forced-choice data using Mplus. Behavior Research Methods, 44, 1135–1147. 33 | DOI: 10.3758/s13428-012-0217-x 34 | } 35 | \usage{ 36 | triplets 37 | } 38 | \description{ 39 | This data set contains synthetic data 40 | of the first 200 out of a total of 2000 participants on 4 triplets, 41 | originally generated as part of Brown and Maydeu-Olivares (2012). 42 | In each triplet, 43 | participants had to rank the three alternative items according 44 | to their preference. Responses were then converted into 45 | a set of dichotomous pairwise responses between all the 46 | three alternatives. More details can be found in 47 | Brown and Maydeu-Olivares (2012). 48 | } 49 | \examples{ 50 | # load the data 51 | data("triplets") 52 | 53 | # define the blocks of items 54 | blocks <- 55 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 56 | signs = c(1, 1, 1)) + 57 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 58 | signs = c(-1, 1, 1)) + 59 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 60 | signs = c(1, 1, -1)) + 61 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 62 | signs = c(1, -1, 1)) 63 | 64 | # generate the data to be understood by 'thurstonianIRT' 65 | tdat <- make_TIRT_data( 66 | triplets, blocks, direction = "larger", 67 | format = "pairwise", family = "bernoulli", range = c(0, 1) 68 | ) 69 | 70 | \donttest{ 71 | # fit the data using Stan 72 | fit <- fit_TIRT_stan(tdat, chains = 1) 73 | print(fit) 74 | predict(fit) 75 | } 76 | 77 | } 78 | \keyword{datasets} 79 | -------------------------------------------------------------------------------- /paper/paper.bib: -------------------------------------------------------------------------------- 1 | @article{brown2011, 2 | author = {Brown, Anna and Maydeu-Olivares, Alberto}, 3 | title = {Item Response Modeling of Forced-Choice Questionnaires}, 4 | journal = {Educational and Psychological Measurement}, 5 | volume = {71}, 6 | number = {3}, 7 | pages = {460--502}, 8 | year = {2011}, 9 | doi = {10.1177/0013164410375112}, 10 | } 11 | 12 | @article{buerkner2019, 13 | title={On the Statistical and Practical Limitations of {T}hurstonian {IRT} Models}, 14 | author={B{\"u}rkner, Paul-Christian and Schulte, Niklas and Holling, Heinz}, 15 | journal={Educational and Psychological Measurement}, 16 | year={2019}, 17 | pages = {827--854}, 18 | volume = {79}, 19 | number = {5}, 20 | publisher={SAGE Publications Sage CA: Los Angeles, CA}, 21 | doi = {10.1177/0013164419832063}, 22 | } 23 | 24 | @Article{carpenter2017, 25 | author = {Carpenter, B. and Gelman, A. and Hoffman, M. and Lee, D. and Goodrich, B. and Betancourt, M. and Brubaker, M. A. and Guo, J. and Li, P. and Ridell, A.}, 26 | title = {{S}tan: A Probabilistic Programming Language}, 27 | journal = {Journal of Statistical Software}, 28 | year = {2017}, 29 | pages = {1--32}, 30 | volume = {76}, 31 | number = {1}, 32 | owner = {Paul}, 33 | timestamp = {2015.06.19}, 34 | doi = {10.18637/jss.v076.i01}, 35 | } 36 | 37 | @Article{rosseel2012, 38 | title = {{lavaan}: An {R} Package for Structural Equation Modeling}, 39 | author = {Yves Rosseel}, 40 | journal = {Journal of Statistical Software}, 41 | year = {2012}, 42 | volume = {48}, 43 | number = {2}, 44 | pages = {1--36}, 45 | url = {http://www.jstatsoft.org/v48/i02/}, 46 | doi = {10.18637/jss.v048.i02}, 47 | } 48 | 49 | -------------------------------------------------------------------------------- /paper/paper.md: -------------------------------------------------------------------------------- 1 | --- 2 | title: 'thurstonianIRT: Thurstonian IRT Models in R' 3 | tags: 4 | - R 5 | - item response theory 6 | - forced-choice data 7 | - Stan 8 | - lavaan 9 | authors: 10 | - name: Paul-Christian Bürkner 11 | orcid: 0000-0001-5765-8995 12 | affiliation: '1' 13 | affiliations: 14 | - name: Aalto University, Department of Computer Science 15 | index: 1 16 | date: "11 August 2019" 17 | bibliography: paper.bib 18 | --- 19 | 20 | # Summary 21 | 22 | In the human sciences, we often aim to measure certain person characteristics 23 | that are latent, that is, not directly observable. Examples for these latents 24 | characteristics are personality traits such as extraversion or emotional 25 | stability as well as performance related traits such as intelligence or 26 | creativity. When measuring personality traits, we mostly rely on self-reported 27 | measures based on rating scales where people answer how much they agree on an 28 | item. This format is easily manipulatable, for example, if participants know 29 | which answers are desirable. Thus its application in high stakes situations 30 | (e.g., in personnel selection) is problematic, as participants may be 31 | motivated to answer dishonestly [@brown2011]. 32 | 33 | An an alternative, forced-choice formats have been proposed in which people are 34 | required to make comparative judgments between two or more items. In this case, 35 | they would not be able to endorse all items at the same time. Analysing data 36 | obtained from forced-choice questionnaires requires specialized statistical 37 | models. One of these models is the Thurstonian Item Response Theory (IRT) model, 38 | which was originally proposed by @brown2011. IRT in general comes with several 39 | advantages over classical test theory, for instance, the ability to model 40 | varying item difficulties as well as item factor loadings on the participants' 41 | traits they are supposed to measure. Moreover, if multiple traits are modeled at 42 | the same time, their correlation can be incorporated into an IRT model to 43 | improve the overall estimation accuracy [@brown2011]. In addition to those 44 | general advantages, forced-choice questionnaires and corresponding IRT models 45 | specifically come with the hope of providing more valid inference in situations 46 | where participants have motivation to fake. Whether they live up to this hope 47 | remains a topic of debate [e.g., see @buerkner2019] but it is in any case 48 | necessary to provide software for fitting these statistical models both for 49 | research and practical purposes. 50 | 51 | The R package *thurstonianIRT* has been developed to fit various IRT models for 52 | forced-choice data, in particular the Thurstonian IRT model. In the original 53 | formulation, the Thurstonian IRT model assumes responses on dichotomous pairwise 54 | comparisons and models the probability of endorsing one versus the other item. 55 | This probability depends on parameters related to the items under comparison as 56 | well as on parameters related to the participants' latent traits, which are 57 | assumed to be measured by the items. For more details see @brown2011 and 58 | @buerkner2019. For model estimation, thurstonianIRT offers multiple backends, 59 | most notably the open source packages Stan [@carpenter2017] and lavaan 60 | [@rosseel2012]. The thurstonianIRT package was originally developed as part of a 61 | project that led to the publication of @buerkner2019 but has since been 62 | developed further to fit and postprocess a more broad set of models for 63 | analysing forced-choice data. For instance, the formulation of the 64 | Thurstonian IRT model may be extended to ordinal or continuous comparative 65 | judgements, which are an active area of research facilitated by the 66 | thurstonianIRT package. 67 | 68 | The source code of the package is available on GitHub (https://github.com/paul-buerkner/thurstonianIRT). 69 | 70 | # References 71 | -------------------------------------------------------------------------------- /src/Makevars: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | STANHEADERS_SRC = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "message()" -e "cat(system.file('include', 'src', package = 'StanHeaders', mustWork = TRUE))" -e "message()" | grep "StanHeaders") 4 | 5 | STANC_FLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "cat(ifelse(utils::packageVersion('rstan') >= '2.26', '-DUSE_STANC3',''))") 6 | PKG_CPPFLAGS = -I"../inst/include" -I"$(STANHEADERS_SRC)" -DBOOST_DISABLE_ASSERTS -DEIGEN_NO_DEBUG -DBOOST_MATH_OVERFLOW_ERROR_POLICY=errno_on_error $(STANC_FLAGS) -D_HAS_AUTO_PTR_ETC=0 7 | PKG_CXXFLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::CxxFlags()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::CxxFlags()") 8 | PKG_LIBS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::RcppParallelLibs()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::LdFlags()") 9 | 10 | CXX_STD = CXX17 11 | -------------------------------------------------------------------------------- /src/Makevars.win: -------------------------------------------------------------------------------- 1 | # Generated by rstantools. Do not edit by hand. 2 | 3 | STANHEADERS_SRC = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "message()" -e "cat(system.file('include', 'src', package = 'StanHeaders', mustWork = TRUE))" -e "message()" | grep "StanHeaders") 4 | 5 | STANC_FLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "cat(ifelse(utils::packageVersion('rstan') >= '2.26', '-DUSE_STANC3',''))") 6 | PKG_CPPFLAGS = -I"../inst/include" -I"$(STANHEADERS_SRC)" -DBOOST_DISABLE_ASSERTS -DEIGEN_NO_DEBUG -DRCPP_PARALLEL_USE_TBB=1 $(STANC_FLAGS) 7 | PKG_CXXFLAGS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::CxxFlags()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::CxxFlags()") 8 | PKG_LIBS = $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "RcppParallel::RcppParallelLibs()") $(shell "$(R_HOME)/bin$(R_ARCH_BIN)/Rscript" -e "StanHeaders:::LdFlags()") 9 | 10 | CXX_STD = CXX14 11 | -------------------------------------------------------------------------------- /src/RcppExports.cpp: -------------------------------------------------------------------------------- 1 | // Generated by using Rcpp::compileAttributes() -> do not edit by hand 2 | // Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 3 | 4 | #include 5 | #include 6 | 7 | using namespace Rcpp; 8 | 9 | #ifdef RCPP_USE_GLOBAL_ROSTREAM 10 | Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); 11 | Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); 12 | #endif 13 | 14 | 15 | RcppExport SEXP _rcpp_module_boot_stan_fit4thurstonian_irt_model_mod(); 16 | RcppExport SEXP _rcpp_module_boot_stan_fit4thurstonian_irt_model_newdata_mod(); 17 | 18 | static const R_CallMethodDef CallEntries[] = { 19 | {"_rcpp_module_boot_stan_fit4thurstonian_irt_model_mod", (DL_FUNC) &_rcpp_module_boot_stan_fit4thurstonian_irt_model_mod, 0}, 20 | {"_rcpp_module_boot_stan_fit4thurstonian_irt_model_newdata_mod", (DL_FUNC) &_rcpp_module_boot_stan_fit4thurstonian_irt_model_newdata_mod, 0}, 21 | {NULL, NULL, 0} 22 | }; 23 | 24 | RcppExport void R_init_thurstonianIRT(DllInfo *dll) { 25 | R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); 26 | R_useDynamicSymbols(dll, FALSE); 27 | } 28 | -------------------------------------------------------------------------------- /src/RcppExports.o: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/paul-buerkner/thurstonianIRT/fd7f134a7308cd69dc94a3030413baa3359347e9/src/RcppExports.o -------------------------------------------------------------------------------- /src/stanExports_thurstonian_irt_model.cc: -------------------------------------------------------------------------------- 1 | // Generated by rstantools. Do not edit by hand. 2 | 3 | #include 4 | using namespace Rcpp ; 5 | #include "stanExports_thurstonian_irt_model.h" 6 | 7 | RCPP_MODULE(stan_fit4thurstonian_irt_model_mod) { 8 | 9 | 10 | class_ >("rstantools_model_thurstonian_irt_model") 11 | 12 | .constructor() 13 | 14 | 15 | .method("call_sampler", &rstan::stan_fit ::call_sampler) 16 | .method("param_names", &rstan::stan_fit ::param_names) 17 | .method("param_names_oi", &rstan::stan_fit ::param_names_oi) 18 | .method("param_fnames_oi", &rstan::stan_fit ::param_fnames_oi) 19 | .method("param_dims", &rstan::stan_fit ::param_dims) 20 | .method("param_dims_oi", &rstan::stan_fit ::param_dims_oi) 21 | .method("update_param_oi", &rstan::stan_fit ::update_param_oi) 22 | .method("param_oi_tidx", &rstan::stan_fit ::param_oi_tidx) 23 | .method("grad_log_prob", &rstan::stan_fit ::grad_log_prob) 24 | .method("log_prob", &rstan::stan_fit ::log_prob) 25 | .method("unconstrain_pars", &rstan::stan_fit ::unconstrain_pars) 26 | .method("constrain_pars", &rstan::stan_fit ::constrain_pars) 27 | .method("num_pars_unconstrained", &rstan::stan_fit ::num_pars_unconstrained) 28 | .method("unconstrained_param_names", &rstan::stan_fit ::unconstrained_param_names) 29 | .method("constrained_param_names", &rstan::stan_fit ::constrained_param_names) 30 | .method("standalone_gqs", &rstan::stan_fit ::standalone_gqs) 31 | ; 32 | } 33 | -------------------------------------------------------------------------------- /src/stanExports_thurstonian_irt_model_newdata.cc: -------------------------------------------------------------------------------- 1 | // Generated by rstantools. Do not edit by hand. 2 | 3 | #include 4 | using namespace Rcpp ; 5 | #include "stanExports_thurstonian_irt_model_newdata.h" 6 | 7 | RCPP_MODULE(stan_fit4thurstonian_irt_model_newdata_mod) { 8 | 9 | 10 | class_ >("rstantools_model_thurstonian_irt_model_newdata") 11 | 12 | .constructor() 13 | 14 | 15 | .method("call_sampler", &rstan::stan_fit ::call_sampler) 16 | .method("param_names", &rstan::stan_fit ::param_names) 17 | .method("param_names_oi", &rstan::stan_fit ::param_names_oi) 18 | .method("param_fnames_oi", &rstan::stan_fit ::param_fnames_oi) 19 | .method("param_dims", &rstan::stan_fit ::param_dims) 20 | .method("param_dims_oi", &rstan::stan_fit ::param_dims_oi) 21 | .method("update_param_oi", &rstan::stan_fit ::update_param_oi) 22 | .method("param_oi_tidx", &rstan::stan_fit ::param_oi_tidx) 23 | .method("grad_log_prob", &rstan::stan_fit ::grad_log_prob) 24 | .method("log_prob", &rstan::stan_fit ::log_prob) 25 | .method("unconstrain_pars", &rstan::stan_fit ::unconstrain_pars) 26 | .method("constrain_pars", &rstan::stan_fit ::constrain_pars) 27 | .method("num_pars_unconstrained", &rstan::stan_fit ::num_pars_unconstrained) 28 | .method("unconstrained_param_names", &rstan::stan_fit ::unconstrained_param_names) 29 | .method("constrained_param_names", &rstan::stan_fit ::constrained_param_names) 30 | .method("standalone_gqs", &rstan::stan_fit ::standalone_gqs) 31 | ; 32 | } 33 | -------------------------------------------------------------------------------- /src/thurstonianIRT.so: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/paul-buerkner/thurstonianIRT/fd7f134a7308cd69dc94a3030413baa3359347e9/src/thurstonianIRT.so -------------------------------------------------------------------------------- /tests/testthat.R: -------------------------------------------------------------------------------- 1 | library(testthat) 2 | library(thurstonianIRT) 3 | 4 | test_check("thurstonianIRT") 5 | -------------------------------------------------------------------------------- /tests/testthat/tests.lavaan.R: -------------------------------------------------------------------------------- 1 | context("Tests for TIRT models fitted with lavaan") 2 | 3 | test_that("lavaan code for bernoulli responses works", { 4 | set.seed(1234) 5 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 6 | sdata <- sim_TIRT_data( 7 | npersons = 100, 8 | ntraits = 3, 9 | nblocks_per_trait = 4, 10 | gamma = 0, 11 | lambda = lambdas, 12 | Phi = diag(3), 13 | family = "bernoulli" 14 | ) 15 | fit <- suppressWarnings(fit_TIRT_lavaan(sdata)) 16 | expect_is(fit, "TIRTfit") 17 | pr <- suppressWarnings(predict(fit)) 18 | pr_names <- c("id", "trait", "estimate") 19 | expect_equal(names(pr), pr_names) 20 | expect_equal(length(unique(pr$id)), 100) 21 | expect_equal(names(gof(fit)), c("chi_sq", "df", "p_val", "RMSEA")) 22 | 23 | # test predictions for new data 24 | new_sdata <- dplyr::filter(sdata, person %in% 1:5) 25 | pr_new <- suppressWarnings(predict(fit, new_sdata)) 26 | expect_equal(names(pr_new), pr_names) 27 | expect_equal(length(unique(pr_new$id)), 5) 28 | }) 29 | 30 | test_that("lavaan code for gaussian responses works", { 31 | set.seed(12345) 32 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 33 | sdata <- sim_TIRT_data( 34 | npersons = 100, 35 | ntraits = 3, 36 | nblocks_per_trait = 4, 37 | gamma = 0, 38 | lambda = lambdas, 39 | Phi = diag(3), 40 | family = "gaussian" 41 | ) 42 | fit <- suppressWarnings(fit_TIRT_lavaan(sdata)) 43 | expect_is(fit, "TIRTfit") 44 | pr <- suppressWarnings(predict(fit)) 45 | pr_names <- c("id", "trait", "estimate") 46 | expect_equal(names(pr), pr_names) 47 | expect_equal(length(unique(pr$id)), 100) 48 | 49 | # test predictions for new data 50 | new_sdata <- dplyr::filter(sdata, person %in% 1:5) 51 | pr_new <- suppressWarnings(predict(fit, new_sdata)) 52 | expect_equal(names(pr_new), pr_names) 53 | expect_equal(length(unique(pr_new$id)), 5) 54 | }) 55 | -------------------------------------------------------------------------------- /tests/testthat/tests.make_TIRT_data.R: -------------------------------------------------------------------------------- 1 | context("Tests for creating T-IRT compatible data sets") 2 | 3 | test_that("make_TIRT_data works correctly for binary data", { 4 | data("triplets") 5 | 6 | # define the blocks of items 7 | blocks <- 8 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 9 | signs = c(1, 1, 1)) + 10 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 11 | signs = c(-1, 1, 1)) + 12 | set_block(c("i7", "i8", "i9"), traits = c("t1", "t2", "t3"), 13 | signs = c(1, 1, -1)) + 14 | set_block(c("i10", "i11", "i12"), traits = c("t1", "t2", "t3"), 15 | signs = c(1, -1, 1)) 16 | 17 | # generate the data to be understood by 'thurstonianIRT' 18 | triplets_long <- make_TIRT_data( 19 | data = triplets, blocks = blocks, direction = "larger", 20 | format = "pairwise", family = "bernoulli", range = c(0, 1) 21 | ) 22 | expect_equal(NROW(triplets_long), NROW(triplets) * 12) 23 | expect_true(all(triplets_long$response %in% 0:1)) 24 | }) 25 | 26 | test_that("make_TIRT_data works correctly for rank data", { 27 | ranks <- data.frame( 28 | i1 = c(1,2), i2 = c(2,3), i3 = c(3,1), 29 | i4 = c(3,1), i5 = c(1,3), i6 = c(2,2) 30 | ) 31 | 32 | # define the blocks of items 33 | blocks <- 34 | set_block(c("i1", "i2", "i3"), traits = c("t1", "t2", "t3"), 35 | signs = c(1, 1, 1)) + 36 | set_block(c("i4", "i5", "i6"), traits = c("t1", "t2", "t3"), 37 | signs = c(1, 1, 1)) 38 | 39 | # generate the data to be understood by 'thurstonianIRT' 40 | triplets_long <- make_TIRT_data( 41 | data = ranks, blocks = blocks, direction = "larger", 42 | format = "ranks", family = "bernoulli", range = c(0, 1) 43 | ) 44 | 45 | expect_equal(NROW(triplets_long), NROW(ranks) * 6) 46 | expect_true(all(triplets_long$response %in% 0:1)) 47 | }) 48 | -------------------------------------------------------------------------------- /tests/testthat/tests.mplus.R: -------------------------------------------------------------------------------- 1 | context("Tests for TIRT models fitted with Mplus") 2 | 3 | skip("Mplus is not open source software") 4 | 5 | test_that("mplus code for bernoulli responses works", { 6 | set.seed(1234) 7 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 8 | sdata <- sim_TIRT_data( 9 | npersons = 100, 10 | ntraits = 3, 11 | nblocks_per_trait = 4, 12 | gamma = 0, 13 | lambda = lambdas, 14 | Phi = diag(3), 15 | family = "bernoulli" 16 | ) 17 | fit <- suppressWarnings(fit_TIRT_mplus(sdata)) 18 | expect_is(fit, "TIRTfit") 19 | pr <- suppressWarnings(predict(fit)) 20 | pr_names <- c("id", "trait", "estimate") 21 | expect_equal(names(pr), pr_names) 22 | expect_equal(length(unique(pr$id)), 100) 23 | }) 24 | -------------------------------------------------------------------------------- /tests/testthat/tests.stan.R: -------------------------------------------------------------------------------- 1 | context("Tests for TIRT models fitted with Stan") 2 | 3 | test_that("Stan code for bernoulli responses works", { 4 | set.seed(1234) 5 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 6 | sdata <- sim_TIRT_data( 7 | npersons = 10, 8 | ntraits = 3, 9 | nblocks_per_trait = 4, 10 | gamma = 0, 11 | lambda = lambdas, 12 | Phi = diag(3), 13 | family = "bernoulli" 14 | ) 15 | fit <- suppressWarnings(fit_TIRT_stan(sdata, chains = 1, iter = 500)) 16 | expect_is(fit, "TIRTfit") 17 | pr <- predict(fit) 18 | pr_names <- c("id", "trait", "estimate", "se", "lower_ci", "upper_ci") 19 | expect_equal(names(pr), pr_names) 20 | expect_equal(length(unique(pr$id)), 10) 21 | 22 | # test predictions for new data 23 | new_sdata <- dplyr::filter(sdata, person %in% 1:5) 24 | pr_new <- predict(fit, new_sdata, chains = 1, iter = 500) 25 | expect_equal(names(pr_new), pr_names) 26 | expect_equal(length(unique(pr_new$id)), 5) 27 | }) 28 | 29 | test_that("Stan code for ordinal responses works", { 30 | set.seed(1234) 31 | ncat <- 4 32 | gamma <- matrix( 33 | seq(-2, 2, length.out = max(ncat) - 1), 34 | nrow = 12, 35 | ncol = max(ncat) - 1, 36 | byrow = TRUE 37 | ) 38 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 39 | sdata <- sim_TIRT_data( 40 | npersons = 10, 41 | ntraits = 3, 42 | nblocks_per_trait = 4, 43 | gamma = gamma, 44 | lambda = lambdas, 45 | Phi = diag(3), 46 | family = "cumulative" 47 | ) 48 | fit <- suppressWarnings(fit_TIRT_stan(sdata, chains = 1, iter = 500)) 49 | expect_is(fit, "TIRTfit") 50 | pr <- predict(fit) 51 | pr_names <- c("id", "trait", "estimate", "se", "lower_ci", "upper_ci") 52 | expect_equal(names(pr), pr_names) 53 | expect_equal(length(unique(pr$id)), 10) 54 | 55 | # test predictions for new data 56 | new_sdata <- dplyr::filter(sdata, person %in% 1:5) 57 | pr_new <- predict(fit, new_sdata, chains = 1, iter = 500) 58 | expect_equal(names(pr_new), pr_names) 59 | expect_equal(length(unique(pr_new$id)), 5) 60 | }) 61 | 62 | test_that("Stan code for gaussian responses works", { 63 | set.seed(1234) 64 | lambdas <- c(runif(6, 0.5, 1), runif(6, -1, -0.5)) 65 | sdata <- sim_TIRT_data( 66 | npersons = 10, 67 | ntraits = 3, 68 | nblocks_per_trait = 4, 69 | gamma = 0, 70 | lambda = lambdas, 71 | Phi = diag(3), 72 | family = "gaussian" 73 | ) 74 | fit <- suppressWarnings(fit_TIRT_stan(sdata, chains = 1, iter = 500)) 75 | expect_is(fit, "TIRTfit") 76 | pr <- predict(fit) 77 | pr_names <- c("id", "trait", "estimate", "se", "lower_ci", "upper_ci") 78 | expect_equal(names(pr), pr_names) 79 | expect_equal(length(unique(pr$id)), 10) 80 | 81 | # test predictions for new data 82 | new_sdata <- dplyr::filter(sdata, person %in% 1:5) 83 | pr_new <- predict(fit, new_sdata, chains = 1, iter = 500) 84 | expect_equal(names(pr_new), pr_names) 85 | expect_equal(length(unique(pr_new$id)), 5) 86 | }) 87 | -------------------------------------------------------------------------------- /thurstonianIRT.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: No 4 | SaveWorkspace: No 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 | AutoAppendNewline: Yes 16 | StripTrailingWhitespace: Yes 17 | 18 | BuildType: Package 19 | PackageUseDevtools: Yes 20 | PackageInstallArgs: --no-multiarch --with-keep.source 21 | PackageBuildArgs: --no-build-vignettes 22 | PackageBuildBinaryArgs: --preclean 23 | PackageCheckArgs: --as-cran --ignore-vignettes 24 | PackageRoxygenize: rd,collate,namespace 25 | -------------------------------------------------------------------------------- /vignettes/TIRT_sim_tests.Rmd: -------------------------------------------------------------------------------- 1 | --- 2 | title: "Test parameter recovery via simulations with thurstonianIRT" 3 | author: "Paul Bürkner" 4 | date: "`r Sys.Date()`" 5 | output: 6 | rmarkdown::html_vignette: 7 | toc: yes 8 | vignette: > 9 | %\VignetteIndexEntry{Test parameter recovery via simulations with thurstonianIRT} 10 | \usepackage[utf8]{inputenc} 11 | %\VignetteEngine{knitr::rmarkdown} 12 | params: 13 | EVAL: !r identical(Sys.getenv("NOT_CRAN"), "true") 14 | editor_options: 15 | chunk_output_type: console 16 | --- 17 | 18 | ```{r, SETTINGS-knitr, include=FALSE} 19 | stopifnot(require(knitr)) 20 | options(width = 90) 21 | opts_chunk$set( 22 | comment = NA, 23 | message = FALSE, 24 | warning = FALSE, 25 | eval = if (isTRUE(exists("params"))) params$EVAL else FALSE, 26 | dev = "png", 27 | dpi = 150, 28 | fig.asp = 0.8, 29 | fig.width = 5, 30 | out.width = "60%", 31 | fig.align = "center" 32 | ) 33 | ``` 34 | 35 | # Introduction 36 | 37 | In this vignette, we will perform a small simulation study to 38 | test whether the model fitting engines implemented in the thurstonianIRT 39 | package are able to recover known parameter values from a simulated data set. 40 | This also extends the automated unit tests implemented in the package 41 | to check the correctness of the software. The simulation design used below 42 | was inspired by Brown and Maydeu-Olivares (2012). For a more extensive simulation 43 | study using thurstonianIRT, see Bürkner, Schulte, and Holling (2019). 44 | 45 | First, we will load a bunch of packages required in the vignette. 46 | ```{r} 47 | library(thurstonianIRT) 48 | library(dplyr) 49 | library(tidyr) 50 | ``` 51 | 52 | Next, we will set up the simulation condition. 53 | ```{r} 54 | npersons <- 500 55 | ntraits <- 5 56 | nitems_per_block <- 3 57 | nblocks_per_trait <- 9 58 | nblocks <- ntraits * nblocks_per_trait / nitems_per_block 59 | nitems <- ntraits * nblocks_per_trait 60 | ncomparisons <- (nitems_per_block * (nitems_per_block - 1)) / 2 * nblocks 61 | ``` 62 | 63 | Now, we will choose a set of true parameter values. 64 | ```{r} 65 | set.seed(123) 66 | lambda <- runif(nitems, 0.65, 0.96) 67 | signs <- c(rep(1, ceiling(nitems / 2)), rep(-1, floor(nitems / 2))) 68 | lambda <- lambda * signs[sample(seq_len(nitems))] 69 | gamma <- runif(nitems, -1, 1) 70 | Phi <- diag(5) 71 | ``` 72 | 73 | Finally, we put all of this together and simulate a data set based 74 | on the condion and true parameter values. 75 | ```{r} 76 | sdata <- sim_TIRT_data( 77 | npersons = npersons, 78 | ntraits = ntraits, 79 | nitems_per_block = nitems_per_block, 80 | nblocks_per_trait = nblocks_per_trait, 81 | gamma = gamma, 82 | lambda = lambda, 83 | Phi = Phi 84 | ) 85 | ``` 86 | 87 | We know that the chosen simulation condition and parameter values are well 88 | behaved (this may not be the case in all situations; see Bürkner, Schulte, & 89 | Holling, 2019). Accordingly, the model fitting engines should show good 90 | parameter recovery given that they are correctly implemented. We will now go 91 | ahead and fit the model with all three engines. 92 | ```{r, results="hide"} 93 | fit_stan <- fit_TIRT_stan(sdata, chains = 1, iter = 1000, warmup = 500) 94 | fit_lavaan <- fit_TIRT_lavaan(sdata) 95 | fit_mplus <- fit_TIRT_mplus(sdata) 96 | ``` 97 | 98 | We can now predict the trait scores of all persons and compare them 99 | to the true scores, which are stored in the simulated data set. 100 | ```{r} 101 | eta <- as_tibble(as.data.frame(attributes(sdata)$eta)) 102 | names(eta) <- paste0("trait", 1:ncol(eta)) 103 | true_scores <- eta %>% 104 | mutate(id = 1:n()) %>% 105 | gather(key = "trait", value = "truth", -id) 106 | true_summaries <- true_scores %>% 107 | group_by(trait) %>% 108 | summarise(true_mean = mean(truth), true_sd = sd(truth)) 109 | 110 | pred <- predict(fit_stan) %>% 111 | bind_rows(predict(fit_lavaan), predict(fit_mplus), .id = "source") %>% 112 | mutate( 113 | source = as.character(factor( 114 | source, levels = 1:3, labels = c("stan", "lavaan", "mplus") 115 | )), 116 | trait = tolower(trait) 117 | ) %>% 118 | inner_join(true_scores, by = c("id", "trait")) 119 | 120 | pred <- pred %>% 121 | inner_join( 122 | pred %>% 123 | group_by(trait, source) %>% 124 | summarise(cor_est_truth = cor(estimate, truth)), 125 | by = c("trait", "source") 126 | ) %>% 127 | mutate( 128 | sign = sign(cor_est_truth), 129 | estimate = ifelse(sign %in% -1, -estimate, estimate) 130 | ) %>% 131 | inner_join(true_summaries, by = "trait") %>% 132 | group_by(trait, source) %>% 133 | mutate( 134 | est_mean = mean(estimate), 135 | est_sd = sd(estimate) 136 | ) %>% 137 | ungroup() %>% 138 | mutate( 139 | ztruth = (truth - true_mean) / true_sd, 140 | zestimate = (estimate - est_mean) / est_sd 141 | ) 142 | ``` 143 | 144 | Various measures of model predictive accuracy can be computed, for instance, 145 | the reliability. For the present simulation condition, we would expect 146 | the reliability to be roughly between 0.85 and 0.9 for all traits. 147 | By looking at the results below, we can verify that this is indeed that case. 148 | ```{r} 149 | res <- pred %>% 150 | group_by(trait, source) %>% 151 | summarise(rel = cor(estimate, truth)^2) 152 | 153 | res 154 | ``` 155 | 156 | ```{r, include = FALSE} 157 | testthat::expect_true(all(res$rel > 0.75)) 158 | ``` 159 | 160 | Lastly, we can also compute and investigate the trait correlations between 161 | different engines so check whether they really estimate equivalent trait scores. 162 | ```{r} 163 | cor_matrix <- pred %>% 164 | mutate( 165 | # ensure correct ordering of traits 166 | SC = paste0(source, "_", trait), 167 | SC = factor(SC, levels = unique(SC)) 168 | ) %>% 169 | select(id, SC, estimate) %>% 170 | spread(key = "SC", value = "estimate") %>% 171 | bind_cols(eta, .) %>% 172 | select(-id) %>% 173 | cor() 174 | ``` 175 | 176 | We would expect the correlations of the estimates of the same trait across 177 | engines to be very high, that is, higher than 0.95 at least. 178 | We can verify that this is indeed the case as exemplified for `trait1` below. 179 | ```{r} 180 | trait1 <- paste0(c("stan", "lavaan", "mplus"), "_trait1") 181 | round(cor_matrix[trait1, trait1], 2) 182 | ``` 183 | 184 | ```{r, include = FALSE} 185 | for (i in 1:ntraits) { 186 | trait_cols <- paste0(c("stan", "lavaan", "mplus"), "_trait", i) 187 | testthat::expect_true(all(cor_matrix[trait_cols, trait_cols] > 0.96)) 188 | } 189 | ``` 190 | 191 | Taken together, we have seen how to set up and perform a simple simulation 192 | study to test the parameter recovery of Thurstonian IRT models and, at the 193 | same time, test the correctness of the thurstonianIRT software. 194 | 195 | # References 196 | 197 | Bürkner P. C., Schulte N., & Holling H. (2019). On the Statistical and Practical 198 | Limitations of Thurstonian IRT Models. *Educational and Psychological 199 | Measurement*. 79(5). 827–854. 200 | 201 | Brown, A. & Maydeu-Olivares, A. (2012). Fitting a Thurstonian IRT model to forced-choice data using Mplus. Behavior Research Methods, 44, 1135–1147. DOI: 10.3758/s13428-012-0217-x 202 | --------------------------------------------------------------------------------