bookclub-advr

html.json (9840B)

---

 {
   "hash": "21ef572cb9871c3d1d642b297469a824",
   "result": {
     "engine": "knitr",
     "markdown": "---\nengine: knitr\ntitle: S4\n---\n\n## Introduction\n\nObject consists of:\n\n- Slots. Like fields in R6.\n- Methods. Accessed through generics. Dispatched to particular methods.\n\nUses functions to define classes and their methods:\n\n- `setClass()`. Define class and its components. \n- `setGenerics()`. Define generic functions. Used to dispatch.\n- `setMethods()`. Define methods\n\n## Basics overview\n\n### Set class\n\nDefine the class:\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetClass(\"Person\", \n  slots = c(\n    name = \"character\", \n    age = \"numeric\"\n  )\n)\n```\n:::\n\n\nCreate an instance of the class\n\n\n::: {.cell}\n\n```{.r .cell-code}\njohn <- new(\"Person\", name = \"John Smith\", age = NA_real_)\n```\n:::\n\n\n\n### Set generics\n\nDefine generic functions for setting and getting the age slot\n\n\n::: {.cell}\n\n```{.r .cell-code}\n# get the value\nsetGeneric(\"age\", function(x) standardGeneric(\"age\"))\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"age\"\n```\n\n\n:::\n\n```{.r .cell-code}\n# set the value\nsetGeneric(\"age<-\", function(x, value) standardGeneric(\"age<-\"))\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"age<-\"\n```\n\n\n:::\n:::\n\n\n### Set methods\n\nDefine methods for the generics:\n\n\n::: {.cell}\n\n```{.r .cell-code}\n# get the value\nsetMethod(\"age\", \"Person\", function(x) x@age)\n# set the value\nsetMethod(\"age<-\", \"Person\", function(x, value) {\n  x@age <- value\n  x\n})\n\n# set the value\nage(john) <- 50\n# get the value\nage(john)\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] 50\n```\n\n\n:::\n:::\n\n\nTo give a flavor, there is only one method per slot. In more realistic cases, there might be several methods.\n\n## Details on defining the class\n\n### Inheritance\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetClass(\"Employee\", \n  contains = \"Person\", \n  slots = c(\n    boss = \"Person\"\n  ),\n  prototype = list(\n    boss = new(\"Person\")\n  )\n)\n```\n:::\n\n\n### Instantiation\n\nCreate an instance of the class at two levels:\n\n- For developer (you): `methods::new()`\n- For user: constructor function\n\n\n::: {.cell}\n\n```{.r .cell-code}\n# how user constructs an instance\nPerson <- function(name, age = NA) {\n  age <- as.double(age)\n  \n  # how the developer constructs an instance\n  new(\"Person\", name = name, age = age)\n}\n\nPerson(\"Someone\")\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> An object of class \"Person\"\n#> Slot \"name\":\n#> [1] \"Someone\"\n#> \n#> Slot \"age\":\n#> [1] NA\n```\n\n\n:::\n:::\n\n\n### Validation\n\nS4 objects\n\n- Check class of slot at creation\n\n::: {.cell}\n\n```{.r .cell-code}\nPerson(mtcars)\n```\n\n::: {.cell-output .cell-output-error}\n\n```\n#> Error in validObject(.Object): invalid class \"Person\" object: invalid object for slot \"name\" in class \"Person\": got class \"data.frame\", should be or extend class \"character\"\n```\n\n\n:::\n:::\n\n\n- Do **not** check other things\n\n::: {.cell}\n\n```{.r .cell-code}\nPerson(\"Hadley\", age = c(30, 37))\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> An object of class \"Person\"\n#> Slot \"name\":\n#> [1] \"Hadley\"\n#> \n#> Slot \"age\":\n#> [1] 30 37\n```\n\n\n:::\n:::\n\n\nThat's where validation comes in--at two stages:\n\n1. At creation\n2. At modification\n\n#### At creation\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetValidity(\"Person\", function(object) {\n  if (length(object@name) != length(object@age)) {\n    \"@name and @age must be same length\"\n  } else {\n    TRUE\n  }\n})\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> Class \"Person\" [in \".GlobalEnv\"]\n#> \n#> Slots:\n#>                           \n#> Name:       name       age\n#> Class: character   numeric\n```\n\n\n:::\n\n```{.r .cell-code}\nPerson(\"Hadley\", age = c(30, 37))\n```\n\n::: {.cell-output .cell-output-error}\n\n```\n#> Error in validObject(.Object): invalid class \"Person\" object: @name and @age must be same length\n```\n\n\n:::\n:::\n\n\n#### At modification\n\n\n::: {.cell}\n\n```{.r .cell-code}\n# get value\nsetGeneric(\"name\", function(x) standardGeneric(\"name\"))\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"name\"\n```\n\n\n:::\n\n```{.r .cell-code}\nsetMethod(\"name\", \"Person\", function(x) x@name)\n\n# set value--and assess whether resulting object is valid\nsetGeneric(\"name<-\", function(x, value) standardGeneric(\"name<-\"))\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"name<-\"\n```\n\n\n:::\n\n```{.r .cell-code}\nsetMethod(\"name<-\", \"Person\", function(x, value) {\n  x@name <- value\n  validObject(x)\n  x\n})\n\n# normal name; no problem\nname(john) <- \"Jon Smythe\"\nname(john)\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"Jon Smythe\"\n```\n\n\n:::\n\n```{.r .cell-code}\n# invalid name; error thrown\nname(john) <- letters\n```\n\n::: {.cell-output .cell-output-error}\n\n```\n#> Error in validObject(x): invalid class \"Person\" object: @name and @age must be same length\n```\n\n\n:::\n:::\n\n\n\n## Details on generics and methods\n\n### Dictate dispatch via signature\n\nSpecify function arguments to be used in determining method.\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetGeneric(\"myGeneric\", \n  function(x, ..., verbose = TRUE) standardGeneric(\"myGeneric\"),\n  signature = \"x\"\n)\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"myGeneric\"\n```\n\n\n:::\n:::\n\n\n### Define generics\n\nGeneral form:\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetMethod(\"myGeneric\", \"Person\", function(x) {\n  # method implementation\n})\n```\n:::\n\n\nExample to print object:\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetMethod(\"show\", \"Person\", function(object) {\n  cat(is(object)[[1]], \"\\n\",\n      \"  Name: \", object@name, \"\\n\",\n      \"  Age:  \", object@age, \"\\n\",\n      sep = \"\"\n  )\n})\njohn\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> Person\n#>   Name: Jon Smythe\n#>   Age:  50\n```\n\n\n:::\n:::\n\n\nExample to access slot:\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetGeneric(\"name\", function(x) standardGeneric(\"name\"))\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"name\"\n```\n\n\n:::\n\n```{.r .cell-code}\nsetMethod(\"name\", \"Person\", function(x) x@name)\n\nname(john)\n```\n\n::: {.cell-output .cell-output-stdout}\n\n```\n#> [1] \"Jon Smythe\"\n```\n\n\n:::\n:::\n\n\n\nThis is how end users should access slots.\n\n## Example: `lubridate::period()`\n\n### Define the class\n\n\n::: {.cell}\n\n```{.r .cell-code}\nsetClass(\"Period\",\n  # inherits from these classes\n  contains = c(\"Timespan\", \"numeric\"),\n  # has slots for time components\n  slots = c(\n    year = \"numeric\", \n    month = \"numeric\", \n    day = \"numeric\",\n    hour = \"numeric\", \n    minute = \"numeric\"\n  ),\n  # defines prototype as period of zero duration for all slots\n  prototype = prototype(year = 0, month = 0, day = 0, hour = 0, minute = 0),\n  # check validity with `check_period` function; see section below\n  validity = check_period\n)\n```\n:::\n\n\nSee source code [here](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L90)\n\n### Validate object\n\nCheck whether object is valid--notably if all arugments have the same length and are integers.\n\n\n::: {.cell}\n\n```{.r .cell-code}\ncheck_period <- function(object) {\n  # start with an empty vector of error messages\n  errors <- character()\n\n  # check length of object's data\n  length(object@.Data) -> n\n  # check length of each slot\n  lengths <- c(\n    length(object@year), \n    length(object@month),\n    length(object@day), \n    length(object@hour), \n    length(object@minute)\n  )\n\n  # if length of any slot is different than overall length, compose error message\n  if (any(lengths != n)) {\n    msg <- paste(\"Inconsistent lengths: year = \", lengths[1],\n      \", month = \", lengths[2],\n      \", day = \", lengths[3],\n      \", hour = \", lengths[4],\n      \", minute = \", lengths[5],\n      \", second = \", n,\n      sep = \"\"\n    )\n    # add just-composed error to vector of error messages\n    errors <- c(errors, msg)\n  }\n\n  values <- c(object@year, object@month, object@day, object@hour, object@minute)\n  values <- na.omit(values)\n  if (sum(values - trunc(values))) {\n    msg <- \"periods must have integer values\"\n    errors <- c(errors, msg)\n  }\n\n  if (length(errors) == 0) {\n    TRUE\n  } else {\n    errors\n  }\n}\n```\n:::\n\n\n\nSee source code [here](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L6).\n\n### Set methods\n\nShow period:\n\n\n::: {.cell}\n\n```{.r .cell-code}\n#' @export\nsetMethod(\"show\", signature(object = \"Period\"), function(object) {\n  if (length(object@.Data) == 0) {\n    cat(\"<Period[0]>\\n\")\n  } else {\n    print(format(object))\n  }\n})\n\n#' @export\nformat.Period <- function(x, ...) {\n  if (length(x) == 0) {\n    return(character())\n  }\n\n  show <- paste(\n    x@year, \"y \", x@month, \"m \", x@day, \"d \",\n    x@hour, \"H \", x@minute, \"M \", x@.Data, \"S\",\n    sep = \"\"\n  )\n  start <- regexpr(\"[-1-9]|(0\\\\.)\", show)\n  show <- ifelse(start > 0, substr(show, start, nchar(show)), \"0S\")\n\n  show[is.na(x)] <- NA\n  show\n}\n```\n:::\n\n\nSee source code [here](https://github.com/tidyverse/lubridate/blob/0bb49b21c88736240219dc67e7ed0eb3df15d9b1/R/periods.r#L195)\n",
     "supporting": [
       "15_files"
     ],
     "filters": [
       "rmarkdown/pagebreak.lua"
     ],
     "includes": {},
     "engineDependencies": {},
     "preserve": {},
     "postProcess": true
   }
 }