---
title: "Internals of ggtintshade"
output: rmarkdown::html_vignette
vignette: >
  %\VignetteIndexEntry{Internals of ggtintshade}
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteEncoding{UTF-8}
---

```{r, include = FALSE}
knitr::opts_chunk$set(
  collapse = TRUE,
  comment = "#>",
  fig.width = 7, 
  fig.height = 4
)
set.seed(1)
```

`ggtintshade` uses a bit of a hack to let two aesthetics interact. The default
`ggplot2` API deliberately keeps aesthetics independent, and for the most part
that makes sense. Here, though, we *want* `color` (a hue) and `tintshade` (a
lightness) to interact: the tint of each point depends on both its color group
and its tintshade value.

The hack has two parts:

1. **A per-layer cache.** Each layer gets its own environment, created when the
   geom is built and carried along on the `ggproto` object, so there is no
   shared or global state.
2. **The (ab)use of `use_defaults`.** This is a late step in `ggplot_build()`
   where the mapped colors and the mapped tintshade values are finally
   available side by side. There we compute each point's tint, recolor the
   points, and record the final color in the cache keyed by its tintshade
   value. The guide later reads those colors back when it draws the legend.

This vignette rebuilds the following plot using a stripped-down 
`geom_point_tintshadedemo` to show the general mechanism.

```{r}
library(ggplot2)
library(ggtintshade)

metab_data <- data.frame(
  metab = rep(c("Alanine", "Threonine", "Glycine",
                "Glycine betaine", "Proline betaine", "Carnitine",
                "DMSP", "DMS-Ac", "Isethionate"), 3),
  metab_group = rep(rep(c("Amino acid", "Betaine", "Sulfur"), each = 3), 3),
  tripl = rep(c("A", "B", "C"), each = 9),
  area  = runif(27)
)

ggplot(metab_data) +
  aes(x = tripl, y = area, color = metab_group, tintshade = metab) +
  geom_point_tintshade(size = 4)
```

## The cache, created in the constructor

Initialise the cache in the geom constructor so each layer gets its own — no
shared or global state to worry about. The environment is attached to a
per-layer `ggproto` instance.

```{r}
geom_point_tintshadedemo <- function(mapping = NULL, data = NULL, ..., size = NULL) {
  cache <- new.env(parent = emptyenv())
  cache$lookup <- character(0)

  geom <- ggproto(NULL, GeomPointTintshadeDemo, tintshade_cache = cache)
  layer(
    geom = geom, mapping = mapping, data = data,
    stat = "identity", position = "identity",
    params = list(size = size, ...)
  )
}
```

## Tinting the points in `use_defaults`

`use_defaults()` is called (at least) twice during `ggplot_build()`: once for the
panel data and once for the legend key. We only want to touch the panel data, so
we skip the legend key. The legend has an `.id` column, which the panel data does
not, so we use that to disambiguate them.

Inside, we rank each point's tintshade value within its color group, spread
those ranks across the tintshade range, and feed the result to
`colorspace::lighten()` (positive lightens, negative darkens). We overwrite
`data$colour` with the tint and record it in the cache under its numeric
tintshade value, for the guide to recall later.

```{r}
# Rank tintshade values within each color group and spread over the range.
local_tint <- function(color, tintshade) {
  ave(tintshade, color, FUN = function(v) {
    ranks <- match(v, sort(unique(v)))
    scales::rescale(ranks, to = range(tintshade))
  })
}

GeomPointTintshadeDemo <- ggproto("GeomPointTintshadeDemo", GeomPoint,
  tintshade_cache = NULL,   # supplied by the constructor
  use_defaults = function(self, data, params = list(), ...) {
    data <- ggproto_parent(GeomPoint, self)$use_defaults(data, params, ...)

    if (!is.null(self$tintshade_cache) && is.null(data$.id) && !is.null(data$tintshadedemo)) {
      t <- local_tint(data$colour, data$tintshadedemo)
      data$colour <- colorspace::lighten(data$colour, 2 * t - 1)   # 0.5 -> no change
      self$tintshade_cache$lookup[sprintf("%.10f", data$tintshadedemo)] <- data$colour
    }
    data
  }
)
GeomPointTintshadeDemo$default_aes$tintshadedemo <- NA   # register the new aesthetic

scale_tintshadedemo_discrete <- function(..., range = c(0.2, 0.8)) {
  discrete_scale("tintshadedemo", palette = function(n) seq(range[1], range[2], length.out = n))
}
```

With just this, the panel is correctly tinted but the legend is incorrect 
because we haven't yet defined the guide so it defaults to the solid black entries.

```{r}
ggplot(metab_data) +
  aes(x = tripl, y = area, color = metab_group, tintshadedemo = metab) +
  geom_point_tintshadedemo(size = 4)
```

## Reading the cache back in the guide

The guide has two parts. In `get_layer_key()` we grab the layer's cache and stash
it on the guide's `params`. In `draw()`, which runs after the build has filled
the cache, we look up each key's tintshade value and recolor it. We also redefine
the default scale (constructed from the aesthetic name) to use the new guide.

```{r}
GuideTintshadeDemo <- ggproto("GuideTintshadeDemo", GuideLegend,
  get_layer_key = function(self, params, layers, data, theme = NULL) {
    params <- ggproto_parent(GuideLegend, self)$get_layer_key(params, layers, data, theme)
    params$tintshade_cache <- layers[[1]]$geom$tintshade_cache
    params
  },
  draw = function(self, theme, position = NULL, direction = NULL, params = self$params) {
    keys <- params$decor[[1]]$data
    params$decor[[1]]$data$colour <-
      params$tintshade_cache$lookup[sprintf("%.10f", keys$tintshadedemo)]
    ggproto_parent(GuideLegend, self)$draw(theme, position, direction, params)
  }
)

guide_tintshadedemo <- function(...) {
  new_guide(..., available_aes = "tintshadedemo", super = GuideTintshadeDemo)
}

scale_tintshadedemo_discrete <- function(..., range = c(0.2, 0.8)) {
  discrete_scale("tintshadedemo", palette = function(n) seq(range[1], range[2], length.out = n),
                 guide = guide_tintshadedemo())
}
```

And we have our expected behavior.

```{r}
ggplot(metab_data) +
  aes(x = tripl, y = area, color = metab_group, tintshadedemo = metab) +
  geom_point_tintshadedemo(size = 4)
```

The real package generalizes this in a few ways and adds some additional 
functionality but the two-part hack is the one shown here.

-----------------------------------------

Vignette last built on `r Sys.Date()`
