6. Object-Oriented Programming

There are multiple ways to do object-oriented programming OOP in R. You will need to pick an object model from the following to start OOP.

• S3 is the object model for release 3

• S4 is the object model for release 4

• R6 is the current object model

6.1. S3

6.1.1. S3 class definition

Defining an S3 class is basically through using a function. Here, we have a class called S3Student which has the properties

• name: characters

• age: numeric

• grades: vector

• male: logical

Note the convention is to prefix S3 to the class name.

S3Student <- function(name, age, grades, male) {
    student <- list(name=name, age=age, grades=grades, male=male)
    class(student) <- 'S3Student'
    return(student)
}

Now we may instantiate a S3Student as follows.

s <- S3Student('John', 18, c(99, 100, 80, 70, 90), TRUE)

print(class(s))

[1] "S3Student"

print(str(s))

List of 4
 $ name  : chr "John"
 $ age   : num 18
 $ grades: num [1:5] 99 100 80 70 90
 $ male  : logi TRUE
 - attr(*, "class")= chr "S3Student"
NULL

We may access the properties of the student using $ notation (since these properties are just stored in a named list).

print(s$name)

[1] "John"

print(s$age)

[1] 18

print(s$grades)

[1]  99 100  80  70  90

print(s$male)

[1] TRUE

6.1.2. S3 methods

Methods in S3 objects are not a part of the objects. Instead, we define them and then register the name with R to be able to use them properly.

• generic functions: functions that are defined to be used over different types

• parametric polymorphism: defining generic functions over types such that behavior will change depending on the type; methods belong to functions not classes

Below, we define a method S3grade that will compute the letter grade of a S3Student. We also register the method with R.

# define S3grade function
S3grade.S3Student <- function(student) {
    avg <- mean(student$grades)
    if (avg >= 90.0) {
        return('A')
    } else if (avg >= 80.0) {
        return('B')
    } else if (avg >= 70.0) {
        return('C')
    } else if (avg >= 60.0) {
        return('D')
    } else {
        return('F')
    }
}

# register S3grade with R
S3grade <- function(object) UseMethod('S3grade')

Now we may use the S3grade function on a S3Student.

grade <- S3grade(s)
print(grade)

[1] "B"

We can also overload the print function too.

print.S3Student <- function(student) {
    print(paste(
        student$name, student$age, ifelse(student$male, 'male', 'female'), S3grade(student)
    ))
}

print(s)

[1] "John 18 male B"

6.1.3. S3 inheritance

S3Animal <- function(name, type='animal') {
    animal <- list(name=name)
    class(animal) <- 'S3Animal'
    return(animal)
}

S3Dog <- function(name) {
    dog <- S3Animal(name, 'dog')
    class(dog) <- c('S3Dog', class(dog))
    return(dog)
}

S3Cat <- function(name) {
    cat <- S3Animal(name, 'cat')
    class(cat) <- c('S3Cat', class(cat))
    return(cat)
}

dog <- S3Dog('Clifford')
cat <- S3Cat('Heathcliff')

print(class(dog))

[1] "S3Dog"    "S3Animal"

print(class(cat))

[1] "S3Cat"    "S3Animal"

S3sound.S3Animal <- function(object) return('argghhh!')
S3sound.S3Dog <- function(object) return('woof!')
S3sound.S3Cat <- function(object) return('meoww!')

S3sound <- function(object) UseMethod('S3sound')

print(S3sound(dog))

[1] "woof!"

print(S3sound(cat))

[1] "meoww!"

6.2. S4

6.2.1. S4 class definition

setClass(
    Class = 'S4Student',
    representation = representation(
        name = 'character',
        age = 'numeric',
        grades = 'numeric',
        male = 'logical'
    )
)

s <- new('S4Student', name='John', age=18, grades=c(99, 100, 80, 70, 90), male=TRUE)

print(class(s))

[1] "S4Student"
attr(,"package")
[1] ".GlobalEnv"

print(str(s))

Formal class 'S4Student' [package ".GlobalEnv"] with 4 slots
  ..@ name  : chr "John"
  ..@ age   : num 18
  ..@ grades: num [1:5] 99 100 80 70 90
  ..@ male  : logi TRUE
NULL

print(s@name)

[1] "John"

print(s@age)

[1] 18

print(s@grades)

[1]  99 100  80  70  90

print(s@male)

[1] TRUE

6.2.2. S4 methods

setGeneric('S4grade', function(self) {
    standardGeneric('S4grade')
})

setMethod('S4grade', 'S4Student', function(self) {
    avg <- mean(self@grades)
    if (avg >= 90.0) {
        return('A')
    } else if (avg >= 80.0) {
        return('B')
    } else if (avg >= 70.0) {
        return('C')
    } else if (avg >= 60.0) {
        return('D')
    } else {
        return('F')
    }
})

'S4grade'

grade <- S4grade(s)
print(grade)

