Nothing
setClassUnion(name = "listNULL", members = c("list","NULL"))
setClassUnion(name = "characterNULL", members = c("character","NULL"))
############################################################################@###
############################# Itempool class ###################################
############################################################################@###
#' An S4 class to represent an Itempool
#' @description
#' \code{\link{Itempool-class}} is a class to represent an item pool. This class
#' is composed of the collection of 'Item' class objects.
#'
#' @slot item_list The list of items that are 'Item' class
#' @slot misc A list of additional parameters for the item pool. For example,
#' one can put the calibration date of the item pool as
#' \code{misc = list(calibration_date = as.Date("2020-01-17"))}.
#'
#' @include item-class.R
#' @include item-class-methods.R
#'
#' @export
#'
#' @author Emre Gonulates
#'
setClass(
Class = "Itempool",
slots = c(item_list = "list", misc = "listNULL")
)
############################################################################@###
############################# initialize (Itempool) ############################
############################################################################@###
#' @noRd
#' @title This function initializes an \code{Itempool} object.
#'
#' @importFrom methods callNextMethod new
#'
#' @author Emre Gonulates
#'
setMethod("initialize", "Itempool",
function(.Object, item_list = list(new(Class = "Item")),
misc = NULL, ...) {
.Object <- callNextMethod(.Object, ...)
.Object@item_list <- item_list
.Object@misc <- misc
# Check validity of the object
validObject(.Object)
.Object
})
############################################################################@###
############################# setValidity(Itempool) ############################
############################################################################@###
setValidity(
Class = "Itempool",
function(object)
{
# Itempool cannot be empty.
if (length(object@item_list) == 0)
stop("Invalid elements. Item pool cannot be empty. ")
# All of the elements of the list should be "Item" or "Testlet" class.
if (!all(sapply(object@item_list, FUN = function(x) is(x, "Item") |
is(x, "Testlet")) ))
stop(paste0("Invalid 'Itempool' elements. All of the elements of ",
"'Itempool' class should be either 'Item' or 'Testlet' ",
"class."))
# Get first level Item ID's, standalone items and Testlet items.
item_ids <- unlist(lapply(object@item_list, FUN = function(x)
if (is(x, "Item")) x@item_id else x@testlet_id))
# Make sure that the item_list has the names equal to the item_ids
if (is.null(names(object@item_list)) ||
!all(names(object@item_list) == item_ids))
stop(paste0("The names of the 'item_list' elements should be the same ",
"as the ID's of the 'Item' or 'Testlet' objects."))
# Add the item ID's of the testlet
for (tstlet in object@item_list[sapply(object@item_list, is, "Testlet")])
item_ids <- c(item_ids,
sapply(tstlet@item_list@item_list, slot, "item_id"))
# ID's of all elements should be unique and they cannot be NULL.
if (is.null(item_ids) || any(duplicated(item_ids)))
stop(paste0("Invalid ID's. Each Item object in the item pool should ",
"have a unique 'item_id'. Items in the testlets should not ",
"have duplicate item_id's with standalone items."))
})
############################################################################@###
############################# Testlet class ####################################
############################################################################@###
#' An S4 class to represent a Testlet
#' @description
#' \code{Testlet} is a class to represent an a collection of items. Items that
#' are connected by a common stimulus (for example a reading passage, a graph,
#' etc.) can form a testlet. An object in \code{Testlet} class should
#' have a \code{model} name and \code{item_list} which is an \code{Itempool}.
#' object. In fact, a \code{Testlet} object is very similar to an
#' \code{\link{Itempool-class}} object, except, it has a designated model and
#' optional parameters.
#'
#' @slot testlet_id Testlet ID. Default value is \code{NULL}.
#' @slot item_list A list of \code{Item} objects.
#' @slot model The model that testlet \code{parameters} represents. Currently
#' model can be:
#' BTM (Basic Testlet Model, this is default testlet model where no
#' parameters necessary and testlet simply connects items),
#' RTM (Rasch Testlet Model),
#' BF (Bifactor Model) (Not implemented yet),
#' 2PTM (Two-parameter testlet model),
#' 3PTM (three-parameter testlet model).
#' A model must be specified for the construction of an \code{tetlet} object.
#' @slot parameters A list containing numeric vectors that represent testlet
#' parameters. Depending on the model these parameters can change.
#' @slot se_parameters Standard error of testlet parameters.
#' @slot content Content information for testlet.
#' @slot misc A list of additional parameters for the testlet.
#'
#' @export
#'
#' @author Emre Gonulates
#'
setClass(Class = "Testlet",
slots = c(testlet_id = "characterNULL",
item_list = "Itempool",
model = "character",
parameters = "listNULL",
se_parameters = "listNULL",
content = "characterNULL",
misc = "listNULL"))
# List of currently implemented models for Testlet class
# tmodels : Testlet Models
tmodels <- list(
'BTM' = list(parameters = NULL,
se_parameters = NULL,
verbose_name = "Basic Testlet Model"),
'RTM' = list(parameters = c('mean', 'sd'),
se_parameters = c('mean', 'sd'),
verbose_name = "Rasch Testlet Model")
)
############################################################################@###
############################# initialize (Testlet) #############################
############################################################################@###
#' @noRd
#' @title This function initializes a \code{Testlet} object.
#'
#' @importFrom methods callNextMethod
#'
#' @author Emre Gonulates
#'
setMethod("initialize", "Testlet",
function(.Object, testlet_id = NULL, item_list = NULL, model = "BTM",
parameters = NULL, se_parameters = NULL, content = NULL,
misc = NULL, ...) {
.Object <- callNextMethod(.Object, ...)
.Object@testlet_id <- testlet_id
if (is(item_list, "Itempool")) .Object@item_list <- item_list else
stop("'item_list' should be an 'Itempool' object." )
if (is.character(model) && model %in% names(tmodels))
.Object@model <- model else
stop(paste0("Invalid model value. Model name should be one of the ",
'following:\n"', paste0(names(tmodels), collapse = '", "'),
'"'))
.Object@model <- model
.Object@parameters <- parameters
.Object@se_parameters <- se_parameters
.Object@content <- content
.Object@misc <- misc
# Check validity of the object
validObject(.Object)
.Object
})
############################################################################@###
############################# setValidity(Testlet) #############################
############################################################################@###
setValidity(
Class = "Testlet",
function(object)
{
# # ----------------------- Check item_list ------------------------------ #
# # item_id's of all elements should be unique and they cannot be NULL.
# # Itempool cannot be empty.
# if (length(object@item_list) == 0)
# stop(
# "Invalid 'item_list'. 'item_list' of Testlet object cannot be empty.")
# # All of the elements of the list should be "Item" class.
# if (!all(sapply(object@item_list, FUN = "is.Item") ))
# stop(paste0("Invalid elements in item_list. All of the elements of
# 'item_list' should be an 'Item' class object."))
# # Item ID's in item_list should be unique.
# item_ids <- unlist(lapply(object@item_list, FUN = function(x) x@item_id))
# if (is.null(item_ids) ||
# (length(unique(item_ids)) != length(object@item_list)))
# stop(paste0("Invalid Item ID's. Each 'Item' object in the 'Testlet' ",
# "should have a unique ID."))
# ----------------------- Check testlet_id ------------------------------- #
# The length of testlet ID should be 1 or NULL, and it cannot be NA
if (!is.null(object@testlet_id) && (
length(object@testlet_id) > 1 || is.na(object@testlet_id)))
stop(paste0("Invalid 'testlet_id'."))
# ----------------------- Check model ------------------------------------ #
# Check the model, currently only irt1PM, irt2PM,
# irt3PM, irt4PM, mirt1PM, mirt2PM and mirt3PM is used
if (is.null(object@model) || (length(object@model) != 1) ||
!(object@model %in% names(tmodels)))
stop(paste0("Invalid model name. Testlet model should be specified ",
"correctly. It can be either: ",
paste0(names(tmodels), collapse = ", ")))
# ----------------------- Check parameters ------------------------------- #
# Object parameters cannot be NULL or NA
if (object@model != "BTM" &
(is.null(object@parameters) || any(is.na(object@parameters))))
stop(paste0("Invalid testlet parameter. Testlet parameters cannot be ",
"NULL or NA for models except 'BTM'."))
# Number of parameters should be as specified in tmodels parameters
if (length(object@parameters) != length(tmodels[[object@model]]$parameters))
stop(paste0("Invalid testlet parameters. Number of parameters for ",
object@model," model should be ",
length(tmodels[[object@model]]$parameters), "."))
# Check for proper naming of parameters. Parameter names should be unique
# and all should correspond one-to-one with tmodels[[model_name]]$parameters
if (object@model != "BTM") {
if (is.null(parNames <- names(object@parameters)))
stop(paste0("Invalid parameter names. Parameter names of Testlet ",
"class cannot be NULL except for 'BTM' model. Please ",
"give relevant names."))
if (
(length(parNames) != length(tmodels[[object@model]]$parameters)) ||
length(unique(parNames)) != length(tmodels[[object@model]]$parameters)
)
stop(paste0("Invalid parameter names. Parameter names of Testlet ",
"class should be unique and complete. Please give ",
"relevant names."))
if (!all(parNames %in% tmodels[[object@model]]$parameters))
stop(paste0("Invalid parameter names. Parameter names for ",
object@model," model should be ",
paste0(tmodels[[object@model]]$parameters, collapse = ", "),
". Please give relevant names."))
}
})
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.