S4.Rmd

# S4

```{r setup, include = FALSE}
library(lubridate)
source("common.R")
source("emoji.R")

code <- function(...) paste0("`", ..., "`")
```

## Basics (Exercises 15.2.1)

---

**Q1.** `lubridate::period()` returns an S4 class. What slots does it have? What class is each slot? What accessors does it provide?

**A1.** Let's first create an instance of `Period` class:

```{r S4-1}
library(lubridate)
x <- lubridate::period(c(2, 43, 6), c("hour", "second", "minute"))
x
```

It has the following slots:

```{r S4-2}
slotNames(x)
```

Additionally, the base type of each slot (`numeric`) can be seen in `str()` output:

```{r S4-3}
str(x)
```

The `{lubridate}` package provides accessors for all slots:

```{r S4-4}
year(x)
month(x)
day(x)
hour(x)
minute(x)
second(x)
```

---

**Q2.** What other ways can you find help for a method? Read `?"?"` and summarise the details.

**A2.** The `"?"` operator allows access to documentation in three ways. To demonstrate different ways to access documentation, let's define a new `S4` class.

```{r S4-5}
pow <- function(x, exp) c(x, exp)
setGeneric("pow")
setMethod("pow", c("numeric", "numeric"), function(x, exp) x^exp)
```

Ways to access documentation:

- The general documentation for a generic can be found with `?topic`:

```{r S4-6, eval=FALSE}
?pow
```

- The expression `type?topic` will look for the overall documentation methods for the function `f`.

```{r S4-7, eval=FALSE}
?pow # produces the function documentation

methods?pow # looks for the overall methods documentation
```

---

## Classes (Exercises 15.3.6)

---

**Q1.** 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.

**A1.** The code below extends the `Person` class described in the book to match more closely with `utils::person()`.

```{r S4-8}
setClass("Person",
  slots = c(
    age     = "numeric",
    given   = "character",
    family  = "character",
    middle  = "character",
    email   = "character",
    role    = "character",
    comment = "character"
  ),
  prototype = list(
    age     = NA_real_,
    given   = NA_character_,
    family  = NA_character_,
    middle  = NA_character_,
    email   = NA_character_,
    role    = NA_character_,
    comment = NA_character_
  )
)

# Helper function to create an instance of the `Person` class
Person <- function(given,
                   family,
                   middle = NA_character_,
                   age = NA_real_,
                   email = NA_character_,
                   role = NA_character_,
                   comment = NA_character_) {
  age <- as.double(age)

  new("Person",
    age     = age,
    given   = given,
    family  = family,
    middle  = middle,
    email   = email,
    role    = role,
    comment = comment
  )
}

# Validator to ensure that each slot is of length one and that the specified
# role is one of the possible roles
setValidity("Person", function(object) {
  invalid_length <- NULL
  slot_lengths <- c(
    length(object@age),
    length(object@given),
    length(object@middle),
    length(object@family),
    length(object@email),
    length(object@comment)
  )

  if (any(slot_lengths > 1L)) {
    invalid_length <- "\nFollowing slots must be of length 1:\n @age, @given, @family, @middle, @email, @comment"
  }

  possible_roles <- c(
    NA_character_, "aut", "com", "cph", "cre", "ctb", "ctr", "dtc", "fnd", "rev", "ths", "trl"
  )

  if (any(!object@role %in% possible_roles)) {
    invalid_length <- paste(
      invalid_length,
      "\nSlot @role(s) must be one of the following:\n",
      paste(possible_roles, collapse = ", ")
    )
  }

  if (!is.null(invalid_length)) {
    return(invalid_length)
  } else {
    return(TRUE)
  }
})
```

Let's make sure that validation works as expected:

```{r S4-9, error=TRUE}
# length of first argument not 1
Person(c("Indrajeet", "Surendra"), "Patil")

# role not recognized
Person("Indrajeet", "Patil", role = "xyz")

# all okay
Person("Indrajeet", "Patil", role = c("aut", "cph"))
```

