1#' @export
2#' @rdname position_dodge
3#' @param padding Padding between elements at the same position. Elements are
4#'   shrunk by this proportion to allow space between them. Defaults to 0.1.
5#' @param reverse If `TRUE`, will reverse the default stacking order.
6#'   This is useful if you're rotating both the plot and legend.
7position_dodge2 <- function(width = NULL, preserve = c("total", "single"),
8                            padding = 0.1, reverse = FALSE) {
9  ggproto(NULL, PositionDodge2,
10    width = width,
11    preserve = match.arg(preserve),
12    padding = padding,
13    reverse = reverse
14  )
15}
16
17#' @rdname ggplot2-ggproto
18#' @format NULL
19#' @usage NULL
20#' @export
21PositionDodge2 <- ggproto("PositionDodge2", PositionDodge,
22  preserve = "total",
23  padding = 0.1,
24  reverse = FALSE,
25
26  setup_params = function(self, data) {
27    flipped_aes <- has_flipped_aes(data)
28    data <- flip_data(data, flipped_aes)
29    if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) {
30      warn("Width not defined. Set with `position_dodge2(width = ?)`")
31    }
32
33    if (identical(self$preserve, "total")) {
34      n <- NULL
35    } else {
36      panels <- unname(split(data, data$PANEL))
37      if ("x" %in% names(data)) {
38        # Point geom
39        groups <- lapply(panels, function(panel) table(panel$x))
40      } else {
41        # Interval geom
42        groups <- lapply(panels, find_x_overlaps)
43      }
44      n_groups <- vapply(groups, max, double(1))
45      n <- max(n_groups)
46    }
47
48    list(
49      width = self$width,
50      n = n,
51      padding = self$padding,
52      reverse = self$reverse,
53      flipped_aes = flipped_aes
54    )
55  },
56
57  compute_panel = function(data, params, scales) {
58    data <- flip_data(data, params$flipped_aes)
59    collided <- collide2(
60      data,
61      params$width,
62      name = "position_dodge2",
63      strategy = pos_dodge2,
64      n = params$n,
65      padding = params$padding,
66      check.width = FALSE,
67      reverse = params$reverse
68    )
69    flip_data(collided, params$flipped_aes)
70  }
71)
72
73pos_dodge2 <- function(df, width, n = NULL, padding = 0.1) {
74  if (!all(c("xmin", "xmax") %in% names(df))) {
75    df$xmin <- df$x
76    df$xmax <- df$x
77  }
78
79  # xid represents groups of boxes that share the same position
80  df$xid <- find_x_overlaps(df)
81
82  # based on xid find newx, i.e. the center of each group of overlapping
83  # elements. for boxes, bars, etc. this should be the same as original x, but
84  # for arbitrary rects it may not be
85  newx <- (tapply(df$xmin, df$xid, min) + tapply(df$xmax, df$xid, max)) / 2
86  df$newx <- newx[df$xid]
87
88  if (is.null(n)) {
89    # If n is null, preserve total widths of elements at each position by
90    # dividing widths by the number of elements at that position
91    n <- table(df$xid)
92    df$new_width <- (df$xmax - df$xmin) / as.numeric(n[df$xid])
93  } else {
94    df$new_width <- (df$xmax - df$xmin) / n
95  }
96
97  # Find the total width of each group of elements
98  group_sizes <- stats::aggregate(
99    list(size = df$new_width),
100    list(newx = df$newx),
101    sum
102  )
103
104  # Starting xmin for each group of elements
105  starts <- group_sizes$newx - (group_sizes$size / 2)
106
107  # Set the elements in place
108  for (i in seq_along(starts)) {
109    divisions <- cumsum(c(starts[i], df[df$xid == i, "new_width"]))
110    df[df$xid == i, "xmin"] <- divisions[-length(divisions)]
111    df[df$xid == i, "xmax"] <- divisions[-1]
112  }
113
114  # x values get moved to between xmin and xmax
115  df$x <- (df$xmin + df$xmax) / 2
116
117  # If no elements occupy the same position, there is no need to add padding
118  if (!any(duplicated(df$xid))) {
119    return(df)
120  }
121
122  # Shrink elements to add space between them
123  df$pad_width <- df$new_width * (1 - padding)
124  df$xmin <- df$x - (df$pad_width / 2)
125  df$xmax <- df$x + (df$pad_width / 2)
126
127  df$xid <- NULL
128  df$newx <- NULL
129  df$new_width <- NULL
130  df$pad_width <- NULL
131
132  df
133}
134
135# Find groups of overlapping elements that need to be dodged from one another
136find_x_overlaps <- function(df) {
137  overlaps <- numeric(nrow(df))
138  overlaps[1] <- counter <- 1
139
140  for (i in seq_asc(2, nrow(df))) {
141    if (is.na(df$xmin[i]) || is.na(df$xmax[i - 1]) || df$xmin[i] >= df$xmax[i - 1]) {
142      counter <- counter + 1
143    }
144    overlaps[i] <- counter
145  }
146  overlaps
147}
148