class: center, middle, inverse, title-slide # Advanced R - Object oriented programming ## Part 2 - S3 ### Hannes Oberreiter ### Cohort 5 --- class: left, middle # S3 - Base - `class` Attribute ```r f <- factor(c("a", "b", "c")) typeof(f) ``` ``` ## [1] "integer" ``` ```r attributes(f) ``` ``` ## $levels ## [1] "a" "b" "c" ## ## $class ## [1] "factor" ``` --- class: left, middle ## Generic and Class If you pass S3 to generic it will behave differently, accordance to their implementation. > ... extended function objects, containing information used in creating and dispatching methods for this function ... Generic is a middleman with interface and looks for the correct method for specific class (**method dispatch**). --- class:left, top ```r sloop::ftype(str) ``` ``` ## [1] "S3" "generic" ``` ```r time <- strptime(c("2017-01-01"), "%Y-%m-%d") str(time) ``` ``` ## POSIXlt[1:1], format: "2017-01-01" ``` ```r str(unclass(time)) ``` ``` ## List of 11 ## $ sec : num 0 ## $ min : int 0 ## $ hour : int 0 ## $ mday : int 1 ## $ mon : int 0 ## $ year : int 117 ## $ wday : int 0 ## $ yday : int 0 ## $ isdst : int 0 ## $ zone : chr "CET" ## $ gmtoff: int NA ``` --- class:left, top ## Method Dispatch ```r sloop::s3_dispatch(str(time)) ``` ``` ## str.POSIXlt ## => str.POSIXt ## * str.default ``` We could call this generic method manually, but its hidden from us and thats good. ```r utils:::str.POSIXt(time) ``` ``` ## POSIXlt[1:1], format: "2017-01-01" ``` - `sloop::ftype()` check if method or class - `s3_get_method()` source code of methods, which are not exported --- class:left, top ## S3 Classes ```r animal <- structure(list(), class = "animal") class(animal) ``` ``` ## [1] "animal" ``` ```r inherits(animal, "animal") ``` ``` ## [1] TRUE ``` We could also change classes of base objects crazy aren't? ```r class(f) ``` ``` ## [1] "factor" ``` ```r class(f) <- "Date" f ``` ``` ## [1] "1970-01-02" "1970-01-03" "1970-01-04" ``` --- class:left, middle ## Good Pratice - A low-level **constructor** - `new_myclass()` - creates new objects - A **validator**, `validate_myclass()` - checks to ensure that the object has correct values - A user-friendly **helper**, `myclass()` - help others create objects of your class --- class:left, top ### Constructor ```r new_Taxa <- function(taxon = character(), kingdom = "Animalia") { stopifnot(is.character(taxon)) kingdom <- match.arg(kingdom, c("Animalia", "Plantae", "Fungi")) structure( taxon, class = "Taxa", kingdom = kingdom ) } new_Taxa("Dog") ``` ``` ## [1] "Dog" ## attr(,"class") ## [1] "Taxa" ## attr(,"kingdom") ## [1] "Animalia" ``` > The constructor is a developer function: it will be called in many places, by an experienced user. That means it’s OK to trade a little safety in return for performance, and you should avoid potentially time-consuming checks in the constructor. --- class:left, top ### Validator - for performance reason we should create a own function ```r validate_Taxa <- function(x) { values <- unclass(x) if (length(values) != length(unique(values))) { warning( "All Taxa must be unique.", call. = FALSE ) return(FALSE) } x } validate_Taxa(new_Taxa(c("Dog", "Dog"))) ``` ``` ## Warning: All Taxa must be unique. ``` ``` ## [1] FALSE ``` --- class: left, top ### Helpers - Have the **same name as the class**, e.g. `Taxa()` - **Finish** - calling the constructor - and the validator - **error messages** for end-user - **user interface** - default values - useful conversions --- class: left, top ### Helpers ```r Taxa <- function( taxon_name = character(), kingdom = "Animalia" ) { taxon_name <- trimws(taxon_name) kingdom <- trimws(kingdom) validate_Taxa( new_Taxa(taxon_name, kingdom) ) } pets <- Taxa(c("Dog", "Cat"), "Animalia") attributes(pets) ``` ``` ## $class ## [1] "Taxa" ## ## $kingdom ## [1] "Animalia" ``` --- class:left, top ### Why Classes, Complex Example - "Class: lm" ```r (mod <- lm(cyl ~ ., data = mtcars)) ``` ``` ## ## Call: ## lm(formula = cyl ~ ., data = mtcars) ## ## Coefficients: ## (Intercept) mpg disp hp drat wt ## 12.107199 -0.004857 0.004610 0.003723 -0.427435 -0.222489 ## qsec vs am gear carb ## -0.187945 -0.644076 -0.500770 -0.500323 0.179872 ``` ```r typeof(mod) ``` ``` ## [1] "list" ``` --- class:left, top ### Why Classes, Complex Example - "Class: lm" ```r attributes(mod) ``` ``` ## $names ## [1] "coefficients" "residuals" "effects" "rank" ## [5] "fitted.values" "assign" "qr" "df.residual" ## [9] "xlevels" "call" "terms" "model" ## ## $class ## [1] "lm" ``` ```r map_chr(mod, typeof) ``` ``` ## coefficients residuals effects rank fitted.values ## "double" "double" "double" "integer" "double" ## assign qr df.residual xlevels call ## "integer" "list" "integer" "list" "language" ## terms model ## "language" "list" ``` --- class:left, top ```r new_lm <- function( coefficients, residuals, effects, rank, fitted.values, assign, qr, df.residual, xlevels, call, terms, model ) { stopifnot( is.double(coeficients) # check inputs ............ ) structure( list( coefficients = coefficients, residuals = residuals, effects = effects, rank = rank, fitted.values = fitted.values, assign = assign, qr = qr, df.residual = df.residual, xlevels = xlevels, call = call, terms = terms, model = model ), class = "lm" ) } ``` --- class: left, top ### Generic (Method) Functions > S3 generic is to perform method dispatch, i.e. find the specific implementation for a class ```r print ``` ``` ## function (x, ...) ## UseMethod("print") ## <bytecode: 0x7f9e858eaa68> ## <environment: namespace:base> ``` ```r sloop::s3_dispatch(print(Sys.Date())) ``` ``` ## => print.Date ## * print.default ``` --- class: left, top ### Generic (Method) Functions Find all available methods: ```r sloop::s3_methods_generic("print") ``` ``` ## # A tibble: 321 x 4 ## generic class visible source ## <chr> <chr> <lgl> <chr> ##  1 print acf FALSE registered S3method ##  2 print AES FALSE registered S3method ##  3 print all_vars FALSE registered S3method ##  4 print anova FALSE registered S3method ##  5 print ansi_string FALSE registered S3method ##  6 print ansi_style FALSE registered S3method ##  7 print any_vars FALSE registered S3method ##  8 print aov FALSE registered S3method ##  9 print aovlist FALSE registered S3method ## 10 print ar FALSE registered S3method ## # … with 311 more rows ``` --- class: left, top ### Writing your own If you want to write your own method, there are 2 cases: 1. There's a pre-existing generic function - create a new method generic.class 2. There is not a pre-existing generic function - create a new generic - create a method --- class: left, top ### Writing your own ```r print_animal <- function(x) { # Generic Function UseMethod("print_animal") } print_animal.default <- function(x, ...){ # Default Method print("No specific method defined") } print_animal.Taxa <- function(x, ...){ # Method for Class = Taxa cat(x) } print_animal(pets) ``` ``` ## Dog Cat ``` ```r print_animal(1) ``` ``` ## [1] "No specific method defined" ``` ```r sloop::s3_dispatch(print_animal(1)) ``` ``` ## print_animal.double ## print_animal.numeric ## => print_animal.default ``` --- class: left, top ### Inheritance ```r class(ordered("x")) ``` ``` ## [1] "ordered" "factor" ``` - `ordered` is a subclass of factor - `factor` is a superclass of ordered No subclass lets use the inherited superclass: ```r s3_dispatch(print(ordered("x"))) ``` ``` ## print.ordered ## => print.factor ## * print.default ``` --- class: left, top ### Inheritance - NextMethod() ```r print.Taxa <- function(x, ...) { print(glue::glue("Your Taxa **{stringr::str_c(x, collapse = ', ')}** belongs to Kingdom of **{attr(x, 'kingdom')}**")) invisible(x) } sloop::s3_dispatch(print(pets)) ``` ``` ## => print.Taxa ## * print.default ``` ```r print(pets) ``` ``` ## Your Taxa **Dog, Cat** belongs to Kingdom of **Animalia** ``` --- class: left, top ### Inheritance - NextMethod() If we subset the class attributes get lost: ```r print(pets[1]) ``` ``` ## [1] "Dog" ``` ```r sloop::s3_dispatch(print(pets[1])) ``` ``` ## print.character ## => print.default ``` Workaround create dispatch for subsetting and create a new Taxa Class Object: ```r `[.Taxa` <- function(x, i) { new_Taxa(NextMethod()) } print(pets[1]) ``` ``` ## Your Taxa **Dog** belongs to Kingdom of **Animalia** ``` --- class: left, top ### Subclass - add `...` - add `class` argument ```r new_TaxaSimple <- function( taxon = character(), kingdom = "Animalia", ..., class = character() ) { stopifnot(is.character(taxon)) kingdom <- match.arg(kingdom, c("Animalia", "Plantae", "Fungi")) structure( taxon, kingdom = kingdom, ..., class = c(class, "Taxa") ) } ``` --- class: left, top ### Subclass ```r new_Science <- function( taxon = character(), kingdom = "Animalia", latin = "" ) { new_TaxaSimple(taxon, kingdom, latin = latin, class = "Science") } dogScience <- new_Science(taxon = "Dog", kingdom = "Animalia", latin = "Canis lupus") sloop::s3_dispatch(print(dogScience)) ``` ``` ## print.Science ## => print.Taxa ## * print.default ``` ```r class(dogScience) ``` ``` ## [1] "Science" "Taxa" ``` ```r dogScience ``` ``` ## Your Taxa **Dog** belongs to Kingdom of **Animalia** ``` --- class: left, top ### Subclass ```r print.Science <- function(x, ...) { print( glue::glue( " **Name**: <span style='color:green!important'>{x}</span></br> **Species**: *{attr(x, 'latin')}*; <br/> **Kingdom:** {attr(x, 'kingdom')} " ) ) invisible(x) } print(dogScience) ``` **Name**: <span style='color:green!important'>Dog</span></br> **Species**: *Canis lupus*; <br/> **Kingdom:** Animalia --- class: middle, top ### Subclass > If you build your class using the tools provided by the vctrs package, [ will gain this behaviour automatically. You will only need to provide your own [ method if you use attributes that depend on the data or want non-standard subsetting behaviour. See ?vctrs::new_vctr for details. --- class: middle, center ### Skipping Dispatch Details