Reproducible jitter

DESCRIPTION

@@ -16,14 +16,15 @@ Imports:
     digest,
     grid,
     gtable (>= 0.1.1),
+    lazyeval,
     MASS,
     plyr (>= 1.7.1),
     reshape2,
     scales (>= 0.4.1.9002),
     stats,
     tibble,
-    lazyeval,
-    viridisLite
+    viridisLite,
+    withr
 Suggests:
     covr,
     ggplot2movies,
@@ -47,7 +48,8 @@ Suggests:
     svglite (>= 1.2.0.9001)
 Remotes:
     hadley/scales,
-    hadley/svglite
+    hadley/svglite,
+    jimhester/withr
 Enhances: sp
 License: GPL-2 | file LICENSE
 URL: http://ggplot2.tidyverse.org, https://github.com/tidyverse/ggplot2

NEWS.md

@@ -119,6 +119,8 @@
 
 * `ggproto()` produces objects with class `c("ggproto", "gg")`. This was added so that when layers, scales, or other ggproto objects are added together, an informative error message is raised (@jrnold, #2056).
 
+* `position_jitter()` gains a `seed` argument that allows specifying a random seed for reproducible jittering (#1996, @krlmlr).
+
 
 ### sf
 

R/position-jitter.r

@@ -13,6 +13,14 @@
 #'   jitter values will occupy 80\% of the implied bins. Categorical data
 #'   is aligned on the integers, so a width or height of 0.5 will spread the
 #'   data so it's not possible to see the distinction between the categories.
+#' @param seed A random seed to make the jitter reproducible.
+#'   Useful if you need to apply the same jitter twice, e.g., for a point and
+#'   a corresponding label.
+#'   The random seed is reset after jittering.
+#'   If `NA` (the default value), the seed is initialised with a random value;
+#'   this makes sure that two subsequent calls start with a different seed.
+#'   Use `NULL` to use the current random seed and also avoid resetting
+#'   (the behavior of \pkg{ggplot} 2.2.1 and earlier).
 #' @export
 #' @examples
 #' # Jittering is useful when you have a discrete position, and a relatively
@@ -31,10 +39,21 @@
 #'   geom_jitter(width = 0.1, height = 0.1)
 #' ggplot(mtcars, aes(am, vs)) +
 #'   geom_jitter(position = position_jitter(width = 0.1, height = 0.1))
-position_jitter <- function(width = NULL, height = NULL) {
+#'
+#' # Create a jitter object for reproducible jitter:
+#' jitter <- position_jitter(width = 0.1, height = 0.1)
+#' ggplot(mtcars, aes(am, vs)) +
+#'   geom_point(position = jitter) +
+#'   geom_point(position = jitter, color = "red", aes(am + 0.2, vs + 0.2))
+position_jitter <- function(width = NULL, height = NULL, seed = NA) {
+  if (!is.null(seed) && is.na(seed)) {
+    seed <- sample.int(.Machine$integer.max, 1L)
+  }
+
   ggproto(NULL, PositionJitter,
     width = width,
-    height = height
+    height = height,
+    seed = seed
   )
 }
 
@@ -48,14 +67,15 @@ PositionJitter <- ggproto("PositionJitter", Position,
   setup_params = function(self, data) {
     list(
       width = self$width %||% (resolution(data$x, zero = FALSE) * 0.4),
-      height = self$height %||% (resolution(data$y, zero = FALSE) * 0.4)
+      height = self$height %||% (resolution(data$y, zero = FALSE) * 0.4),
+      seed = self$seed
     )
   },
 
   compute_layer = function(data, params, panel) {
     trans_x <- if (params$width > 0) function(x) jitter(x, amount = params$width)
     trans_y <- if (params$height > 0) function(x) jitter(x, amount = params$height)
 
-    transform_position(data, trans_x, trans_y)
+    with_seed_null(params$seed, transform_position(data, trans_x, trans_y))
   }
 )

R/utilities.r

@@ -386,6 +386,14 @@ find_args <- function(...) {
 # global data
 dummy_data <- function() data.frame(x = NA)
 
+with_seed_null <- function(seed, code) {
+  if (is.null(seed)) {
+    code
+  } else {
+    withr::with_seed(seed, code)
+  }
+}
+
 # Needed to trigger package loading
 #' @importFrom tibble tibble
 NULL