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