Nothing
## {poly.mod} class
## This is a class that characterizes the item response models associated with each item
## It includes a validity check between the number of models in {model} and the number
## of list elements for {items}. It also checks to make sure only acceptable values for
## {model} are included
setClass("poly.mod",representation(model="character", items="list"))
.Valid.poly.mod <- function(object) {
out <- TRUE
if (length(object@model)!=length(object@items)) {
out <- "Number of models does not match the number list elements for {items}."
}
if (length(which(object@model %in% c("drm","grm","gpcm","nrm","mcm") ))!=length(object@model)) {
out <- "One or more of the specified models is not {drm, grm, gpcm, nrm, mcm}"
}
return(out)
}
setValidity("poly.mod", .Valid.poly.mod)
## as.poly.mod function
## This function facilitates the creation of a {poly.mod} object
as.poly.mod <- function(n, model="drm", items=NULL) {
if (missing(items)) {
if (length(model)==1) items <- list(1:n )
} else if (!is.list(items)) {
items <- list(items)
}
if (length(unlist(items))!=n) stop("Number of items in {items} does not match {n}")
names(items) <- model
new("poly.mod", model=model, items=items)
}
## is.poly.mod function
## This function checks to see if {x} is an object of class {poly.mod}
is.poly.mod <- function(x) {
is(x, "poly.mod")
}
## {sep.pars} class
## This class stores a set of separated item parameters, the number of response categories,
## the total number of items (as well as the number of items associated with each item
## response model), descriptive labels for the models (e.g., 3PL and Graded Response Model),
## an indicator for whether various models include a location parameter, and the number of
## dimensions. This class also extends the {poly.mod} class. It includes validity checks to
## ensure that the number number of rows in {a}, {b}, and {c} and the length of {cat} all
## equal {n}. It also checks to make sure that the number of model labels is the same as the
## number of models (from the {poly.mod} class).
setClass("sep.pars", representation(a="matrix", b="matrix", c="matrix", cat="numeric", n="numeric", mod.lab="character", location="logical", dimensions="numeric"), prototype(location=FALSE, dimensions=1), contains="poly.mod")
.Valid.sep.pars <- function(object) {
out <- TRUE
if (nrow(object@a)!=object@n[1]) paste("The number of a-parameters does not match the total number of items.")
if (nrow(object@b)!=object@n[1]) paste("The number of b-parameters does not match the total number of items.")
if (nrow(object@b)!=object@n[1]) paste("The number of c-parameters does not match the total number of items.")
if (length(object@cat)!=object@n[1]) paste("The length of {cat} does not match the total number of items.")
if (length(object@mod.lab)!=length(object@model)) paste("Number of model labels does not match the number of models.")
return(out)
}
setValidity("sep.pars", .Valid.sep.pars)
## is.sep.pars function
## This function checks to see if {x} is an object of class {sep.pars}
is.sep.pars <- function(x) {
is(x, "sep.pars")
}
## {irt.prob} class
## This class stores a T x Nk data.frame of response probabilities for T theta values
## (or a combination of theta values if there is more than one dimension), a vector identifying
## the number of columns in the data.frame associated with each item, descriptive labels for
## the modeled items, the number of dimensions, and a list of item parameters. This class also
## extends the {poly.mod} class.
setClassUnion("dat.null",c("data.frame","NULL"))
setClass("irt.prob",representation(prob="data.frame", info="dat.null", p.cat="numeric", mod.lab="character", dimensions="numeric", D="numeric", pars="list"), prototype(info=NULL), contains="poly.mod")
.Valid.irt.prob<- function(object) {
out <- TRUE
if ((ncol(object@prob)-object@dimensions)!=sum(object@p.cat)) paste("The number of columns in {prob} does not align with {p.cat} and {dimensions}")
if (length(object@mod.lab)!=length(object@model)) paste("Number of model labels does not match the number of models.")
}
setValidity("irt.prob", .Valid.irt.prob)
## is.sep.pars function
## This function checks to see if {x} is an object of class {sep.pars}
is.irt.prob <- function(x) {
is(x, "irt.prob")
}
## {irt.pars} class
## This class stores information for one or more sets of item parameters. It uses
## three union classes {list.num}, {list.mat}, and {list.poly}. It includes slots for
## item parameters, numbers of response categories, {poly.mod} objects, common
## item matrices, whether location parameters are used, the number of groups, and
## numbers of dimensions. The item parameters are stored as a matrix when there
## is one group or as a list of matrices when there are multiple groups. Similarly,
## the slots {cat}, {poly.mod}, and {common} are stored as a vector, poly.mod object,
## or matrix respectively when there is one group or as a list with these formats
## when there is more than one group.
setClassUnion("list.num",c("list","numeric"))
setClassUnion("list.mat",c("list","matrix","data.frame","numeric","NULL"))
setClassUnion("list.poly",c("list","poly.mod"))
setClass("irt.pars",representation(pars="list.mat", cat="list.num", poly.mod="list.poly", common="list.mat", location="logical", groups="numeric", dimensions="numeric"))
setMethod("initialize", "irt.pars", function(.Object, pars, cat, poly.mod, common=NULL, location=NULL, groups=1, dimensions=1) {
## Reformat {pars} to be a matrix or a list of matrices
if (is.data.frame(pars)|is.numeric(pars)) pars <- as.matrix(pars)
if (is.list(pars)) {
n <- length(pars)
if (n==1) {
pars <- pars[[1]]
} else if (n>1) {
for (i in 1:n) {
pars[[i]] <- as.matrix(pars[[i]])
}
}
} else {
n <- 1
}
## Check the {cat} object
if (n==1) {
if (is.list(cat)) {
if (length(cat)==1) {
cat <- cat[[1]]
} else {
stop("There is more than one list element for {cat}. {cat} should be a vector")
}
}
} else if (n>1) {
if (is.list(cat)) {
if (length(cat)!=n) {
stop(paste("The number of category elements",length(cat),"does equal the number of item parameter sets", n))
}
## Check to see if each of the elements in {cat} is a numeric vector
## If not numeric, add the list element number to a temporary object so that
## an error message can be displayed
tmp <- NULL
for (i in 1:length(cat)) {
if (!is.numeric(cat[[i]])) tmp <- c(tmp,i)
}
if (length(tmp)) {
if (length(tmp==1)) {
stop(paste("Category",tmp,"is not an object of class 'numeric'"))
} else {
stop(paste("Categories",tmp,"are not objects of class 'numeric'"))
}
}
} else {
stop("There are two or more sets of item parameters. {cat} should be a list.")
}
}
## Check the {poly.mod} object
if (n==1) {
if (is.list(poly.mod)) {
if (length(poly.mod)==1) {
poly.mod <- poly.mod[[1]]
} else {
stop("There is more than one list element for {poly.mod}.")
}
}
} else if (n>1) {
if (is.list(poly.mod)) {
if (length(poly.mod)==1) {
stop("There are two or more sets of item parameters. {poly.mod} should be a list.")
} else {
if (length(poly.mod)!=n) {
stop(paste("The number of poly.mod list elements",length(poly.mod),"does equal the number of item parameter sets", n))
}
## Check to see if each of the elements in {poly.mod} is of class {poly.mod}
## If not numeric, add the list element number to a temporary object so that
## an error message can be displayed
tmp <- NULL
for (i in 1:length(poly.mod)) {
if (!is.poly.mod(poly.mod[[i]])) tmp <- c(tmp,i)
}
if (length(tmp)) {
if (length(tmp==1)) {
stop(paste("{poly.mod} list element",tmp,"is not an object of class 'poly.mod'"))
} else {
stop(paste("{poly.mod} list elements",tmp,"are not objects of class 'poly.mod'"))
}
}
}
}
}
## Check the correspondence between {pars}/{cat} and {pars}/{poly.mod}
## That is, do the number of response categories match the number of items in {pars}
## and do the number of items in the {poly.mod} object(s) match the number
## of items in pars.
for (i in 1:n) {
if (n==1) {
if (length(cat)!=nrow(pars)) {
stop("The length of {cat} does not match the number of items")
}
if(length(unlist(poly.mod@items))!=nrow(pars)) {
stop("The number of items in {poly.mod} does not match number of items in {pars}")
}
} else if (n>1) {
if (length(cat[[i]])!=nrow(pars[[i]])) {
stop(paste("The length of {cat} in element", i, "does not match the number of items in {pars} element",i))
}
if(length(unlist(poly.mod[[i]]@items))!=nrow(pars[[i]])) {
stop(paste("The number of items in {poly.mod} element",i,"does not match number of items in {pars} element",i))
}
}
}
## Check the {location} object
if (is.null(location)) {
location <- rep(FALSE,n)
} else {
if (length(location)!=n) {
stop("The length of {location} should equal the number of groups")
}
}
## Check the {common} object
if(is.null(common)) {
if (n>1) {
stop("There are two or more sets of item parameters. {common} should be included.")
}
} else if (is.list(common)) {
## Check to see if each of the elements in {common} is a matrix
## If not numeric, add the list element number to a temporary object so that
## an error message can be displayed
tmp <- NULL
for (i in 1:length(common)) {
if (!is.matrix(common[[i]])) {
if (is.data.frame(common[[i]])) {
common[[i]] <- as.matrix(common[[i]])
} else {
tmp <- c(tmp,i)
}
}
}
if (length(tmp)) {
if (length(tmp==1)) {
stop(paste("{common} element",tmp,"is not an object of class 'matrix'"))
} else {
stop(paste("{common} elements",tmp,"are not objects of class 'matrix'"))
}
}
if (length(common)!=(n-1)) {
stop(paste("The number of common item sets",length(common),"does correspond to the number of item parameter sets", n))
} else {
if (n==2) common <- common[[1]]
}
}else if (is.data.frame(common)) {
if (n==1) {
common <- as.matrix(common)
} else if (n>2) {
stop("There are more than two sets of item parameters. {common} should be a list.")
}
} else if (is.matrix(common)) {
if (n>2) {
stop("There are more than two sets of item parameters. {common} should be a list.")
}
} else {
if (n==1) {
stop("{common} must be a matrix")
} else if (n>1) {
stop("There are more than two sets of item parameters. {common} should be a list.")
}
}
## Check the {dimensions} object
if (length(dimensions)!=groups) {
stop("The number of elements in the vector {dimensions} must be equal to the number of groups.")
}
## Check the correspondence between the number of response categories in {cat}
## and the response model associated with each item in {poly.mod}.
for (i in 1:n) {
if (n==1) {
tmp.cat <- list(cat)
pm <- list(poly.mod)
} else {
tmp.cat <- cat
pm <- poly.mod
}
## Loop through the response models
for (j in 1:length(pm[[i]]@model)) {
if (pm[[i]]@model[j]=="drm") {
dichot <- tmp.cat[[i]][pm[[i]]@items$drm]
if (length(dichot[dichot==2])!=length(pm[[i]]@items$drm)) {
stop(paste("One or more values in {cat} for group",i,"does not align with the DRM items in the {poly.mod} object"))
}
} else {
poly <- tmp.cat[[i]][pm[[i]]@items[[j]]]
if (length(poly[poly>2])!=length(pm[[i]]@items[[j]])) {
stop(paste("One or more values in {cat} for group",i,"are less than 2 for the", toupper(pm[[i]]@model[[j]]),"items in the {poly.mod} object"))
}
}
}
}
## Check the correspondence between the number of response categories in {cat}
## and the number of item parameters in {pars}
for (i in 1:n) {
if (n==1) {
tmp.pars <- list(pars)
tmp.cat <- list(cat)
pm <- list(poly.mod)
} else {
tmp.pars <- pars
tmp.cat <- cat
pm <- poly.mod
}
## Loop through the response models
for (j in 1:length(pm[[i]]@model)) {
## Number of items associated with the given model
np <- length(pm[[i]]@items[[j]])
if (pm[[i]]@model[j]=="drm") {
tmp <- !is.na(tmp.pars[[i]][pm[[i]]@items$drm,])
if (np==1) tmp <- t(tmp)
dichot.p <- apply(tmp,1,sum)
if (length(dichot.p[dichot.p<=(dimensions[i]+2)])!=length(pm[[i]]@items$drm)) {
stop(paste("One or more NRM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
} else if (pm[[i]]@model[j]=="grm") {
poly.c <- tmp.cat[[i]][pm[[i]]@items$grm]
tmp <- !is.na(tmp.pars[[i]][pm[[i]]@items$grm,])
if (np==1) tmp <- t(tmp)
poly.p <- apply(tmp,1,sum)
if (location[i]==TRUE) {
if (length(poly.p[poly.p==(dimensions[i]+poly.c)])!=length(pm[[i]]@items$grm)) {
stop(paste("One or more GRM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
} else {
if (length(poly.p[poly.p==(dimensions[i]+poly.c-1)])!=length(pm[[i]]@items$grm)) {
stop(paste("One or more GRM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
}
} else if (pm[[i]]@model[j]=="gpcm") {
poly.c <- tmp.cat[[i]][pm[[i]]@items$gpcm]
tmp <- !is.na(tmp.pars[[i]][pm[[i]]@items$gpcm,])
if (np==1) tmp <- t(tmp)
poly.p <- apply(tmp,1,sum)
if (location[i]==TRUE) {
if (length(poly.p[poly.p==(dimensions[i]+poly.c)])!=length(pm[[i]]@items$gpcm)) {
stop(paste("One or more GPCM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
} else {
if (length(poly.p[poly.p==(dimensions[i]+poly.c-1)])!=length(pm[[i]]@items$gpcm)) {
stop(paste("One or more GPCM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
}
} else if (pm[[i]]@model[j]=="nrm") {
poly.c <- tmp.cat[[i]][pm[[i]]@items$nrm]
tmp <- !is.na(tmp.pars[[i]][pm[[i]]@items$nrm,])
if (np==1) tmp <- t(tmp)
poly.p <- apply(tmp,1,sum)
if (length(poly.p[poly.p==dimensions[i]*poly.c*2])!=length(pm[[i]]@items$nrm)) {
stop(paste("One or more NRM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
} else if (pm[[i]]@model[j]=="mcm") {
poly.c <- tmp.cat[[i]][pm[[i]]@items$mcm]
tmp <- !is.na(tmp.pars[[i]][pm[[i]]@items$mcm,])
if (np==1) tmp <- t(tmp)
poly.p <- apply(tmp,1,sum)
if (length(poly.p[poly.p==(dimensions[i]*poly.c*2+(poly.c-1))])!=length(pm[[i]]@items$mcm)) {
stop(paste("One or more MCM items in group",i,"as specified by the {poly.mod} object do not have the correct number of parameters"))
}
}
}
}
## Check to make sure the common items in each adjacent groups have the same number of parameters.
## Because the correspondence between {cat} and {pars} has already been checked {cat} is used
## to make the comparison
if (n>1) {
if (n==2) com <- list(common) else com <- common
for (i in 1:(n-1)) {
cat1 <- cat[[i]][com[[i]][,1]]
cat2 <- cat[[i+1]][com[[i]][,2]]
if (sum(cat1-cat2)!=0) {
stop(paste("One or more common items in groups ",i,"/",i+1," do not have the same number of parameters",sep=""))
}
}
}
.Object@pars <- pars
.Object@cat <- cat
.Object@poly.mod <- poly.mod
.Object@common <- common
.Object@location <- location
.Object@groups<- n
.Object@dimensions <- dimensions
.Object
})
## is.poly.mod function
## This function checks to see if {x} is an object of class {irt.pars}
is.irt.pars <- function(x) {
is(x, "irt.pars")
}
## {link} class
## This class stores information from the estimation of linking constants in {plink}.
## It uses four union classes {num.null}, {list.dat}, {list.null}, {pars.null}.
## It also includes slots for rescaled item and ability parameters
setClassUnion("num.null",c("matrix","numeric","NULL"))
setClassUnion("list.dat",c("list","data.frame"))
setClassUnion("list.null",c("list","NULL"))
setClassUnion("pars.null",c("irt.pars","NULL"))
setClass("link", representation(constants="list", descriptives="list.dat", iterations="numeric", objective="numeric", convergence="character", base.grp="numeric", n="numeric", grp.names="character", mod.lab="character", dilation="character") )
## is.link function
## This function checks to see if {x} is an object of class {link}
is.link <- function(x) {
is(x, "link")
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.