POC: Partial scales

DESCRIPTION

@@ -226,6 +226,7 @@ Collate:
     'scale-linetype.R'
     'scale-linewidth.R'
     'scale-manual.R'
+    'scale-partial.R'
     'scale-shape.R'
     'scale-size.R'
     'scale-steps.R'

NAMESPACE

@@ -238,6 +238,7 @@ export(ScaleContinuousPosition)
 export(ScaleDiscrete)
 export(ScaleDiscreteIdentity)
 export(ScaleDiscretePosition)
+export(ScalePartial)
 export(Stat)
 export(StatAlign)
 export(StatBin)
@@ -578,6 +579,7 @@ export(scale_linewidth_discrete)
 export(scale_linewidth_identity)
 export(scale_linewidth_manual)
 export(scale_linewidth_ordinal)
+export(scale_partial)
 export(scale_radius)
 export(scale_shape)
 export(scale_shape_binned)
@@ -598,6 +600,7 @@ export(scale_size_identity)
 export(scale_size_manual)
 export(scale_size_ordinal)
 export(scale_type)
+export(scale_x)
 export(scale_x_binned)
 export(scale_x_continuous)
 export(scale_x_date)
@@ -607,6 +610,7 @@ export(scale_x_log10)
 export(scale_x_reverse)
 export(scale_x_sqrt)
 export(scale_x_time)
+export(scale_y)
 export(scale_y_binned)
 export(scale_y_continuous)
 export(scale_y_date)

R/layout.R

@@ -129,6 +129,10 @@ Layout <- ggproto("Layout", NULL,
   train_position = function(self, data, x_scale, y_scale) {
     # Initialise scales if needed, and possible.
     layout <- self$layout
+
+    x_scale <- resolve_partial(x_scale)
+    y_scale <- resolve_partial(y_scale)
+
     if (is.null(self$panel_scales_x)) {
       self$panel_scales_x <- self$facet$init_scales(layout, x_scale = x_scale,
         params = self$facet_params)$x

R/limits.R

@@ -90,13 +90,13 @@ lims <- function(...) {
 #' @export
 #' @rdname lims
 xlim <- function(...) {
-  limits(c(...), "x", call = current_call())
+  scale_x(limits = c(...), call = current_call())
 }
 
 #' @export
 #' @rdname lims
 ylim <- function(...) {
-  limits(c(...), "y", call = current_call())
+  scale_y(limits = c(...), call = current_call())
 }
 
 #' Generate correct scale type for specified limits

R/scale-.R

@@ -409,6 +409,9 @@ binned_scale <- function(aesthetics, scale_name = deprecated(), palette, name =
 #' - `make_sec_title()` Hook to modify the title for the second axis that is calculated
 #'   when the `Layout` calculates the x and y labels.
 #'
+#' - `fields` A character vector naming parameters that can be updated by
+#'   partial scales.
+#'
 #' @rdname ggplot2-ggproto
 #' @format NULL
 #' @usage NULL
@@ -558,6 +561,47 @@ Scale <- ggproto("Scale", NULL,
 
   make_sec_title = function(title) {
     title
+  },
+
+  fields = character(0),
+
+  validate = function(self, fields = self$fields) {
+    if (any(c("breaks", "labels") %in% fields)) {
+      check_breaks_labels(self$breaks, self$labels, call = self$call)
+    }
+    return()
+  },
+
+  update_params = function(self, params, default = FALSE, call = NULL) {
+
+    fields <- intersect(self$fields, names(params))
+    extra  <- setdiff(names(params), fields)
+
+    if (length(extra) > 0) {
+      cli::cli_warn(
+        "Ignoring unknown scale parameter{?s}: {.and {.field {extra}}}.",
+        call = call
+      )
+    }
+
+    if (!default) {
+      # Don't update fields that were already defined in non-default scale
+      fields <- setdiff(fields, call_args_names(self$call))
+    } else {
+      self$call <- call
+    }
+
+    if (length(fields) < 1) {
+      # Nothing to update here
+      return()
+    }
+
+    # Update parameters
+    for (field in fields) {
+      self[[field]] <- params[[field]]
+    }
+    self$validate(fields)
+    return()
   }
 )
 
@@ -841,6 +885,59 @@ ScaleContinuous <- ggproto("ScaleContinuous", Scale,
     )
   },
 
+  fields = setdiff(
+    fn_fmls_names(continuous_scale),
+    c("aesthetics", "scale_name", "super", "call", "position")
+  ),
+
+  update_params = function(self, params, default = FALSE, call = NULL) {
+
+    if ("trans" %in% names(params)) {
+      # We're using the old transform to revert the limits to input data, so
+      # that new transform returns valid limits.
+      if (!is.null(self$limits) && !is.function(self$limits)) {
+        self$limits <- self$trans$inverse(self$limits)
+      }
+    }
+    ggproto_parent(Scale, self)$update_params(params, default = default, call = call)
+    return()
+  },
+
+  validate = function(self, fields = self$fields) {
+
+    ggproto_parent(Scale, self)$validate(fields)
+
+    limits <- self$limits
+    if ("trans" %in% fields) {
+      self$trans  <- as.trans(self$trans)
+      if (!is.null(limits) && !is.function(limits)) {
+        self$limits <- self$trans$transform(limits)
+      }
+    }
+    if ("limits" %in% fields && !is.null(limits) && !is.function(limits)) {
+      if (is.discrete(limits)) {
+        cli::cli_abort(
+          "Discrete limits supplied to continuous scale.",
+          call = self$call
+        )
+      }
+      if (length(limits) != 2 || !vec_is(limits)) {
+        cli::cli_abort(
+          "{.arg limits} must a vector of length 2.",
+          call = self$call
+        )
+      }
+      self$limits <- self$trans$transform(limits)
+    }
+    if ("rescaler" %in% fields) {
+      check_function(self$rescaler, call = self$call, arg = "rescaler")
+    }
+    if ("oob" %in% fields) {
+      check_function(self$oob, call = self$call, arg = "oob")
+    }
+    return()
+  },
+
   print = function(self, ...) {
     show_range <- function(x) paste0(formatC(x, digits = 3), collapse = " -- ")
 
@@ -1040,7 +1137,24 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale,
       major_source = major,
       minor_source = NULL
     )
-  }
+  },
+
+  fields = setdiff(
+    fn_fmls_names(discrete_scale),
+    c("aesthetics", "scale_name", "super", "call", "position")
+  ),
+
+  validate = function(self, fields = self$fields) {
+
+    ggproto_parent(Scale, self)$validate(fields)
+
+    if ("limits" %in% fields) {
+      if (!is.discrete(self$limits)) {
+        cli::cli_abort("Continuous limits supplied to discrete scale.")
+      }
+    }
+    return()
+  },
 )
 
 #' @rdname ggplot2-ggproto
@@ -1271,7 +1385,12 @@ ScaleBinned <- ggproto("ScaleBinned", Scale,
     list(range = range, labels = labels,
          major = pal, minor = NULL,
          major_source = major, minor_source = NULL)
-  }
+  },
+
+  fields = setdiff(
+    fn_fmls_names(binned_scale),
+    c("aesthetics", "scale_name", "super", "call", "position")
+  )
 )
 
 # In place modification of a scale to change the primary axis

