|
| 1 | +#' @rdname position_dodgenudge_to |
| 2 | +#' |
| 3 | +#' @export |
| 4 | +#' |
| 5 | +position_dodge2nudge_to <- |
| 6 | + function(width = 1, |
| 7 | + preserve = c("total", "single"), |
| 8 | + padding = 0.1, |
| 9 | + reverse = FALSE, |
| 10 | + x = NULL, |
| 11 | + y = NULL, |
| 12 | + x.action = c("none", "spread"), |
| 13 | + y.action = c("none", "spread"), |
| 14 | + x.distance = "equal", |
| 15 | + y.distance = "equal", |
| 16 | + x.expansion = 0, |
| 17 | + y.expansion = 0, |
| 18 | + kept.origin = c("dodged", "original", "none")) { |
| 19 | + |
| 20 | + stopifnot("'x' must be NULL or of mode numeric" = length(x) == 0 || |
| 21 | + (!anyNA(x) && mode(x) == "numeric")) |
| 22 | + stopifnot("'y' must be NULL or of mode numeric" = length(y) == 0 || |
| 23 | + (!anyNA(y) && mode(y) == "numeric")) |
| 24 | + |
| 25 | + # this works as long as nudge and mapped variable are of the same class |
| 26 | + # ggplot2's behaviour has been in the past and seems to be again to expect |
| 27 | + # numeric seconds for POSIXct and numeric days for Date time shifts |
| 28 | + if (lubridate::is.instant(x)) { |
| 29 | + x <- as.numeric(x) |
| 30 | + } |
| 31 | + if (lubridate::is.instant(y)) { |
| 32 | + y <- as.numeric(y) |
| 33 | + } |
| 34 | + |
| 35 | + ggplot2::ggproto(NULL, PositionDodge2AndNudgeTo, |
| 36 | + x = x, |
| 37 | + y = y, |
| 38 | + x.action = rlang::arg_match(x.action), |
| 39 | + y.action = rlang::arg_match(y.action), |
| 40 | + x.distance = x.distance, |
| 41 | + y.distance = y.distance, |
| 42 | + x.expansion = rep_len(x.expansion, 2), |
| 43 | + y.expansion = rep_len(y.expansion, 2), |
| 44 | + kept.origin = rlang::arg_match(kept.origin), |
| 45 | + width = width, |
| 46 | + preserve = rlang::arg_match(preserve), |
| 47 | + padding = padding, |
| 48 | + reverse = reverse |
| 49 | + ) |
| 50 | + } |
| 51 | + |
| 52 | +#' @rdname ggpp-ggproto |
| 53 | +#' @format NULL |
| 54 | +#' @usage NULL |
| 55 | +#' @export |
| 56 | +PositionDodge2AndNudgeTo <- |
| 57 | + ggplot2::ggproto( |
| 58 | + "PositionDodge2AndNudgeTo", |
| 59 | + Position, |
| 60 | + x = NULL, |
| 61 | + y = NULL, |
| 62 | + |
| 63 | + setup_params = function(self, data) { |
| 64 | + list(x = self$x, |
| 65 | + y = self$y, |
| 66 | + x.action = self$x.action, |
| 67 | + y.action = self$y.action, |
| 68 | + x.distance = self$x.distance, |
| 69 | + y.distance = self$y.distance, |
| 70 | + x.expansion = self$x.expansion, |
| 71 | + y.expansion = self$y.expansion, |
| 72 | + x.reorder = !is.null(self$x) && length(self$x) > 1 && length(self$x) < nrow(data), |
| 73 | + y.reorder = !is.null(self$y) && length(self$y) > 1 && length(self$y) < nrow(data), |
| 74 | + kept.origin = self$kept.origin, |
| 75 | + width = self$width, |
| 76 | + preserve = self$preserve, |
| 77 | + padding = self$padding, |
| 78 | + reverse = self$reverse |
| 79 | + ) |
| 80 | + }, |
| 81 | + |
| 82 | + compute_layer = function(self, data, params, layout) { |
| 83 | + x_orig <- data$x |
| 84 | + y_orig <- data$y |
| 85 | + if (!is.na(params$width)) { |
| 86 | + # operate on the dodged positions |
| 87 | + data = ggplot2::ggproto_parent(ggplot2::PositionDodge2, self)$compute_layer(data, params, layout) |
| 88 | + } |
| 89 | + x_dodged <- data$x |
| 90 | + y_dodged <- data$y |
| 91 | + |
| 92 | + # compute/convert x nudges |
| 93 | + if (!length(params$x)) { |
| 94 | + # set default x |
| 95 | + if (params$x.action == "none") { |
| 96 | + params$x <- rep_len(0, nrow(data)) |
| 97 | + } else if (params$x.action == "spread") { |
| 98 | + params$x <- range(x_dodged) |
| 99 | + } |
| 100 | + } else if (is.numeric(params$x)) { |
| 101 | + # check user supplied x |
| 102 | + if (length(params$x) > nrow(data)) { |
| 103 | + warning("Argument 'x' longer than data: some values dropped!") |
| 104 | + } |
| 105 | + if (params$x.action == "none") { |
| 106 | + # recycle or trim x as needed |
| 107 | + if (params$x.reorder) { |
| 108 | + params$x <- rep_len(params$x, nrow(data))[order(order(data$x))] - x_dodged |
| 109 | + } else { |
| 110 | + params$x <- rep_len(params$x, nrow(data)) - x_dodged |
| 111 | + } |
| 112 | + } else if (params$x.action == "spread") { |
| 113 | + params$x <- range(params$x) |
| 114 | + } |
| 115 | + } |
| 116 | + |
| 117 | + if (params$x.action == "spread") { |
| 118 | + # apply x.expansion to x |
| 119 | + x.spread <- diff(params$x) |
| 120 | + params$x[1] <- params$x[1] - params$x.expansion[1] * x.spread |
| 121 | + params$x[2] <- params$x[2] + params$x.expansion[2] * x.spread |
| 122 | + if (params$x.distance == "equal") { |
| 123 | + # evenly spaced sequence of positions ordered as in data |
| 124 | + params$x <- seq(from = params$x[1], |
| 125 | + to = params$x[2], |
| 126 | + length.out = nrow(data))[order(order(data$x))] - x_dodged |
| 127 | + } |
| 128 | + # other strategies to distribute positions could be added here |
| 129 | + } |
| 130 | + |
| 131 | + # compute/convert y nudges |
| 132 | + if (!length(params$y)) { |
| 133 | + # set default y |
| 134 | + if (params$y.action == "none") { |
| 135 | + params$y <- rep_len(0, nrow(data)) |
| 136 | + } else if (params$y.action == "spread") { |
| 137 | + params$y <- range(y_dodged) |
| 138 | + } |
| 139 | + } else if (is.numeric(params$y)) { |
| 140 | + # check user supplied y |
| 141 | + if (length(params$y) > nrow(data)) { |
| 142 | + warning("Argument 'y' longer than data: some values dropped!") |
| 143 | + } |
| 144 | + if (params$y.action == "none") { |
| 145 | + # recycle or trim y as needed |
| 146 | + if (params$y.reorder) { |
| 147 | + params$y <- rep_len(params$y, nrow(data))[order(order(data$y))] - y_dodged |
| 148 | + } else { |
| 149 | + params$y <- rep_len(params$y, nrow(data)) - y_dodged |
| 150 | + } |
| 151 | + } else if (params$y.action == "spread") { |
| 152 | + params$y <- range(params$y) |
| 153 | + } |
| 154 | + } |
| 155 | + |
| 156 | + if (params$y.action == "spread") { |
| 157 | + y.spread <- diff(params$y) |
| 158 | + params$y[1] <- params$y[1] - params$y.expansion[1] * y.spread |
| 159 | + params$y[2] <- params$y[2] + params$y.expansion[2] * y.spread |
| 160 | + if (params$y.distance == "equal") { |
| 161 | + # evenly spaced sequence ordered as in data |
| 162 | + params$y <- seq(from = params$y[1], |
| 163 | + to = params$y[2], |
| 164 | + length.out = nrow(data))[order(order(data$y))] - y_dodged |
| 165 | + } |
| 166 | + # other strategies could be added here |
| 167 | + } |
| 168 | + |
| 169 | + # As in 'ggplot2' we apply the nudge to xmin, xmax, xend, ymin, ymax, and yend. |
| 170 | + # Transform the dimensions for which not all nudges are zero |
| 171 | + if (any(params$x != 0)) { |
| 172 | + if (any(params$y != 0)) { |
| 173 | + data <- transform_position(data, function(x) x + params$x, function(y) y + params$y) |
| 174 | + } else { |
| 175 | + data <- transform_position(data, function(x) x + params$x, NULL) |
| 176 | + } |
| 177 | + } else if (any(params$y != 0)) { |
| 178 | + data <- transform_position(data, NULL, function(y) y + params$y) |
| 179 | + } |
| 180 | + # add original position |
| 181 | + if (params$kept.origin == "dodged" && !is.na(params$width)) { |
| 182 | + data$x_orig <- x_dodged |
| 183 | + data$y_orig <- y_dodged |
| 184 | + } else if (params$kept.origin == "original") { |
| 185 | + data$x_orig <- x_orig |
| 186 | + data$y_orig <- y_orig |
| 187 | + } |
| 188 | + |
| 189 | + data |
| 190 | + }, |
| 191 | + |
| 192 | + compute_panel = function(self, data, params, scales) { |
| 193 | + ggplot2::ggproto_parent(PositionDodge2, self)$compute_panel(data, params, scales) |
| 194 | + } |
| 195 | + ) |
0 commit comments