Advanced Data Visualisation with R

.info-box.w-60.bg-white[
These slides are viewed best by Chrome or Firefox and occasionally need to be refreshed if elements did not load properly. See <a href=day1-session3.pdf>here for the PDF <i class="fas fa-file-pdf"></i></a>. 
]

<br>

---

# .monash-blue[Advanced Data Visualisation with R]

<br>

<h2 style="font-weight:900!important;">Writing `ggplot2` extensions</h2>

.bottom_abs.width100[

Instructor: *Emi Tanaka*

<i class="fas fa-envelope"></i>  emi.tanaka@monash.edu

<i class="fas fa-calendar-alt"></i> 8th Dec 2021 @ Statistical Society of Australia Canberra Branch | Zoom

<br>

]

---

# Dissecting the `ggplot` object

```r
library(ggplot2)
g <- ggplot(cars, aes(speed, dist)) +
  geom_point()  
```

.flex.mt3[
.w-35.pr3[

```r
g
```

]
.w-60[

```r
str(g)
```
.scroll-sign.f5[
.overflow-scroll.h5[

```
## List of 9
##  $ data       :'data.frame':	50 obs. of  2 variables:
##   ..$ speed: num [1:50] 4 4 7 7 8 9 10 10 10 11 ...
##   ..$ dist : num [1:50] 2 10 4 22 16 10 18 26 34 17 ...
##  $ layers     :List of 1
##   ..$ :Classes 'LayerInstance', 'Layer', 'ggproto', 'gg' <ggproto object: Class LayerInstance, Layer, gg>
##     aes_params: list
##     compute_aesthetics: function
##     compute_geom_1: function
##     compute_geom_2: function
##     compute_position: function
##     compute_statistic: function
##     computed_geom_params: list
##     computed_mapping: uneval
##     computed_stat_params: list
##     data: waiver
##     draw_geom: function
##     finish_statistics: function
##     geom: <ggproto object: Class GeomPoint, Geom, gg>
##         aesthetics: function
##         default_aes: uneval
##         draw_group: function
##         draw_key: function
##         draw_layer: function
##         draw_panel: function
##         extra_params: na.rm
##         handle_na: function
##         non_missing_aes: size shape colour
##         optional_aes: 
##         parameters: function
##         required_aes: x y
##         setup_data: function
##         setup_params: function
##         use_defaults: function
##         super:  <ggproto object: Class Geom, gg>
##     geom_params: list
##     inherit.aes: TRUE
##     layer_data: function
##     map_statistic: function
##     mapping: NULL
##     position: <ggproto object: Class PositionIdentity, Position, gg>
##         compute_layer: function
##         compute_panel: function
##         required_aes: 
##         setup_data: function
##         setup_params: function
##         super:  <ggproto object: Class Position, gg>
##     print: function
##     setup_layer: function
##     show.legend: NA
##     stat: <ggproto object: Class StatIdentity, Stat, gg>
##         aesthetics: function
##         compute_group: function
##         compute_layer: function
##         compute_panel: function
##         default_aes: uneval
##         extra_params: na.rm
##         finish_layer: function
##         non_missing_aes: 
##         optional_aes: 
##         parameters: function
##         required_aes: 
##         retransform: TRUE
##         setup_data: function
##         setup_params: function
##         super:  <ggproto object: Class Stat, gg>
##     stat_params: list
##     super:  <ggproto object: Class Layer, gg> 
##  $ scales     :Classes 'ScalesList', 'ggproto', 'gg' <ggproto object: Class ScalesList, gg>
##     add: function
##     clone: function
##     find: function
##     get_scales: function
##     has_scale: function
##     input: function
##     n: function
##     non_position_scales: function
##     scales: list
##     super:  <ggproto object: Class ScalesList, gg> 
##  $ mapping    :List of 2
##   ..$ x: language ~speed
##   .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
##   ..$ y: language ~dist
##   .. ..- attr(*, ".Environment")=<environment: R_GlobalEnv> 
##   ..- attr(*, "class")= chr "uneval"
##  $ theme      : list()
##  $ coordinates:Classes 'CoordCartesian', 'Coord', 'ggproto', 'gg' <ggproto object: Class CoordCartesian, Coord, gg>
##     aspect: function
##     backtransform_range: function
##     clip: on
##     default: TRUE
##     distance: function
##     expand: TRUE
##     is_free: function
##     is_linear: function
##     labels: function
##     limits: list
##     modify_scales: function
##     range: function
##     render_axis_h: function
##     render_axis_v: function
##     render_bg: function
##     render_fg: function
##     setup_data: function
##     setup_layout: function
##     setup_panel_guides: function
##     setup_panel_params: function
##     setup_params: function
##     train_panel_guides: function
##     transform: function
##     super:  <ggproto object: Class CoordCartesian, Coord, gg> 
##  $ facet      :Classes 'FacetNull', 'Facet', 'ggproto', 'gg' <ggproto object: Class FacetNull, Facet, gg>
##     compute_layout: function
##     draw_back: function
##     draw_front: function
##     draw_labels: function
##     draw_panels: function
##     finish_data: function
##     init_scales: function
##     map_data: function
##     params: list
##     setup_data: function
##     setup_params: function
##     shrink: TRUE
##     train_scales: function
##     vars: function
##     super:  <ggproto object: Class FacetNull, Facet, gg> 
##  $ plot_env   :<environment: R_GlobalEnv> 
##  $ labels     :List of 2
##   ..$ x: chr "speed"
##   ..$ y: chr "dist"
##  - attr(*, "class")= chr [1:2] "gg" "ggplot"
```
]]
{{content}}
]
]

