make a proper datatype for partial color ramps

NAMESPACE

@@ -19,6 +19,7 @@ S3method(distr_point_interval,distribution)
 S3method(distr_point_interval,list)
 S3method(distr_point_interval,rvar)
 S3method(format,ggdist__weighted_sample)
+S3method(format,ggdist_partial_colour_ramp)
 S3method(format,ggdist_thickness)
 S3method(generate,ggdist__weighted_sample)
 S3method(generate,ggdist__wrapped_categorical)
@@ -29,6 +30,7 @@ S3method(hdci_,rvar)
 S3method(hdi_,distribution)
 S3method(hdi_,numeric)
 S3method(hdi_,rvar)
+S3method(is.na,ggdist_partial_colour_ramp)
 S3method(is.na,ggdist_thickness)
 S3method(makeContent,dots_grob)
 S3method(mean,ggdist__weighted_sample)
@@ -56,16 +58,27 @@ S3method(vec_arith.ggdist_thickness,default)
 S3method(vec_arith.ggdist_thickness,ggdist_thickness)
 S3method(vec_arith.ggdist_thickness,numeric)
 S3method(vec_arith.numeric,ggdist_thickness)
+S3method(vec_cast,double.ggdist_partial_colour_ramp)
 S3method(vec_cast,double.ggdist_thickness)
+S3method(vec_cast,ggdist_partial_colour_ramp.double)
+S3method(vec_cast,ggdist_partial_colour_ramp.integer)
 S3method(vec_cast,ggdist_thickness.double)
 S3method(vec_cast,ggdist_thickness.integer)
+S3method(vec_cast,integer.ggdist_partial_colour_ramp)
 S3method(vec_cast,integer.ggdist_thickness)
+S3method(vec_ptype2,double.ggdist_partial_colour_ramp)
 S3method(vec_ptype2,double.ggdist_thickness)
+S3method(vec_ptype2,ggdist_partial_colour_ramp.double)
+S3method(vec_ptype2,ggdist_partial_colour_ramp.ggdist_partial_colour_ramp)
+S3method(vec_ptype2,ggdist_partial_colour_ramp.integer)
 S3method(vec_ptype2,ggdist_thickness.double)
 S3method(vec_ptype2,ggdist_thickness.ggdist_thickness)
 S3method(vec_ptype2,ggdist_thickness.integer)
+S3method(vec_ptype2,integer.ggdist_partial_colour_ramp)
 S3method(vec_ptype2,integer.ggdist_thickness)
+S3method(vec_ptype_abbr,ggdist_partial_colour_ramp)
 S3method(vec_ptype_abbr,ggdist_thickness)
+S3method(vec_ptype_full,ggdist_partial_colour_ramp)
 S3method(vec_ptype_full,ggdist_thickness)
 S3method(weights,ggdist__weighted_sample)
 export(AbstractStatSlabinterval)
@@ -321,7 +334,6 @@ importFrom(rlang,syms)
 importFrom(scales,area_pal)
 importFrom(scales,identity_pal)
 importFrom(scales,linetype_pal)
-importFrom(scales,rescale)
 importFrom(scales,rescale_pal)
 importFrom(scales,shape_pal)
 importFrom(stats,D)

R/scale_colour_ramp.R

@@ -25,6 +25,16 @@
 #' @param range a numeric vector of length 2 that specifies the minimum and maximum
 #' values after the scale transformation. These values should be between `0`
 #' (the `from` color) and `1` (the color determined by the `fill` aesthetic).
+#' @details
+#' These scales transform data into values between `0` and `1` that represent a
+#' color between `from` and the target color. The target color is determined by
+#' the aesthetic: for example, the `colour_ramp` aesthetic creates ramps between
+#' `from` and whatever the value of the `colour` aesthetic is. Then, if the
+#' `colour_ramp` aesthetic is set, \pkg{ggdist} geometries will modify their
+#' `colour` by applying the colour ramp between `from` and `colour`.
+#'
+#' [partial_colour_ramp()] is used by these scales to create `numeric()`-like
+#' objects marked as being a partial colour ramp from the colour `from`.
 #' @return
 #' A [ggplot2::Scale] representing a scale for the `colour_ramp` and/or `fill_ramp`
 #' aesthetics for `ggdist` geoms. Can be added to a [ggplot()] object.
