## AlongIterator gives indices of values along the "along" dimension,
## for successive values for the classifying variables.
## HAS_TESTS
setClass("AlongIterator",
slots = c(indices = "integer",
initial = "integer",
iWithin = "integer",
nWithin = "integer",
iBetween = "integer",
nBetween = "integer",
incrementBetween = "integer"),
prototype = prototype(iWithin = 1L, iBetween = 1L),
validity = function(object) {
indices <- object@indices
initial <- object@initial
iWithin <- object@iWithin
nWithin <- object@nWithin
iBetween <- object@iBetween
nBetween <- object@nBetween
for (name in c("indices", "initial")) {
value <- methods::slot(object, name)
## length of 'indices', 'initial' greater than 0
if (identical(length(value), 0L))
return(gettextf("'%s' has length %d", name, 0L))
## 'indices', 'initial' have no missing values
if (any(is.na(value)))
return(gettextf("'%s' has missing values", name))
## values of 'indices', 'initial' at least 1
if (any(value < 1L))
return(gettextf("'%s' has values less than %d", name, 1L))
}
## 'indices' and 'initial' have same length
if (!identical(length(indices), length(initial)))
return(gettextf("'%s' and '%s' have different lengths",
"indices", "initial"))
for (name in c("iWithin", "nWithin", "iBetween",
"nBetween", "incrementBetween")) {
value <- methods::slot(object, name)
## length of 'iWithin', 'nWithin', 'iBetween', 'nBetween',
## 'incrementBetween' all 1
if (!identical(length(value), 1L))
return(gettextf("'%s' does not have length %d", name, 1L))
## iWithin', 'nWithin', 'iBetween', 'nBetween',
## 'incrementBetween' have no missing values
if (is.na(value))
return(gettextf("'%s' is missing", name))
## values of 'iWithin', 'nWithin', 'iBetween', 'nBetween',
## 'incrementBetween' at least 1
if (value < 1L)
return(gettextf("'%s' is less than %d", name, 1L))
}
## 'iWithin' less than or equal to 'nWithin'
if (iWithin > nWithin)
return(gettextf("'%s' is greater than '%s'", "iWithin", "nWithin"))
## 'iBetween' less than or equal to 'nBetween'
if (iBetween > nBetween)
return(gettextf("'%s' is greater than '%s'", "iBetween", "nBetween"))
TRUE
})
## BetaIterator gives the elements of each 'beta' associated with
## each element of 'mu'. Slot 'indices' gives the indices of each 'beta'.
## The first element of 'indices' is always 1, since the first 'beta'
## is always an intercept term. If, for instance, indices is c(1L, 3L, 5L),
## then the current value of 'mu' equals the intercept term plus the
## third element of the first 'beta' plus the fifth element of the second 'beta'.
## Slot 'dimIterators' is a list of objects of class "DimIterator". It has
## an iterator for each dimension contained in the 'beta'. For instance,
## if beta consists of a main effect for dimension 1, a main effect for dimension
## 3 and an interaction between dimensions 1 and 3, then 'dimIterators' will
## have an interator for dimensions 1 and 3 (but not dimension 2).
## Slot 'strideLengths' is a list containing an integer vector for each beta
## other than the intercept. The vectors record how far to advance along the 'beta'
## vector for each stride returned by the associated dimIterator. The distance is
## always 1 if 'beta' is a main effect, but is greater than 1 for all dimensions
## other than the first if 'beta' is an interaction. Note that the terms in
## 'margin' apart from the intercept can be out of order - including terms
## within each interaction. For instance 'margin' might be list(0L, 2:1, 2L, 1L).
## HAS_TESTS
setClass("BetaIterator",
slots = c(indices = "integer",
strideLengths = "list",
dimIterators = "list"),
validity = function(object) {
indices <- object@indices
strideLengths <- object@strideLengths
dimIterators <- object@dimIterators
hasMissing <- function(x) any(is.na(x))
## 'indices' has no missing values
if (any(is.na(indices)))
return(gettextf("'%s' has missing values",
"indices"))
## 'indices' has no values less than 1
if (any(indices < 1L))
return(gettextf("'%s' has values less than %d",
"indices", 1L))
## all elements of 'strideLengths' have type "integer"
if (!all(sapply(strideLengths, is.integer)))
return(gettextf("'%s' has elements not of type \"%s\"",
"strideLengths", "integer"))
## 'strideLengths' has no missing values
if (any(sapply(strideLengths, hasMissing)))
return(gettextf("'%s' has missing values",
"strideLengths"))
## all elements of 'dimIterators' have class "DimIterator"
if (!all(sapply(dimIterators, is, "DimIterator")))
return(gettextf("'%s' has elements not of class \"%s\"",
"dimIterators", "DimIterator"))
## 'strideLenths' has one fewer elements than 'indices'
if (!identical(length(strideLengths), length(indices) - 1L))
return(gettextf("'%s' should have one fewer elements than '%s'",
"strideLengths", "indices"))
## each element within 'strideLengths' has same length as 'dimIterators'
## (because intercept term does not use stride lengths)
if (!all(sapply(strideLengths, length) == length(dimIterators)))
return(gettextf("each element of '%s' should have same length as '%s'",
"strideLengths", "dimIterators"))
TRUE
})
## HAS_TESTS
setClass("CohortIterator",
slots = c(i = "integer",
nTime = "integer",
stepTime = "integer",
iTime = "integer",
hasAge = "logical",
nAge = "integer",
stepAge = "integer",
iAge = "integer",
finished = "logical"),
contains = "VIRTUAL",
validity = function(object) {
iTime <- object@iTime
nTime <- object@nTime
hasAge <- object@hasAge
iAge <- object@iAge
nAge <- object@nAge
finished <- object@finished
## all slots have length 1
for (name in c("i",
"nTime", "stepTime", "iTime",
"hasAge", "nAge", "stepAge", "iAge",
"finished")) {
value <- methods::slot(object, name)
if (!identical(length(value), 1L))
return(gettextf("'%s' does not have length %d",
name, 1L))
}
## i, nTime, stepTime, iTime, hasAge, finished not missing
for (name in c("i", "nTime", "stepTime", "iTime", "hasAge", "finished")) {
value <- methods::slot(object, name)
if (is.na(value))
return(gettextf("'%s' is missing",
name))
}
## i, nTime, stepTime, iTime positive
for (name in c("i", "nTime", "stepTime", "iTime")) {
value <- methods::slot(object, name)
if (value < 1L)
return(gettextf("'%s' is non-positive",
name))
}
## iTime less than or equal to nTime
if (iTime > nTime)
return(gettextf("'%s' is greater than '%s'",
"iTime", "nTime"))
if (hasAge) {
## if hasAge: nAge, stepAge, iAge not missing
for (name in c("nAge", "stepAge", "iAge")) {
value <- methods::slot(object, name)
if (is.na(value))
return(gettextf("'%s' is missing",
name))
}
## if hasAge: nAge, stepAge, iAge positive
for (name in c("nAge", "stepAge", "iAge")) {
value <- methods::slot(object, name)
if (value < 1L)
return(gettextf("'%s' is non-positive",
name))
}
## if hasAge: iAge less than or equal to nAge
if (iAge > nAge)
return(gettextf("'%s' is greater than '%s'",
"iAge", "nAge"))
}
else {
## if not hasAge: nAge, stepAge, iAge all missing
for (name in c("nAge", "stepAge", "iAge")) {
value <- methods::slot(object, name)
if (!is.na(value))
return(gettextf("'%s' is %s but '%s' is not missing",
"hasAge", FALSE, name))
}
}
## finished is TRUE iff iTime >= nTime
if (!identical(finished, iTime >= nTime))
return(gettextf("'%s', '%s', and '%s' inconsistent",
"finished", "iTime", "nTime"))
TRUE
})
## HAS_TESTS
setClass("CohortIteratorAccession",
contains = "CohortIterator")
## HAS_TESTS
setClass("CohortIteratorPopulation",
contains = "CohortIterator")
## HAS_TESTS
setClass("CohortIteratorComponent",
slots = c(stepTriangle = "integer",
iTriangle = "integer",
lastAgeGroupOpen = "logical"),
contains = "CohortIterator",
validity = function(object) {
hasAge <- object@hasAge
for (name in c("stepTriangle", "iTriangle", "lastAgeGroupOpen")) {
value <- methods::slot(object, name)
## stepTriangle, iTriangle have length 1
if (!identical(length(value), 1L))
return(gettextf("'%s' does not have length %d",
name, 1L))
if (hasAge) {
## if hasAge is TRUE: stepTriangle, iTriangle, lastAgeGroupOpen not missing
if (is.na(value))
return(gettextf("'%s' is missing",
name))
## if hasAge is TRUE: stepTriangle, iTriangle positive
if ((name %in% c("stepTriangle", "iTriangle")) && (value < 1L))
return(gettextf("'%s' is non-positive",
name))
}
else {
## if hasAge is FALSE: stepTriangle, iTriangle, lastAgeGroupOpen missing
if (!is.na(value))
return(gettextf("'%s' is %s but '%s' is not missing",
"hasAge", FALSE, name))
}
}
TRUE
})
## HAS_TESTS
setClass("CohortIteratorOrigDestParChPool",
slots = c(iVec = "integer",
lengthVec = "integer",
increment = "integer"),
contains = "CohortIteratorComponent",
validity = function(object) {
iVec <- object@iVec
lengthVec <- object@lengthVec
increment <- object@increment
for (name in c("iVec", "lengthVec", "increment")) {
value <- methods::slot(object, name)
## iVec, lengthVec, increment do not have length 0
if (identical(length(value), 0L))
return(gettextf("'%s' has length %d",
name, 0L))
## iVec, lengthVec, increment do not have missing values
if (any(is.na(value)))
return(gettextf("'%s' has missing values",
name))
## iVec, lengthVec, increment have no negative values
if (any(value < 0L))
return(gettextf("'%s' has negative values",
name))
}
## 'iVec' and 'increment' have same length
if (!identical(length(iVec), length(increment)))
return(gettextf("'%s' and '%s' have different lengths",
"iVec", "increment"))
## 'lengthVec' has length 1
if (!identical(length(lengthVec), 1L))
return(gettextf("'%s' has length %d",
"lengthVec", length(lengthVec)))
## length of 'iVec' equal to 'lengthVec'
if (!identical(length(iVec), lengthVec))
return(gettextf("length of '%s' not equal to '%s'",
"iVec", "lengthVec"))
TRUE
})
## HAS_TESTS
## DimIterator is a 'helper' iterator for BetaIterator and MarginIterator.
## It shows how position along a chosen margin changes as the
## iterator moves along the length of an array. For instance,
## a particular iterator might show how position along the
## second dimension changes as the iterator moves along an
## object of dimension c(3L, 2L, 4L). The iterator does not
## show the current position along the margin, but instead the
## number of strides taken on the most recent move (as this
## is what is required by BetaIterator).
setClass("DimIterator",
slots = c(nStrides = "integer",
iWithin = "integer",
nWithin = "integer",
iBetween = "integer",
nBetween = "integer"),
prototype = prototype(iWithin = 1L, iBetween = 1L),
validity = function(object) {
## all slots have length 1 and are not missing
for (name in methods::slotNames(object)) {
value <- methods::slot(object, name)
if (!identical(length(value), 1L))
return(gettextf("'%s' does not have length %d", name, 1L))
if (is.na(value))
return(gettextf("'%s' is missing", name))
}
## iWithin, nWithin, iBetween, nBetween all at least one.
## Enforces R-style indexing. Probably clearest to do so,
## even if it requires some -1 subtractions in C.
for (name in c("iWithin", "nWithin", "iBetween", "nBetween")) {
value <- methods::slot(object, name)
if (value < 1L)
return(gettextf("'%s' is less than %d", name, 1L))
}
## iWithin <= nWithin
if (object@iWithin > object@nWithin)
return(gettextf("'%s' is greater than '%s'", "iWithin", "nWithin"))
## iBetween <= nBetween
if (object@iBetween > object@nBetween)
return(gettextf("'%s' is greater than '%s'", "iBetween", "nBetween"))
TRUE
})
## MarginIterator is for stepping through an array of dimension 'dim'.
## 'indices' shows the position along each of the length(dim) dimensions.
## HAS_TESTS
setClass("MarginIterator",
slots = c(indices = "integer",
dimIterators = "list"),
validity = function(object) {
indices <- object@indices
dimIterators <- object@dimIterators
hasMissing <- function(x) any(is.na(x))
## 'indices' has no missing values
if (any(is.na(indices)))
return(gettextf("'%s' has missing values",
"indices"))
## 'indices' has no values less than 1
if (any(indices < 1L))
return(gettextf("'%s' has values less than %d",
"indices", 1L))
## all elements of 'dimIterators' have class "DimIterator"
if (!all(sapply(dimIterators, is, "DimIterator")))
return(gettextf("'%s' has elements not of class \"%s\"",
"dimIterators", "DimIterator"))
## 'indices' and 'dimIterators' have same length
if (!identical(length(indices), length(dimIterators)))
return(gettextf("'%s' and '%s' have different lengths",
"indices", "dimIterators"))
## indices and dimIterators consistent
indices.implied <- sapply(dimIterators, slot, name = "iBetween")
if (!identical(indices.implied, indices))
return(gettextf("'%s' and '%s' inconsistent",
"dimIterators", "indices"))
TRUE
})
## HAS_TESTS
setClass("SliceIterator",
slots = c(indices = "integer",
increment = "integer",
posDim = "integer",
lengthDim = "integer"),
validity = function(object) {
indices <- object@indices
increment <- object@increment
posDim <- object@posDim
lengthDim <- object@lengthDim
## 'indices' has no missing values
if (any(is.na(indices)))
return(gettextf("'%s' has missing values",
"indices"))
## 'indices' has no values less than 1
if (any(indices < 1L))
return(gettextf("'%s' has values less than %d",
"indices", 1L))
## elements of 'indices' increasing'
if (any(diff(indices) < 1L))
return(gettextf("'%s' non-increasing",
"indices"))
for (name in c("increment", "posDim", "lengthDim")) {
value <- methods::slot(object, name)
## increment, posDim, lengthDim length 1
if (!identical(length(value), 1L))
return(gettextf("'%s' does not have length %d",
name, 1L))
## increment, posDim, lengthDim not missing
if (is.na(value))
return(gettextf("'%s' is missing",
name))
## increment, posDim, lengthDim positive
if (value < 1L)
return(gettextf("'%s' is non-positive",
name))
}
## posDim less than or equal to lengthDim
if (posDim > lengthDim)
return(gettextf("'%s' is greater than '%s'",
"posDim", "lengthDim"))
TRUE
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.