---

**Q2.** What happens if you define a new S4 class that doesn't have any slots? (Hint: read about virtual classes in `?setClass`.)

**A2.** If you define a new `S4` class that doesn't have any slots, it will create *virtual* classes:

```{r S4-10, error=TRUE}
setClass("Empty")

isVirtualClass("Empty")
```

You can't create an instance of this class:

```{r S4-11, error=TRUE}
new("Empty")
```

So how is this useful? As mentioned in `?setClass` docs:

> Classes exist for which no actual objects can be created, the virtual classes.
>
> The most common and useful form of virtual class is the class union, a virtual class that is defined in a call to `setClassUnion()` rather than a call to `setClass()`.

So virtual classes can still be inherited:

```{r S4-12, eval=FALSE}
setClass("Nothing", contains = "Empty")
```

In addition to not specifying any slots, here is another way to create virtual classes:

> Calls to `setClass()` will also create a virtual class, either when only the Class argument is supplied (no slots or superclasses) or when the `contains=` argument includes the special class name `"VIRTUAL"`.

---

**Q3.** 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`.

**A3.** The reimplementation of following classes in `S4` might have definitions like the following.

- `factor`

For simplicity, we won't provide all options that `factor()` provides. Note that `x` has pseudo-class `ANY` to accept objects of any type.

```{r S4-13}
setClass("Factor",
  slots = c(
    x       = "ANY",
    levels  = "character",
    ordered = "logical"
  ),
  prototype = list(
    x       = character(),
    levels  = character(),
    ordered = FALSE
  )
)

new("Factor", x = letters[1:3], levels = LETTERS[1:3])

new("Factor", x = 1:3, levels = letters[1:3])

new("Factor", x = c(TRUE, FALSE, TRUE), levels = c("x", "y", "x"))
```

- `Date`

Just like the base-R version, this will have only integer values.

```{r S4-14}
setClass("Date2",
  slots = list(
    data = "integer"
  ),
  prototype = list(
    data = integer()
  )
)

new("Date2", data = 1342L)
```

- `data.frame`

The tricky part is supporting the `...` argument of `data.frame()`. For this, we can let the users pass a (named) list.

```{r S4-15}
setClass("DataFrame",
  slots = c(
    data      = "list",
    row.names = "character"
  ),
  prototype = list(
    data      = list(),
    row.names = character(0L)
  )
)

new("DataFrame", data = list(x = c("a", "b"), y = c(1L, 2L)))
```

---

## Generics and methods (Exercises 15.4.5)

---

**Q1.** Add `age()` accessors for the `Person` class.

**A1.** We first should define a generic and then a method for our class:

```{r S4-16}
Indra <- Person("Indrajeet", "Patil", role = c("aut", "cph"), age = 34)

setGeneric("age", function(x) standardGeneric("age"))
setMethod("age", "Person", function(x) x@age)

age(Indra)
```

---

**Q2.** In the definition of the generic, why is it necessary to repeat the name of the generic twice?

**A2.** Let's look at the generic we just defined; the generic name `"age"` is repeated twice.

```{r S4-17, eval=FALSE}
setGeneric(name = "age", def = function(x) standardGeneric("age"))
```

This is because:

- the `"age"` passed to argument `name` provides the name for the generic
- the `"age"` passed to argument `def` supplies the method dispatch

This is reminiscent of how we defined `S3` generic, where we also had to repeat the name twice:

```{r S4-18, eval=FALSE}
age <- function(x) {
  UseMethod("age")
}
```

---

**Q3.** Why does the `show()` method defined in Section [Show method](https://adv-r.hadley.nz/s4.html#show-method) use `is(object)[[1]]`? (Hint: try printing the employee subclass.)

**A3.** Because we wish to define `show()` method for a specific class, we need to disregard the other super-/sub-classes. 

```{r S4-19, echo=FALSE}
setClass("Person",
  slots = c(
    name = "character",
    age = "numeric"
  ),
  prototype = list(
    name = NA_character_,
    age = NA_real_
  )
)

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