* Notice that a layer, `geom`, `position`, `stat`, `scales`, `coordinates` and `facet` are **`ggproto` objects**

---

# `ggproto`

---

# `ggproto` basics

* `ggplot2` makes heavy use of **prototype-based programming** 
--

* `ggproto` is a custom build class system made specically for `ggplot`
--

* The system is similar to `R6Class` in the `R6` package that allow inheritance and method access from parent classes
--

```r
OzCovidTracker <- ggproto("OzCovidTracker", NULL, 
                cases = 0,
                location = "Australia",
                last_update = NA,
                add = function(self, cases = 0) {
                  self$cases <- self$cases + cases
                  self$last_update <- Sys.Date()
                },
                reset = function(self) {
                  self$cases <- 0
                })
```

]
]
.w-50.f5[
{{content}}
]
]

```r
OzCovidTracker
```

```
## <ggproto object: Class OzCovidTracker, gg>
##     add: function
##     cases: 0
##     last_update: NA
##     location: Australia
##     reset: function
```

```r
OzCovidTracker$add(cases = 219120)
```
{{content}}

```r
OzCovidTracker$cases
```

```
## [1] 219120
```
{{content}}

```r
OzCovidTracker$add(cases = 80)
```
{{content}}

```r
OzCovidTracker$cases
```

```
## [1] 219200
```

---

# `ggproto` inheritance

```r
VicCovidTracker <- ggproto("VicCovidTracker", OzCovidTracker, location = "Victoria")
```

```r
VicCovidTracker$reset()
VicCovidTracker
```

```
## <ggproto object: Class VicCovidTracker, OzCovidTracker, gg>
##     add: function
##     cases: 0
##     last_update: 2021-12-07
##     location: Victoria
##     reset: function
##     super:  <ggproto object: Class OzCovidTracker, gg>
```

```r
VicCovidTracker$add(128849)
```

```r
VicCovidTracker$cases
```

```
## [1] 128849
```

---

# Creating a new `ggproto` object

* You should not be creating a new `ggroto` object from scratch
--

* You should inherit existing `ggproto` objects as outlined below:

New `ggproto` | Parent `ggproto`
--- | ---
`geom` | `ggplot2::Geom`
`position` | `ggplot2::Position`
`stat` | `ggplot2::Stat`
`scales` | `ggplot2::Scale`
`coordinates` | `ggplot2::Coord`
`facet` | `ggplot2::Facet`

* The convention for class names is to prefix with the parent (or ancestor) `ggproto` class name and use upper camel case, e.g. `GeomPoint`.

---

# `Stat`

---

# Example: fit a normal distribution

🎯 Create a new layer called `stat_dist_normal()` which fits a normal density curve