@@ -60,8 +70,9 @@ scale_colour_ramp_continuous = function(
   from = "white", ..., limits = function(l) c(min(0, l[[1]]), l[[2]]), range = c(0, 1),
   guide = "legend", aesthetics = "colour_ramp"
 ) {
+  scale = ggproto(NULL, ScaleColourRampContinuous, from = from)
   continuous_scale(
-    aesthetics, "colour_ramp_c", colour_ramp_pal(range, from), limits = limits, guide = guide, ...
+    aesthetics, "colour_ramp_c", rescale_pal(range), limits = limits, guide = guide, ..., super = scale
   )
 }
 #' @rdname scale_colour_ramp
@@ -73,8 +84,9 @@ scale_colour_ramp_discrete = function(
   from = "white", ..., range = c(0.2, 1),
   aesthetics = "colour_ramp"
 ) {
+  scale = ggproto(NULL, ScaleColourRampDiscrete, from = from)
   discrete_scale(
-    aesthetics, "colour_ramp_d", colour_ramp_pal_discrete(range, from), ...
+    aesthetics, "colour_ramp_d", function(n) seq(range[1], range[2], length.out = n), ..., super = scale
   )
 }
 #' @rdname scale_colour_ramp
@@ -96,53 +108,119 @@ scale_fill_ramp_discrete = function(..., aesthetics = "fill_ramp") {
 }
 
 
-# helpers -----------------------------------------------------------------
+# partial_colour_ramp datatype --------------------------------------------
 
