15.5 Example: lubridate::period()
15.5.1 Define the class
setClass("Period",
# inherits from these classes
contains = c("Timespan", "numeric"),
# has slots for time components
slots = c(
year = "numeric",
month = "numeric",
day = "numeric",
hour = "numeric",
minute = "numeric"
),
# defines prototype as period of zero duration for all slots
prototype = prototype(year = 0, month = 0, day = 0, hour = 0, minute = 0),
# check validity with `check_period` function; see section below
validity = check_period
)
See source code here
15.5.2 Validate object
Check whether object is valid–notably if all arugments have the same length and are integers.
check_period <- function(object) {
# start with an empty vector of error messages
errors <- character()
# check length of object's data
length(object@.Data) -> n
# check length of each slot
lengths <- c(
length(object@year),
length(object@month),
length(object@day),
length(object@hour),
length(object@minute)
)
# if length of any slot is different than overall length, compose error message
if (any(lengths != n)) {
msg <- paste("Inconsistent lengths: year = ", lengths[1],
", month = ", lengths[2],
", day = ", lengths[3],
", hour = ", lengths[4],
", minute = ", lengths[5],
", second = ", n,
sep = ""
)
# add just-composed error to vector of error messages
errors <- c(errors, msg)
}
values <- c(object@year, object@month, object@day, object@hour, object@minute)
values <- na.omit(values)
if (sum(values - trunc(values))) {
msg <- "periods must have integer values"
errors <- c(errors, msg)
}
if (length(errors) == 0) {
TRUE
} else {
errors
}
}
See source code here.
15.5.3 Set methods
Show period:
#' @export
setMethod("show", signature(object = "Period"), function(object) {
if (length(object@.Data) == 0) {
cat("<Period[0]>\n")
} else {
print(format(object))
}
})
#' @export
format.Period <- function(x, ...) {
if (length(x) == 0) {
return(character())
}
show <- paste(
x@year, "y ", x@month, "m ", x@day, "d ",
x@hour, "H ", x@minute, "M ", x@.Data, "S",
sep = ""
)
start <- regexpr("[-1-9]|(0\\.)", show)
show <- ifelse(start > 0, substr(show, start, nchar(show)), "0S")
show[is.na(x)] <- NA
show
}
See source code here