Make discrete scale determination stable (#3998)

Author: thomasp85

NAMESPACE

@@ -4,14 +4,17 @@ S3method("$",ggproto)
 S3method("$",ggproto_parent)
 S3method("$<-",uneval)
 S3method("+",gg)
+S3method("[",mapped_discrete)
 S3method("[",uneval)
+S3method("[<-",mapped_discrete)
 S3method("[<-",uneval)
 S3method("[[",ggproto)
 S3method("[[<-",uneval)
 S3method(.DollarNames,ggproto)
 S3method(as.list,ggproto)
 S3method(autolayer,default)
 S3method(autoplot,default)
+S3method(c,mapped_discrete)
 S3method(drawDetails,zeroGrob)
 S3method(element_grob,element_blank)
 S3method(element_grob,element_line)

R/scale-discrete-.r

@@ -108,10 +108,9 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete,
 
   map = function(self, x, limits = self$get_limits()) {
     if (is.discrete(x)) {
-      seq_along(limits)[match(as.character(x), limits)]
-    } else {
-      x
+      x <- seq_along(limits)[match(as.character(x), limits)]
     }
+    new_mapped_discrete(x)
   },
 
   rescale = function(self, x, limits = self$get_limits(), range = self$dimension(limits = limits)) {
@@ -129,3 +128,29 @@ ScaleDiscretePosition <- ggproto("ScaleDiscretePosition", ScaleDiscrete,
     new
   }
 )
+
+# TODO: This is a clear candidate for vctrs once we adopt it
+new_mapped_discrete <- function(x) {
+  if (!is.numeric(x)) {
+    abort("`mapped_discrete` objects can only be created from numeric vectors")
+  }
+  class(x) <- c("mapped_discrete", "numeric")
+  x
+}
+is_mapped_discrete <- function(x) inherits(x, "mapped_discrete")
+#' @export
+c.mapped_discrete <- function(..., recursive = FALSE) {
+  new_mapped_discrete(c(unlist(lapply(list(...), unclass))))
+}
+#' @export
+`[.mapped_discrete` <- function(x, ..., drop = TRUE) {
+  new_mapped_discrete(NextMethod())
+}
+#' @export
+`[<-.mapped_discrete` <- function(x, ..., value) {
+  if (length(value) == 0) {
+    return(x)
+  }
+  value <- as.numeric(unclass(value))
+  new_mapped_discrete(NextMethod())
+}

R/utilities.r

@@ -562,10 +562,10 @@ has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA,
   }
 
   # Is there a single actual discrete position
-  y_is_int <- is.integer(y)
-  x_is_int <- is.integer(x)
-  if (xor(y_is_int, x_is_int)) {
-    return(y_is_int != main_is_continuous)
+  y_is_discrete <- is_mapped_discrete(y)
+  x_is_discrete <- is_mapped_discrete(x)
+  if (xor(y_is_discrete, x_is_discrete)) {
+    return(y_is_discrete != main_is_continuous)
   }
 
   # Does each group have a single x or y value
@@ -586,51 +586,6 @@ has_flipped_aes <- function(data, params = list(), main_is_orthogonal = NA,
     }
   }
 
-  # give up early
-  if (!has_x && !has_y) {
-    return(FALSE)
-  }
-
-  # Both true discrete. give up
-  if (y_is_int && x_is_int) {
-    return(FALSE)
-  }
-  # Is there a single discrete-like position
-  y_is_int <- if (has_y) isTRUE(all.equal(y, round(y))) else FALSE
-  x_is_int <- if (has_x) isTRUE(all.equal(x, round(x))) else FALSE
-  if (xor(y_is_int, x_is_int)) {
-    return(y_is_int != main_is_continuous)
-  }
-
-  if (main_is_optional) {
-    # Is one of the axes all 0
-    if (all(x == 0)) {
-      return(main_is_continuous)
-    }
-    if (all(y == 0)) {
-      return(!main_is_continuous)
-    }
-  }
-
-  y_diff <- diff(sort(y))
-  x_diff <- diff(sort(x))
-
-  # FIXME: If both are discrete like, give up. Probably, we can make a better
-  # guess, but it's not possible with the current implementation as very little
-  # information is available in Geom$setup_params().
-  if (y_is_int && x_is_int) {
-    return(FALSE)
-  }
-
-  y_diff <- y_diff[y_diff != 0]
-  x_diff <- x_diff[x_diff != 0]
-
-  # If none are discrete is either regularly spaced
-  y_is_regular <- if (has_y && length(y_diff) != 0) all((y_diff / min(y_diff)) %% 1 < .Machine$double.eps) else FALSE
-  x_is_regular <- if (has_x && length(x_diff) != 0) all((x_diff / min(x_diff)) %% 1 < .Machine$double.eps) else FALSE
-  if (xor(y_is_regular, x_is_regular)) {
-    return(y_is_regular != main_is_continuous)
-  }
   # default to no
   FALSE
 }

tests/testthat/test-build.r

