Scale capability: Use native colour format if the geom prefers it

DESCRIPTION

@@ -31,6 +31,7 @@ Depends:
     R (>= 3.3)
 Imports: 
     cli,
+    farver,
     glue,
     grDevices,
     grid,

R/geom-.r

@@ -202,8 +202,20 @@ Geom <- ggproto("Geom",
   },
 
   # Should the geom rename size to linewidth?
-  rename_size = FALSE
-
+  rename_size = FALSE,
+  # Parameters to pass to scale$map() for each aesthetic:
+  # This can be either a named list (names are aesthetics, values are lists of parameters)
+  # or a function that takes a list of geom parameters as input and returns the list.
+  # The scale_params can be used to tell the scale map function a mapping method.
+  #   e.g. scale_params = list(fill = list(mapping_method = "raw"))
+  # See the map method for ScaleContinuous in R/scale-.r for further details.
+  #
+  # The scale_params will be used to tell the scale map function the expected colour
+  # format, in case the geom prefers native colours (because it uses nativeRaster objects)
+  # instead of the default character vector:
+  #   e.g. scale_params = list(fill = list("color_fmt" = "character")) # "#00FF00"
+  #   e.g. scale_params = list(fill = list("color_fmt" = "native"))    # from nativeRaster
+  scale_params = list()
 )
 
 

R/ggproto.r

