diff --git a/DESCRIPTION b/DESCRIPTION index cbf8db6cd5..d3ca49180d 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -31,6 +31,7 @@ Depends: R (>= 3.3) Imports: cli, + farver, glue, grDevices, grid, diff --git a/R/geom-.r b/R/geom-.r index defac7a55a..1a4b9c0cf4 100644 --- a/R/geom-.r +++ b/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() ) diff --git a/R/ggproto.r b/R/ggproto.r index d6b0533f01..f93a6bc6f5 100644 --- a/R/ggproto.r +++ b/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 +} diff --git a/R/layer.r b/R/layer.r index 89ccb58028..a23a6688fe 100644 --- a/R/layer.r +++ b/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()) diff --git a/R/plot-build.r b/R/plot-build.r index b6102eed6e..cdf9930aec 100644 --- a/R/plot-build.r +++ b/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. diff --git a/R/scale-.r b/R/scale-.r index b0065ffd52..b7b58b903f 100644 --- a/R/scale-.r +++ b/R/scale-.r @@ -458,10 +458,13 @@ 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 @@ -469,14 +472,24 @@ Scale <- ggproto("Scale", NULL, 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) { diff --git a/R/scales-.r b/R/scales-.r index cb1e784670..3d20adb34a 100644 --- a/R/scales-.r +++ b/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))]) } diff --git a/tests/testthat/test-scale-colour-continuous.R b/tests/testthat/test-scale-colour-continuous.R index 10e3ae4dd5..0df43ba67e 100644 --- a/tests/testthat/test-scale-colour-continuous.R +++ b/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) +})