Discrete secondary axes

R/axis-secondary.R

@@ -119,7 +119,7 @@ sec_axis <- function(transform = NULL,
 #' @rdname sec_axis
 #'
 #' @export
-dup_axis <- function(transform = ~., trans = deprecated(),
+dup_axis <- function(transform = identity, trans = deprecated(),
                      name = derive(), breaks = derive(), labels = derive(), guide = derive()) {
   sec_axis(transform, trans = trans, name, breaks, labels, guide)
 }
@@ -130,6 +130,11 @@ is.sec_axis <- function(x) {
 
 set_sec_axis <- function(sec.axis, scale) {
   if (!is.waive(sec.axis)) {
+    if (scale$is_discrete()) {
+      if (!identical(.subset2(sec.axis, "transform"), identity)) {
+        cli::cli_abort("Discrete secondary axes must have the {.fn identity} transformation.")
+      }
+    }
     if (is.formula(sec.axis)) sec.axis <- sec_axis(sec.axis)
     if (!is.sec_axis(sec.axis)) {
       cli::cli_abort("Secondary axes must be specified using {.fn sec_axis}.")
@@ -179,7 +184,13 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
     }
     if (is.derived(self$name) && !is.waive(scale$name)) self$name <- scale$name
     if (is.derived(self$breaks)) self$breaks <- scale$breaks
-    if (is.waive(self$breaks)) self$breaks <- scale$transformation$breaks
+    if (is.waive(self$breaks)) {
+      if (scale$is_discrete()) {
+        self$breaks <- scale$get_breaks()
+      } else {
+        self$breaks <- scale$transformation$breaks
+      }
+    }
     if (is.derived(self$labels)) self$labels <- scale$labels
     if (is.derived(self$guide)) self$guide <- scale$guide
   },
@@ -212,10 +223,15 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
     if (self$empty()) return()
 
     # Test for monotonicity on unexpanded range
-    self$mono_test(scale)
+    if (!scale$is_discrete()) {
+      self$mono_test(scale)
+      breaks <- self$breaks
+    } else {
+      breaks <- scale$map(self$breaks)
+    }
 
     # Get scale's original range before transformation
-    transformation <- scale$get_transformation()
+    transformation <- scale$get_transformation() %||% transform_identity()
     along_range <- seq(range[1], range[2], length.out = self$detail)
     old_range <- transformation$inverse(along_range)
 
@@ -243,7 +259,7 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
       old_val_trans <- rescale(range_info$major, from = c(0, 1), to = range)
       old_val_minor_trans <- rescale(range_info$minor, from = c(0, 1), to = range)
     } else {
-      temp_scale <- self$create_scale(new_range)
+      temp_scale <- self$create_scale(new_range, breaks = breaks)
       range_info <- temp_scale$break_info()
 
       # Map the break values back to their correct position on the primary scale
@@ -292,10 +308,11 @@ AxisSecondary <- ggproto("AxisSecondary", NULL,
   },
 
   # Temporary scale for the purpose of calling break_info()
-  create_scale = function(self, range, transformation = transform_identity()) {
+  create_scale = function(self, range, transformation = transform_identity(),
+                          breaks = self$breaks) {
     scale <- ggproto(NULL, ScaleContinuousPosition,
                      name = self$name,
-                     breaks = self$breaks,
+                     breaks = breaks,
                      labels = self$labels,
                      limits = range,
                      expand = c(0, 0),

R/scale-discrete-.R

@@ -12,6 +12,7 @@
 #'
 #' @inheritDotParams discrete_scale
 #' @inheritParams discrete_scale
+#' @param sec.axis [dup_axis()] is used to specify a secondary axis.
 #' @rdname scale_discrete
 #' @family position scales
 #' @seealso
@@ -62,7 +63,8 @@
 #'   scale_x_discrete(labels = abbreviate)
 #' }
 scale_x_discrete <- function(name = waiver(), ..., expand = waiver(),
-                             guide = waiver(), position = "bottom") {
+                             guide = waiver(), position = "bottom",
+                             sec.axis = waiver()) {
   sc <- discrete_scale(
     aesthetics = c("x", "xmin", "xmax", "xend"), name = name,
     palette = identity, ...,
@@ -71,12 +73,13 @@ scale_x_discrete <- function(name = waiver(), ..., expand = waiver(),
   )
 
   sc$range_c <- ContinuousRange$new()
-  sc
+  set_sec_axis(sec.axis, sc)
 }
 #' @rdname scale_discrete
 #' @export
 scale_y_discrete <- function(name = waiver(), ..., expand = waiver(),
-                             guide = waiver(), position = "left") {
+                             guide = waiver(), position = "left",
+                             sec.axis = waiver()) {
   sc <- discrete_scale(
     aesthetics = c("y", "ymin", "ymax", "yend"), name = name,
     palette = identity, ...,
@@ -85,7 +88,7 @@ scale_y_discrete <- function(name = waiver(), ..., expand = waiver(),
   )
 
   sc$range_c <- ContinuousRange$new()
-  sc
+  set_sec_axis(sec.axis, sc)
 }
 
 # The discrete position scale maintains two separate ranges - one for
@@ -145,6 +148,14 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete,
     expand_limits_scale(self, expand, limits)
   },
 
+  sec_name = function(self) {
+    if (is.waive(self$secondary.axis)) {
+      waiver()
+    } else {
+      self$secondary.axis$name
+    }
+  },
+
   clone = function(self) {
     new <- ggproto(NULL, self)
     new$range <- DiscreteRange$new()

tests/testthat/test-sec-axis.R

@@ -380,3 +380,23 @@ test_that("sec_axis() works for power transformations (monotonicity test doesn't
   breaks <- scale$break_info()
   expect_equal(breaks$major, breaks$sec.major, tolerance = .001)
 })
+
+test_that("discrete scales can have secondary axes", {
+
+  data <- data.frame(x = c("A", "B", "C"), y = c("D", "E", "F"))
+  p <- ggplot(data, aes(x, y)) +
+    geom_point() +
+    scale_x_discrete(sec.axis = dup_axis(labels = c("foo", "bar", "baz"))) +
+    scale_y_discrete(sec.axis = dup_axis(
+      breaks = c(1.5, 2.5), labels = c("grault", "garply")
+    ))
+  b <- ggplot_build(p)
+
+  x <- get_guide_data(b, "x.sec")
+  expect_equal(x$.value, 1:3, ignore_attr = TRUE)
+  expect_equal(x$.label, c("foo", "bar", "baz"))
+
+  y <- get_guide_data(b, "y.sec")
+  expect_equal(y$.value, c(1.5, 2.5), ignore_attr = TRUE)
+  expect_equal(y$.label, c("grault", "garply"))
+})