15.Rmd (6411B)
1 --- 2 engine: knitr 3 title: S4 4 --- 5 6 ## Introduction 7 8 Object consists of: 9 10 - Slots. Like fields in R6. 11 - Methods. Accessed through generics. Dispatched to particular methods. 12 13 Uses functions to define classes and their methods: 14 15 - `setClass()`. Define class and its components. 16 - `setGenerics()`. Define generic functions. Used to dispatch. 17 - `setMethods()`. Define methods 18 19 ## Basics overview 20 21 ### Set class 22 23 Define the class: 24 25 ```{r} 26 setClass("Person", 27 slots = c( 28 name = "character", 29 age = "numeric" 30 ) 31 ) 32 ``` 33 34 Create an instance of the class 35 36 ```{r} 37 john <- new("Person", name = "John Smith", age = NA_real_) 38 ``` 39 40 41 ### Set generics 42 43 Define generic functions for setting and getting the age slot 44 45 ```{r} 46 # get the value 47 setGeneric("age", function(x) standardGeneric("age")) 48 # set the value 49 setGeneric("age<-", function(x, value) standardGeneric("age<-")) 50 ``` 51 52 ### Set methods 53 54 Define methods for the generics: 55 56 ```{r} 57 # get the value 58 setMethod("age", "Person", function(x) x@age) 59 # set the value 60 setMethod("age<-", "Person", function(x, value) { 61 x@age <- value 62 x 63 }) 64 65 # set the value 66 age(john) <- 50 67 # get the value 68 age(john) 69 ``` 70 71 To give a flavor, there is only one method per slot. In more realistic cases, there might be several methods. 72 73 ## Details on defining the class 74 75 ### Inheritance 76 77 ```{r, eval=FALSE} 78 setClass("Employee", 79 contains = "Person", 80 slots = c( 81 boss = "Person" 82 ), 83 prototype = list( 84 boss = new("Person") 85 ) 86 ) 87 ``` 88 89 ### Instantiation 90 91 Create an instance of the class at two levels: 92 93 - For developer (you): `methods::new()` 94 - For user: constructor function 95 96 ```{r} 97 # how user constructs an instance 98 Person <- function(name, age = NA) { 99 age <- as.double(age) 100 101 # how the developer constructs an instance 102 new("Person", name = name, age = age) 103 } 104 105 Person("Someone") 106 ``` 107 108 ### Validation 109 110 S4 objects 111 112 - Check class of slot at creation 113 ```{r, error = TRUE} 114 Person(mtcars) 115 ``` 116 117 - Do **not** check other things 118 ```{r} 119 Person("Hadley", age = c(30, 37)) 120 ``` 121 122 That's where validation comes in--at two stages: 123 124 1. At creation 125 2. At modification 126 127 #### At creation 128 129 ```{r, error = TRUE} 130 setValidity("Person", function(object) { 131 if (length(object@name) != length(object@age)) { 132 "@name and @age must be same length" 133 } else { 134 TRUE 135 } 136 }) 137 138 Person("Hadley", age = c(30, 37)) 139 ``` 140 141 #### At modification 142 143 ```{r, error = TRUE} 144 # get value 145 setGeneric("name", function(x) standardGeneric("name")) 146 setMethod("name", "Person", function(x) x@name) 147 148 # set value--and assess whether resulting object is valid 149 setGeneric("name<-", function(x, value) standardGeneric("name<-")) 150 setMethod("name<-", "Person", function(x, value) { 151 x@name <- value 152 validObject(x) 153 x 154 }) 155 156 # normal name; no problem 157 name(john) <- "Jon Smythe" 158 name(john) 159 160 # invalid name; error thrown 161 name(john) <- letters 162 ``` 163 164 165 ## Details on generics and methods 166 167 ### Dictate dispatch via signature 168 169 Specify function arguments to be used in determining method. 170 171 ```{r} 172 setGeneric("myGeneric", 173 function(x, ..., verbose = TRUE) standardGeneric("myGeneric"), 174 signature = "x" 175 ) 176 ``` 177 178 ### Define generics 179 180 General form: 181 182 ```{r, eval=FALSE} 183 setMethod("myGeneric", "Person", function(x) { 184 # method implementation 185 }) 186 ``` 187 188 Example to print object: 189 190 ```{r} 191 setMethod("show", "Person", function(object) { 192 cat(is(object)[[1]], "\n", 193 " Name: ", object@name, "\n", 194 " Age: ", object@age, "\n", 195 sep = "" 196 ) 197 }) 198 john 199 ``` 200 201 Example to access slot: 202 203 ```{r} 204 setGeneric("name", function(x) standardGeneric("name")) 205 setMethod("name", "Person", function(x) x@name) 206 207 name(john) 208 ``` 209 210 211 This is how end users should access slots. 212 213 ## Example: `lubridate::period()` 214 215 ### Define the class 216 217 ```{r, eval=FALSE} 218 setClass("Period", 219 # inherits from these classes 220 contains = c("Timespan", "numeric"), 221 # has slots for time components 222 slots = c( 223 year = "numeric", 224 month = "numeric", 225 day = "numeric", 226 hour = "numeric", 227 minute = "numeric" 228 ), 229 # defines prototype as period of zero duration for all slots 230 prototype = prototype(year = 0, month = 0, day = 0, hour = 0, minute = 0), 231 # check validity with `check_period` function; see section below 232 validity = check_period 233 ) 234 ``` 235 236 See source code [here](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L90) 237 238 ### Validate object 239 240 Check whether object is valid--notably if all arugments have the same length and are integers. 241 242 ```{r, eval=FALSE} 243 check_period <- function(object) { 244 # start with an empty vector of error messages 245 errors <- character() 246 247 # check length of object's data 248 length(object@.Data) -> n 249 # check length of each slot 250 lengths <- c( 251 length(object@year), 252 length(object@month), 253 length(object@day), 254 length(object@hour), 255 length(object@minute) 256 ) 257 258 # if length of any slot is different than overall length, compose error message 259 if (any(lengths != n)) { 260 msg <- paste("Inconsistent lengths: year = ", lengths[1], 261 ", month = ", lengths[2], 262 ", day = ", lengths[3], 263 ", hour = ", lengths[4], 264 ", minute = ", lengths[5], 265 ", second = ", n, 266 sep = "" 267 ) 268 # add just-composed error to vector of error messages 269 errors <- c(errors, msg) 270 } 271 272 values <- c(object@year, object@month, object@day, object@hour, object@minute) 273 values <- na.omit(values) 274 if (sum(values - trunc(values))) { 275 msg <- "periods must have integer values" 276 errors <- c(errors, msg) 277 } 278 279 if (length(errors) == 0) { 280 TRUE 281 } else { 282 errors 283 } 284 } 285 ``` 286 287 288 See source code [here](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L6). 289 290 ### Set methods 291 292 Show period: 293 294 ```{r, eval=FALSE} 295 #' @export 296 setMethod("show", signature(object = "Period"), function(object) { 297 if (length(object@.Data) == 0) { 298 cat("<Period[0]>\n") 299 } else { 300 print(format(object)) 301 } 302 }) 303 304 #' @export 305 format.Period <- function(x, ...) { 306 if (length(x) == 0) { 307 return(character()) 308 } 309 310 show <- paste( 311 x@year, "y ", x@month, "m ", x@day, "d ", 312 x@hour, "H ", x@minute, "M ", x@.Data, "S", 313 sep = "" 314 ) 315 start <- regexpr("[-1-9]|(0\\.)", show) 316 show <- ifelse(start > 0, substr(show, start, nchar(show)), "0S") 317 318 show[is.na(x)] <- NA 319 show 320 } 321 ``` 322 323 See source code [here](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L195)