commit c3409027c8fdff42c9acff8ab26b2c67907d98bf
parent b71d07101c9b29942bac8aa7283d4e25e4dcd8a2
Author: Arthur Shaw <47256431+arthur-shaw@users.noreply.github.com>
Date: Thu, 29 Sep 2022 20:26:57 -0400
Draft notes (#28)
Diffstat:
| M | 15_S4.Rmd | | | 320 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-- |
1 file changed, 315 insertions(+), 5 deletions(-)
diff --git a/15_S4.Rmd b/15_S4.Rmd
@@ -1,13 +1,323 @@
# S4
-**Learning objectives:**
+## Introduction
-- THESE ARE NICE TO HAVE BUT NOT ABSOLUTELY NECESSARY
+Object consists of:
-## SLIDE 1
+- Slots. Like fields in R6.
+- Methods. Accessed through generics. Dispatched to particular methods.
-- ADD SLIDES AS SECTIONS (`##`).
-- TRY TO KEEP THEM RELATIVELY SLIDE-LIKE; THESE ARE NOTES, NOT THE BOOK ITSELF.
+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:
+
+```{r}
+setClass("Person",
+ slots = c(
+ name = "character",
+ age = "numeric"
+ )
+)
+```
+
+Create an instance of the class
+
+```{r}
+john <- new("Person", name = "John Smith", age = NA_real_)
+```
+
+
+### Set generics
+
+Define generic functions for setting and getting the age slot
+
+```{r}
+# get the value
+setGeneric("age", function(x) standardGeneric("age"))
+# set the value
+setGeneric("age<-", function(x, value) standardGeneric("age<-"))
+```
+
+### Set methods
+
+Define methods for the generics:
+
+```{r}
+# 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)
+```
+
+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
+
+```{r, eval=FALSE}
+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
+
+```{r}
+# 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")
+```
+
+### Validation
+
+S4 objects
+
+- Check class of slot at creation
+```{r}
+Person(mtcars)
+```
+
+- Do **not** check other things
+```{r}
+Person("Hadley", age = c(30, 37))
+```
+
+That's where validation comes in--at two stages:
+
+1. At creation
+2. At modification
+
+#### At creation
+
+```{r}
+setValidity("Person", function(object) {
+ if (length(object@name) != length(object@age)) {
+ "@name and @age must be same length"
+ } else {
+ TRUE
+ }
+})
+
+Person("Hadley", age = c(30, 37))
+```
+
+#### At modification
+
+```{r}
+# get value
+setGeneric("name", function(x) standardGeneric("name"))
+setMethod("name", "Person", function(x) x@name)
+
+# set value--and assess whether resulting object is valid
+setGeneric("name<-", function(x, value) standardGeneric("name<-"))
+setMethod("name<-", "Person", function(x, value) {
+ x@name <- value
+ validObject(x)
+ x
+})
+
+# normal name; no problem
+name(john) <- "Jon Smythe"
+name(john)
+
+# invalid name; error thrown
+name(john) <- letters
+```
+
+
+## Details on generics and methods
+
+### Dictate dispatch via signature
+
+Specify function arguments to be used in determining method.
+
+```{r}
+setGeneric("myGeneric",
+ function(x, ..., verbose = TRUE) standardGeneric("myGeneric"),
+ signature = "x"
+)
+```
+
+### Define generics
+
+General form:
+
+```{r, eval=FALSE}
+setMethod("myGeneric", "Person", function(x) {
+ # method implementation
+})
+```
+
+Example to print object:
+
+```{r}
+setMethod("show", "Person", function(object) {
+ cat(is(object)[[1]], "\n",
+ " Name: ", object@name, "\n",
+ " Age: ", object@age, "\n",
+ sep = ""
+ )
+})
+john
+```
+
+Example to access slot:
+
+```{r}
+setGeneric("name", function(x) standardGeneric("name"))
+setMethod("name", "Person", function(x) x@name)
+
+name(john)
+```
+
+
+This is how end users should access slots.
+
+## Example: `lubridate::period()`
+
+### Define the class
+
+```{r, eval=FALSE}
+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](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L90)
+
+### Validate object
+
+Check whether object is valid--notably if all arugments have the same length and are integers.
+
+```{r, eval=FALSE}
+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](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L6).
+
+### Set methods
+
+Show period:
+
+```{r, eval=FALSE}
+#' @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](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L195)
## Meeting Videos