@@ -25,8 +25,8 @@ test_that("position aesthetics are coerced to correct type", {
   l2 <- ggplot(df, aes(x, z)) + geom_point() + scale_x_discrete()
   d2 <- layer_data(l2, 1)
 
-  expect_is(d2$x, "integer")
-  expect_is(d2$y, "integer")
+  expect_s3_class(d2$x, "mapped_discrete")
+  expect_s3_class(d2$y, "mapped_discrete")
 })
 
 test_that("non-position aesthetics are mapped", {

tests/testthat/test-coord-polar.r

@@ -76,9 +76,9 @@ test_that("Inf is squished to range", {
 
   # 0.4 is the upper limit of radius hardcoded in r_rescale()
   expect_equal(d[[2]]$r, 0.4)
-  expect_equal(d[[2]]$theta, 0)
+  expect_equal(d[[2]]$theta, new_mapped_discrete(0))
   expect_equal(d[[3]]$r, 0)
-  expect_equal(d[[3]]$theta, 0)
+  expect_equal(d[[3]]$theta, new_mapped_discrete(0))
 })
 
 

tests/testthat/test-geom-freqpoly.R

@@ -6,7 +6,7 @@ test_that("can do frequency polygon with categorical x", {
   p <- ggplot(df, aes(x)) + geom_freqpoly(stat = "count")
   d <- layer_data(p)
 
-  expect_is(d$x, "integer")
-  expect_equal(d$x, 1:3)
+  expect_s3_class(d$x, "mapped_discrete")
+  expect_equal(d$x, new_mapped_discrete(1:3))
   expect_equal(d$y, 3:1)
 })

tests/testthat/test-geom-tile.R

@@ -4,12 +4,12 @@ test_that("accepts width and height params", {
   df <- data_frame(x = c("a", "b"), y = c("a", "b"))
 
   out1 <- layer_data(ggplot(df, aes(x, y)) + geom_tile())
-  expect_equal(out1$xmin, c(0.5, 1.5))
-  expect_equal(out1$xmax, c(1.5, 2.5))
+  expect_equal(out1$xmin, new_mapped_discrete(c(0.5, 1.5)))
+  expect_equal(out1$xmax, new_mapped_discrete(c(1.5, 2.5)))
 
   out2 <- layer_data(ggplot(df, aes(x, y)) + geom_tile(width = 0.5, height = 0.5))
-  expect_equal(out2$xmin, c(0.75, 1.75))
-  expect_equal(out2$xmax, c(1.25, 2.25))
+  expect_equal(out2$xmin, new_mapped_discrete(c(0.75, 1.75)))
+  expect_equal(out2$xmax, new_mapped_discrete(c(1.25, 2.25)))
 })
 
 test_that("accepts width and height aesthetics", {

tests/testthat/test-position_dodge.R

@@ -8,6 +8,6 @@ test_that("can control whether to preserve total or individual width", {
   p_single <- ggplot(df, aes(x, fill = y)) +
     geom_bar(position = position_dodge(preserve = "single"), width = 1)
 
-  expect_equal(layer_data(p_total)$x, c(1, 1.75, 2.25))
-  expect_equal(layer_data(p_single)$x, c(0.75, 1.75, 2.25))
+  expect_equal(layer_data(p_total)$x, new_mapped_discrete(c(1, 1.75, 2.25)))
+  expect_equal(layer_data(p_single)$x, new_mapped_discrete(c(0.75, 1.75, 2.25)))
 })

tests/testthat/test-scale-discrete.R

@@ -15,18 +15,18 @@ test_that("NAs are translated/preserved for position scales", {
   p2a <- ggplot(df, aes(x2, y)) + geom_point()
   p3a <- ggplot(df, aes(x3, y)) + geom_point()
 
-  expect_equal(layer_data(p1a)$x, c(1, 2, 3))
-  expect_equal(layer_data(p2a)$x, c(1, 2, 3))
-  expect_equal(layer_data(p3a)$x, c(1, 2, 3))
+  expect_equal(layer_data(p1a)$x, new_mapped_discrete(c(1, 2, 3)))
+  expect_equal(layer_data(p2a)$x, new_mapped_discrete(c(1, 2, 3)))
+  expect_equal(layer_data(p3a)$x, new_mapped_discrete(c(1, 2, 3)))
 
   rm_na_x <- scale_x_discrete(na.translate = FALSE)
   p1b <- p1a + rm_na_x
   p2b <- p2a + rm_na_x
   p3b <- p3a + rm_na_x
 
-  expect_equal(layer_data(p1b)$x, c(1, 2, NA))
-  expect_equal(layer_data(p2b)$x, c(1, 2, NA))
-  expect_equal(layer_data(p3b)$x, c(1, 2, NA))
+  expect_equal(layer_data(p1b)$x, new_mapped_discrete(c(1, 2, NA)))
+  expect_equal(layer_data(p2b)$x, new_mapped_discrete(c(1, 2, NA)))
+  expect_equal(layer_data(p3b)$x, new_mapped_discrete(c(1, 2, NA)))
 })
 
 test_that("NAs are translated/preserved for non-position scales", {

tests/testthat/test-stat-bin.R

@@ -175,13 +175,13 @@ test_that("stat_count preserves x order for continuous and discrete", {
   # x is factor where levels match numeric order
   mtcars$carb2 <- factor(mtcars$carb)
   b <- ggplot_build(ggplot(mtcars, aes(carb2)) + geom_bar())
-  expect_identical(b$data[[1]]$x, 1:6)
+  expect_identical(b$data[[1]]$x, new_mapped_discrete(1:6))
   expect_identical(b$data[[1]]$y, c(7,10,3,10,1,1))
 
   # x is factor levels differ from numeric order
   mtcars$carb3 <- factor(mtcars$carb, levels = c(4,1,2,3,6,8))
   b <- ggplot_build(ggplot(mtcars, aes(carb3)) + geom_bar())
-  expect_identical(b$data[[1]]$x, 1:6)
+  expect_identical(b$data[[1]]$x, new_mapped_discrete(1:6))
   expect_identical(b$layout$panel_params[[1]]$x$get_labels(), c("4","1","2","3","6","8"))
   expect_identical(b$data[[1]]$y, c(10,7,10,3,1,1))
 })