-#' @importFrom scales rescale
-colour_ramp_pal = function(range, from) {
-  force(range)
-  force(from)
-  function(x) {
-    # this is a stupid hack so we can pass the color through
-    # surely there is a better way? TODO: use a record type, probably
-    lapply(rescale(x, range, c(0, 1)), function(y) {
-      attr(y, "from") = from
-      y
-    })
-  }
+new_partial_colour_ramp = function(amount = double(), from = "white") {
+  if (length(amount) < 1) x = double()
+  stopifnot(is.double(amount))
+  if (length(from) <= 1) from = rep(from, length(amount))
+  stopifnot(is.character(from))
+  vctrs::new_rcrd(list(amount = amount, from = from), class = "ggdist_partial_colour_ramp")
 }
 
-colour_ramp_pal_discrete = function(range, from) {
-  force(range)
-  force(from)
-  function(n) {
-    # this is a stupid hack so we can pass the color through
-    # surely there is a better way?
-    lapply(seq(range[1], range[2], length.out = n), function(y) {
-      attr(y, "from") = from
-      y
-    })
-  }
+#' @rdname scale_colour_ramp
+#' @param amount double in `[0, 1]` giving the amount to ramp from
+#' the `from` colour (`0` == `from` and `1` == the other endpoint).
+partial_colour_ramp = function(amount = double(), from = "white") {
+  amount = vctrs::vec_cast(amount, numeric())
+  from = vctrs::vec_cast(from, character())
+  new_partial_colour_ramp(amount, from)
+}
+
+
+# formatting --------------------------------------------------------------
+
+#' @export
+vec_ptype_full.ggdist_partial_colour_ramp = function(x, ...) "partial_colour_ramp"
+#' @export
+vec_ptype_abbr.ggdist_partial_colour_ramp = function(x, ...) "rmp"
+
+#' @export
+format.ggdist_partial_colour_ramp = function(x, ...) {
+  sprintf("[%s from %s]", field(x, "amount"), field(x, "from"))
 }
 
-#' Assuming equal-length vectors `colors` and `amounts`, where `colors` are
-#' colors and `amounts` is a scaled ramp aesthetic column, returns a vector
-#' of same length as input giving the transformed (ramped) colors.
+
+# predicates --------------------------------------------------------------
+
+#' @export
+is.na.ggdist_partial_colour_ramp = function(x) {
+  is.na(field(x, "amount")) | is.na(field(x, "from"))
+}
+
+
+# casting -------------------------------------------------------
+
+as_partial_colour_ramp = function(x) {
+  vec_cast(x, new_partial_colour_ramp())
+}
+
+#' @export
+vec_ptype2.ggdist_partial_colour_ramp.ggdist_partial_colour_ramp = function(x, y, ...) new_partial_colour_ramp()
+
+#' @export
+vec_ptype2.ggdist_partial_colour_ramp.double = function(x, y, ...) new_partial_colour_ramp()
+#' @export
+vec_ptype2.double.ggdist_partial_colour_ramp = function(x, y, ...) new_partial_colour_ramp()
+#' @export
+vec_ptype2.ggdist_partial_colour_ramp.integer = function(x, y, ...) new_partial_colour_ramp()
+#' @export
+vec_ptype2.integer.ggdist_partial_colour_ramp = function(x, y, ...) new_partial_colour_ramp()
+
+#' @export
+vec_cast.ggdist_partial_colour_ramp.double = function(x, to, ...) partial_colour_ramp(x)
+#' @export
+vec_cast.ggdist_partial_colour_ramp.integer = function(x, to, ...) partial_colour_ramp(x)
+#' @export
+vec_cast.double.ggdist_partial_colour_ramp = function(x, to, ...) field(x, "amount")
+#' @export
+vec_cast.integer.ggdist_partial_colour_ramp = function(x, to, ...) as.integer(field(x, "amount"))
+
+
+# continuous scale --------------------------------------------------------
+
+ScaleColourRampContinuous = ggproto("ScaleColourRampContinuous", ScaleContinuous,
+  from = "white",
+
+  map = function(self, x, limits = self$get_limits()) {
+    out = ggproto_parent(ScaleContinuous, self)$map(x, limits)
+    partial_colour_ramp(out, self$from)
+  }
+)
+
+
+# discrete scale --------------------------------------------------------
+
+ScaleColourRampDiscrete = ggproto("ScaleColourRampDiscrete", ScaleDiscrete,
+  from = "white",
+
+  map = function(self, x, limits = self$get_limits()) {
+    out = ggproto_parent(ScaleDiscrete, self)$map(x, limits)
+    partial_colour_ramp(out, self$from)
+  }
+)
+
+
+# applying color ramps --------------------------------------------------------
+
+#' Assuming equal-length vectors `colors` and `ramps`, where `colors` are
+#' colors and `ramps` is a partial colour ramp aesthetic column, returns
+#' a vector of same length as input giving the transformed (ramped) colors.
 #'
 #' E.g. inside a `draw_group()` or `draw_panel()` method of a geom,
 #' usage might be:
 #'
 #'  data$fill = apply_colour_ramp(data$fill, data$fill_ramp)
 #'
 #' to apply the effects of the fill_ramp aesthetic to the fill aesthetic.
+#' @param colors character vector of colours
+#' @param ramps `partial_colour_ramp` vector
 #' @noRd
-apply_colour_ramp = function(colors, amounts) {
-  if (is.null(colors) || is.null(amounts)) return(colors)
-
-  map2_chr_(colors, amounts, function(color, amount) {
-    # null amounts come from missing values
-    amount = amount %||% NA
-    from = attr(amount, "from") %||% "white"
-    scales::seq_gradient_pal(from, color)(amount)
+apply_colour_ramp = function(colors, ramps) {
+  if (is.null(colors) || is.null(ramps)) return(colors)
+  ramps <- vec_cast(ramps, new_partial_colour_ramp())
+
+  map2_chr_(colors, ramps, function(color, ramp) {
+    scales::seq_gradient_pal(field(ramp, "from"), color)(field(ramp, "amount"))
   })
 }

R/scale_thickness.R

@@ -240,8 +240,6 @@ vec_ptype2.ggdist_thickness.integer = function(x, y, ...) new_thickness()
 #' @export
 vec_ptype2.integer.ggdist_thickness = function(x, y, ...) new_thickness()
 
-#' @export
-vec_cast.double.ggdist_thickness = function(x, to, ...) vec_data(x)
 #' @export
 vec_cast.ggdist_thickness.double = function(x, to, ...) thickness(x)
 #' @export