Reproducible jitter

R/position-jitter.r

@@ -13,6 +13,9 @@
 #'   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 An optional 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.
 #' @export
 #' @examples
 #' # Jittering is useful when you have a discrete position, and a relatively
@@ -31,10 +34,11 @@
 #'   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) {
+position_jitter <- function(width = NULL, height = NULL, seed = NULL) {
   ggproto(NULL, PositionJitter,
     width = width,
-    height = height
+    height = height,
+    seed = seed
   )
 }
 
@@ -48,14 +52,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(params$seed, transform_position(data, trans_x, trans_y))
   }
 )

R/utilities.r

@@ -299,6 +299,16 @@ find_args <- function(...) {
 # global data
 dummy_data <- function() data.frame(x = NA)
 
+with_seed <- function(seed, code) {
+  if (!is.null(seed)) {
+    old_seed <- get0(".Random.seed", globalenv())
+    if (!is.null(old_seed)) {
+      on.exit(assign(".Random.seed", old_seed, globalenv()), add = TRUE)
+    }
+  }
+  code
+}
+
 # Needed to trigger package loading
 #' @importFrom tibble tibble
 NULL