Always using the first element ensures that the method will be defined for the class in question:

```{r S4-20}
Alice <- new("Employee")

is(Alice)

is(Alice)[[1]]
```

---

**Q4.** What happens if you define a method with different argument names to the generic?

**A4.** Let's experiment with the method we defined in **Q1.** to study this behavior.

The original method that worked as expected since the argument name between generic and method matched:

```{r S4-21}
setMethod("age", "Person", function(x) x@age)
```

If this is not the case, we either get a warning or get an error depending on which and how many arguments have been specified:

```{r S4-22, error=TRUE}
setMethod("age", "Person", function(object) object@age)

setMethod("age", "Person", function(object, x) object@age)

setMethod("age", "Person", function(...) ...elt(1)@age)

setMethod("age", "Person", function(x, ...) x@age)
```

---

## Method dispatch (Exercises 15.5.5)

---

**Q1.** Draw the method graph for `r paste0(code("f("), emoji("sweat_smile"), ", ", emoji("kissing_cat"), code(")"))`.

**A1.** I don't how to prepare the visual illustrations used in the book, so I am linking to the illustration in the [official solution manual](https://advanced-r-solutions.rbind.io/s4.html#method-dispatch):

```{r S4-23, echo=FALSE}
knitr::include_graphics("https://raw.githubusercontent.com/Tazinho/Advanced-R-Solutions/main/images/s4/method_dispatch1.png")
```

---

**Q2.** Draw the method graph for `r paste0(code("f("), emoji("smiley"), ", ", emoji("wink"), ", ", emoji("kissing_smiling_eyes"), code(")"))`.

**A2.** I don't how to prepare the visual illustrations used in the book, so I am linking to the illustration in the [official solution manual](https://advanced-r-solutions.rbind.io/s4.html#method-dispatch):

```{r S4-24, echo=FALSE}
knitr::include_graphics("https://raw.githubusercontent.com/Tazinho/Advanced-R-Solutions/main/images/s4/method_dispatch2.png")
```

---

**Q3.** 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?

**A3.** Because one class has distance of 2 to all terminal nodes and the other four have distance of 1 to two terminal nodes each, this will introduce ambiguity. 

Method dispatch not save us much work here because to resolve this ambiguity we have to define five more methods (one per class combination).

---

## `S4` and `S3` (Exercises 15.6.3)

---

**Q1.** What would a full `setOldClass()` definition look like for an ordered factor (i.e. add `slots` and `prototype` the definition above)?

**A1.** We can register the old-style/`S3` `ordered` class to a formally defined class using `setOldClass()`.

```{r S4-25}
setClass("factor",
  contains = "integer",
  slots = c(
    levels = "character"
  ),
  prototype = structure(
    integer(),
    levels = character()
  )
)
setOldClass("factor", S4Class = "factor")

setClass("Ordered",
  contains = "factor",
  slots = c(
    levels  = "character",
    ordered = "logical"
  ),
  prototype = structure(
    integer(),
    levels  = character(),
    ordered = logical()
  )
)

setOldClass("ordered", S4Class = "Ordered")
```

Let's use it to see if it works as expected. 

```{r S4-26}
x <- new("Ordered", 1L:4L, levels = letters[1:4], ordered = TRUE)

x

str(x)

class(x)
```

---

**Q2.** Define a `length` method for the `Person` class.

**A2.** Because our `Person` class can be used to create objects that represent multiple people, let's say the `length()` method returns how many persons are in the object.

```{r S4-27}
Friends <- new("Person", name = c("Vishu", "Aditi"))
```

We can define an `S3` method for this class:

```{r S4-28}
length.Person <- function(x) length(x@name)

length(Friends)
```

Alternatively, we can also write `S4` method:

```{r S4-29}
setMethod("length", "Person", function(x) length(x@name))

length(Friends)
```

---

## Session information

```{r S4-30}
sessioninfo::session_info(include_base = TRUE)
```