2-15-S4.Rmd

```{r, include=FALSE}
source("common.R")
```

# S4

## Prerequisites

We load the methods package as it contains the S4 object-orientation system.

```{r, message = FALSE}
library(methods)
```

## Basics

1. __[Q]{.Q}__: `lubridate::period()` returns an S4 class. What slots does it have? What class is each slot? What accessors does it provide?
    
   __[A]{.solved}__: Objects of the S4 `Period` class have six slots named `.Data`, `year`, `month`, `day`, `hour` and `minute`, which are each of type double. Most fields can be retrieved by identically named accessor (e.g. `lubridate::year()` will return the field). Just the `.Data` has a specially named accessor, called `methods::gedDataPart()`.

   As a short example, we';; create a period of 1 second, 2 minutes, 3 hours, 4 days and 5 weeks.
   
    ```{r}
    example_12345 <- lubridate::period(c(1, 2, 3, 4, 5), 
              c("second", "minute", "hour", "day", "week"))
    ```
    
   This should add up to a period of 39 days, 3 hours, 2 minutes and 1 second.
   
    ```{r}
    example_12345
    ```
    
   When we inspect `example_12345`, we see the fields and infer that the seconds are stored in the `.Data` field.
   
    ```{r}
    str(example_12345)
    ```

2. __[Q]{.Q}__: What other ways can you find help for a method? Read `?"?"` and summarise the details.
    
   __[A]{.solved}__: Besides adding `?` in front of a function call (`?method()`), we may find:
    
   * general documentation for a generic via `?genericName`
   * general documentation for the methods of a generic via `methods?genericName`
   * documentation for a specific method via `ClassName?methodName`.
    
## Classes

1. __[Q]{.Q}__: Extend the Person class with fields to match `utils::person()`. Think about what slots you will need, what class each slot should have, and what you’ll need to check in your validity method.
    
   __[A]{.solved}__: The Person class from the textbook contains the slots `name` and `age`. The person class from the utils package contains the slots `given`, `family`, `role`, `email` and `comment`. All these slots must be of type character.
   
   The entries in the `role` slot must match one of the following abbreviations "aut", "com", "cph", "cre", "ctb", "ctr", "dtc", "fnd", "rev", "ths", "trl". Therefore we include all these slots in our new definition of the `Person` class. `role` might be of different length than the other slots. Because of this we add a constraint to the validator, that all slots must be of length one.
   
    ```{r}
    # Definition of the Person class
    setClass("Person", 
         slots = c(
           name = "character", 
           age = "numeric",
           given = "character",
           family = "character",
           role = "character",
           email = "character",
           comment = "character"
         ),
         prototype = list(
           name = NA_character_,
           age = NA_real_,
           given = NA_character_,
           family = NA_character_,
           role = NA_character_,
           email = NA_character_,
           comment = NA_character_
         )
    )
    
    # Helper to create instances of the Person class
    Person <- function(name, age = NA, 
                   given = NA_character_,
                   family = NA_character_,
                   role = NA_character_,
                   email = NA_character_,
                   comment = NA_character_) {
      age <- as.double(age)
      
      new("Person", name = name, age = age, 
      given = given, family = family, 
      role = role, email = email,
      comment = comment)
    }

    # Validator to ensure that each slot is of length one
    setValidity("Person", function(object) {
      if (length(object@name)    != 1 |
          length(object@age)     != 1 |
          length(object@given)   != 1 |
          length(object@family)  != 1 |
          length(object@email)   != 1 |
          length(object@comment) != 1) {
        "@name, @age, @given, @family, @email, @comment must be of length 1"
      } 
  
      if (!all(object@role %in% c(NA_character_, 
            "aut", "com", "cph", "cre", "ctb",
            "ctr", "dtc", "fnd", "rev", "ths", "trl"))) {
        paste("@role (s) must be one of", 
              paste (c(NA_character_, 
                                     "aut", "com", "cph", "cre", "ctb",
                                     "ctr", "dtc", "fnd", "rev", "ths", "trl"),
                     collapse = ", "), ".")
      }
  
      TRUE
    })
    ```

