Example of R's S4 classes

talented_people.R

## S4 classes for talented people
##
## Code to go along with a blog post about
## object oriented programming in R:
## 
## http://digitheadslabnotebook.blogspot.com/2012/09/oo-in-r.html
##
################################################################

# define an S4 class for people
setClass(
  "Person",
  representation(name = "character", age = "numeric"),
  prototype(name = NA_character_, age = NA_real_)
)

# define subclasses for different types of people
setClass("Programmer", representation(language = "character"), contains="Person")
setClass("Musician", representation(instrument = "character"), contains="Person")

# create a generic method called 'talent' that dispatches
# on the type of object it's applied to
setGeneric(
  "talent",
  function(object) {
    standardGeneric("talent")
  }
)

setMethod(
  "talent",
  signature("Programmer"),
  function(object) {
    paste("Codes in", paste(object@language, collapse=", "))
  }
)

setMethod(
  "talent",
  signature("Musician"),
  function(object) {
    paste("Plays the", paste(object@instrument, collapse=", "))
  }
)

# create some talented people
donald <- new("Programmer",
              name="Donald Knuth",
              age=74,
              language=c("MMIX"))

coltrane <- new("Musician",
                name="John Coltrane",
                age=40,
                instrument=c("Tenor Sax", "Alto Sax"))

miles <- new("Musician",
             name="Miles Dewey Davis",
             instrument=c("Trumpet"))

monk <- new("Musician",
            name="Theloneous Sphere Monk",
            instrument=c("Piano"))

talent(coltrane)
# [1] "Plays the Tenor Sax, Alto Sax"

talent(donald)
# [1] "Codes in MMIX"

talent(monk)
# [1] "Plays the Piano"

# There's nothing wrong with plain old functions.
getNameAndTitle <- function(person) {
  sprintf("%s, %s", person@name, class(person))
}

getNameAndTitle(miles)
# [1] "Miles Dewey Davis, Musician"


# Let's write a method that changes the state of an object.
# An employee is a person who has a salary and gets a raise
# now and then.
setClass("Employee",
         representation(boss = "Person", salary="numeric"),
         contains = "Person")

setGeneric(
  "raise",
  function(object, percent=0) {
    standardGeneric("raise")
  })

setMethod(
  "raise",
  signature("Employee"),
  function(object, percent=0) {
    object@salary <- object@salary * (1+(percent/100))
    object
  })

smithers <- new("Employee",
                name="Waylon Smithers",
                boss=new("Person",name="Mr. Burns"),
                salary=100)

# Mr. Burns gives Smithers a raise
raise(smithers, percent=15)

# doesn't work?!?!
smithers@salary
# [1] 100

# The raise method returns the new object with the new
# value for salary. Don't forget to capture it.
smithers <- raise(smithers, percent=15)
smithers@salary
# [1] 115000

# multiple inheritance: The humble code monkey is a programmer
# and also an employee
setClass("Code Monkey", contains=c("Programmer","Employee"))

setMethod(
  "talent",
  signature("Code Monkey"),
  function(object) {
    paste("Codes in", paste(object@language, collapse=", "), "for", object@boss@name)
  }
)

# This is a code monkey
chris <- new("Code Monkey",
             name="Chris",
             age=29,
             boss=new("Person", name="The Man"),
             language=c("Java", "R", "Python", "Clojure"),
             salary=80000)

talent(chris)

# Bad code code monkey. Take a pay cut!
chris <-raise(chris,percent=-10)

# Some folks consider it poor form to access slots this way,
# preferring to write getter and setter methods instead.
chris@salary


# Multiple dispatch. I'm curious as to what else you can do
# with method dispatch
setGeneric(
  "together",
  function(person1, person2) {
    standardGeneric("together")
  })

setMethod(
  "together",
  signature("Musician", "Musician"),
  function(person1, person2) {
    sprintf("%s and %s jam together!", person1@name, person2@name)
  })

setMethod(
  "together",
  signature("Musician", "Programmer"),
  function(person1, person2) {
    sprintf("%s and %s make electronic music!", person1@name, person2@name)
  })

setMethod(
  "together",
  signature("Programmer", "Programmer"),
  function(person1, person2) {
    sprintf("%s and %s hack some code!", person1@name, person2@name)
  })

together(miles, coltrane)
# [1] "Miles Dewey Davis and John Coltrane jam together!"

together(monk, chris)
# [1] "Theloneous Sphere Monk and Chris make electronic music!"

together(donald, chris)
# [1] "Donald Knuth and Chris hack some code!"


# For more on formal classes see:
# S4 Classes in 15 pages, more or less
# How S4 Methods Work by John Chambers
# Hadley Wickham's The S4 object system at https://github.com/hadley/devtools/wiki/S4