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

## -----------------------------------------------------------------------------
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)

## -----------------------------------------------------------------------------
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, ...)
  )
}

## -----------------------------------------------------------------------------
# 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))
}

## -----------------------------------------------------------------------------
ggplot(metab_data) +
  aes(x = tripl, y = area, color = metab_group, tintshadedemo = metab) +
  geom_point_tintshadedemo(size = 4)

## -----------------------------------------------------------------------------
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())
}

## -----------------------------------------------------------------------------
ggplot(metab_data) +
  aes(x = tripl, y = area, color = metab_group, tintshadedemo = metab) +
  geom_point_tintshadedemo(size = 4)