## HAS_TESTS
#' S4 class for describing a life table.
#'
#' An object of class \code{LifeTable} holds values for 'mx' and 'ax',
#' plus the life table 'radix' (ie l0). These provide sufficient information
#' to calculate all life table functions.
#'
#' At present, objects of class \code{LifeTable} can only handle
#' single-decrement life tables. In future they will be extended to
#' handle multiple-decrement and multi-state life tables.
#'
#' Objects of class \code{LifeTable} also holds names of the life table
#' functions that are displayed when the object is printed, that are
#' included when the object is turned into a data.frame.
#'
#' @slot mx An object of class
#' \code{\link[dembase:DemographicArray-class]{Values}}, holding mortality
#' rates.
#' @slot ax An object of class
#' \code{\link[dembase:DemographicArray-class]{Values}}, with the same
#' metadata as \code{mx}, holding separation factors.
#' @slot radix A positive number.
#' @slot showFun A character vector with names of life table
#' functions.
#' @slot showQuantiles \code{TRUE} or \code{FALSE}.
#' @slot showTotal \code{TRUE} or \code{FALSE}.
#' @slot prob A numeric vector.
#'
#' @param object An object of class \code{"LifeTable"}.
#'
#' @seealso Objects of class \code{LifeTable} are typically created using
#' function \code{\link{LifeTable}}.
#'
#' @export
setClass("LifeTable",
slots = c(mx = "Values",
ax = "Values",
radix = "numeric",
showFun = "character",
showQuantiles = "logical",
showTotal = "logical",
prob = "numeric"),
validity = function(object) {
mx <- object@mx
ax <- object@ax
showFun <- object@showFun
radix <- object@radix
showQuantiles <- object@showQuantiles
showTotal <- object@showTotal
prob <- object@prob
dim <- dim(mx)
dimtypes <- dembase::dimtypes(mx, use.names = FALSE)
DimScales <- dembase::DimScales(mx, use.names = FALSE)
## 'ax' and 'mx' have identical metadata
if (!identical(ax@metadata, mx@metadata))
return(gettextf("'%s' and '%s' have different metadata",
"mx", "ax"))
## first dimension of 'mx' has dimtype "age"
if (dimtypes[1L] != "age")
return(gettextf("first dimension of '%s' does not have %s \"%s\"",
"mx", "dimtype", "age"))
## age dimension of 'mx':
## - has age dimension
## - has at least 2 age groups
## - has dimscale "Intervals"
## - first intervals is not open
## - last interval can be (but is not necessarily) open
return.value <- tryCatch(dembase::checkAge(object = mx,
minAges = 2L,
regular = FALSE,
openLeftOK = FALSE,
openRightOK = TRUE,
expectedDimscale = "Intervals"),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## if 'mx' has time dimension, dimscale must be "Intervals"
i.time <- match("time", dimtypes, nomatch = 0L)
has.time <- i.time > 0L
if (has.time) {
dimscale.time <- DimScales[[i.time]]
if (!is(dimscale.time, "Intervals"))
stop(gettextf("dimension with %s \"%s\" has %s \"%s\"",
"dimtype", "time", "dimscale", class(dimscale.time)))
}
## 'mx' does not have quantile dimension
i.quantile <- match("quantile", dimtypes, nomatch = 0L)
has.quantile <- i.quantile > 0L
if (has.quantile)
stop(gettextf("dimension with dimtype \"%s\"",
"quantile"))
## 'mx' has no zero-length dimensions
if (any(dim == 0L))
return(gettextf("'%s' has dimension with length %d",
"mx", 0L))
for (name in c("mx", "ax")) {
value <- slot(object, name)
## 'mx', 'ax' do not have missing values
if (any(is.na(value)))
return(gettextf("'%s' has missing values",
name))
## 'mx', 'ax' do not have negative values
if (any(value < 0))
return(gettextf("'%s' has negative values",
name))
}
## all values of 'ax' are within range implied by metadata for age
i.age <- match("age", dimtypes)
DimScale.age <- DimScales[[i.age]]
dv.age <- DimScale.age@dimvalues
nx <- diff(dv.age)
.Data.ax <- ax@.Data
index <- slice.index(.Data.ax, MARGIN = i.age)
for (i in seq_along(nx)) {
if (any(.Data.ax[index == i] > nx[i]))
stop(gettextf("'some values of '%s' are larger than the width of the age group",
"ax"))
}
## check 'showFun'
return.value <- tryCatch(checkShowFun(showFun),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'radix'
return.value <- tryCatch(checkAndTidyRadix(radix),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'showQuantiles'
return.value <- tryCatch(checkShowQuantiles(showQuantiles),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'showTotal'
return.value <- tryCatch(checkShowTotal(showTotal),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'prob'
return.value <- tryCatch(checkAndTidyProb(prob),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
TRUE
})
## NO_TESTS
setClass("SummaryLifeTable",
slots = c(dimensions = "matrix",
showFun = "character",
radix = "character",
showQuantiles = "logical",
showTotal = "logical",
prob = "numeric"),
validity = function(object) {
dimensions <- object@dimensions
showFun <- object@showFun
radix <- object@radix
showQuantiles <- object@showQuantiles
prob <- object@prob
## 'dimensions' has type "character"
if (!is.character(dimensions))
return(gettextf("'%s' does not have type \"%s\"",
"dimensions", "character"))
## check 'showFun'
return.value <- tryCatch(checkShowFun(showFun),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'radix'
return.value <- tryCatch(checkAndTidyRadix(radix),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'showQuantiles'
return.value <- tryCatch(checkShowQuantiles(showQuantiles),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'showTotal'
return.value <- tryCatch(checkShowTotal(showTotal),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
## check 'prob'
return.value <- tryCatch(checkAndTidyProb(prob),
error = function(e) e)
if (methods::is(return.value, "error"))
return(return.value$message)
TRUE
})
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.