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