```r
# your data
df <- data.frame(x = rnorm(400, 10, 2))

# normal fit
x <- seq(min(df$x), max(df$x), 
         length.out = 1000)
fit <- data.frame(x = x,
                  y = dnorm(x, mean(df$x), sd(df$x)))

# plot
ggplot(df, aes(x)) + 
  geom_histogram(aes(y = stat(density)), bins = 30) + 
  geom_line(data = fit, color = "red", size = 2, 
            aes(x, y))
```

]
.w-50[
<img src="images/day1-session3/norm-dist-1.png" width="504" style="display: block; margin: auto;" />
]
]

---

# `Stat` `ggproto`

```r
Stat
```

```
## <ggproto object: Class Stat, gg>
##     aesthetics: function
##     compute_group: function
##     compute_layer: function
##     compute_panel: function
##     default_aes: uneval
##     extra_params: na.rm
##     finish_layer: function
##     non_missing_aes: 
##     optional_aes: 
##     parameters: function
##     required_aes: 
##     retransform: TRUE
##     setup_data: function
##     setup_params: function
```
]
]
.w-65.f5[
{{content}}
]
]

```r
StatDistNormal <- ggproto("StatDistNormal", Stat,
                          compute_group = function(data, scales) {
                            x <- seq(min(data$x), max(data$x), length.out = 1000)
                            y <- dnorm(x, mean(data$x), sd(data$x))
                            data.frame(x = x, y = y)
                          },
                          required_aes = "x")

stat_dist_normal <- function(mapping = NULL, data = NULL, geom = "line",
                    position = "identity", na.rm = FALSE, show.legend = NA, 
                    inherit.aes = TRUE, ...) {
  layer(
    stat = StatDistNormal, data = data, geom = "line", position = "identity", 
    show.legend = show.legend, inherit.aes = inherit.aes,
    params = list(na.rm = na.rm, ...)
    )
}
```

---

# `stat_dist_normal`

```r
ggplot(df, aes(x)) + 
  geom_histogram(aes(y = stat(density)), bins = 30) + 
  stat_dist_normal(color = "red", size = 2) 
```

<img src="images/day1-session3/stat-dist-normal-1.png" width="360" style="display: block; margin: auto;" />
]
.w-50.f5.pl3[
{{content}}
]
]

Works for facetting as well!

```r
# make some artificial group
df$group <- sample(c(0, 1), replace = TRUE, size = nrow(df))
ggplot(df, aes(x)) + 
  geom_histogram(aes(y = stat(density)), bins = 30) + 
  stat_dist_normal(color = "red", size = 2) +
  facet_wrap(~group)
```

---

# `Geom`

---

# Example: tic-tac-toe

🎯 Create a new layer called `geom_tictactoe()` which draws a tic-tac-toe like board

```r
game <- expand.grid(col = 1:3, row = 1:3)
game$move <- sample(rep(c("Alice", "Bob"), c(4, 5)))
```

.flex.mt3[
.w-30.pr3[

```r
game
```

```
##   col row  move
## 1   1   1   Bob
## 2   2   1   Bob
## 3   3   1 Alice
## 4   1   2   Bob
## 5   2   2 Alice
## 6   3   2   Bob
## 7   1   3 Alice
## 8   2   3 Alice
## 9   3   3   Bob
```

]
.w-70.f4[

```r
ggplot(game, aes(col, row)) + 
  geom_tile(fill = "white", color = "black") +
  geom_text(aes(label = ifelse(move=="Alice", "X", "O")), 
            size = 20) +
  theme_minimal()
```

<img src="images/day1-session3/tic-tac-toe-1.png" width="252" style="display: block; margin: auto;" />
]
]

---

# `Geom` `ggproto`

```r
Geom
```

```
## <ggproto object: Class Geom, gg>
##     aesthetics: function
##     default_aes: uneval
##     draw_group: function
##     draw_key: function
##     draw_layer: function
##     draw_panel: function
##     extra_params: na.rm
##     handle_na: function
##     non_missing_aes: 
##     optional_aes: 
##     parameters: function
##     required_aes: 
##     setup_data: function
##     setup_params: function
##     use_defaults: function
```
]
]
.w-65.f5[
{{content}}
]
]

