Allow to both position_stack and position_nudge

[krassowski]

Summary

I was trying to achieve something similar as in this question: Is there a possibility to combine position_stack and nudge_x in a stacked bar chart in ggplot2?, but with ggrepel. I think I succeeded.

Minimal code example

Intent

Having the following plot, I would like to move the names out of the bars and point to them with arrows:

df <- tibble::tribble(
  ~y, ~x, ~grp,
  "a", 1,  "some long name",
  "a", 2,  "other name",
  "b", 1,  "some name",
  "b", 3,  "another name",
  "b", -1, "some long name"
)

ggplot(data = df, aes(x, y, group = grp)) +
  geom_col(aes(fill = grp), width=0.5) +
  geom_vline(xintercept = 0) +
  geom_text(aes(label = grp), position = position_stack(vjust = 0.5))

Problem

ggplot(data = df, aes(x, y, group = grp)) +
  geom_col(aes(fill = grp), width=0.5) +
  geom_vline(xintercept = 0) +
  geom_text_repel(
      aes(label = grp),
      position = position_stack(vjust = 0.5),
      nudge_y = 0.4,
      direction = 'x'
  )

Will raise:

Error: Specify either `position` or `nudge_x`/`nudge_y`

Suggestions

Surprisingly, this turned out easy to implement with:

ggplot(data = df, aes(x, y, group = grp)) +
  geom_col(aes(fill = grp), width=0.5) +
  geom_vline(xintercept = 0) +
  geom_text_repel(
      aes(label = grp),
      position = position_stack_and_nudge(vjust = 0.5, y = 0.4),
      direction = 'x'
  )

Where position_stack_and_nudge() is a combination of ggrepel::position_nudge2 and ggplot::position_stack():

position_stack_and_nudge <- function(x = 0, y = 0, vjust = 1, reverse = FALSE) {
  ggproto(NULL, PositionStackAndNudge,
    x = x,
    y = y,
    vjust = vjust,
    reverse = reverse
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @noRd
PositionStackAndNudge <- ggproto("PositionStackAndNudge", PositionStack,
  x = 0,
  y = 0,

  setup_params = function(self, data) {
    c(
        list(x = self$x, y = self$y),
        ggproto_parent(PositionStack, self)$setup_params(data)
    )
  },

  compute_layer = function(self, data, params, panel) {
    # operate on the stacked positions (updated in August 2020)
    data = ggproto_parent(PositionStack, self)$compute_layer(data, params, panel)

    x_orig <- data$x
    y_orig <- data$y
    # transform only the dimensions for which non-zero nudging is requested
    if (any(params$x != 0)) {
      if (any(params$y != 0)) {
        data <- transform_position(data, function(x) x + params$x, function(y) y + params$y)
      } else {
        data <- transform_position(data, function(x) x + params$x, NULL)
      }
    } else if (any(params$y != 0)) {
      data <- transform_position(data, function(x) x, function(y) y + params$y)
    }
    data$nudge_x <- data$x
    data$nudge_y <- data$y
    data$x <- x_orig
    data$y <- y_orig

    data
  },

  compute_panel = function(self, data, params, scales) {
      ggproto_parent(PositionStack, self)$compute_panel(data, params, scales)
  }
)

This is my first attempt at modifying ggproto, and I am not confident in the quality of the code above, but it seems to work. Does ggproto allow multi-inheritance? This would have reduced the code much more!

My gut feeling is that it might be a bit specific use-case, so it might be just good enough to keep it in an issue, but if there is more users interested I could make it into a PR.

Version information

Here is the output from sessionInfo() in my R session:

``` R version 3.6.3 (2020-02-29) Platform: x86_64-pc-linux-gnu (64-bit) Running under: Ubuntu 20.04 LTS Matrix products: default BLAS: /usr/lib/x86_64-linux-gnu/blas/libblas.so.3.9.0 LAPACK: /usr/lib/x86_64-linux-gnu/lapack/liblapack.so.3.9.0 locale: [1] LC_CTYPE=en_GB.UTF-8 LC_NUMERIC=C [3] LC_TIME=en_GB.UTF-8 LC_COLLATE=en_GB.UTF-8 [5] LC_MONETARY=en_GB.UTF-8 LC_MESSAGES=en_GB.UTF-8 [7] LC_PAPER=en_GB.UTF-8 LC_NAME=C [9] LC_ADDRESS=C LC_TELEPHONE=C [11] LC_MEASUREMENT=en_GB.UTF-8 LC_IDENTIFICATION=C attached base packages: [1] tools stats graphics grDevices utils datasets methods [8] base other attached packages: [1] ggrepel_0.9.0 ComplexUpset_0.5.7 patchwork_1.0.0.9000 [4] ggplot2_3.3.0 loaded via a namespace (and not attached): [1] Rcpp_1.0.4.6 magrittr_1.5 tidyselect_1.0.0 munsell_0.5.0 [5] colorspace_1.4-1 R6_2.4.1 rlang_0.4.5 dplyr_0.8.4 [9] grid_3.6.3 gtable_0.3.0 withr_2.2.0 ellipsis_0.3.0 [13] assertthat_0.2.1 digest_0.6.25 tibble_3.0.1 lifecycle_0.2.0 [17] crayon_1.3.4 purrr_0.3.3 RColorBrewer_1.1-2 farver_2.0.3 [21] vctrs_0.2.4 glue_1.4.0 labeling_0.3 compiler_3.6.3 [25] pillar_1.4.3 scales_1.1.0 pkgconfig_2.0.3 ```

[slowkow]

Thanks for sharing this! Very cool. I agree with you that we might want to distribute this in some package if there is interest.

[choc2000]

I would be very much interested in such a feature. Specifically, I'd need a combination of position_dodge/position_jitter and position_nudge. Use case: I have geom_point that is dedged/jittered. I want to label the points but with an additional offset (nudge).

Would this be possible as well?

[krassowski]

I guess it would need to be similar in principle to the code above, but using PositionJitterdodge rather than PositionStack.

[slowkow]

@krassowski Hey Michał, if you're still interested, I would like to invite you to make a pull request with your new code. I might also add an example to show off this cool new feature.

[nikostr]

Hey, I'm interested in this feature :) is a PR coming? :)

[aphalo]

@krassowski @slowkow Are you both o.k. with me adding position_stack_and_nudge() to package 'ggpp'? If yes, Michel, could you please send me your ORCID or directly add yourself as a contributor at https://github.com/aphalo/ggpp ?

I provisionally added the code to 'ggpp' and will do some testing, but it seems to work nicely. If you disagree, I will remove it.

Thanks!

[slowkow]

I think ggpp is an OK place for position_stack_and_nudge().

[krassowski]

Fine by me. AFK but my ORCID is https://orcid.org/0000-0002-9638-7785

[aphalo]

@krassowski @slowkow Many thanks! I also implemented position_dodge_and_nudge() in 'ggpp'.