[1] "B"

We do not overload print but provide a a method implementation for show so that we can use print.

setMethod('show', 'S4Student', function(object) {
    print(paste(
        object@name, object@age, ifelse(object@male, 'male', 'female'), S4grade(object)
    ))
})

print(s)

[1] "John 18 male B"

6.2.3. S4 inheritance

setClass(
    Class = 'S4Animal',
    representation = representation(
        name = 'character',
        type = 'character'
    )
)

setClass(Class='S4Dog', contains='S4Animal')
setClass(Class='S4Cat', contains='S4Animal')

dog = new('S4Dog', name='Clifford', type='dog')
cat = new('S4Cat', name='Heathcliff', type='cat')

print(class(dog))

[1] "S4Dog"
attr(,"package")
[1] ".GlobalEnv"

print(class(cat))

[1] "S4Cat"
attr(,"package")
[1] ".GlobalEnv"

setGeneric('S4sound', function(self) {
    standardGeneric('S4sound')
})

setMethod('S4sound', 'S4Animal', function(self) return('argghhh!'))
setMethod('S4sound', 'S4Dog', function(self) return('woof!'))
setMethod('S4sound', 'S4Cat', function(self) return('meoww!'))

'S4sound'

print(S4sound(dog))

[1] "woof!"

print(S4sound(cat))

[1] "meoww!"

6.3. R6

6.3.1. R6 class definition

To define R6 classes, you will need to load the R6 library.

library(R6)

R6Student <- R6Class(
    'R6Student',
    public = list(
        initialize = function(name, age, grades, male) {
            private$name <- name
            private$age <- age
            private$grades <- grades
            private$male <- male
        },
        grade = function() {
            avg = mean(private$grades)
            if (avg >= 90.0) {
                return('A')
            } else if (avg >= 80.0) {
                return('B')
            } else if (avg >= 70.0) {
                return('C')
            } else if (avg >= 60.0) {
                return('D')
            } else {
                return('F')
            }
        },
        print = function() {
            print(paste(
                private$name, private$age, ifelse(private$male, 'male', 'female'), self$grade()
            ))
            invisible(self)
        }
    ),
    private = list(name=NULL, age=NULL, grades=NULL, male=NULL)
)

s <- R6Student$new('John', 18, c(99, 100, 80, 70, 90), TRUE)

print(class(s))

[1] "R6Student" "R6"

print(str(s))

Classes 'R6Student', 'R6' <R6Student>
  Public:
    clone: function (deep = FALSE)
    grade: function ()
    initialize: function (name, age, grades, male)
    print: function ()
  Private:
    age: 18
    grades: 99 100 80 70 90
    male: TRUE
    name: John
NULL

print(s)

[1] "John 18 male B"

6.3.2. R6 inheritance

• Note the use of active binding to access and mutate fields.

• Note the use of finalize to clean up resources.

R6Animal <- R6Class(
    'R6Animal',
    public = list(
        initialize = function(name, type='animal') {
            private$name <- name
            private$type <- type
        },
        sound = function() {
            print('argghhh!')
            invisible(self)
        },
        print = function() {
            print(paste(
                private$name, private$type
            ))
            invisible(self)
        },
        finalize = function() {
            print(paste('finalizer called', private$name, private$type))
        }
    ),
    private = list(name=NULL, type=NULL),
    active = list(
        name_field = function(new_name) {
            if (missing(new_name)) {
                return(private$name)
            } else {
                private$name <- new_name
            }
        },
        sound_field = function(new_sound) {
            if (missing(new_sound)) {
                return(private$sound)
            } else {
                private$sound <- new_sound
            }
        }
    )
)

R6Dog <- R6Class(
    'R6Dog',
    inherit=R6Animal,
    public = list(
        initialize = function(name) {
            super$initialize(name, type='dog')
        },
        sound = function() {
            print('woof!')
            invisible(self)
        }
    )
)

R6Cat <- R6Class(
    'R6Cat',
    inherit=R6Animal,
    public = list(
        initialize = function(name) {
            super$initialize(name, type='cat')
        },
        sound = function() {
            print('meoww!')
            invisible(self)
        }
    )
)

dog <- R6Dog$new('Clifford')
cat <- R6Cat$new('Heathcliff')

print(class(dog))

[1] "R6Dog"    "R6Animal" "R6"

print(class(cat))

[1] "R6Cat"    "R6Animal" "R6"

dog$sound()

[1] "woof!"

cat$sound()

[1] "meoww!"

You may mutate the name field as well.

# original name
print(dog)

# mutate name
dog$name_field <- 'Droopy'
print(dog)

[1] "Clifford dog"
[1] "Droopy dog"

6.3.3. Introspection

To list all methods and fields, use names.

print(names(dog))

[1] ".__enclos_env__" "sound_field"     "name_field"      "clone"
[5] "sound"           "initialize"      "finalize"        "print"