```r
GeomTile
```

```
## <ggproto object: Class GeomTile, GeomRect, Geom, gg>
##     aesthetics: function
##     default_aes: uneval
##     draw_group: function
##     draw_key: function
##     draw_layer: function
##     draw_panel: function
##     extra_params: na.rm
##     handle_na: function
##     non_missing_aes: 
##     optional_aes: 
##     parameters: function
##     required_aes: x y
##     setup_data: function
##     setup_params: function
##     use_defaults: function
##     super:  <ggproto object: Class GeomRect, Geom, gg>
```

---

# `GeomTicTacToe`

```r
GeomTicTacToe <- ggproto("GeomTicTacToe", GeomTile,
                         draw_panel = function(data, panel_params, coord) {
                           coords <- coord$transform(data, panel_params)
                           width <- coords$xmax - coords$xmin
                           height <- coords$ymax - coords$ymin
                           tiles <- grid::rectGrob(coords$xmin, coords$ymax, 
                                                   width = width, 
                                                   height = height, 
                                                   default.units = "native", 
                                                   just = c("left", "top"), 
                                                   gp = grid::gpar(col = coords$colour, 
                                                                   fill = alpha(coords$fill, coords$alpha), 
                                                                   lwd = coords$size * .pt, lty = coords$linetype, 
                                                                   linejoin = "mitre", lineend = "square"))
                           if(length(unique(coords$label)) != 2) {
                             stop("There should be only two players in tic-tac-toe")
                           }
                           fontsize <- min(c(height, width))
                           fontsize <- grid::convertUnit(grid::unit(fontsize, "snpc"), "pt")
                           moves <- grid::textGrob(label = factor(coords$label, labels = c("X", "O")),
                                                   x = coords$x, y = coords$y, 
                                                   gp = grid::gpar(fontsize = fontsize))
                           ggplot2:::ggname("geom_tictactoe", grid::gTree(children = grid::gList(tiles, moves)))
                         },
                         required_aes = c("x", "y", "label"))
```

]

---

# `geom_tictactoe`

```r
geom_tictactoe <- function(mapping = NULL, data = NULL, stat = "identity", position = "identity", 
    ..., na.rm = FALSE, show.legend = NA, inherit.aes = TRUE, color = "black", fill = "white")  {
*     list(
        layer(data = data, mapping = mapping, stat = stat, geom = GeomTicTacToe, 
              position = position, show.legend = show.legend, inherit.aes = inherit.aes, 
              params = list(na.rm = na.rm, color = color, fill = fill, ...)),
*       theme_minimal())
    }
```

```r
ggplot(game, aes(col, row, 
                 label = move)) +
  geom_tictactoe() 
```
]
.w-50[
<img src="images/day1-session3/game-tictactoe-1.png" width="288" style="display: block; margin: auto;" />
]
]

---

# More than the tic-tac-toe game

```r
checklist <- expand.grid(person = c("Alex", "Sandy"), 
                         task = c("Shop", "Work", "Exercise", "Cook"))
checklist$done <- c(TRUE, FALSE, TRUE, FALSE, TRUE, TRUE, TRUE, FALSE)
```

.flex.mt3[
.w-50.pr3[

```r
checklist
```

```
##   person     task  done
## 1   Alex     Shop  TRUE
## 2  Sandy     Shop FALSE
## 3   Alex     Work  TRUE
## 4  Sandy     Work FALSE
## 5   Alex Exercise  TRUE
## 6  Sandy Exercise  TRUE
## 7   Alex     Cook  TRUE
## 8  Sandy     Cook FALSE
```

]
.w-50[

```r
ggplot(checklist, 
       aes(task, person, label = done)) +
  geom_tictactoe()
```

<img src="images/day1-session3/gg-checklist-1.png" width="504" style="display: block; margin: auto;" />
]
]

---

# Resources

<br>

