Nothing
R/catIrt.R
In catIrt: Simulate IRT-Based Computerized Adaptive Tests
Defines functions
catIrt
Documented in
catIrt
# This function will be the main CAT function.
catIrt <- function( params, mod = c("brm", "grm"),
resp = NULL,
theta = NULL,
catStart = list( n.start = 5, init.theta = 0,
select = c("UW-FI", "LW-FI", "PW-FI",
"FP-KL", "VP-KL", "FI-KL", "VI-KL",
"random"),
at = c("theta", "bounds"),
it.range = NULL, n.select = 1,
delta = .1,
score = c("fixed", "step", "random",
"WLE", "BME", "EAP"),
range = c(-1, 1),
step.size = 3, leave.after.MLE = FALSE ),
catMiddle = list( select = c("UW-FI", "LW-FI", "PW-FI",
"FP-KL", "VP-KL", "FI-KL", "VI-KL",
"random"),
at = c("theta", "bounds"),
it.range = NULL, n.select = 1,
delta = .1,
score = c("MLE", "WLE", "BME", "EAP"),
range = c(-6, 6),
expos = c("none", "SH") ),
catTerm = list( term = c("fixed", "precision", "info", "class"),
score = c("MLE", "WLE", "BME", "EAP"),
n.min = 5, n.max = 50,
p.term = list(method = c("threshold", "change"),
crit = .25),
i.term = list(method = c("threshold", "change"),
crit = 2),
c.term = list(method = c("SPRT", "GLR", "CI"),
bounds = c(-1, 1),
categ = c(0, 1, 2),
delta = .1,
alpha = .05, beta = .05,
conf.lev = .95)),
ddist = dnorm,
progress = TRUE, ... )
{
# Make sure that the environments are OK, so that the "<<-" works.
environment(startCat) <- environment()
environment(middleCat) <- environment()
environment(termCat) <- environment()
#############################################################################
######################## BEGIN ARGUMENT CHECK SECTION #######################
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ARGUMENT CHECKS (PART 1) # (INITIAL CHECKING OF: resp/params/theta/mod)
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
## 1 ## (Make sure that the parameter matrix exists)
if( missing(params) )
stop( "need to supply a 'params' matrix" )
## 2 ## (Make sure that one of "resp" or "thetas" exists and is of appropriate dimension)
if( is.null(resp) & is.null(theta) ){
stop( "need to include 'resp' and/or 'theta'" )
} else if( !is.null(resp) & all(dim(resp)[2] != dim(params)[1]) ){
stop( "the number of 'resp' columns must equal the number of 'params' rows" )
} else if( ( !is.null(resp) & !is.null(theta) ) & all(dim(resp)[1] != length(theta)) ){
warning( "the number of 'resp' rows does not equal the length of 'theta'" )
} # END ifelse STATEMENTS
## 3 ## (Make sure that the model is appropriately declared)
mod.opt <- c("brm", "grm")
if(missing(mod))
mod <- NULL
if( (length(mod) != 1) | !any(mod %in% mod.opt) ){
# --> If class of resp inherits any of the appropriate models, set mod to that model OR
if( any(class(resp) %in% mod.opt) ){
mod <- class(resp)[class(resp) %in% mod.opt][1]
# --> Ask the user for the model (repeating until you get it).
} else if( interactive() ){
while( !( length(mod) == 1 & all(mod %in% mod.opt) ) )
mod <- readline( paste("Select from ONLY ONE of the following IRT models - ",
paste(mod.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'mod' must be ONLY ONE of ", paste(mod.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## 4 ## (If any of catStart/catMiddle/catTerm doesn't exist, then initialize it)
if(missing(catStart))
catStart <- NULL
if(missing(catMiddle))
catMiddle <- NULL
if(missing(catTerm))
catTerm <- NULL
## 5 ## (Make sure the parameters are OK for exposure control)
# --> If the user specifies multiple exposures or not an appropriate one, exposure should be none.
if( (length(catMiddle$expos) != 1) | !any(catMiddle$expos %in% c("none", "SH")) )
catMiddle$expos <- "none"
# --> If exposure is none, add an P(S | A) column of 1s.
if( catMiddle$expos == "none" )
params <- cbind(params, 1)
# --> If the user exists, warn the user about setting up the param matrix appropriately.
if( interactive() & progress )
cat("\nIff 'catMiddle$expos' equals 'SH', the last 'params' column must contain P(Admin | Select)'s.\n\n")
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# BUILDING THE PARAMS/RESPONSE MATRIX #
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# Making sure the parameters are of a particular class:
if( inherits(params, mod.opt) ){
if( any( round(params[ , 1]) != 1:nrow(params) ) ){
params <- cbind(1:nrow(params), params) # first column is item number
} # END if STATEMENT
} else{
params <- cbind(1:nrow(params), params) # first column is item number
} # END ifelse STATEMENT
# Building the response matrix and indicating its class:
if( is.null(resp) ){
resp <- simIrt(theta = theta, params = params[ , -c(1, ncol(params))], mod = mod)$resp
} else{
# And then make sure that 'resp' is a matrix:
resp <- rbind(resp)
class(resp) <- c(mod, "matrix")
} # END ifelse STATEMENT
# And then make sure that 'resp' is a matrix:
if( is.null( dim(resp) ) ){ # if it's a vector ... -->
resp <- matrix(resp, nrow = 1) # ... --> turn it into a multi-column matrix,
class(resp) <- c(mod, "matrix") # ... --> and indicate its class
} # END if STATEMENT
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ARGUMENT CHECKS (PART 2) # (MODEL-SPECIFIC CHECKS)
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
## FOR THE BINARY RESPONSE MODEL ##
if( mod == "brm" ){
## 1 ## (Make sure resp has all 0's and 1's and warn if it's ALL 0's or 1's)
if( any(resp != 0 & resp != 1) )
stop( "'resp' must only contain 0's and 1's" )
if( all(resp == 0) | all(resp == 1) )
warning( "'resp' contains only 0's or only 1's" )
## 2 ## (Make sure that the dimensions of params are correct)
if( dim(params)[2] != 5 )
stop( "'params' must have three or four columns: item, a, b, and c" )
## 3 ## (Naming and classing the parameters)
colnames(params) <- c("item", "a", "b", "c", "SH")
class(params) <- c(mod, "matrix")
} # END if (brm) STATEMENT
## FOR THE GRADED RESPONSE MODEL ##
if( mod == "grm" ){
## 1 ## (Make sure that the responses are all positive)
if( any(resp < 0) )
stop( "'resp' must contain positive integers" )
## 2 ## (Make sure that the responses are not too big)
if( any(resp > dim(params)[2]) )
stop( "every entry of 'resp' must be less than the number of columns of 'params'" )
## 3 ## (Make sure the parameters are in the appropriate order)
params <- cbind( params[, 1:2],
t(apply(params[, 3:(dim(params)[2] - 1)], MARGIN = 1, FUN = sort)),
params[, dim(params)[2]] )
## 4 ## (Naming and classing the parameters)
colnames(params) <- c("item", "a", paste("b", 1:(dim(params)[2] - 3), sep = ""), "SH")
class(params) <- c(mod, "matrix")
} # END if (grm) STATEMENT
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ARGUMENT CHECKS (PART 3) # (CHECKING OF: catStart/catMiddle/catTerm)
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
## I. FOR THE CATSTART LIST ##
## LIST OF OPTIONS ##
sel.opt <- c("UW-FI", "LW-FI", "PW-FI", "FP-KL", "VP-KL", "FI-KL", "VI-KL", "random")
at.opt <- c("theta", "bounds")
sco.opt <- c("fixed", "step", "random", "WLE", "BME", "EAP")
## a) n.start ##
if( {length(catStart$n.start) != 1 | !all(catStart$n.start %in% 1:nrow(params)) } ){
# --> Make sure 'n.it' is a positive integer that is not too large of a number.
if( interactive() ){
while( !( length(catStart$n.start) == 1 & all(catStart$n.start %in% 1:nrow(params)) ) ){
catStart$n.start <- readline("Select the number of items for starting the CAT: ")
catStart$n.start <- suppressWarnings(as.numeric(catStart$n.start))
} # END while LOOP
} else{
catStart$n.start <- 1
} # END ifelse STATEMENTS
} # END if STATEMENT
## b) init.theta ## (a number that ends up being as long as the number of examinees)
# --> If init.theta isn't specified, then it should be NA so the functions work.
if( is.null(catStart$init.theta) )
catStart$init.theta <- NA
# --> If init.theta is an odd length, warn the user.
if( length(catStart$init.theta) != 1 & (length(catStart$init.theta) != dim(resp)[1]) )
warning( "initial values are not specified for each simulee" )
# --> Turn init.theta into a numeric variable.
catStart$init.theta <- suppressWarnings(as.numeric(catStart$init.theta))
# --> And make sure that it is an actual number (and NOT NA).
if( interactive() ){
while( any(is.na(catStart$init.theta)) ){
catStart$init.theta <- readline("Select the initial/fixed trait estimate used for all simulees: ")
catStart$init.theta <- suppressWarnings(as.numeric(catStart$init.theta))
} # END while LOOP
} else{
catStart$init.theta <- rep(0, length.out = dim(resp))
} # END ifelse STATEMENT
# Finally, we want the same number of initial ability values as there are simulees.
catStart$init.theta <- rep(catStart$init.theta, length.out = dim(resp)[1])
## c) select ##
if( (length(catStart$select) != 1) | !any(catStart$select %in% sel.opt) ){
# --> Make sure 'select' matches one of the possible selection mechanisms.
if( interactive() ){
while( !( length(catStart$select) == 1 & all(catStart$select %in% sel.opt) ) )
catStart$select <- readline( paste("Select from ONLY ONE of the following starting methods to select items - ",
paste(sel.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$select' must be ONLY ONE of ", paste(sel.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## d) at ## (only if 'select' is not 'random', 'LW-FI' ,or 'PW-FI')
if( (length(catStart$at) != 1) | !any(catStart$at %in% at.opt) ){
# --> If we are randomly selecting or selecting based on weights, who cares about where.
if( catStart$select == "random" | catStart$select == "LW-FI" | catStart$select == "PW-FI" ){
catStart$at <- "theta"
# --> Make sure 'at' matches one of the possible selection-at mechanisms.
} else if( interactive() ){
while( !( length(catStart$at) == 1 & all(catStart$at %in% at.opt) ) )
catStart$at <- readline( paste("Select from ONLY ONE of the following starting locations to select items - ",
paste(at.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$at' must be ONLY ONE of ", paste(at.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## e) it.range ##
# --> If 'it.range' is specified for non-binary response models, warn
if( mod != "brm" & !is.null(catStart$it.range) )
warning("'catStart$it.range' can only be specified for 'brm'")
## f) n.select ##
# --> If 'n.select' is not specified, set it to 1.
if( length(catStart$n.select) != 1 )
catStart$n.select <- 1
## g) delta ## (only if using KL selection mechanism)
if( any( catStart$select %in% c("FP-KL", "VP-KL", "FI-KL", "VI-KL") ) ){
if( length(catStart$delta) != 1 )
catStart$delta <- NA
if( any(is.na(catStart$delta)) | any(!is.numeric(catStart$delta)) ){
# --> Make sure 'delta' is a positive number.
if(interactive()){
while( !( { length(catStart$delta) == 1 &
all(!is.na(catStart$delta)) &
all(is.numeric(catStart$delta)) } ) ){
catStart$delta <- readline("Select a starting half-width constant for use in KL information: ")
catStart$delta <- suppressWarnings(abs(as.numeric(catStart$delta)))
} # END while LOOP
} else{
catStart$delta <- .1
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## h) score ##
if( (length(catStart$score) != 1) | !any(catStart$score %in% sco.opt) ){
# --> Make sure 'score' matches one of the possible scoring methods.
if( interactive() ){
while( !( length(catStart$score) == 1 & all(catStart$score %in% sco.opt) ) )
catStart$score <- readline( paste("Select from ONLY ONE of the following starting methods to score the latent trait - ",
paste(sco.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$score' must be ONLY ONE of ", paste(sco.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## i) range ## (Make sure that the MLE/EAP/BME has an integer to maximize)
# --> If 'int' is not correctly specified, set it to a default.
if( length(catStart$range) != 2 )
catStart$range <- c(-6, 6)
# --> And making sure that the interval is in sorted order.
catStart$range <- sort(catStart$range)
## j) step.size ## (only if 'score' is 'step')
if( { catStart$score == "step" &
( length(catStart$step.size) != 1 | !is.numeric(catStart$step.size) ) } ){
# --> Make sure 'step.size' is a positive number.
if( interactive() ){
catStart$step.size <- NA
# --> If we don't have a number yet, read in a value and try to make it a positive number.
while( !( { length(catStart$step.size) == 1 &
all( !is.na(catStart$step.size) ) & is.numeric(catStart$step.size) } ) ){
catStart$step.size <- readline("Select the initial change in latent trait for a correct or incorrect response: ")
catStart$step.size <- suppressWarnings(abs(as.numeric(catStart$step.size)))
} # END while STATEMENT
} else{
catStart$step.size <- 1
} # END ifelse STATEMENTS
} # END if STATEMENT
## k) leave.after.MLE ##
# --> If 'leave.after.MLE' is not specified, set it to FALSE.
if( !is.logical(catStart$leave.after.MLE) )
catStart$leave.after.MLE <- FALSE
## II. FOR THE CATMIDDLE LIST ##
## LIST OF OPTIONS ##
sel.opt <- c("UW-FI", "LW-FI", "PW-FI", "FP-KL", "VP-KL", "FI-KL", "VI-KL", "random")
at.opt <- c("theta", "bounds")
sco.opt <- c("MLE", "WLE", "BME", "EAP")
## a) select ##
if( (length(catMiddle$select) != 1) | !any(catMiddle$select %in% sel.opt) ){
# --> Make sure 'select' matches one of the possible selection mechanisms.
if( interactive() ){
while( !( length(catMiddle$select) == 1 & all(catMiddle$select %in% sel.opt) ) )
catMiddle$select <- readline( paste("Select from ONLY ONE of the following middle methods to select items - ",
paste(sel.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catMiddle$select' must be ONLY ONE of ", paste(sel.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## b) at ## (only if 'select' is not 'random', 'LW-FI' ,or 'PW-FI')
if( (length(catMiddle$at) != 1) | !any(catMiddle$at %in% at.opt) ){
# --> If we are randomly selecting or selecting based on weights, who cares about where.
if( catMiddle$select == "random" | catMiddle$select == "LW-FI" | catMiddle$select == "PW-FI" ){
catMiddle$at <- "theta"
# --> Make sure 'at' matches one of the possible selection-at mechanisms.
} else if( interactive() ){
while( !( length(catMiddle$at) == 1 & all(catMiddle$at %in% at.opt) ) )
catMiddle$at <- readline( paste("Select from ONLY ONE of the following middle locations to select items - ",
paste(at.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$at' must be ONLY ONE of ", paste(at.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## c) it.range ##
# --> If 'it.range' is specified for non-binary response models, warn
if( mod != "brm" & !is.null(catMiddle$it.range) )
warning("'catMiddle$it.range' can only be specified for 'brm'")
## d) n.select ##
# --> If 'n.select' is not specified, set it to 1.
if( length(catMiddle$n.select) != 1)
catMiddle$n.select <- 1
## e) delta ## (only if using KL selection mechanism)
if( any( catMiddle$select %in% c("FP-KL", "VP-KL", "FI-KL", "VI-KL") ) ){
if( length(catMiddle$delta) != 1 )
catMiddle$delta <- NA
if( any(is.na(catMiddle$delta)) | any(!is.numeric(catMiddle$delta)) ){
# --> Make sure 'delta' is a positive number.
if(interactive()){
while( !( { length(catMiddle$delta) == 1 &
all(!is.na(catMiddle$delta)) &
all(is.numeric(catMiddle$delta)) } ) ){
catMiddle$delta <- readline("Select a middle half-width constant for use in KL information: ")
catMiddle$delta <- suppressWarnings(abs(as.numeric(catMiddle$delta)))
} # END while LOOP
} else{
catMiddle$delta <- .1
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## f) score ##
if( (length(catMiddle$score) != 1) | !any(catMiddle$score %in% sco.opt) ){
# --> Make sure 'score' matches one of the possible scoring methods.
if( interactive() ){
while( !( length(catMiddle$score) == 1 & all(catMiddle$score %in% sco.opt) ) )
catMiddle$score <- readline( paste("Select from ONLY ONE of the following middle methods to score the latent trait - ",
paste(sco.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catMiddle$score' must be ONLY ONE of ", paste(sco.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## g) range ## (Make sure that the MLE/EAP/BME has an integer to maximize)
# --> If 'int' is not correctly specified, set it to a default.
if( length(catMiddle$range) != 2 )
catMiddle$range <- c(-6, 6)
# --> And making sure that the interval is in sorted order.
catMiddle$range <- sort(catMiddle$range)
## III. FOR THE CATTERM LIST ##
## LIST OF OPTIONS ##
term.opt <- c("fixed", "precision", "info", "class")
sco.opt <- c("MLE", "WLE", "BME", "EAP")
p.meth.opt <- c("threshold", "change")
i.meth.opt <- c("threshold", "change")
c.meth.opt <- c("SPRT", "GLR", "CI")
## a) term ##
if( (length(catTerm$term) < 1) | !all(catTerm$term %in% term.opt) ){
# --> Make sure 'term' matches at least one of the possible termination criteria.
if( interactive() ){
while( !( length(catTerm$term) >= 1 & all(catTerm$term %in% term.opt) ) ){
cat("Select from one or more of the following stopping rules (press 'return' after each) - ",
paste(term.opt, collapse = ", "),
": ", sep = "")
catTerm$term <- scan(what = character(), n = length(term.opt), quiet = TRUE)
} # END while STATEMENT
} else{
stop( paste("'catTerm$term' must be ONLY ", paste(term.opt, collapse = " and/or "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## b) score ##
# --> If score at the end of the cat isn't specified, set it to the typical scoring.
if( (length(catTerm$score) < 1) | !all(catTerm$score %in% sco.opt))
catTerm$score <- catMiddle$score
## c) n.min ## (must be an integer greater than or equal to 0 and less than the number of params)
if( { is.null(catTerm$n.min) |
!all(catTerm$n.min %in% 1:nrow(params)) } ){
# --> Make sure 'n.it' is a positive integer that is not too large of a number.
if( interactive() ){
while( !( length(catTerm$n.min) == 1 & all(catTerm$n.min %in% 1:nrow(params)) ) ){
catTerm$n.min <- readline("Select a minimum number of items: ")
catTerm$n.min <- suppressWarnings(as.numeric(catTerm$n.min))
} # END while LOOP
} else{
catTerm$n.min <- 1
} # END ifelse STATEMENTS
} # END if STATEMENT
## d) n.max ## (must be an integer greater than n.min AND n.it or "all")
if( { is.null(catTerm$n.max) |
!all(catTerm$n.max %in% max(catTerm$n.min, catStart$n.it):nrow(params)) } ){
if(catTerm$n.max == "all" | catTerm$n.max == "'all'" | catTerm$n.max == "\"all\"")
catTerm$n.max <- nrow(params)
# --> Make sure 'n.it' is a positive integer that is not too small of a number.
if( interactive() ){
while( !( { (length(catTerm$n.max) == 1) &
all(catTerm$n.max %in% max(catTerm$n.min, catStart$n.it):nrow(params)) } ) ){
catTerm$n.max <- readline("Select a maximum number of items or 'all': ")
# --> If "all" is selected, break the while loop so the comparison isn't made.
if(catTerm$n.max == "all" | catTerm$n.max == "'all'" | catTerm$n.max == "\"all\""){
catTerm$n.max <- nrow(params)
} else{
catTerm$n.max <- suppressWarnings(as.numeric(catTerm$n.max))
} # END ifelse STATEMENT
} # END while LOOP
} else{
catTerm$n.max <- nrow(params)
} # END ifelse STATEMENTS
} # END if STATEMENT
# And if n.max is less than the total number of params, one of the termination is implicitly fixed.
if( catTerm$n.max < nrow(params) )
catTerm$term <- c(catTerm$term, "fixed")
## e) p.term ##
## e1) p.term --> method ## (only for the precision termination criterion)
if( { any(catTerm$term == "precision") &
( (length(catTerm$p.term$method) != 1) | !any(catTerm$p.term$method %in% p.meth.opt) ) } ){
# --> Make sure 'method' matches at least one of the possible method stopping rules.
if( interactive() ){
while( !( length(catTerm$p.term$method) == 1 & all(catTerm$p.term$method %in% p.meth.opt) ) )
catTerm$p.term$method <- readline( paste("Select from ONLY ONE of the following precision-based stopping rules - ",
paste(p.meth.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catTerm$p.term$method' must be ONLY ONE of ", paste(p.meth.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## e2) p.term --> crit ##
## threshold ##
if( any(catTerm$term == "precision" & catTerm$p.term$method %in% c("threshold") ) ){
if( length(catTerm$p.term$crit) != 1 )
catTerm$p.term$crit <- NA
if( any(is.na(catTerm$p.term$crit)) | any(!is.numeric(catTerm$p.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$p.term$crit <- readline("Select an SEM cut-off for variable termination: ")
catTerm$p.term$crit <- suppressWarnings(as.numeric(catTerm$p.term$crit))
if( !( all(!is.na(catTerm$p.term$crit)) & all(is.numeric(catTerm$p.term$crit)) ) )
next;
if( catTerm$p.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$p.term$crit <- .25
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## change ##
if( any(catTerm$term == "precision" & catTerm$p.term$method %in% c("change") ) ){
if( length(catTerm$p.term$crit) != 1 )
catTerm$p.term$crit <- NA
if( any(is.na(catTerm$p.term$crit)) | any(!is.numeric(catTerm$p.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$p.term$crit <- readline("Select the maximum SEM change for variable termination: ")
catTerm$p.term$crit <- suppressWarnings(as.numeric(catTerm$p.term$crit))
if( !( all(!is.na(catTerm$p.term$crit)) & all(is.numeric(catTerm$p.term$crit)) ) )
next;
if( catTerm$p.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$p.term$crit <- .25
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## f) i.term ## (only for the info termination criterion)
## f1) i.term --> method ## (only for the info termination criterion)
if( { any(catTerm$term == "info") &
( (length(catTerm$i.term$method) != 1) | !any(catTerm$i.term$method %in% i.meth.opt) ) } ){
# --> Make sure 'method' matches at least one of the possible method stopping rules.
if( interactive() ){
while( !( length(catTerm$i.term$method) == 1 & all(catTerm$i.term$method %in% i.meth.opt) ) )
catTerm$i.term$method <- readline( paste("Select from ONLY ONE of the following info-based stopping rules - ",
paste(i.meth.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catTerm$i.term$method' must be ONLY ONE of ", paste(i.meth.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## f2) i.term --> crit ##
## threshold ##
if( any(catTerm$term == "info" & catTerm$i.term$method %in% c("threshold") ) ){
if( length(catTerm$i.term$crit) != 1 )
catTerm$i.term$crit <- NA
if( any(is.na(catTerm$i.term$crit)) | any(!is.numeric(catTerm$i.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$i.term$crit <- readline("Select a Fisher Information cut-off for variable termination: ")
catTerm$i.term$crit <- suppressWarnings(as.numeric(catTerm$i.term$crit))
if( !( all(!is.na(catTerm$i.term$crit)) & all(is.numeric(catTerm$i.term$crit)) ) )
next;
if( catTerm$i.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$i.term$crit <- 2
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## change ##
if( any(catTerm$term == "info" & catTerm$i.term$method %in% c("change") ) ){
if( length(catTerm$i.term$crit) != 1 )
catTerm$i.term$crit <- NA
if( any(is.na(catTerm$i.term$crit)) | any(!is.numeric(catTerm$i.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$i.term$crit <- readline("Select the maximum Fisher Information change for variable termination: ")
catTerm$i.term$crit <- suppressWarnings(as.numeric(catTerm$i.term$crit))
if( !( all(!is.na(catTerm$i.term$crit)) & all(is.numeric(catTerm$i.term$crit)) ) )
next;
if( catTerm$i.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$i.term$crit <- .5
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## g) c.term ##
## g1) c.term --> method ## (only for the classification termination criterion)
if( { any(catTerm$term == "class") &
( (length(catTerm$c.term$method) != 1) | !any(catTerm$c.term$method %in% c.meth.opt) ) } ){
# --> Make sure 'method' matches at least one of the possible classification stopping rules.
if( interactive() ){
while( !( length(catTerm$c.term$method) == 1 & all(catTerm$c.term$method %in% c.meth.opt) ) )
catTerm$c.term$method <- readline( paste("Select from ONLY ONE of the following classification-based stopping rules - ",
paste(c.meth.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catTerm$c.term$method' must be ONLY ONE of ", paste(c.meth.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## g2) c.term --> bounds ## (only for the class termination criterion or weird selection)
if( any(catTerm$term == "class") | any(c(catStart$at, catMiddle$at) %in% "bounds") ){
# Step 1: Make sure that the classification bound(s) exist.
if( !all(is.numeric(catTerm$c.term$bounds)) ){
if( interactive() ){
catTerm$c.term$bounds <- NA
while( !( all(is.numeric(catTerm$c.term$bounds)) & all(!is.na(catTerm$c.term$bounds)) ) ){
cat("Select the classification bound(s) used for all simulees (press 'return' after each): ")
catTerm$c.term$bounds <- suppressWarnings(as.numeric(scan(what = character(), quiet = TRUE)))
} # END while LOOP
} else{
catTerm$c.term$bounds <- 0
} # END ifelse STATEMENT
} # END if STATEMENT
# Step 2: Turn the classification bounds into a matrix.
if( !is.null( dim(catTerm$c.term$bounds) ) ){
if( (nrow(catTerm$c.term$bounds) != 1) & (nrow(catTerm$c.term$bounds) != dim(resp)[1]) )
warning( "classification bounds are not specified for every simulee" )
# --> a) original matrix of bounds --> repeat that matrix for all people.
catTerm$c.term$bounds <- matrix(catTerm$c.term$bounds,
nrow = dim(resp)[1],
ncol = dim(catTerm$c.term$bounds)[2],
byrow = TRUE)
} else if( length(catTerm$c.term$bounds) == dim(resp)[1] ){
# --> b) original vector of bounds equal to simulees --> one-column matrix.
catTerm$c.term$bounds <- matrix(catTerm$c.term$bounds,
nrow = dim(resp)[1],
ncol = 1,
byrow = TRUE)
} else{
# --> c) original vector of bounds NOT equal to simulees --> vector is on each row.
catTerm$c.term$bounds <- matrix(catTerm$c.term$bounds,
nrow = dim(resp)[1],
ncol = length(catTerm$c.term$bounds),
byrow = TRUE)
} # END ifelse STATEMENTS
# --> d) sort the bounds (with a trick incase there is only one bound per person).
catTerm$c.term$bounds <- t( apply( cbind(catTerm$c.term$bounds, -Inf),
MARGIN = 1, FUN = sort ) )[ , -1, drop = FALSE]
} # END if STATEMENT
## g3) c.term --> categ ## (only for the class termination criterion)
if( any(catTerm$term == "class") & is.null(catTerm$c.term$categ) )
catTerm$c.term$categ <- 1:(ncol(catTerm$c.term$bounds) + 1)
## g4) c.term --> delta ## (only for the class termination criterion)
if( { any( catTerm$term == "class" & catTerm$c.term$method %in% c("SPRT", "GLR") ) } ){
if( length(catTerm$c.term$delta) != 1 )
catTerm$c.term$delta <- NA
if( any(is.na(catTerm$c.term$delta)) | any(!is.numeric(catTerm$c.term$delta)) ){
# --> Make sure 'delta' is a positive number.
if(interactive()){
while( !( { length(catTerm$c.term$delta) == 1 &
all(!is.na(catTerm$c.term$delta)) &
all(is.numeric(catTerm$c.term$delta)) } ) ){
catTerm$c.term$delta <- readline("Select an indifference region/testing half-width: ")
catTerm$c.term$delta <- suppressWarnings(abs(as.numeric(catTerm$c.term$delta)))
} # END while LOOP
} else{
catTerm$c.term$delta <- .1
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## g5) c.term --> alpha/beta ##
if( any( catTerm$term == "class" & catTerm$c.term$method %in% c("SPRT", "GLR") ) ){
if( length(catTerm$c.term$alpha) != 1 )
catTerm$c.term$alpha <- NA
if( length(catTerm$c.term$beta) != 1 )
catTerm$c.term$beta <- NA
if( any(is.na(catTerm$c.term$alpha)) | any(!is.numeric(catTerm$c.term$alpha)) ){
# --> Make sure 'alpha' is a positive number between 0 and 1.
if( interactive() ){
repeat{
catTerm$c.term$alpha <- readline("Select an SPRT specified Type I error rate: ")
catTerm$c.term$alpha <- suppressWarnings(as.numeric(catTerm$c.term$alpha))
if( !( all(!is.na(catTerm$c.term$alpha)) & all(is.numeric(catTerm$c.term$alpha)) ) )
next;
if( catTerm$c.term$alpha < 1 & catTerm$c.term$alpha > 0 )
break;
} # END repeat LOOP
} else{
catTerm$c.term$alpha <- .05
} # END ifelse STATEMENTS
} # END if STATEMENTS
if( any(is.na(catTerm$c.term$beta)) | any(!is.numeric(catTerm$c.term$beta)) ){
# --> Make sure 'beta' is a positive number between 0 and 1.
if( interactive() ){
repeat{
catTerm$c.term$beta <- readline("Select an SPRT specified Type II error rate: ")
catTerm$c.term$beta <- suppressWarnings(as.numeric(catTerm$c.term$beta))
if( !( all(!is.na(catTerm$c.term$beta)) & all(is.numeric(catTerm$c.term$beta)) ) )
next;
if( catTerm$c.term$beta < 1 & catTerm$c.term$beta > 0 )
break;
} # END repeat LOOP
} else{
catTerm$c.term$beta <- .05
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## g6) c.term --> conf.lev ##
if( any(catTerm$term == "class" & catTerm$c.term$method %in% c("CI") ) ){
if( length(catTerm$c.term$conf.lev) != 1 )
catTerm$c.term$conf.lev <- NA
if( any(is.na(catTerm$c.term$conf.lev)) | any(!is.numeric(catTerm$c.term$conf.lev)) ){
# --> Make sure 'conf.lev' is a positive number between 0 and 1.
if( interactive() ){
repeat{
catTerm$c.term$conf.lev <- readline("Select a confidence interval level between 0 and 1: ")
catTerm$c.term$conf.lev <- suppressWarnings(as.numeric(catTerm$c.term$conf.lev))
if( !( all(!is.na(catTerm$c.term$conf.lev)) & all(is.numeric(catTerm$c.term$conf.lev)) ) )
next;
if( catTerm$c.term$conf.lev < 1 & catTerm$c.term$conf.lev > 0 )
break;
} # END repeat LOOP
} else{
catTerm$c.term$conf.lev <- .95
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
######################## END ARGUMENT CHECK SECTION #######################
###########################################################################
#~~~~~~~~~~~~~~~~~~~~~~~~#
# SETTING UP THE OBJECTS #
#~~~~~~~~~~~~~~~~~~~~~~~~#
# The number of people should be equal to the number of response matrix rows:
N <- dim(resp)[1] # N is the number of row of theta/resp
J <- dim(params)[1] # J is the number of rows of params
# A list to store individual, person attributes (final responses, final theta, etc.)
cat_indiv <- vector("list", length = N)
# Vectors to store CAT thetas, categories, test info, and SEM:
cat_theta <- vector("numeric", length = N)
cat_categ <- vector("character", length = N)
cat_info <- vector("numeric", length = N)
cat_sem <- vector("numeric", length = N)
cat_length <- vector("numeric", length = N)
cat_term <- vector("character", length = N)
# Vectors to store TOT thetas, categories, test info, and SEM:
tot_theta <- vector("numeric", length = N)
tot_categ <- vector("character", length = N)
tot_info <- vector("numeric", length = N)
tot_sem <- vector("numeric", length = N)
# Vectors to store TRUE thetas, categories:
if( missing(theta) ){
theta <- NULL
true_theta <- rep(NA, length = N)
} else if( is.null(theta) ){
true_theta <- rep(NA, length = N)
} else{
true_theta <- theta
} # END ifelse STATEMENT
true_categ <- vector("character", length = N)
# To store the selection rates (for Sympson-Hetter):
S <- NULL
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# RUNNING THROUGH THE CAT: PER PERSON #
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
#~~~~~~~~~~~~~~~~~~~~~~#
# Progress Statement 1 #
#~~~~~~~~~~~~~~~~~~~~~~#
# For calibrations, we will want to suppress the upper progress bar.
if( progress ){
cat("CAT Progress:\n")
pb <- txtProgressBar(min = 0, max = N, initial = 0, char = "*", style = 3)
} # END if STATEMENT
# We will repeat the CAT for each person:
for( i in 1:N ){
#####
# 1 # (INITIALIZING THE CAT)
#####
# First, the particular simulee's response vector:
resp.i <- resp[i, ]
catStart.i <- catStart
catMiddle.i <- catMiddle
catTerm.i <- catTerm
# Second, the particular simulee's initial theta value and classification bounds:
catStart.i$init.theta <- catStart$init.theta[i]
if( !is.null( dim(catTerm$c.term$bounds) ) )
catTerm.i$c.term$bounds <- catTerm$c.term$bounds[i, ]
#####
# 2 # (THE FIRST SEVERAL ITEMS)
#####
# Responses, proximate theta ests/info/sem, item numbers/parameters of CAT:
cat_resp.i <- rep(NA, times = catTerm.i$n.max)
cat_par.i <- matrix(NA, nrow = catTerm.i$n.max, ncol = ncol(params))
cat_it.i <- cat_resp.i
cat_theta.i <- c(catStart.i$init.theta, cat_resp.i)
cat_info.i <- cat_resp.i
cat_sem.i <- cat_resp.i
# Setting the classes, so the other functions will work.
class(cat_par.i) <- class(resp)
class(cat_resp.i) <- mod
# A vector indicating whether or not the examinee has taken an item:
it_flags <- rep(0, nrow(params))
# Running the loop at the beginning of the CAT for each person:
x <- startCat( params = params, resp = resp.i, mod = mod,
it_flags = it_flags,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i,
ddist = ddist, ... )
# Updated to where we are in the CAT:
j <- x$j
S <- c(S, x$S)
#####
# 3 # (PRELIMINARY TERMINATION CHECK)
#####
# If the estimation method for early CATs was silly, then re-estimate.
if( any(catStart.i$score %in% c("fixed", "step", "random")) ){
# --> a) Build a character string for the WLE/EAP/BME estimation function,
scoreFun <- paste(tolower(catMiddle.i$score), "Est", sep = "")
# --> b) Call the estimation function on stuff to this point,
x <- get(scoreFun)( resp = cat_resp.i[1:j],
params = cat_par.i[1:j, -c(1, ncol(params)), drop = FALSE],
range = catMiddle.i$range, mod = mod,
ddist = ddist, ... )
cat_theta.i[j + 1] <- x$theta
cat_info.i[j] <- x$info
cat_sem.i[j] <- x$sem
} # END if STATEMENT
# Before entering the loop check the termination criterion:
y <- termCat( params = params[ , -c(1, ncol(params))],
resp = resp.i,
mod = mod,
it_flags = it_flags,
cat_par = cat_par.i[1:j , -c(1, ncol(cat_par.i)), drop = FALSE],
cat_resp = cat_resp.i[1:j],
cat_theta = cat_theta.i[j + 1],
cat_info = cat_info.i,
cat_sem = cat_sem.i,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i )
# And if we should stop, skip the while loop altogether:
stp <- y$cat_dec$stp
#####
# 4 # (THE REMAINING ITEMS)
#####
# We will repeat the next several steps until the CAT is over :(
while( !stp ){
x <- middleCat( params = params,
resp = resp.i,
mod = mod,
it_flags = it_flags,
cat_par = cat_par.i[1:j, , drop = FALSE],
cat_it = cat_it.i[1:j],
cat_resp = cat_resp.i[1:j],
cat_theta = cat_theta.i[j + 1],
cat_info = cat_info.i,
cat_sem = cat_sem.i,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i,
ddist = ddist, ... )
# Updated to where we are in the CAT:
j <- x$j
S <- c(S, x$S)
y <- termCat( params = params[ , -c(1, ncol(params))],
resp = resp.i,
mod = mod,
it_flags = it_flags,
cat_par = cat_par.i[1:j , -c(1, ncol(cat_par.i)), drop = FALSE],
cat_resp = cat_resp.i[1:j],
cat_theta = cat_theta.i[j + 1],
cat_info = cat_info.i,
cat_sem = cat_sem.i,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i )
stp <- y$cat_dec$stp
} # END while LOOP
#####
# 5 # (FINAL ASSIGNMENT AND FINAL CATEGORY STUFF)
#####
# Need to indicate: true (a) class, (b) theta (if applicable), and
# total (a) class, (b) theta.
# First, find the appropriate theta estimate given resp and params.
# --> a) Build a character string for the WLE/EAP/BME estimation function,
scoreFun <- paste(tolower(catTerm.i$score), "Est", sep = "")
# --> b) Call the estimation function on stuff to this point,
x <- get(scoreFun)( resp = resp.i,
params = params[ , -c(1, ncol(params))],
range = catMiddle.i$range, mod = mod, ddist = ddist, ... )
tot_theta[i] <- x$theta
tot_info[i] <- x$info
tot_sem[i] <- x$sem
# If the EAP estimate didn't work, change estimation to BME with same dist/params:
if( catTerm.i$score == "EAP" & is.nan(x$theta) ){
# --> a) Change scoring of the total theta to BME,
catTerm$score <- "BME"
# --> b) Estimate the total thetas to this point as BME.
x <- bmeEst( resp = resp[1:i, ],
params = params[ , -c(1, ncol(params))],
range = catMiddle.i$range, mod = mod, ddist = ddist, ... )
tot_theta[1:i] <- x$theta
tot_info[1:i] <- x$info
tot_sem[1:i] <- x$sem
msg <- TRUE
} # END if STATEMENT
# Second, determine the true and total classification.
if( any(catTerm.i$term == "class") ){
tot_categ[i] <- catTerm.i$c.term$categ[sum( tot_theta[i] > catTerm.i$c.term$bounds ) + 1] # based on total-test thetas
if( !is.null(theta) )
true_categ[i] <- catTerm.i$c.term$categ[sum( theta[i] > catTerm.i$c.term$bounds ) + 1] # based on true thetas
} # END if STATEMENT
# Third, insert all of the individual CAT (thetas, sem, ... ) stuff
cat_theta[i] <- cat_theta.i[j + 1]
cat_categ[i] <- y$cat_categ
cat_info[i] <- cat_info.i[j]
cat_sem[i] <- cat_sem.i[j]
cat_term[i] <- y$cat_dec$term
cat_length[i] <- j
# Fourth, name the CAT parameters to put into the cat_indiv list.
colnames(cat_par.i) <- colnames(params)
# Note that j had already been declared before another item/estimation.
cat_indiv[[i]] <- list( cat_theta = cat_theta.i[1:(j + 1)],
cat_it = cat_it.i[1:j],
cat_info = c(NA, cat_info.i[1:j]),
cat_sem = c(NA, cat_sem.i[1:j]),
cat_resp = cat_resp.i[1:j],
cat_params = cat_par.i[1:j, ] )
#~~~~~~~~~~~~~~~~~~~~~~#
# Progress Statement 2 #
#~~~~~~~~~~~~~~~~~~~~~~#
# And indicate the progress thus far into the cat:
if( progress )
setTxtProgressBar(pb, value = i)
} # END for i LOOP
if( progress )
cat("\n")
# And if we had to change EAP to BME, let people know:
if( exists("msg", where = environment()) )
if( msg )
cat("\nToo large an item bank for full-test EAP estimation. Changed estimation for full-test to BME.\n")
#~~~~~~~~~~~~~~~~~~~#
# FINISHING THE CAT #
#~~~~~~~~~~~~~~~~~~~#
# Determining the number of times each item was selected/administered:
select <- tabulate(S, nbins = nrow(params))
admin <- tabulate(do.call(c, lapply(cat_indiv, FUN = function(x) x$cat_it)), nbins = nrow(params))
names(select) <- names(admin) <- 1:nrow(params)
ret <- list( cat_theta = cat_theta, cat_categ = cat_categ, # CAT STUFF
cat_info = cat_info, cat_sem = cat_sem, # CAT STUFF
cat_length = cat_length, cat_term = cat_term, # CAT STUFF
tot_theta = tot_theta, tot_categ = tot_categ, # TOTAL TEST STUFF
tot_info = tot_info, tot_sem = tot_sem, # TOTAL TEST STUFF
true_theta = true_theta, true_categ = true_categ, # TRUE STUFF
full_params = params, full_resp = resp, # FULL PARAMETERS AND RESPONSES
it_select = list(select = select, admin = admin), # TABLE OF SELECTED AND ADMINISTERED ITEMS
cat_indiv = cat_indiv, # INDIVIDUAL STUFF
mod = list(mod = mod, catStart = catStart, catMiddle = catMiddle, catTerm = catTerm) )
class(ret) <- "catIrt"
return(ret)
} # END catIrt FUNCTION
Try the catIrt package in your browser
Any scripts or data that you put into this service are public.
catIrt documentation built on May 28, 2022, 1:09 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Defines functions catIrt
Documented in catIrt
# This function will be the main CAT function.
catIrt <- function( params, mod = c("brm", "grm"),
resp = NULL,
theta = NULL,
catStart = list( n.start = 5, init.theta = 0,
select = c("UW-FI", "LW-FI", "PW-FI",
"FP-KL", "VP-KL", "FI-KL", "VI-KL",
"random"),
at = c("theta", "bounds"),
it.range = NULL, n.select = 1,
delta = .1,
score = c("fixed", "step", "random",
"WLE", "BME", "EAP"),
range = c(-1, 1),
step.size = 3, leave.after.MLE = FALSE ),
catMiddle = list( select = c("UW-FI", "LW-FI", "PW-FI",
"FP-KL", "VP-KL", "FI-KL", "VI-KL",
"random"),
at = c("theta", "bounds"),
it.range = NULL, n.select = 1,
delta = .1,
score = c("MLE", "WLE", "BME", "EAP"),
range = c(-6, 6),
expos = c("none", "SH") ),
catTerm = list( term = c("fixed", "precision", "info", "class"),
score = c("MLE", "WLE", "BME", "EAP"),
n.min = 5, n.max = 50,
p.term = list(method = c("threshold", "change"),
crit = .25),
i.term = list(method = c("threshold", "change"),
crit = 2),
c.term = list(method = c("SPRT", "GLR", "CI"),
bounds = c(-1, 1),
categ = c(0, 1, 2),
delta = .1,
alpha = .05, beta = .05,
conf.lev = .95)),
ddist = dnorm,
progress = TRUE, ... )
{
# Make sure that the environments are OK, so that the "<<-" works.
environment(startCat) <- environment()
environment(middleCat) <- environment()
environment(termCat) <- environment()
#############################################################################
######################## BEGIN ARGUMENT CHECK SECTION #######################
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ARGUMENT CHECKS (PART 1) # (INITIAL CHECKING OF: resp/params/theta/mod)
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
## 1 ## (Make sure that the parameter matrix exists)
if( missing(params) )
stop( "need to supply a 'params' matrix" )
## 2 ## (Make sure that one of "resp" or "thetas" exists and is of appropriate dimension)
if( is.null(resp) & is.null(theta) ){
stop( "need to include 'resp' and/or 'theta'" )
} else if( !is.null(resp) & all(dim(resp)[2] != dim(params)[1]) ){
stop( "the number of 'resp' columns must equal the number of 'params' rows" )
} else if( ( !is.null(resp) & !is.null(theta) ) & all(dim(resp)[1] != length(theta)) ){
warning( "the number of 'resp' rows does not equal the length of 'theta'" )
} # END ifelse STATEMENTS
## 3 ## (Make sure that the model is appropriately declared)
mod.opt <- c("brm", "grm")
if(missing(mod))
mod <- NULL
if( (length(mod) != 1) | !any(mod %in% mod.opt) ){
# --> If class of resp inherits any of the appropriate models, set mod to that model OR
if( any(class(resp) %in% mod.opt) ){
mod <- class(resp)[class(resp) %in% mod.opt][1]
# --> Ask the user for the model (repeating until you get it).
} else if( interactive() ){
while( !( length(mod) == 1 & all(mod %in% mod.opt) ) )
mod <- readline( paste("Select from ONLY ONE of the following IRT models - ",
paste(mod.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'mod' must be ONLY ONE of ", paste(mod.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## 4 ## (If any of catStart/catMiddle/catTerm doesn't exist, then initialize it)
if(missing(catStart))
catStart <- NULL
if(missing(catMiddle))
catMiddle <- NULL
if(missing(catTerm))
catTerm <- NULL
## 5 ## (Make sure the parameters are OK for exposure control)
# --> If the user specifies multiple exposures or not an appropriate one, exposure should be none.
if( (length(catMiddle$expos) != 1) | !any(catMiddle$expos %in% c("none", "SH")) )
catMiddle$expos <- "none"
# --> If exposure is none, add an P(S | A) column of 1s.
if( catMiddle$expos == "none" )
params <- cbind(params, 1)
# --> If the user exists, warn the user about setting up the param matrix appropriately.
if( interactive() & progress )
cat("\nIff 'catMiddle$expos' equals 'SH', the last 'params' column must contain P(Admin | Select)'s.\n\n")
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# BUILDING THE PARAMS/RESPONSE MATRIX #
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# Making sure the parameters are of a particular class:
if( inherits(params, mod.opt) ){
if( any( round(params[ , 1]) != 1:nrow(params) ) ){
params <- cbind(1:nrow(params), params) # first column is item number
} # END if STATEMENT
} else{
params <- cbind(1:nrow(params), params) # first column is item number
} # END ifelse STATEMENT
# Building the response matrix and indicating its class:
if( is.null(resp) ){
resp <- simIrt(theta = theta, params = params[ , -c(1, ncol(params))], mod = mod)$resp
} else{
# And then make sure that 'resp' is a matrix:
resp <- rbind(resp)
class(resp) <- c(mod, "matrix")
} # END ifelse STATEMENT
# And then make sure that 'resp' is a matrix:
if( is.null( dim(resp) ) ){ # if it's a vector ... -->
resp <- matrix(resp, nrow = 1) # ... --> turn it into a multi-column matrix,
class(resp) <- c(mod, "matrix") # ... --> and indicate its class
} # END if STATEMENT
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ARGUMENT CHECKS (PART 2) # (MODEL-SPECIFIC CHECKS)
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
## FOR THE BINARY RESPONSE MODEL ##
if( mod == "brm" ){
## 1 ## (Make sure resp has all 0's and 1's and warn if it's ALL 0's or 1's)
if( any(resp != 0 & resp != 1) )
stop( "'resp' must only contain 0's and 1's" )
if( all(resp == 0) | all(resp == 1) )
warning( "'resp' contains only 0's or only 1's" )
## 2 ## (Make sure that the dimensions of params are correct)
if( dim(params)[2] != 5 )
stop( "'params' must have three or four columns: item, a, b, and c" )
## 3 ## (Naming and classing the parameters)
colnames(params) <- c("item", "a", "b", "c", "SH")
class(params) <- c(mod, "matrix")
} # END if (brm) STATEMENT
## FOR THE GRADED RESPONSE MODEL ##
if( mod == "grm" ){
## 1 ## (Make sure that the responses are all positive)
if( any(resp < 0) )
stop( "'resp' must contain positive integers" )
## 2 ## (Make sure that the responses are not too big)
if( any(resp > dim(params)[2]) )
stop( "every entry of 'resp' must be less than the number of columns of 'params'" )
## 3 ## (Make sure the parameters are in the appropriate order)
params <- cbind( params[, 1:2],
t(apply(params[, 3:(dim(params)[2] - 1)], MARGIN = 1, FUN = sort)),
params[, dim(params)[2]] )
## 4 ## (Naming and classing the parameters)
colnames(params) <- c("item", "a", paste("b", 1:(dim(params)[2] - 3), sep = ""), "SH")
class(params) <- c(mod, "matrix")
} # END if (grm) STATEMENT
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
# ARGUMENT CHECKS (PART 3) # (CHECKING OF: catStart/catMiddle/catTerm)
#~~~~~~~~~~~~~~~~~~~~~~~~~~#
## I. FOR THE CATSTART LIST ##
## LIST OF OPTIONS ##
sel.opt <- c("UW-FI", "LW-FI", "PW-FI", "FP-KL", "VP-KL", "FI-KL", "VI-KL", "random")
at.opt <- c("theta", "bounds")
sco.opt <- c("fixed", "step", "random", "WLE", "BME", "EAP")
## a) n.start ##
if( {length(catStart$n.start) != 1 | !all(catStart$n.start %in% 1:nrow(params)) } ){
# --> Make sure 'n.it' is a positive integer that is not too large of a number.
if( interactive() ){
while( !( length(catStart$n.start) == 1 & all(catStart$n.start %in% 1:nrow(params)) ) ){
catStart$n.start <- readline("Select the number of items for starting the CAT: ")
catStart$n.start <- suppressWarnings(as.numeric(catStart$n.start))
} # END while LOOP
} else{
catStart$n.start <- 1
} # END ifelse STATEMENTS
} # END if STATEMENT
## b) init.theta ## (a number that ends up being as long as the number of examinees)
# --> If init.theta isn't specified, then it should be NA so the functions work.
if( is.null(catStart$init.theta) )
catStart$init.theta <- NA
# --> If init.theta is an odd length, warn the user.
if( length(catStart$init.theta) != 1 & (length(catStart$init.theta) != dim(resp)[1]) )
warning( "initial values are not specified for each simulee" )
# --> Turn init.theta into a numeric variable.
catStart$init.theta <- suppressWarnings(as.numeric(catStart$init.theta))
# --> And make sure that it is an actual number (and NOT NA).
if( interactive() ){
while( any(is.na(catStart$init.theta)) ){
catStart$init.theta <- readline("Select the initial/fixed trait estimate used for all simulees: ")
catStart$init.theta <- suppressWarnings(as.numeric(catStart$init.theta))
} # END while LOOP
} else{
catStart$init.theta <- rep(0, length.out = dim(resp))
} # END ifelse STATEMENT
# Finally, we want the same number of initial ability values as there are simulees.
catStart$init.theta <- rep(catStart$init.theta, length.out = dim(resp)[1])
## c) select ##
if( (length(catStart$select) != 1) | !any(catStart$select %in% sel.opt) ){
# --> Make sure 'select' matches one of the possible selection mechanisms.
if( interactive() ){
while( !( length(catStart$select) == 1 & all(catStart$select %in% sel.opt) ) )
catStart$select <- readline( paste("Select from ONLY ONE of the following starting methods to select items - ",
paste(sel.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$select' must be ONLY ONE of ", paste(sel.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## d) at ## (only if 'select' is not 'random', 'LW-FI' ,or 'PW-FI')
if( (length(catStart$at) != 1) | !any(catStart$at %in% at.opt) ){
# --> If we are randomly selecting or selecting based on weights, who cares about where.
if( catStart$select == "random" | catStart$select == "LW-FI" | catStart$select == "PW-FI" ){
catStart$at <- "theta"
# --> Make sure 'at' matches one of the possible selection-at mechanisms.
} else if( interactive() ){
while( !( length(catStart$at) == 1 & all(catStart$at %in% at.opt) ) )
catStart$at <- readline( paste("Select from ONLY ONE of the following starting locations to select items - ",
paste(at.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$at' must be ONLY ONE of ", paste(at.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## e) it.range ##
# --> If 'it.range' is specified for non-binary response models, warn
if( mod != "brm" & !is.null(catStart$it.range) )
warning("'catStart$it.range' can only be specified for 'brm'")
## f) n.select ##
# --> If 'n.select' is not specified, set it to 1.
if( length(catStart$n.select) != 1 )
catStart$n.select <- 1
## g) delta ## (only if using KL selection mechanism)
if( any( catStart$select %in% c("FP-KL", "VP-KL", "FI-KL", "VI-KL") ) ){
if( length(catStart$delta) != 1 )
catStart$delta <- NA
if( any(is.na(catStart$delta)) | any(!is.numeric(catStart$delta)) ){
# --> Make sure 'delta' is a positive number.
if(interactive()){
while( !( { length(catStart$delta) == 1 &
all(!is.na(catStart$delta)) &
all(is.numeric(catStart$delta)) } ) ){
catStart$delta <- readline("Select a starting half-width constant for use in KL information: ")
catStart$delta <- suppressWarnings(abs(as.numeric(catStart$delta)))
} # END while LOOP
} else{
catStart$delta <- .1
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## h) score ##
if( (length(catStart$score) != 1) | !any(catStart$score %in% sco.opt) ){
# --> Make sure 'score' matches one of the possible scoring methods.
if( interactive() ){
while( !( length(catStart$score) == 1 & all(catStart$score %in% sco.opt) ) )
catStart$score <- readline( paste("Select from ONLY ONE of the following starting methods to score the latent trait - ",
paste(sco.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$score' must be ONLY ONE of ", paste(sco.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## i) range ## (Make sure that the MLE/EAP/BME has an integer to maximize)
# --> If 'int' is not correctly specified, set it to a default.
if( length(catStart$range) != 2 )
catStart$range <- c(-6, 6)
# --> And making sure that the interval is in sorted order.
catStart$range <- sort(catStart$range)
## j) step.size ## (only if 'score' is 'step')
if( { catStart$score == "step" &
( length(catStart$step.size) != 1 | !is.numeric(catStart$step.size) ) } ){
# --> Make sure 'step.size' is a positive number.
if( interactive() ){
catStart$step.size <- NA
# --> If we don't have a number yet, read in a value and try to make it a positive number.
while( !( { length(catStart$step.size) == 1 &
all( !is.na(catStart$step.size) ) & is.numeric(catStart$step.size) } ) ){
catStart$step.size <- readline("Select the initial change in latent trait for a correct or incorrect response: ")
catStart$step.size <- suppressWarnings(abs(as.numeric(catStart$step.size)))
} # END while STATEMENT
} else{
catStart$step.size <- 1
} # END ifelse STATEMENTS
} # END if STATEMENT
## k) leave.after.MLE ##
# --> If 'leave.after.MLE' is not specified, set it to FALSE.
if( !is.logical(catStart$leave.after.MLE) )
catStart$leave.after.MLE <- FALSE
## II. FOR THE CATMIDDLE LIST ##
## LIST OF OPTIONS ##
sel.opt <- c("UW-FI", "LW-FI", "PW-FI", "FP-KL", "VP-KL", "FI-KL", "VI-KL", "random")
at.opt <- c("theta", "bounds")
sco.opt <- c("MLE", "WLE", "BME", "EAP")
## a) select ##
if( (length(catMiddle$select) != 1) | !any(catMiddle$select %in% sel.opt) ){
# --> Make sure 'select' matches one of the possible selection mechanisms.
if( interactive() ){
while( !( length(catMiddle$select) == 1 & all(catMiddle$select %in% sel.opt) ) )
catMiddle$select <- readline( paste("Select from ONLY ONE of the following middle methods to select items - ",
paste(sel.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catMiddle$select' must be ONLY ONE of ", paste(sel.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## b) at ## (only if 'select' is not 'random', 'LW-FI' ,or 'PW-FI')
if( (length(catMiddle$at) != 1) | !any(catMiddle$at %in% at.opt) ){
# --> If we are randomly selecting or selecting based on weights, who cares about where.
if( catMiddle$select == "random" | catMiddle$select == "LW-FI" | catMiddle$select == "PW-FI" ){
catMiddle$at <- "theta"
# --> Make sure 'at' matches one of the possible selection-at mechanisms.
} else if( interactive() ){
while( !( length(catMiddle$at) == 1 & all(catMiddle$at %in% at.opt) ) )
catMiddle$at <- readline( paste("Select from ONLY ONE of the following middle locations to select items - ",
paste(at.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catStart$at' must be ONLY ONE of ", paste(at.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## c) it.range ##
# --> If 'it.range' is specified for non-binary response models, warn
if( mod != "brm" & !is.null(catMiddle$it.range) )
warning("'catMiddle$it.range' can only be specified for 'brm'")
## d) n.select ##
# --> If 'n.select' is not specified, set it to 1.
if( length(catMiddle$n.select) != 1)
catMiddle$n.select <- 1
## e) delta ## (only if using KL selection mechanism)
if( any( catMiddle$select %in% c("FP-KL", "VP-KL", "FI-KL", "VI-KL") ) ){
if( length(catMiddle$delta) != 1 )
catMiddle$delta <- NA
if( any(is.na(catMiddle$delta)) | any(!is.numeric(catMiddle$delta)) ){
# --> Make sure 'delta' is a positive number.
if(interactive()){
while( !( { length(catMiddle$delta) == 1 &
all(!is.na(catMiddle$delta)) &
all(is.numeric(catMiddle$delta)) } ) ){
catMiddle$delta <- readline("Select a middle half-width constant for use in KL information: ")
catMiddle$delta <- suppressWarnings(abs(as.numeric(catMiddle$delta)))
} # END while LOOP
} else{
catMiddle$delta <- .1
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## f) score ##
if( (length(catMiddle$score) != 1) | !any(catMiddle$score %in% sco.opt) ){
# --> Make sure 'score' matches one of the possible scoring methods.
if( interactive() ){
while( !( length(catMiddle$score) == 1 & all(catMiddle$score %in% sco.opt) ) )
catMiddle$score <- readline( paste("Select from ONLY ONE of the following middle methods to score the latent trait - ",
paste(sco.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catMiddle$score' must be ONLY ONE of ", paste(sco.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## g) range ## (Make sure that the MLE/EAP/BME has an integer to maximize)
# --> If 'int' is not correctly specified, set it to a default.
if( length(catMiddle$range) != 2 )
catMiddle$range <- c(-6, 6)
# --> And making sure that the interval is in sorted order.
catMiddle$range <- sort(catMiddle$range)
## III. FOR THE CATTERM LIST ##
## LIST OF OPTIONS ##
term.opt <- c("fixed", "precision", "info", "class")
sco.opt <- c("MLE", "WLE", "BME", "EAP")
p.meth.opt <- c("threshold", "change")
i.meth.opt <- c("threshold", "change")
c.meth.opt <- c("SPRT", "GLR", "CI")
## a) term ##
if( (length(catTerm$term) < 1) | !all(catTerm$term %in% term.opt) ){
# --> Make sure 'term' matches at least one of the possible termination criteria.
if( interactive() ){
while( !( length(catTerm$term) >= 1 & all(catTerm$term %in% term.opt) ) ){
cat("Select from one or more of the following stopping rules (press 'return' after each) - ",
paste(term.opt, collapse = ", "),
": ", sep = "")
catTerm$term <- scan(what = character(), n = length(term.opt), quiet = TRUE)
} # END while STATEMENT
} else{
stop( paste("'catTerm$term' must be ONLY ", paste(term.opt, collapse = " and/or "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## b) score ##
# --> If score at the end of the cat isn't specified, set it to the typical scoring.
if( (length(catTerm$score) < 1) | !all(catTerm$score %in% sco.opt))
catTerm$score <- catMiddle$score
## c) n.min ## (must be an integer greater than or equal to 0 and less than the number of params)
if( { is.null(catTerm$n.min) |
!all(catTerm$n.min %in% 1:nrow(params)) } ){
# --> Make sure 'n.it' is a positive integer that is not too large of a number.
if( interactive() ){
while( !( length(catTerm$n.min) == 1 & all(catTerm$n.min %in% 1:nrow(params)) ) ){
catTerm$n.min <- readline("Select a minimum number of items: ")
catTerm$n.min <- suppressWarnings(as.numeric(catTerm$n.min))
} # END while LOOP
} else{
catTerm$n.min <- 1
} # END ifelse STATEMENTS
} # END if STATEMENT
## d) n.max ## (must be an integer greater than n.min AND n.it or "all")
if( { is.null(catTerm$n.max) |
!all(catTerm$n.max %in% max(catTerm$n.min, catStart$n.it):nrow(params)) } ){
if(catTerm$n.max == "all" | catTerm$n.max == "'all'" | catTerm$n.max == "\"all\"")
catTerm$n.max <- nrow(params)
# --> Make sure 'n.it' is a positive integer that is not too small of a number.
if( interactive() ){
while( !( { (length(catTerm$n.max) == 1) &
all(catTerm$n.max %in% max(catTerm$n.min, catStart$n.it):nrow(params)) } ) ){
catTerm$n.max <- readline("Select a maximum number of items or 'all': ")
# --> If "all" is selected, break the while loop so the comparison isn't made.
if(catTerm$n.max == "all" | catTerm$n.max == "'all'" | catTerm$n.max == "\"all\""){
catTerm$n.max <- nrow(params)
} else{
catTerm$n.max <- suppressWarnings(as.numeric(catTerm$n.max))
} # END ifelse STATEMENT
} # END while LOOP
} else{
catTerm$n.max <- nrow(params)
} # END ifelse STATEMENTS
} # END if STATEMENT
# And if n.max is less than the total number of params, one of the termination is implicitly fixed.
if( catTerm$n.max < nrow(params) )
catTerm$term <- c(catTerm$term, "fixed")
## e) p.term ##
## e1) p.term --> method ## (only for the precision termination criterion)
if( { any(catTerm$term == "precision") &
( (length(catTerm$p.term$method) != 1) | !any(catTerm$p.term$method %in% p.meth.opt) ) } ){
# --> Make sure 'method' matches at least one of the possible method stopping rules.
if( interactive() ){
while( !( length(catTerm$p.term$method) == 1 & all(catTerm$p.term$method %in% p.meth.opt) ) )
catTerm$p.term$method <- readline( paste("Select from ONLY ONE of the following precision-based stopping rules - ",
paste(p.meth.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catTerm$p.term$method' must be ONLY ONE of ", paste(p.meth.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## e2) p.term --> crit ##
## threshold ##
if( any(catTerm$term == "precision" & catTerm$p.term$method %in% c("threshold") ) ){
if( length(catTerm$p.term$crit) != 1 )
catTerm$p.term$crit <- NA
if( any(is.na(catTerm$p.term$crit)) | any(!is.numeric(catTerm$p.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$p.term$crit <- readline("Select an SEM cut-off for variable termination: ")
catTerm$p.term$crit <- suppressWarnings(as.numeric(catTerm$p.term$crit))
if( !( all(!is.na(catTerm$p.term$crit)) & all(is.numeric(catTerm$p.term$crit)) ) )
next;
if( catTerm$p.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$p.term$crit <- .25
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## change ##
if( any(catTerm$term == "precision" & catTerm$p.term$method %in% c("change") ) ){
if( length(catTerm$p.term$crit) != 1 )
catTerm$p.term$crit <- NA
if( any(is.na(catTerm$p.term$crit)) | any(!is.numeric(catTerm$p.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$p.term$crit <- readline("Select the maximum SEM change for variable termination: ")
catTerm$p.term$crit <- suppressWarnings(as.numeric(catTerm$p.term$crit))
if( !( all(!is.na(catTerm$p.term$crit)) & all(is.numeric(catTerm$p.term$crit)) ) )
next;
if( catTerm$p.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$p.term$crit <- .25
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## f) i.term ## (only for the info termination criterion)
## f1) i.term --> method ## (only for the info termination criterion)
if( { any(catTerm$term == "info") &
( (length(catTerm$i.term$method) != 1) | !any(catTerm$i.term$method %in% i.meth.opt) ) } ){
# --> Make sure 'method' matches at least one of the possible method stopping rules.
if( interactive() ){
while( !( length(catTerm$i.term$method) == 1 & all(catTerm$i.term$method %in% i.meth.opt) ) )
catTerm$i.term$method <- readline( paste("Select from ONLY ONE of the following info-based stopping rules - ",
paste(i.meth.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catTerm$i.term$method' must be ONLY ONE of ", paste(i.meth.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## f2) i.term --> crit ##
## threshold ##
if( any(catTerm$term == "info" & catTerm$i.term$method %in% c("threshold") ) ){
if( length(catTerm$i.term$crit) != 1 )
catTerm$i.term$crit <- NA
if( any(is.na(catTerm$i.term$crit)) | any(!is.numeric(catTerm$i.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$i.term$crit <- readline("Select a Fisher Information cut-off for variable termination: ")
catTerm$i.term$crit <- suppressWarnings(as.numeric(catTerm$i.term$crit))
if( !( all(!is.na(catTerm$i.term$crit)) & all(is.numeric(catTerm$i.term$crit)) ) )
next;
if( catTerm$i.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$i.term$crit <- 2
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## change ##
if( any(catTerm$term == "info" & catTerm$i.term$method %in% c("change") ) ){
if( length(catTerm$i.term$crit) != 1 )
catTerm$i.term$crit <- NA
if( any(is.na(catTerm$i.term$crit)) | any(!is.numeric(catTerm$i.term$crit)) ){
# --> Make sure 'crit' is a positive number.
if( interactive() ){
repeat{
catTerm$i.term$crit <- readline("Select the maximum Fisher Information change for variable termination: ")
catTerm$i.term$crit <- suppressWarnings(as.numeric(catTerm$i.term$crit))
if( !( all(!is.na(catTerm$i.term$crit)) & all(is.numeric(catTerm$i.term$crit)) ) )
next;
if( catTerm$i.term$crit >= 0 )
break;
} # END repeat LOOP
} else{
catTerm$i.term$crit <- .5
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## g) c.term ##
## g1) c.term --> method ## (only for the classification termination criterion)
if( { any(catTerm$term == "class") &
( (length(catTerm$c.term$method) != 1) | !any(catTerm$c.term$method %in% c.meth.opt) ) } ){
# --> Make sure 'method' matches at least one of the possible classification stopping rules.
if( interactive() ){
while( !( length(catTerm$c.term$method) == 1 & all(catTerm$c.term$method %in% c.meth.opt) ) )
catTerm$c.term$method <- readline( paste("Select from ONLY ONE of the following classification-based stopping rules - ",
paste(c.meth.opt, collapse = ", "),
": ", sep = "")
)
} else{
stop( paste("'catTerm$c.term$method' must be ONLY ONE of ", paste(c.meth.opt, collapse = ", "), sep = "" ) )
} # END ifelse STATEMENTS
} # END if STATEMENT
## g2) c.term --> bounds ## (only for the class termination criterion or weird selection)
if( any(catTerm$term == "class") | any(c(catStart$at, catMiddle$at) %in% "bounds") ){
# Step 1: Make sure that the classification bound(s) exist.
if( !all(is.numeric(catTerm$c.term$bounds)) ){
if( interactive() ){
catTerm$c.term$bounds <- NA
while( !( all(is.numeric(catTerm$c.term$bounds)) & all(!is.na(catTerm$c.term$bounds)) ) ){
cat("Select the classification bound(s) used for all simulees (press 'return' after each): ")
catTerm$c.term$bounds <- suppressWarnings(as.numeric(scan(what = character(), quiet = TRUE)))
} # END while LOOP
} else{
catTerm$c.term$bounds <- 0
} # END ifelse STATEMENT
} # END if STATEMENT
# Step 2: Turn the classification bounds into a matrix.
if( !is.null( dim(catTerm$c.term$bounds) ) ){
if( (nrow(catTerm$c.term$bounds) != 1) & (nrow(catTerm$c.term$bounds) != dim(resp)[1]) )
warning( "classification bounds are not specified for every simulee" )
# --> a) original matrix of bounds --> repeat that matrix for all people.
catTerm$c.term$bounds <- matrix(catTerm$c.term$bounds,
nrow = dim(resp)[1],
ncol = dim(catTerm$c.term$bounds)[2],
byrow = TRUE)
} else if( length(catTerm$c.term$bounds) == dim(resp)[1] ){
# --> b) original vector of bounds equal to simulees --> one-column matrix.
catTerm$c.term$bounds <- matrix(catTerm$c.term$bounds,
nrow = dim(resp)[1],
ncol = 1,
byrow = TRUE)
} else{
# --> c) original vector of bounds NOT equal to simulees --> vector is on each row.
catTerm$c.term$bounds <- matrix(catTerm$c.term$bounds,
nrow = dim(resp)[1],
ncol = length(catTerm$c.term$bounds),
byrow = TRUE)
} # END ifelse STATEMENTS
# --> d) sort the bounds (with a trick incase there is only one bound per person).
catTerm$c.term$bounds <- t( apply( cbind(catTerm$c.term$bounds, -Inf),
MARGIN = 1, FUN = sort ) )[ , -1, drop = FALSE]
} # END if STATEMENT
## g3) c.term --> categ ## (only for the class termination criterion)
if( any(catTerm$term == "class") & is.null(catTerm$c.term$categ) )
catTerm$c.term$categ <- 1:(ncol(catTerm$c.term$bounds) + 1)
## g4) c.term --> delta ## (only for the class termination criterion)
if( { any( catTerm$term == "class" & catTerm$c.term$method %in% c("SPRT", "GLR") ) } ){
if( length(catTerm$c.term$delta) != 1 )
catTerm$c.term$delta <- NA
if( any(is.na(catTerm$c.term$delta)) | any(!is.numeric(catTerm$c.term$delta)) ){
# --> Make sure 'delta' is a positive number.
if(interactive()){
while( !( { length(catTerm$c.term$delta) == 1 &
all(!is.na(catTerm$c.term$delta)) &
all(is.numeric(catTerm$c.term$delta)) } ) ){
catTerm$c.term$delta <- readline("Select an indifference region/testing half-width: ")
catTerm$c.term$delta <- suppressWarnings(abs(as.numeric(catTerm$c.term$delta)))
} # END while LOOP
} else{
catTerm$c.term$delta <- .1
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## g5) c.term --> alpha/beta ##
if( any( catTerm$term == "class" & catTerm$c.term$method %in% c("SPRT", "GLR") ) ){
if( length(catTerm$c.term$alpha) != 1 )
catTerm$c.term$alpha <- NA
if( length(catTerm$c.term$beta) != 1 )
catTerm$c.term$beta <- NA
if( any(is.na(catTerm$c.term$alpha)) | any(!is.numeric(catTerm$c.term$alpha)) ){
# --> Make sure 'alpha' is a positive number between 0 and 1.
if( interactive() ){
repeat{
catTerm$c.term$alpha <- readline("Select an SPRT specified Type I error rate: ")
catTerm$c.term$alpha <- suppressWarnings(as.numeric(catTerm$c.term$alpha))
if( !( all(!is.na(catTerm$c.term$alpha)) & all(is.numeric(catTerm$c.term$alpha)) ) )
next;
if( catTerm$c.term$alpha < 1 & catTerm$c.term$alpha > 0 )
break;
} # END repeat LOOP
} else{
catTerm$c.term$alpha <- .05
} # END ifelse STATEMENTS
} # END if STATEMENTS
if( any(is.na(catTerm$c.term$beta)) | any(!is.numeric(catTerm$c.term$beta)) ){
# --> Make sure 'beta' is a positive number between 0 and 1.
if( interactive() ){
repeat{
catTerm$c.term$beta <- readline("Select an SPRT specified Type II error rate: ")
catTerm$c.term$beta <- suppressWarnings(as.numeric(catTerm$c.term$beta))
if( !( all(!is.na(catTerm$c.term$beta)) & all(is.numeric(catTerm$c.term$beta)) ) )
next;
if( catTerm$c.term$beta < 1 & catTerm$c.term$beta > 0 )
break;
} # END repeat LOOP
} else{
catTerm$c.term$beta <- .05
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
## g6) c.term --> conf.lev ##
if( any(catTerm$term == "class" & catTerm$c.term$method %in% c("CI") ) ){
if( length(catTerm$c.term$conf.lev) != 1 )
catTerm$c.term$conf.lev <- NA
if( any(is.na(catTerm$c.term$conf.lev)) | any(!is.numeric(catTerm$c.term$conf.lev)) ){
# --> Make sure 'conf.lev' is a positive number between 0 and 1.
if( interactive() ){
repeat{
catTerm$c.term$conf.lev <- readline("Select a confidence interval level between 0 and 1: ")
catTerm$c.term$conf.lev <- suppressWarnings(as.numeric(catTerm$c.term$conf.lev))
if( !( all(!is.na(catTerm$c.term$conf.lev)) & all(is.numeric(catTerm$c.term$conf.lev)) ) )
next;
if( catTerm$c.term$conf.lev < 1 & catTerm$c.term$conf.lev > 0 )
break;
} # END repeat LOOP
} else{
catTerm$c.term$conf.lev <- .95
} # END ifelse STATEMENTS
} # END if STATEMENT
} # END if STATEMENT
######################## END ARGUMENT CHECK SECTION #######################
###########################################################################
#~~~~~~~~~~~~~~~~~~~~~~~~#
# SETTING UP THE OBJECTS #
#~~~~~~~~~~~~~~~~~~~~~~~~#
# The number of people should be equal to the number of response matrix rows:
N <- dim(resp)[1] # N is the number of row of theta/resp
J <- dim(params)[1] # J is the number of rows of params
# A list to store individual, person attributes (final responses, final theta, etc.)
cat_indiv <- vector("list", length = N)
# Vectors to store CAT thetas, categories, test info, and SEM:
cat_theta <- vector("numeric", length = N)
cat_categ <- vector("character", length = N)
cat_info <- vector("numeric", length = N)
cat_sem <- vector("numeric", length = N)
cat_length <- vector("numeric", length = N)
cat_term <- vector("character", length = N)
# Vectors to store TOT thetas, categories, test info, and SEM:
tot_theta <- vector("numeric", length = N)
tot_categ <- vector("character", length = N)
tot_info <- vector("numeric", length = N)
tot_sem <- vector("numeric", length = N)
# Vectors to store TRUE thetas, categories:
if( missing(theta) ){
theta <- NULL
true_theta <- rep(NA, length = N)
} else if( is.null(theta) ){
true_theta <- rep(NA, length = N)
} else{
true_theta <- theta
} # END ifelse STATEMENT
true_categ <- vector("character", length = N)
# To store the selection rates (for Sympson-Hetter):
S <- NULL
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
# RUNNING THROUGH THE CAT: PER PERSON #
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~#
#~~~~~~~~~~~~~~~~~~~~~~#
# Progress Statement 1 #
#~~~~~~~~~~~~~~~~~~~~~~#
# For calibrations, we will want to suppress the upper progress bar.
if( progress ){
cat("CAT Progress:\n")
pb <- txtProgressBar(min = 0, max = N, initial = 0, char = "*", style = 3)
} # END if STATEMENT
# We will repeat the CAT for each person:
for( i in 1:N ){
#####
# 1 # (INITIALIZING THE CAT)
#####
# First, the particular simulee's response vector:
resp.i <- resp[i, ]
catStart.i <- catStart
catMiddle.i <- catMiddle
catTerm.i <- catTerm
# Second, the particular simulee's initial theta value and classification bounds:
catStart.i$init.theta <- catStart$init.theta[i]
if( !is.null( dim(catTerm$c.term$bounds) ) )
catTerm.i$c.term$bounds <- catTerm$c.term$bounds[i, ]
#####
# 2 # (THE FIRST SEVERAL ITEMS)
#####
# Responses, proximate theta ests/info/sem, item numbers/parameters of CAT:
cat_resp.i <- rep(NA, times = catTerm.i$n.max)
cat_par.i <- matrix(NA, nrow = catTerm.i$n.max, ncol = ncol(params))
cat_it.i <- cat_resp.i
cat_theta.i <- c(catStart.i$init.theta, cat_resp.i)
cat_info.i <- cat_resp.i
cat_sem.i <- cat_resp.i
# Setting the classes, so the other functions will work.
class(cat_par.i) <- class(resp)
class(cat_resp.i) <- mod
# A vector indicating whether or not the examinee has taken an item:
it_flags <- rep(0, nrow(params))
# Running the loop at the beginning of the CAT for each person:
x <- startCat( params = params, resp = resp.i, mod = mod,
it_flags = it_flags,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i,
ddist = ddist, ... )
# Updated to where we are in the CAT:
j <- x$j
S <- c(S, x$S)
#####
# 3 # (PRELIMINARY TERMINATION CHECK)
#####
# If the estimation method for early CATs was silly, then re-estimate.
if( any(catStart.i$score %in% c("fixed", "step", "random")) ){
# --> a) Build a character string for the WLE/EAP/BME estimation function,
scoreFun <- paste(tolower(catMiddle.i$score), "Est", sep = "")
# --> b) Call the estimation function on stuff to this point,
x <- get(scoreFun)( resp = cat_resp.i[1:j],
params = cat_par.i[1:j, -c(1, ncol(params)), drop = FALSE],
range = catMiddle.i$range, mod = mod,
ddist = ddist, ... )
cat_theta.i[j + 1] <- x$theta
cat_info.i[j] <- x$info
cat_sem.i[j] <- x$sem
} # END if STATEMENT
# Before entering the loop check the termination criterion:
y <- termCat( params = params[ , -c(1, ncol(params))],
resp = resp.i,
mod = mod,
it_flags = it_flags,
cat_par = cat_par.i[1:j , -c(1, ncol(cat_par.i)), drop = FALSE],
cat_resp = cat_resp.i[1:j],
cat_theta = cat_theta.i[j + 1],
cat_info = cat_info.i,
cat_sem = cat_sem.i,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i )
# And if we should stop, skip the while loop altogether:
stp <- y$cat_dec$stp
#####
# 4 # (THE REMAINING ITEMS)
#####
# We will repeat the next several steps until the CAT is over :(
while( !stp ){
x <- middleCat( params = params,
resp = resp.i,
mod = mod,
it_flags = it_flags,
cat_par = cat_par.i[1:j, , drop = FALSE],
cat_it = cat_it.i[1:j],
cat_resp = cat_resp.i[1:j],
cat_theta = cat_theta.i[j + 1],
cat_info = cat_info.i,
cat_sem = cat_sem.i,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i,
ddist = ddist, ... )
# Updated to where we are in the CAT:
j <- x$j
S <- c(S, x$S)
y <- termCat( params = params[ , -c(1, ncol(params))],
resp = resp.i,
mod = mod,
it_flags = it_flags,
cat_par = cat_par.i[1:j , -c(1, ncol(cat_par.i)), drop = FALSE],
cat_resp = cat_resp.i[1:j],
cat_theta = cat_theta.i[j + 1],
cat_info = cat_info.i,
cat_sem = cat_sem.i,
catStart = catStart.i, catMiddle = catMiddle.i, catTerm = catTerm.i )
stp <- y$cat_dec$stp
} # END while LOOP
#####
# 5 # (FINAL ASSIGNMENT AND FINAL CATEGORY STUFF)
#####
# Need to indicate: true (a) class, (b) theta (if applicable), and
# total (a) class, (b) theta.
# First, find the appropriate theta estimate given resp and params.
# --> a) Build a character string for the WLE/EAP/BME estimation function,
scoreFun <- paste(tolower(catTerm.i$score), "Est", sep = "")
# --> b) Call the estimation function on stuff to this point,
x <- get(scoreFun)( resp = resp.i,
params = params[ , -c(1, ncol(params))],
range = catMiddle.i$range, mod = mod, ddist = ddist, ... )
tot_theta[i] <- x$theta
tot_info[i] <- x$info
tot_sem[i] <- x$sem
# If the EAP estimate didn't work, change estimation to BME with same dist/params:
if( catTerm.i$score == "EAP" & is.nan(x$theta) ){
# --> a) Change scoring of the total theta to BME,
catTerm$score <- "BME"
# --> b) Estimate the total thetas to this point as BME.
x <- bmeEst( resp = resp[1:i, ],
params = params[ , -c(1, ncol(params))],
range = catMiddle.i$range, mod = mod, ddist = ddist, ... )
tot_theta[1:i] <- x$theta
tot_info[1:i] <- x$info
tot_sem[1:i] <- x$sem
msg <- TRUE
} # END if STATEMENT
# Second, determine the true and total classification.
if( any(catTerm.i$term == "class") ){
tot_categ[i] <- catTerm.i$c.term$categ[sum( tot_theta[i] > catTerm.i$c.term$bounds ) + 1] # based on total-test thetas
if( !is.null(theta) )
true_categ[i] <- catTerm.i$c.term$categ[sum( theta[i] > catTerm.i$c.term$bounds ) + 1] # based on true thetas
} # END if STATEMENT
# Third, insert all of the individual CAT (thetas, sem, ... ) stuff
cat_theta[i] <- cat_theta.i[j + 1]
cat_categ[i] <- y$cat_categ
cat_info[i] <- cat_info.i[j]
cat_sem[i] <- cat_sem.i[j]
cat_term[i] <- y$cat_dec$term
cat_length[i] <- j
# Fourth, name the CAT parameters to put into the cat_indiv list.
colnames(cat_par.i) <- colnames(params)
# Note that j had already been declared before another item/estimation.
cat_indiv[[i]] <- list( cat_theta = cat_theta.i[1:(j + 1)],
cat_it = cat_it.i[1:j],
cat_info = c(NA, cat_info.i[1:j]),
cat_sem = c(NA, cat_sem.i[1:j]),
cat_resp = cat_resp.i[1:j],
cat_params = cat_par.i[1:j, ] )
#~~~~~~~~~~~~~~~~~~~~~~#
# Progress Statement 2 #
#~~~~~~~~~~~~~~~~~~~~~~#
# And indicate the progress thus far into the cat:
if( progress )
setTxtProgressBar(pb, value = i)
} # END for i LOOP
if( progress )
cat("\n")
# And if we had to change EAP to BME, let people know:
if( exists("msg", where = environment()) )
if( msg )
cat("\nToo large an item bank for full-test EAP estimation. Changed estimation for full-test to BME.\n")
#~~~~~~~~~~~~~~~~~~~#
# FINISHING THE CAT #
#~~~~~~~~~~~~~~~~~~~#
# Determining the number of times each item was selected/administered:
select <- tabulate(S, nbins = nrow(params))
admin <- tabulate(do.call(c, lapply(cat_indiv, FUN = function(x) x$cat_it)), nbins = nrow(params))
names(select) <- names(admin) <- 1:nrow(params)
ret <- list( cat_theta = cat_theta, cat_categ = cat_categ, # CAT STUFF
cat_info = cat_info, cat_sem = cat_sem, # CAT STUFF
cat_length = cat_length, cat_term = cat_term, # CAT STUFF
tot_theta = tot_theta, tot_categ = tot_categ, # TOTAL TEST STUFF
tot_info = tot_info, tot_sem = tot_sem, # TOTAL TEST STUFF
true_theta = true_theta, true_categ = true_categ, # TRUE STUFF
full_params = params, full_resp = resp, # FULL PARAMETERS AND RESPONSES
it_select = list(select = select, admin = admin), # TABLE OF SELECTED AND ADMINISTERED ITEMS
cat_indiv = cat_indiv, # INDIVIDUAL STUFF
mod = list(mod = mod, catStart = catStart, catMiddle = catMiddle, catTerm = catTerm) )
class(ret) <- "catIrt"
return(ret)
} # END catIrt FUNCTION
Try the catIrt package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.