R/scale-continuous.R

@@ -161,7 +161,8 @@ ScaleContinuousPosition <- ggproto("ScaleContinuousPosition", ScaleContinuous,
     } else {
       ggproto_parent(ScaleContinuous, self)$make_sec_title(title)
     }
-  }
+  },
+  fields = union(setdiff(ScaleContinuous$fields, "palette"), "position")
 )
 
 # Transformed scales ---------------------------------------------------------

R/scale-discrete-.R

@@ -140,7 +140,9 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete,
     new$range <- DiscreteRange$new()
     new$range_c <- ContinuousRange$new()
     new
-  }
+  },
+
+  fields = union(setdiff(ScaleDiscrete$fields, "palette"), "position")
 )
 
 # Can't use vctrs - vctrs is too restrictive for mapped_discrete

R/scale-partial.R

@@ -0,0 +1,103 @@
+#' Partial scales
+#'
+#' Partial scales are useful for setting some scale parameters without
+#' committing to any particular scale yet. Partial scales can be added to a plot
+#' and will be combined with full scales.
+#'
+#' @param aesthetic A string specifying an aesthetic to create a partial
+#'   scale for.
+#' @param ... Arguments passed onto full scales.
+#' @param call A `<call>` to report in warning and error messages.
+#'
+#' @return A `<ScalePartial>` object that can be added to a plot.
+#' @export
+#' @name partial-scales
+#'
+#' @examples
+#' # A standard plot
+#' p <- ggplot(mpg, aes(displ, hwy)) +
+#'   geom_point()
+#'
+#' # Adding a partial scale
+#' p + scale_y(trans = "sqrt")
+#'
+#' # Partial scales can be stacked
+#' p + scale_y(trans = "sqrt") + scale_y(breaks = seq(15, 45, by = 5))
+#'
+#' # When two scales declare the same parameter, the latter overrules the first
+#' p + scale_y_continuous(name = "Highway Miles") +
+#'   scale_y(name = "Title from partial scale")
+#'
+#' # But other parameters are kept and not overruled
+#' p + scale_y(name = "Highway Miles",
+#'             breaks = c(20, 30, 40),
+#'             labels = c("A", "B", "C")) +
+#'   scale_y_continuous(name = "Title from full scale")
+scale_partial <- function(aesthetic, ..., call = caller_call()) {
+
+  check_string(aesthetic, allow_empty = FALSE)
+  aesthetic <- standardise_aes_names(aesthetic)
+
+  args <- dots_list(..., .homonyms = "error")
+  if (!is_named(args)) {
+    cli::cli_abort("All arguments in {.code ...} must be named.", call = call)
+  }
+
+  args <- args[!vapply(args, is.waive, logical(1))]
+
+  lambdas <- intersect(
+    names(args),
+    c("limits", "breaks", "labels", "rescaler", "oob", "minor_breaks")
+  )
+  args[lambdas] <- lapply(args[lambdas], allow_lambda)
+
+  call <- call %||% current_call()
+
+  ggproto(
+    NULL, ScalePartial,
+    call = call,
+    aesthetics = aesthetic,
+    params = args
+  )
+}
+
+#' @export
+#' @rdname partial-scales
+scale_x <- function(...) scale_partial(aesthetic = "x", ...)
+#' @export
+#' @rdname partial-scales
+scale_y <- function(...) scale_partial(aesthetic = "y", ...)
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+ScalePartial <- ggproto(
+  "ScalePartial", Scale,
+
+  aesthetics = character(),
+  params = list(),
+  call = NULL,
+
+  update_params = function(self, params, default = FALSE, call = self$call) {
+    self$params <- defaults(params, self$params)
+  },
+
+  clone = function(self) {
+    ggproto(NULL, self)
+  },
+
+  reset = function(self) NULL
+)
+
+resolve_partial <- function(scale) {
+  if (!inherits(scale, "ScalePartial")) {
+    return(scale)
+  }
+  if (is.null(scale$params$limits)) {
+    return(NULL)
+  }
+  new <- limits(scale$params$limits, scale$aesthetics[1])
+  new$update_params(scale$params, default = TRUE)
+  new
+}