S4

Introduction

Object consists of:

  • Slots. Like fields in R6.
  • Methods. Accessed through generics. Dispatched to particular methods.

Uses functions to define classes and their methods:

  • setClass(). Define class and its components.
  • setGenerics(). Define generic functions. Used to dispatch.
  • setMethods(). Define methods

Basics overview

Set class

Define the class:

setClass("Person", 
  slots = c(
    name = "character", 
    age = "numeric"
  )
)

Create an instance of the class

john <- new("Person", name = "John Smith", age = NA_real_)

Set generics

Define generic functions for setting and getting the age slot

# get the value
setGeneric("age", function(x) standardGeneric("age"))
#> [1] "age"
# set the value
setGeneric("age<-", function(x, value) standardGeneric("age<-"))
#> [1] "age<-"

Set methods

Define methods for the generics:

# get the value
setMethod("age", "Person", function(x) x@age)
# set the value
setMethod("age<-", "Person", function(x, value) {
  x@age <- value
  x
})

# set the value
age(john) <- 50
# get the value
age(john)
#> [1] 50

To give a flavor, there is only one method per slot. In more realistic cases, there might be several methods.

Details on defining the class

Inheritance

setClass("Employee", 
  contains = "Person", 
  slots = c(
    boss = "Person"
  ),
  prototype = list(
    boss = new("Person")
  )
)

Instantiation

Create an instance of the class at two levels:

  • For developer (you): methods::new()
  • For user: constructor function
# how user constructs an instance
Person <- function(name, age = NA) {
  age <- as.double(age)
  
  # how the developer constructs an instance
  new("Person", name = name, age = age)
}

Person("Someone")
#> An object of class "Person"
#> Slot "name":
#> [1] "Someone"
#> 
#> Slot "age":
#> [1] NA

Validation

S4 objects

  • Check class of slot at creation
Person(mtcars)
#> Error in validObject(.Object): invalid class "Person" object: invalid object for slot "name" in class "Person": got class "data.frame", should be or extend class "character"
  • Do not check other things
Person("Hadley", age = c(30, 37))
#> An object of class "Person"
#> Slot "name":
#> [1] "Hadley"
#> 
#> Slot "age":
#> [1] 30 37

That’s where validation comes in–at two stages:

  1. At creation
  2. At modification

At creation

setValidity("Person", function(object) {
  if (length(object@name) != length(object@age)) {
    "@name and @age must be same length"
  } else {
    TRUE
  }
})
#> Class "Person" [in ".GlobalEnv"]
#> 
#> Slots:
#>                           
#> Name:       name       age
#> Class: character   numeric
Person("Hadley", age = c(30, 37))
#> Error in validObject(.Object): invalid class "Person" object: @name and @age must be same length

At modification

# get value
setGeneric("name", function(x) standardGeneric("name"))
#> [1] "name"
setMethod("name", "Person", function(x) x@name)

# set value--and assess whether resulting object is valid
setGeneric("name<-", function(x, value) standardGeneric("name<-"))
#> [1] "name<-"
setMethod("name<-", "Person", function(x, value) {
  x@name <- value
  validObject(x)
  x
})

# normal name; no problem
name(john) <- "Jon Smythe"
name(john)
#> [1] "Jon Smythe"
# invalid name; error thrown
name(john) <- letters
#> Error in validObject(x): invalid class "Person" object: @name and @age must be same length

Details on generics and methods

Dictate dispatch via signature

Specify function arguments to be used in determining method.

setGeneric("myGeneric", 
  function(x, ..., verbose = TRUE) standardGeneric("myGeneric"),
  signature = "x"
)
#> [1] "myGeneric"

Define generics

General form:

setMethod("myGeneric", "Person", function(x) {
  # method implementation
})

Example to print object:

setMethod("show", "Person", function(object) {
  cat(is(object)[[1]], "\n",
      "  Name: ", object@name, "\n",
      "  Age:  ", object@age, "\n",
      sep = ""
  )
})
john
#> Person
#>   Name: Jon Smythe
#>   Age:  50

Example to access slot:

setGeneric("name", function(x) standardGeneric("name"))
#> [1] "name"
setMethod("name", "Person", function(x) x@name)

name(john)
#> [1] "Jon Smythe"

This is how end users should access slots.

Example: lubridate::period()

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

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.

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