2. __[Q]{.Q}__: What happens if you define a new S4 class that doesn’t have any slots?  (Hint: read about virtual classes in `?setClass`.)
    
   __[A]{.solved}__: It depends on the other arguments.
   
   If we supply a class that doesn't exist, we'll get an error.
    
    ```{r, error = TRUE}
    setClass("Programmer",
             slots = c(skill = "ANY"),
             contains = "Human")
    ```
    
   To can get around that, we register the new class before we define the new class.
   
    ```{r}
    setOldClass("Human")
    .Programmer <- setClass("Programmer",
                            slots = c(Skill = "ANY"),
                            contains = "Human")
    ```
    
   Supplying neither `slots` nor `contains` leads to a constructor for virtual classes.
    
    ```{r}
    .VirtualProgrammer <- setClass("VirtualProgrammer")
    # equal to contains = "VIRTUAL" (here you could also supply slots)
    .VirtualProgrammer <- setClass("VirtualProgrammer",
                                   contains = "VIRTUAL")
    ```
    
   Just leaving out `contains`, but supplying slots, creates a constructor without a superclass.
    
    ```{r}
    .DataScientist <- setClass("RProgrammer",
                               slots = c(stats = "ANY",
                                         math = "ANY",
                                         programming = "ANY"))
    ```

3. __[Q]{.Q}__: Imagine you were going to reimplement factors, dates, and data frames in S4. Sketch out the `setClass()` calls that you would use to define the classes. Think about appropriate `slots` and `prototype`.

   __[A]{.solved}__: We may use a slot for the base type and one slot per attribute. Keep in mind, that inheritance matters for ordered factors and dates. Also, special checks like equal lengths of list elements for columns of a data frame should be done within a validator.
   
   For simplicity we don't introduce an explicit subclass for ordered factors. Instead, we introduce `ordered` as a slot.
   
    ```{r}
    setClass("Factor", 
          slots = c(
            x = "character",
            levels = "character",
            ordered = "logical"
          ),
          prototype = list(
            x = character(0),
            levels = character(0),
            ordered = FALSE
          )
    )
 
    abc <- new("Factor", x = c("a", "b", "c"))
    abc
    ```
    
   The `Date2` class stores it's dates as integers, similarly to base R. A print method for our new class could then be provided.
   
    ```{r}
    setClass("Date2",
         slots = c(
           Date = "integer", 
           format = "character",
           origin = "integer",
           tz = "character"
         ),
         prototype = list(
           Date = integer(),
           format = "%Y-%m-%d",
           origin = 0L,
           tz = "UTC"
         )
    )
         
    new("Date2")
    ```
    
   Our `DataFrame` class consists of a list and a slot for `row.names`. More serious checks should be part of a validator.
   
    ```{r}
    setClass("DataFrame",
         slots = c(
           x = "list", 
           row.names = "character"
         ),
         prototype = list(
           x = list(),
           row.names = character(0)
           )
         )
         
    df <- new("DataFrame", 
              x = list(a = 1, b = 2))         
    df
    ```

## Generics and methods

1. __[Q]{.Q}__: Add `age()` accessors for the `Person` class.

   __[A]{.solved}__: Here we define an `age()` generic, with a method for the `Person` class and a replacement function `age<-()`:
   
    ```{r}
    setGeneric("age", function(x) standardGeneric("age"))
    setMethod("age", "Person", function(x) x@age)
    
    setGeneric("age<-", function(x, value) standardGeneric("age<-"))
    setMethod("age<-", "Person", function(x, value) {
      x@age <- value
      validObject(x)
      x
    })
    ```