@@ -351,3 +351,7 @@ format.ggproto_method <- function(x, ...) {
 
 # proto2 TODO: better way of getting formals for self$draw
 ggproto_formals <- function(x) formals(environment(x)$f)
+
+ggproto_attr <- function(x, which, default = NULL) {
+  attr(environment(x)$f, which = which, exact = TRUE) %||% default
+}

R/layer.r

@@ -391,6 +391,14 @@ Layer <- ggproto("Layer", NULL,
     self$geom$setup_data(data, self$computed_geom_params)
   },
 
+  get_scale_params = function(self) {
+    if (is.function(self$geom$scale_params)) {
+      self$geom$scale_params(params = self$computed_geom_params)
+    } else {
+      self$geom$scale_params
+    }
+  },
+
   compute_position = function(self, data, layout) {
     if (empty(data)) return(data_frame0())
 

R/plot-build.r

@@ -88,7 +88,8 @@ ggplot_build.ggplot <- function(plot) {
   npscales <- scales$non_position_scales()
   if (npscales$n() > 0) {
     lapply(data, scales_train_df, scales = npscales)
-    data <- lapply(data, scales_map_df, scales = npscales)
+    scale_params <- by_layer(function(l, d) l$get_scale_params(), layers, data, "getting scale_params")
+    data <- mapply(scales_map_df, df = data, scale_params = scale_params, MoreArgs = list(scales = npscales), SIMPLIFY = FALSE)
   }
 
   # Fill in defaults etc.

R/scale-.r

@@ -458,25 +458,38 @@ Scale <- ggproto("Scale", NULL,
     cli::cli_abort("Not implemented")
   },
 
-  map_df = function(self, df, i = NULL) {
+  map_df = function(self, df, i = NULL, scale_params = NULL) {
     if (empty(df)) {
       return()
     }
+    if (is.null(scale_params)) {
+      scale_params <- list()
+    }
 
     aesthetics <- intersect(self$aesthetics, names(df))
     names(aesthetics) <- aesthetics
     if (length(aesthetics) == 0) {
       return()
     }
 
-    if (is.null(i)) {
-      lapply(aesthetics, function(j) self$map(df[[j]]))
+    if ("scale_params" %in% names(ggproto_formals(self$map))) {
+      if (is.null(i)) {
+        lapply(aesthetics, function(j) self$map(df[[j]], scale_params = scale_params[[j]]))
+      } else {
+        lapply(aesthetics, function(j) self$map(df[[j]][i], scale_params = scale_params[[j]]))
+      }
     } else {
-      lapply(aesthetics, function(j) self$map(df[[j]][i]))
+      # Eventually warn if self$map() does not accept scale_params
+      if (is.null(i)) {
+        lapply(aesthetics, function(j) self$map(df[[j]]))
+      } else {
+        lapply(aesthetics, function(j) self$map(df[[j]][i]))
+      }
+
     }
   },
 
-  map = function(self, x, limits = self$get_limits()) {
+  map = function(self, x, limits = self$get_limits(), scale_params = NULL) {
     cli::cli_abort("Not implemented")
   },
 
@@ -602,14 +615,78 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
 
   transform = default_transform,
 
-  map = function(self, x, limits = self$get_limits()) {
+  map = function(self, x, limits = self$get_limits(), scale_params = NULL) {
     x <- self$rescale(self$oob(x, range = limits), limits)
+    if (is.null(scale_params)) {
+      scale_params <- list()
+    }
+    # A mapping method maps the x values in [0-1] range to a continuous aesthetic.
+    # "unique": The default. Find unique values in x, map the unique values to colours,
+    #           match the mapped colours to original x values.
+    # "raw": just map all x values to colours. More efficient if we know there are not
+    #        many repeated values. Usually less efficient if there are some repeated
+    #        values.
+    # "binned": Bin `x` into `mapping_method_bins` levels. Map those levels to colours.
+    #           Assign the colour to each value corresponding to their bin.
+    #           This approach is faster with large vectors, but is lossy.
+    mapping_method <- scale_params[["mapping_method"]]
+    if (is.null(mapping_method)) {
+      mapping_method <- "unique"
+    }
+    if (is.character(mapping_method) && !mapping_method %in% c("unique", "raw", "binned")) {
+      cli::cli_warn(c(
+        "ScaleContinous does not support the mapping method {mapping_method}",
+        "i" = "Using 'unique' instead."
+      ))
+      mapping_method <- "unique"
+    }
+    # Geom prefers native color format:
+    geom_prefers_native <- identical(scale_params[["color_fmt"]], "native")
+    # Palette capability: Accepts native output
+    #  A specific palette can have as attribute "accepts_native_output = TRUE".
+    #  Then, self$palette must have an additional argument (besides x) named
+    #  `color_fmt = "character"`. If we pass `color_fmt = "native"`, it will
+    #  return colors in native format.
+    pal_accepts_native <- ggproto_attr(self$palette, "accepts_native_output", default = FALSE)
+
+    if (geom_prefers_native && pal_accepts_native) {
+      palette <- function(x) self$palette(x, color_fmt = "native")
+      na.value <- farver::encode_native(self$na.value)
+    } else if (geom_prefers_native) {
+      palette <- function(x) farver::encode_native(self$palette(x))
+      na.value <- farver::encode_native(self$na.value)
+    } else {
+      palette <- self$palette
+      na.value <- self$na.value
+    }
 
-    uniq <- unique0(x)
-    pal <- self$palette(uniq)
-    scaled <- pal[match(x, uniq)]
+    if (mapping_method == "unique") {
+      uniq <- unique0(x)
+      pal <- palette(uniq)
+      scaled <- pal[match(x, uniq)]
+    } else if (mapping_method == "raw") {
+      scaled <- palette(x)
+    } else if (mapping_method == "binned") {
+      mapping_method_bins <- scale_params[["mapping_method_bins"]]
+      if (is.null(mapping_method_bins)) {
+        mapping_method_bins <- 1024L
+      }
+      mapping_method_bins <- as.integer(mapping_method_bins[1L])
+      breaks <- seq(from = 0, to = 1, length.out = mapping_method_bins + 1L)
+      colormap <- c(na.value, palette(breaks), na.value)
+      # values below 0 belong to the first bucket, but zero belongs to the second bucket:
+      breaks[1] <- -.Machine$double.eps
+      scaled <- colormap[findInterval(x, breaks, rightmost.closed = TRUE) + 1L]
+    }
+
+    # A specific palette can have as attribute "may_return_NA = FALSE"
+    # If it has such attribute, we will skip the ifelse(!is.na(scaled), ...)
+    pal_may_return_na <- ggproto_attr(self$palette, "may_return_NA", default = TRUE)
+    if (pal_may_return_na) {
+      scaled <- ifelse(!is.na(scaled), scaled, na.value)
+    }
 
-    ifelse(!is.na(scaled), scaled, self$na.value)
+    scaled
   },
 
   rescale = function(self, x, limits = self$get_limits(), range = limits) {

R/scales-.r

@@ -70,10 +70,23 @@ scales_train_df <- function(scales, df, drop = FALSE) {
 }
 
 # Map values from a data.frame. Returns data.frame
-scales_map_df <- function(scales, df) {
+scales_map_df <- function(scales, df, scale_params = NULL) {
   if (empty(df) || length(scales$scales) == 0) return(df)
 
-  mapped <- unlist(lapply(scales$scales, function(scale) scale$map_df(df = df)), recursive = FALSE)
+  mapped <- unlist(
+    lapply(
+      scales$scales,
+      function(scale) {
+        if ("scale_params" %in% names(ggproto_formals(self$map_df))) {
+          scale$map_df(df = df, scale_params = scale_params)
+        } else {
+          # Eventually warn if scale$map_df() does not accept scale_params
+          scale$map_df(df = df)
+        }
+      }
+    ),
+    recursive = FALSE
+  )
 
   data_frame0(!!!mapped, df[setdiff(names(df), names(mapped))])
 }

tests/testthat/test-scale-colour-continuous.R

@@ -18,3 +18,76 @@ test_that("type argument is checked for proper input", {
     scale_colour_continuous(type = "abc")
   )
 })
+
+test_that("palette with accepts_native_output returns native colours", {
+  sc <- scale_fill_continuous()
+  sc$palette <- structure(
+    function(x, color_fmt = "character") {
+      if (color_fmt == "character") {
+        rep("red", length(x))
+      } else {
+        rep(-16776961L, length(x))
+      }
+    },
+    accepts_native_output = TRUE
+  )
+  x <- 0.5
+  nat <- sc$map(x, limits = c(0, 1), scale_params = list(color_fmt = "native"))
+  expect_equal(nat, -16776961L)
+  chr <- sc$map(x, limits = c(0, 1), scale_params = list(color_fmt = "character"))
+  expect_equal(chr, "red")
+  chr2 <- sc$map(x, limits = c(0, 1))
+  expect_equal(chr, chr2)
+})
+
+test_that("palette without accepts_native_output returns native colours as well", {
+  sc <- scale_fill_continuous()
+  sc$palette <- function(x) {
+    rep("red", length(x))
+  }
+  x <- 0.5
+  nat <- sc$map(x, limits = c(0, 1), scale_params = list(color_fmt = "native"))
+  expect_equal(nat, -16776961L)
+  chr <- sc$map(x, limits = c(0, 1), scale_params = list(color_fmt = "character"))
+  expect_equal(chr, "red")
+  chr2 <- sc$map(x, limits = c(0, 1))
+  expect_equal(chr, chr2)
+})
+
+
+
+test_that("palette with may_return_NA=FALSE works as expected", {
+  sc <- scale_fill_continuous()
+  # A palette that may return NAs, will have NAs replaced by the scale's na.value
+  # by the scale:
+  sc$palette <- structure(
+    function(x) {
+      rep(NA_character_, length(x))
+    },
+    may_return_NA = TRUE
+  )
+  sc$na.value <- "red"
+  nat <- sc$map(0.5, limits = c(0, 1))
+  expect_equal(nat, "red")
+
+  # This palette is lying, because it returns NA even though it says it can't.
+  # The scale will not replace the NA values, leading to further errors.
+  # You should not do this in production, but it helps to test:
+  sc <- scale_fill_continuous()
+  sc$palette <- structure(
+    function(x) {
+      rep(NA_character_, length(x))
+    },
+    may_return_NA = FALSE
+  )
+  sc$na.value <- "red"
+  nat <- sc$map(0.5, limits = c(0, 1))
+  expect_equal(nat, NA_character_)
+})
+
+test_that("scale_params mapping_method supports binned", {
+  sc <- scale_fill_continuous()
+  x <- seq(0, 1, length.out = 10)
+  only_two <- sc$map(x, limits = c(0, 1), scale_params = list(mapping_method = "binned", mapping_method_bins = 2))
+  expect_equal(length(unique(only_two)), 2L)
+})