.f2[For more see the ["Extending ggplot2" vignette](https://cran.r-project.org/web/packages/ggplot2/vignettes/extending-ggplot2.html)]

---

# <i class="fas fa-code"></i> Open `day1-exercise-03.Rmd`

---

# Session Information

.overflow-scroll.h-80[

```r
devtools::session_info()
```

```
## ─ Session info  🐍  🇸🇸  😹   ─────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
##  hash: snake, flag: South Sudan, cat with tears of joy
## 
##  setting  value
##  version  R version 4.1.2 (2021-11-01)
##  os       macOS Catalina 10.15.7
##  system   x86_64, darwin17.0
##  ui       RStudio
##  language (EN)
##  collate  en_AU.UTF-8
##  ctype    en_AU.UTF-8
##  tz       Australia/Melbourne
##  date     2021-12-07
##  rstudio  2021.09.1+372 Ghost Orchid (desktop)
##  pandoc   2.14.0.3 @ /Applications/RStudio.app/Contents/MacOS/pandoc/ (via rmarkdown)
## 
## ─ Packages ───────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
##  package     * version date (UTC) lib source
##  assertthat    0.2.1   2019-03-21 [1] CRAN (R 4.1.0)
##  bslib         0.3.1   2021-10-06 [1] CRAN (R 4.1.0)
##  cachem        1.0.6   2021-08-19 [1] CRAN (R 4.1.0)
##  callr         3.7.0   2021-04-20 [1] CRAN (R 4.1.0)
##  cli           3.1.0   2021-10-27 [1] CRAN (R 4.1.0)
##  colorspace    2.0-2   2021-06-24 [1] CRAN (R 4.1.0)
##  countdown     0.3.5   2021-12-07 [1] Github (gadenbuie/countdown@a544fa4)
##  crayon        1.4.2   2021-10-29 [1] CRAN (R 4.1.0)
##  DBI           1.1.1   2021-01-15 [1] CRAN (R 4.1.0)
##  desc          1.4.0   2021-09-28 [1] CRAN (R 4.1.0)
##  devtools      2.4.2   2021-06-07 [1] CRAN (R 4.1.0)
##  digest        0.6.29  2021-12-01 [1] CRAN (R 4.1.0)
##  dplyr         1.0.7   2021-06-18 [1] CRAN (R 4.1.0)
##  ellipsis      0.3.2   2021-04-29 [1] CRAN (R 4.1.0)
##  evaluate      0.14    2019-05-28 [1] CRAN (R 4.1.0)
##  fansi         0.5.0   2021-05-25 [1] CRAN (R 4.1.0)
##  farver        2.1.0   2021-02-28 [1] CRAN (R 4.1.0)
##  fastmap       1.1.0   2021-01-25 [1] CRAN (R 4.1.0)
##  fs            1.5.0   2020-07-31 [1] CRAN (R 4.1.0)
##  generics      0.1.1   2021-10-25 [1] CRAN (R 4.1.0)
##  ggplot2     * 3.3.5   2021-06-25 [1] CRAN (R 4.1.0)
##  glue          1.5.0   2021-11-07 [1] CRAN (R 4.1.0)
##  gtable        0.3.0   2019-03-25 [1] CRAN (R 4.1.0)
##  highr         0.9     2021-04-16 [1] CRAN (R 4.1.0)
##  htmltools     0.5.2   2021-08-25 [1] CRAN (R 4.1.0)
##  httpuv        1.6.3   2021-09-09 [1] CRAN (R 4.1.0)
##  httr          1.4.2   2020-07-20 [1] CRAN (R 4.1.0)
##  jquerylib     0.1.4   2021-04-26 [1] CRAN (R 4.1.0)
##  jsonlite      1.7.2   2020-12-09 [1] CRAN (R 4.1.0)
##  kableExtra    1.3.4   2021-02-20 [1] CRAN (R 4.1.0)
##  knitr         1.36    2021-09-29 [1] CRAN (R 4.1.0)
##  labeling      0.4.2   2020-10-20 [1] CRAN (R 4.1.0)
##  later         1.3.0   2021-08-18 [1] CRAN (R 4.1.0)
##  lifecycle     1.0.1   2021-09-24 [1] CRAN (R 4.1.0)
##  magrittr      2.0.1   2020-11-17 [1] CRAN (R 4.1.0)
##  memoise       2.0.0   2021-01-26 [1] CRAN (R 4.1.0)
##  mime          0.12    2021-09-28 [1] CRAN (R 4.1.0)
##  munsell       0.5.0   2018-06-12 [1] CRAN (R 4.1.0)
##  pillar        1.6.4   2021-10-18 [1] CRAN (R 4.1.0)
##  pkgbuild      1.2.0   2020-12-15 [1] CRAN (R 4.1.0)
##  pkgconfig     2.0.3   2019-09-22 [1] CRAN (R 4.1.0)
##  pkgload       1.2.3   2021-10-13 [1] CRAN (R 4.1.0)
##  prettyunits   1.1.1   2020-01-24 [1] CRAN (R 4.1.0)
##  processx      3.5.2   2021-04-30 [1] CRAN (R 4.1.0)
##  promises      1.2.0.1 2021-02-11 [1] CRAN (R 4.1.0)
##  ps            1.6.0   2021-02-28 [1] CRAN (R 4.1.0)
##  purrr         0.3.4   2020-04-17 [1] CRAN (R 4.1.0)
##  R6            2.5.1   2021-08-19 [1] CRAN (R 4.1.0)
##  Rcpp          1.0.7   2021-07-07 [1] CRAN (R 4.1.0)
##  remotes       2.4.1   2021-09-29 [1] CRAN (R 4.1.0)
##  rlang         0.4.12  2021-10-18 [1] CRAN (R 4.1.0)
##  rmarkdown     2.11    2021-09-14 [1] CRAN (R 4.1.0)
##  rprojroot     2.0.2   2020-11-15 [1] CRAN (R 4.1.0)
##  rstudioapi    0.13    2020-11-12 [1] CRAN (R 4.1.0)
##  rvest         1.0.2   2021-10-16 [1] CRAN (R 4.1.0)
##  sass          0.4.0   2021-05-12 [1] CRAN (R 4.1.0)
##  scales        1.1.1   2020-05-11 [1] CRAN (R 4.1.0)
##  servr         0.24    2021-11-16 [1] CRAN (R 4.1.0)
##  sessioninfo   1.2.1   2021-11-02 [1] CRAN (R 4.1.0)
##  stringi       1.7.5   2021-10-04 [1] CRAN (R 4.1.0)
##  stringr       1.4.0   2019-02-10 [1] CRAN (R 4.1.0)
##  svglite       2.0.0   2021-02-20 [1] CRAN (R 4.1.0)
##  systemfonts   1.0.3   2021-10-13 [1] CRAN (R 4.1.2)
##  testthat      3.1.0   2021-10-04 [1] CRAN (R 4.1.0)
##  tibble        3.1.6   2021-11-07 [1] CRAN (R 4.1.0)
##  tidyselect    1.1.1   2021-04-30 [1] CRAN (R 4.1.0)
##  usethis       2.1.3   2021-10-27 [1] CRAN (R 4.1.0)
##  utf8          1.2.2   2021-07-24 [1] CRAN (R 4.1.0)
##  vctrs         0.3.8   2021-04-29 [1] CRAN (R 4.1.0)
##  viridisLite   0.4.0   2021-04-13 [1] CRAN (R 4.1.0)
##  waldo         0.3.1   2021-09-14 [1] CRAN (R 4.1.0)
##  webshot       0.5.2   2019-11-22 [1] CRAN (R 4.1.0)
##  whisker       0.4     2019-08-28 [1] CRAN (R 4.1.0)
##  withr         2.4.2   2021-04-18 [1] CRAN (R 4.1.0)
##  xaringan      0.22    2021-06-23 [1] CRAN (R 4.1.0)
##  xfun          0.28    2021-11-04 [1] CRAN (R 4.1.0)
##  xml2          1.3.2   2020-04-23 [1] CRAN (R 4.1.0)
##  yaml          2.2.1   2020-02-01 [1] CRAN (R 4.1.0)
## 
##  [1] /Library/Frameworks/R.framework/Versions/4.1/Resources/library
## 
## ──────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
```
]

These slides are licensed under <br><center><a href="https://creativecommons.org/licenses/by-sa/3.0/au/"><img src="images/cc.svg" style="height:2em;"/><img src="images/by.svg" style="height:2em;"/><img src="images/sa.svg" style="height:2em;"/></a></center>