2. __[Q]{.Q}__: In the definition of the generic, why is it necessary to repeat the name of the generic twice?

   __[A]{.solved}__: First the name is needed as the name of the generic. The name also explicitly incorporates method dispatch via `standardGeneric()` within the generic's body (`def` parameter). This behaviour is similar to `UseMethod()` in S3.

3. __[Q]{.Q}__: Why does the `show()` method defined in Section 15.4.3 use `is(object)[[1]]`? (Hint: try printing the employee subclass.)

   __[A]{.solved}__: `is(object)` returns the class of the object. `is(object)` also contains the superclass, for subclasses like `Employee`. In order to always return the most specific class (the subclass), `show()` returns the first element of `is(object)`.

4. __[Q]{.Q}__: What happens if you define a method with different argument names to the generic?

   __[A]{.solved}__: It depends. We first create the object `hadley` of class "Person":
    
    ```{r}
    .Person <- setClass("Person", 
                        slots = c(name = "character", 
                                  age = "numeric"))
    
    hadley <- .Person(name = "Hadley")
    hadley
    ```
    
   Now let's see, which arguments can be supplied to the `show()` generic.
    
    ```{r}
    formals("show")
    ```
    
   Usually we would use this argument when defining a new method.
    
    ```{r}
    setMethod("show", "Person", 
              function(object){
                cat(object@name, "creates hard exercises")
              })
    hadley
    ```
    
   When we supply another name as a first element of our method (e.g. `x` instead of `object`), this element will be matched to the correct `object` argument and we receive a warning. Our method will work, though:
    
    ```{r, eval = TRUE}
    setMethod("show", "Person", 
              function(x){
                cat(x@name, "creates hard exercises")
              })
    hadley
    ```
    
   If we add more arguments to our method than our generic can handle, we will get an error.
    
    ```{r, eval = TRUE, error = TRUE}
    setMethod("show", "Person", 
              function(x, y){
                cat(x@name, "is", x@age, "years old")
              })
    ```
    
   If we do this with arguments added to the correctly written `object` argument, we will receive an informative error message. It states, that we could add other argument names for generics, which can take the `...` argument.
    
    ```{r, eval = TRUE, error = TRUE}
    setMethod("show", "Person", 
              function(object, y){
                cat(object@name, "is", object@age, "years old")
              })
    ```

## Method dispatch 

1. __[Q]{.Q}__: Draw the method graph for `f(😅, 😽)`.

   __[A]{.solved}__: Look at the graph and repeat after me: "I will keep my class structure simple and use multiple inheritance sparingly".

    ```{r, echo = FALSE}
    knitr::include_graphics("diagrams/s4/method_dispatch1.png", dpi = 96)
    ```

2. __[Q]{.Q}__: Draw the method graph for `f(😃, 😉, 😙)`.

   __[A]{.solved}__: We see, that the method graph below looks simpler than the one above. Relativly speaking, multiple dispatch seems to introduce less complexitiy than multiple inheritance. Use it with care, though!

    ```{r, echo = FALSE}
    knitr::include_graphics("diagrams/s4/method_dispatch2.png", dpi = 96)
    ```


3. __[Q]{.Q}__: Take the last example which shows multiple dispatch over two classes that use multiple inheritance. What happens if you define a method for all terminal classes? Why does method dispatch not save us much work here?

   __[A]{.solved}__: We will introduce ambiguity, since one class has distance 2 to all terminal nodes and the other four have distance 1 to two terminal nodes each. To resolve this ambiguity we have to define five more methods, one per class combination.


## S4 and S3

1. __[Q]{.Q}__: What would a full `setOldClass()` definition look like for an ordered factor (i.e. add `slots` and `prototype` the definition above)?

   __[A]{.open}__:
   
2. __[Q]{.Q}__: Define a `length` method for the `Person` class.

   __[A]{.solved}__: We can define this method as an S3 method and register it afterwards:
   
    ```{r}
    length.Person <- function(x) "a"
    setMethod("length", "Person", length.Person)
    ```