1 2#' Axis guide 3#' 4#' Axis guides are the visual representation of position scales like those 5#' created with [scale_(x|y)_continuous()][scale_x_continuous()] and 6#' [scale_(x|y)_discrete()][scale_x_discrete()]. 7#' 8#' @inheritParams guide_legend 9#' @param check.overlap silently remove overlapping labels, 10#' (recursively) prioritizing the first, last, and middle labels. 11#' @param angle Compared to setting the angle in [theme()] / [element_text()], 12#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that 13#' you probably want. 14#' @param n.dodge The number of rows (for vertical axes) or columns (for 15#' horizontal axes) that should be used to render the labels. This is 16#' useful for displaying labels that would otherwise overlap. 17#' @param order Used to determine the order of the guides (left-to-right, 18#' top-to-bottom), if more than one guide must be drawn at the same location. 19#' @param position Where this guide should be drawn: one of top, bottom, 20#' left, or right. 21#' 22#' @export 23#' 24#' @examples 25#' # plot with overlapping text 26#' p <- ggplot(mpg, aes(cty * 100, hwy * 100)) + 27#' geom_point() + 28#' facet_wrap(vars(class)) 29#' 30#' # axis guides can be customized in the scale_* functions or 31#' # using guides() 32#' p + scale_x_continuous(guide = guide_axis(n.dodge = 2)) 33#' p + guides(x = guide_axis(angle = 90)) 34#' 35#' # can also be used to add a duplicate guide 36#' p + guides(x = guide_axis(n.dodge = 2), y.sec = guide_axis()) 37#' 38#' 39guide_axis <- function(title = waiver(), check.overlap = FALSE, angle = NULL, n.dodge = 1, 40 order = 0, position = waiver()) { 41 structure( 42 list( 43 title = title, 44 45 # customizations 46 check.overlap = check.overlap, 47 angle = angle, 48 n.dodge = n.dodge, 49 50 # general 51 order = order, 52 position = position, 53 54 # parameter 55 available_aes = c("x", "y"), 56 57 name = "axis" 58 ), 59 class = c("guide", "axis") 60 ) 61} 62 63#' @export 64guide_train.axis <- function(guide, scale, aesthetic = NULL) { 65 66 aesthetic <- aesthetic %||% scale$aesthetics[1] 67 breaks <- scale$get_breaks() 68 69 empty_ticks <- new_data_frame( 70 list(aesthetic = numeric(0), .value = numeric(0), .label = character(0)) 71 ) 72 names(empty_ticks) <- c(aesthetic, ".value", ".label") 73 74 if (length(intersect(scale$aesthetics, guide$available_aes)) == 0) { 75 warn(glue( 76 "axis guide needs appropriate scales: ", 77 glue_collapse(guide$available_aes, ", ", last = " or ") 78 )) 79 guide$key <- empty_ticks 80 } else if (length(breaks) == 0) { 81 guide$key <- empty_ticks 82 } else { 83 mapped_breaks <- if (scale$is_discrete()) scale$map(breaks) else breaks 84 ticks <- new_data_frame(setNames(list(mapped_breaks), aesthetic)) 85 ticks$.value <- breaks 86 ticks$.label <- scale$get_labels(breaks) 87 88 guide$key <- ticks[is.finite(ticks[[aesthetic]]), ] 89 } 90 91 guide$name <- paste0(guide$name, "_", aesthetic) 92 guide$hash <- digest::digest(list(guide$title, guide$key$.value, guide$key$.label, guide$name)) 93 guide 94} 95 96#' @export 97guide_transform.axis <- function(guide, coord, panel_params) { 98 if (is.null(guide$position) || nrow(guide$key) == 0) { 99 return(guide) 100 } 101 102 aesthetics <- names(guide$key)[!grepl("^\\.", names(guide$key))] 103 104 if (all(c("x", "y") %in% aesthetics)) { 105 guide$key <- coord$transform(guide$key, panel_params) 106 } else { 107 other_aesthetic <- setdiff(c("x", "y"), aesthetics) 108 override_value <- if (guide$position %in% c("bottom", "left")) -Inf else Inf 109 guide$key[[other_aesthetic]] <- override_value 110 111 guide$key <- coord$transform(guide$key, panel_params) 112 113 warn_for_guide_position(guide) 114 } 115 116 guide 117} 118 119# discards the new guide with a warning 120#' @export 121guide_merge.axis <- function(guide, new_guide) { 122 if (!inherits(new_guide, "guide_none")) { 123 warn("guide_axis(): Discarding guide on merge. Do you have more than one guide with the same position?") 124 } 125 126 guide 127} 128 129# axis guides don't care which geometry uses these aesthetics 130#' @export 131guide_geom.axis <- function(guide, layers, default_mapping) { 132 guide 133} 134 135#' @export 136guide_gengrob.axis <- function(guide, theme) { 137 aesthetic <- names(guide$key)[!grepl("^\\.", names(guide$key))][1] 138 139 draw_axis( 140 break_positions = guide$key[[aesthetic]], 141 break_labels = guide$key$.label, 142 axis_position = guide$position, 143 theme = theme, 144 check.overlap = guide$check.overlap, 145 angle = guide$angle, 146 n.dodge = guide$n.dodge 147 ) 148} 149 150 151#' Grob for axes 152#' 153#' @param break_position position of ticks 154#' @param break_labels labels at ticks 155#' @param axis_position position of axis (top, bottom, left or right) 156#' @param theme A complete [theme()] object 157#' @param check.overlap silently remove overlapping labels, 158#' (recursively) prioritizing the first, last, and middle labels. 159#' @param angle Compared to setting the angle in [theme()] / [element_text()], 160#' this also uses some heuristics to automatically pick the `hjust` and `vjust` that 161#' you probably want. 162#' @param n.dodge The number of rows (for vertical axes) or columns (for 163#' horizontal axes) that should be used to render the labels. This is 164#' useful for displaying labels that would otherwise overlap. 165#' 166#' @noRd 167#' 168draw_axis <- function(break_positions, break_labels, axis_position, theme, 169 check.overlap = FALSE, angle = NULL, n.dodge = 1) { 170 171 axis_position <- match.arg(axis_position, c("top", "bottom", "right", "left")) 172 aesthetic <- if (axis_position %in% c("top", "bottom")) "x" else "y" 173 174 # resolve elements 175 line_element_name <- paste0("axis.line.", aesthetic, ".", axis_position) 176 tick_element_name <- paste0("axis.ticks.", aesthetic, ".", axis_position) 177 tick_length_element_name <- paste0("axis.ticks.length.", aesthetic, ".", axis_position) 178 label_element_name <- paste0("axis.text.", aesthetic, ".", axis_position) 179 180 line_element <- calc_element(line_element_name, theme) 181 tick_element <- calc_element(tick_element_name, theme) 182 tick_length <- calc_element(tick_length_element_name, theme) 183 label_element <- calc_element(label_element_name, theme) 184 185 # override label element parameters for rotation 186 if (inherits(label_element, "element_text")) { 187 label_overrides <- axis_label_element_overrides(axis_position, angle) 188 # label_overrides is an element_text, but label_element may not be; 189 # to merge the two elements, we just copy angle, hjust, and vjust 190 # unless their values are NULL 191 if (!is.null(label_overrides$angle)) { 192 label_element$angle <- label_overrides$angle 193 } 194 if (!is.null(label_overrides$hjust)) { 195 label_element$hjust <- label_overrides$hjust 196 } 197 if (!is.null(label_overrides$vjust)) { 198 label_element$vjust <- label_overrides$vjust 199 } 200 } 201 202 # conditionally set parameters that depend on axis orientation 203 is_vertical <- axis_position %in% c("left", "right") 204 205 position_dim <- if (is_vertical) "y" else "x" 206 non_position_dim <- if (is_vertical) "x" else "y" 207 position_size <- if (is_vertical) "height" else "width" 208 non_position_size <- if (is_vertical) "width" else "height" 209 gtable_element <- if (is_vertical) gtable_row else gtable_col 210 measure_gtable <- if (is_vertical) gtable_width else gtable_height 211 measure_labels_non_pos <- if (is_vertical) grobWidth else grobHeight 212 213 # conditionally set parameters that depend on which side of the panel 214 # the axis is on 215 is_second <- axis_position %in% c("right", "top") 216 217 tick_direction <- if (is_second) 1 else -1 218 non_position_panel <- if (is_second) unit(0, "npc") else unit(1, "npc") 219 tick_coordinate_order <- if (is_second) c(2, 1) else c(1, 2) 220 221 # conditionally set the gtable ordering 222 labels_first_gtable <- axis_position %in% c("left", "top") # refers to position in gtable 223 224 # set common parameters 225 n_breaks <- length(break_positions) 226 opposite_positions <- c("top" = "bottom", "bottom" = "top", "right" = "left", "left" = "right") 227 axis_position_opposite <- unname(opposite_positions[axis_position]) 228 229 # draw elements 230 line_grob <- exec( 231 element_grob, line_element, 232 !!position_dim := unit(c(0, 1), "npc"), 233 !!non_position_dim := unit.c(non_position_panel, non_position_panel) 234 ) 235 236 if (n_breaks == 0) { 237 return( 238 absoluteGrob( 239 gList(line_grob), 240 width = grobWidth(line_grob), 241 height = grobHeight(line_grob) 242 ) 243 ) 244 } 245 246 # break_labels can be a list() of language objects 247 if (is.list(break_labels)) { 248 if (any(vapply(break_labels, is.language, logical(1)))) { 249 break_labels <- do.call(expression, break_labels) 250 } else { 251 break_labels <- unlist(break_labels) 252 } 253 } 254 255 # calculate multiple rows/columns of labels (which is usually 1) 256 dodge_pos <- rep(seq_len(n.dodge), length.out = n_breaks) 257 dodge_indices <- split(seq_len(n_breaks), dodge_pos) 258 259 label_grobs <- lapply(dodge_indices, function(indices) { 260 draw_axis_labels( 261 break_positions = break_positions[indices], 262 break_labels = break_labels[indices], 263 label_element = label_element, 264 is_vertical = is_vertical, 265 check.overlap = check.overlap 266 ) 267 }) 268 269 ticks_grob <- exec( 270 element_grob, tick_element, 271 !!position_dim := rep(unit(break_positions, "native"), each = 2), 272 !!non_position_dim := rep( 273 unit.c(non_position_panel + (tick_direction * tick_length), non_position_panel)[tick_coordinate_order], 274 times = n_breaks 275 ), 276 id.lengths = rep(2, times = n_breaks) 277 ) 278 279 # create gtable 280 non_position_sizes <- paste0(non_position_size, "s") 281 label_dims <- do.call(unit.c, lapply(label_grobs, measure_labels_non_pos)) 282 grobs <- c(list(ticks_grob), label_grobs) 283 grob_dims <- unit.c(max(tick_length, unit(0, "pt")), label_dims) 284 285 if (labels_first_gtable) { 286 grobs <- rev(grobs) 287 grob_dims <- rev(grob_dims) 288 } 289 290 gt <- exec( 291 gtable_element, 292 name = "axis", 293 grobs = grobs, 294 !!non_position_sizes := grob_dims, 295 !!position_size := unit(1, "npc") 296 ) 297 298 # create viewport 299 justvp <- exec( 300 viewport, 301 !!non_position_dim := non_position_panel, 302 !!non_position_size := measure_gtable(gt), 303 just = axis_position_opposite 304 ) 305 306 absoluteGrob( 307 gList(line_grob, gt), 308 width = gtable_width(gt), 309 height = gtable_height(gt), 310 vp = justvp 311 ) 312} 313 314draw_axis_labels <- function(break_positions, break_labels, label_element, is_vertical, 315 check.overlap = FALSE) { 316 317 position_dim <- if (is_vertical) "y" else "x" 318 label_margin_name <- if (is_vertical) "margin_x" else "margin_y" 319 320 n_breaks <- length(break_positions) 321 break_positions <- unit(break_positions, "native") 322 323 if (check.overlap) { 324 priority <- axis_label_priority(n_breaks) 325 break_labels <- break_labels[priority] 326 break_positions <- break_positions[priority] 327 } 328 329 labels_grob <- exec( 330 element_grob, label_element, 331 !!position_dim := break_positions, 332 !!label_margin_name := TRUE, 333 label = break_labels, 334 check.overlap = check.overlap 335 ) 336} 337 338#' Determine the label priority for a given number of labels 339#' 340#' @param n The number of labels 341#' 342#' @return The vector `seq_len(n)` arranged such that the 343#' first, last, and middle elements are recursively 344#' placed at the beginning of the vector. 345#' @noRd 346#' 347axis_label_priority <- function(n) { 348 if (n <= 0) { 349 return(numeric(0)) 350 } 351 352 c(1, n, axis_label_priority_between(1, n)) 353} 354 355axis_label_priority_between <- function(x, y) { 356 n <- y - x + 1 357 if (n <= 2) { 358 return(numeric(0)) 359 } 360 361 mid <- x - 1 + (n + 1) %/% 2 362 c( 363 mid, 364 axis_label_priority_between(x, mid), 365 axis_label_priority_between(mid, y) 366 ) 367} 368 369#' Override axis text angle and alignment 370#' 371#' @param axis_position One of bottom, left, top, or right 372#' @param angle The text angle, or NULL to override nothing 373#' 374#' @return An [element_text()] that contains parameters that should be 375#' overridden from the user- or theme-supplied element. 376#' @noRd 377#' 378axis_label_element_overrides <- function(axis_position, angle = NULL) { 379 if (is.null(angle)) { 380 return(element_text(angle = NULL, hjust = NULL, vjust = NULL)) 381 } 382 383 # it is not worth the effort to align upside-down labels properly 384 if (angle > 90 || angle < -90) { 385 abort("`angle` must be between 90 and -90") 386 } 387 388 if (axis_position == "bottom") { 389 element_text( 390 angle = angle, 391 hjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, 392 vjust = if (abs(angle) == 90) 0.5 else 1 393 ) 394 } else if (axis_position == "left") { 395 element_text( 396 angle = angle, 397 hjust = if (abs(angle) == 90) 0.5 else 1, 398 vjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, 399 ) 400 } else if (axis_position == "top") { 401 element_text( 402 angle = angle, 403 hjust = if (angle > 0) 0 else if (angle < 0) 1 else 0.5, 404 vjust = if (abs(angle) == 90) 0.5 else 0 405 ) 406 } else if (axis_position == "right") { 407 element_text( 408 angle = angle, 409 hjust = if (abs(angle) == 90) 0.5 else 0, 410 vjust = if (angle > 0) 1 else if (angle < 0) 0 else 0.5, 411 ) 412 } else { 413 abort(glue("Unrecognized position: '{axis_position}'")) 414 } 415} 416 417warn_for_guide_position <- function(guide) { 418 # This is trying to catch when a user specifies a position perpendicular 419 # to the direction of the axis (e.g., a "y" axis on "top"). 420 # The strategy is to check that two or more unique breaks are mapped 421 # to the same value along the axis. 422 breaks_are_unique <- !duplicated(guide$key$.value) 423 if (empty(guide$key) || sum(breaks_are_unique) == 1) { 424 return() 425 } 426 427 if (guide$position %in% c("top", "bottom")) { 428 position_aes <- "x" 429 } else if(guide$position %in% c("left", "right")) { 430 position_aes <- "y" 431 } else { 432 return() 433 } 434 435 if (length(unique(guide$key[[position_aes]][breaks_are_unique])) == 1) { 436 warn("Position guide is perpendicular to the intended axis. Did you mean to specify a different guide `position`?") 437 } 438} 439