Last updated: 2022-01-12
Checks: 5 1
Knit directory: Padgett-Dissertation/
This reproducible R Markdown analysis was created with workflowr (version 1.6.2). The Checks tab describes the reproducibility checks that were applied when the results were created. The Past versions tab lists the development history.
Great job! The global environment was empty. Objects defined in the global environment can affect the analysis in your R Markdown file in unknown ways. For reproduciblity itโs best to always run the code in an empty environment.
The command set.seed(20210401) was run prior to running the code in the R Markdown file. Setting a seed ensures that any results that rely on randomness, e.g. subsampling or permutations, are reproducible.
Great job! Recording the operating system, R version, and package versions is critical for reproducibility.
Nice! There were no cached chunks for this analysis, so you can be confident that you successfully produced the results during this run.
Great job! Using relative paths to the files within your workflowr project makes it easier to run your code on other machines.
Tracking code development and connecting the code version to the results is critical for reproducibility. To start using Git, open the Terminal and type git init in your project directory.
This project is not being versioned with Git. To obtain the full reproducibility benefits of using workflowr, please see ?wflow_start.
# Load packages & utility functions
source("code/load_packages.R")
source("code/load_utility_functions.R")
# environment options
options(scipen = 999, digits=3)# ===================================== #
# study_1_generate_data.R
# ===================================== #
# Padgett - Dissertation
# Created
# on: 2022-01-06
# by: R. Noah Padgett
# Last Editted
# on: 2022-01-10
# by: R. Noah Padgett
# ===================================== #
# Purpose: Generate data for study 1
# ===================================== #
# libraries
library(mvtnorm)
set.seed(1)
N <- 1000
N_cat <- 3
N_items <- 5
# data parameters
paravec <- c(
N = N
, J = N_items
, C = N_cat
, etaCor = .23
, etasd1 = 1
, etasd2 = sqrt(0.1)
, lambda=0.9
, nu=1.5
, sigma.ei=0.25
, rho1=0.1
)
# thresholds
sim_tau <- matrix(ncol=N_cat-1, nrow=N_items)
for(c in 1:(N_cat-1)){
if(c == 1){
sim_tau[,1] <- runif(N_items, -1, -0.33)
}
if(c > 1){
sim_tau[,c] <- sim_tau[,c-1] + runif(N_items, 1.0, 1.67)
}
}
simulate_data_misclass <- function(paravec, tau=NULL){
# NOTE: tau is a matrix[J, C-1] of item threshold parameters that possibly vary over items
# useful functions
invlogit <- function(x) {exp(x)/(1+exp(x))}
logit <- function(x){log(x/(1-x))}
# Generating Data
N <- paravec[1] # number of respondents
J <- paravec[2] # number of items
C <- paravec[3] # number of response categories
# ========================= #
# latent person parameters
etaCor <- paravec[4] # correlation between ability and speediness
etasd <- paravec[5:6]
eta <- mvtnorm::rmvnorm(
N, mean = c(0, 0),
sigma = matrix(c(etasd[1], etasd[2]*etaCor,
etasd[2]*etaCor, etasd[2]**2),
ncol = 2))
eta0 <- matrix(eta[,1],nrow=1) # ability
eta1 <- matrix(eta[,2],nrow=1) # log speediness
# ========================= #
# item parameters
# item factor loadings
lambda <- matrix(rep(paravec[7], J), ncol=1)
# item latent residual variances
theta <- c(1 - lambda**2)
# item thresholds
if(is.null(tau)){
tau <- matrix(ncol=C-1, nrow=J)
for(c in 1:(C-1)){
if(c == 1){
tau[,1] <- runif(J, -1, -0.33)
}
if(c > 1){
tau[,c] <- tau[,c-1] + runif(J, 0.25, 1)
}
}
}
# latent item response
ystar <- lambda%*%eta0
ystar <- apply(ystar, 2, FUN = function(x){mvtnorm::rmvnorm(1, x, diag(theta, ncol=J, nrow=J))})
# response time parameters (copied from Molenaar et al. 2021)
nu <- matrix(rep(paravec[8], J), ncol=1)
sigma.ei <- matrix(rep(paravec[9], J), ncol=1)
rho1 <- paravec[10]
#rho2 <- 0
#delta <- 0
mulogt <- logt <- matrix(nrow=N, ncol=J)
i<-j <- 1
for(i in 1:N){
for(j in 1:J){
# obtain expected log response time
mulogt[i,j] <- nu[j, 1] - eta1[1,i] - rho1*abs( eta0[1,i] - sum(tau[j,])/length(tau[j,]) )
# sample observed log response time
# logRT ~ N(mulogt, sigma.ie)
logt[i,j] <- rnorm(1, mulogt[i,j], sqrt(sigma.ei[j,1]))
}
}
# construct missclassification
# based on latent response time (nu - eta1)
misclass.time.trans <- function(lrt, c, b, K, diagonal = FALSE){
if(c == b){
g <- 1/(1 + exp(-lrt))
if(diagonal == TRUE){
g <- 1
}
}
if(c != b){
g <- (1/(K-1))*(1-1/(1 + exp(-lrt)))
if(diagonal == TRUE){
g <- 0
}
}
g
}
gamma <- array(dim=c(N,J,C,C))
for(i in 1:N){for(j in 1:J){for(b in 1:C){for(c in 1:C){
gamma[i,j,b,c] <- misclass.time.trans(nu[j, 1] - eta1[1, i], b, c, C)
}}}}# end loops
pi <- pi.gte <- omega <- array(0,dim=c(N, J, C))
Y <- matrix(nrow=N, ncol=J)
i <- j <- c <- 1
for(i in 1:N){
for(j in 1:J){
# transform into probability scale
for(c in 2:C){
# P(greater than or equal to category c > 1)
pi.gte[i,j,c] <- invlogit(ystar[j,i]-tau[j,(c-1)])
}
# P(greater than or equal to category 1)
pi.gte[i,j,1] <- 1
# equal to prob.
for(c in 1:(C-1)){
# P(greater equal to category c < C)
pi[i,j,c] <- pi.gte[i,j,c]-pi.gte[i,j,c+1]
}
# P(greater equal to category C)
pi[i,j,C] <- pi.gte[i,j,C]
# observed category prob (Pr(y=c))
for(c in 1:C){
for(ct in 1:C){
# sum over ct
omega[i,j,c] = omega[i,j,c] + gamma[i,j,ct,c]*pi[i,j,ct]
}
}
Y[i,j] <- sample(x=1:C, size=1, prob=omega[i,j,])
# rescale to 0/1 if dichotomous items
if(C == 2){
Y[i,j] = Y[i,j]-1
}
}
}
# true_values <- list(eta0, eta1, lambda, nu, sigma.ei, tau, mulogt, ystar, theta, gamma, omega)
# names(true_values) <- c("eta", "")
sim_data <- list(Y, logt)
names(sim_data) <- c("y", "logt")
return(sim_data)
}
# Use parameters to simulate data
sim.data <- simulate_data_misclass(paravec, tau=sim_tau)
sessionInfo()R version 4.0.5 (2021-03-31)
Platform: x86_64-w64-mingw32/x64 (64-bit)
Running under: Windows 10 x64 (build 22000)
Matrix products: default
locale:
[1] LC_COLLATE=English_United States.1252
[2] LC_CTYPE=English_United States.1252
[3] LC_MONETARY=English_United States.1252
[4] LC_NUMERIC=C
[5] LC_TIME=English_United States.1252
attached base packages:
[1] stats graphics grDevices utils datasets methods base
other attached packages:
[1] car_3.0-10 carData_3.0-4 mvtnorm_1.1-1
[4] LaplacesDemon_16.1.4 runjags_2.2.0-2 lme4_1.1-26
[7] Matrix_1.3-2 sirt_3.9-4 R2jags_0.6-1
[10] rjags_4-12 eRm_1.0-2 diffIRT_1.5
[13] statmod_1.4.35 xtable_1.8-4 kableExtra_1.3.4
[16] lavaan_0.6-7 polycor_0.7-10 bayesplot_1.8.0
[19] ggmcmc_1.5.1.1 coda_0.19-4 data.table_1.14.0
[22] patchwork_1.1.1 forcats_0.5.1 stringr_1.4.0
[25] dplyr_1.0.5 purrr_0.3.4 readr_1.4.0
[28] tidyr_1.1.3 tibble_3.1.0 ggplot2_3.3.5
[31] tidyverse_1.3.0 workflowr_1.6.2
loaded via a namespace (and not attached):
[1] minqa_1.2.4 TAM_3.5-19 colorspace_2.0-0 rio_0.5.26
[5] ellipsis_0.3.1 ggridges_0.5.3 rprojroot_2.0.2 fs_1.5.0
[9] rstudioapi_0.13 fansi_0.4.2 lubridate_1.7.10 xml2_1.3.2
[13] splines_4.0.5 mnormt_2.0.2 knitr_1.31 jsonlite_1.7.2
[17] nloptr_1.2.2.2 broom_0.7.5 dbplyr_2.1.0 compiler_4.0.5
[21] httr_1.4.2 backports_1.2.1 assertthat_0.2.1 cli_2.3.1
[25] later_1.1.0.1 htmltools_0.5.1.1 tools_4.0.5 gtable_0.3.0
[29] glue_1.4.2 Rcpp_1.0.7 cellranger_1.1.0 jquerylib_0.1.3
[33] vctrs_0.3.6 svglite_2.0.0 nlme_3.1-152 psych_2.0.12
[37] xfun_0.21 ps_1.6.0 openxlsx_4.2.3 rvest_1.0.0
[41] lifecycle_1.0.0 MASS_7.3-53.1 scales_1.1.1 hms_1.0.0
[45] promises_1.2.0.1 parallel_4.0.5 RColorBrewer_1.1-2 curl_4.3
[49] yaml_2.2.1 sass_0.3.1 reshape_0.8.8 stringi_1.5.3
[53] zip_2.1.1 boot_1.3-27 rlang_0.4.10 pkgconfig_2.0.3
[57] systemfonts_1.0.1 evaluate_0.14 lattice_0.20-41 tidyselect_1.1.0
[61] GGally_2.1.1 plyr_1.8.6 magrittr_2.0.1 R6_2.5.0
[65] generics_0.1.0 DBI_1.1.1 foreign_0.8-81 pillar_1.5.1
[69] haven_2.3.1 withr_2.4.1 abind_1.4-5 modelr_0.1.8
[73] crayon_1.4.1 utf8_1.1.4 tmvnsim_1.0-2 rmarkdown_2.7
[77] grid_4.0.5 readxl_1.3.1 CDM_7.5-15 pbivnorm_0.6.0
[81] git2r_0.28.0 reprex_1.0.0 digest_0.6.27 webshot_0.5.2
[85] httpuv_1.5.5 stats4_4.0.5 munsell_0.5.0 viridisLite_0.3.0
[89] bslib_0.2.4 R2WinBUGS_2.1-21