1#' A binned version of guide_legend 2#' 3#' This guide is a version of the [guide_legend()] guide for binned scales. It 4#' differs in that it places ticks correctly between the keys, and sports a 5#' small axis to better show the binning. Like [guide_legend()] it can be used 6#' for all non-position aesthetics though colour and fill defaults to 7#' [guide_coloursteps()], and it will merge aesthetics together into the same 8#' guide if they are mapped in the same way. 9#' 10#' @inheritParams guide_legend 11#' @param axis Logical. Should a small axis be drawn along the guide 12#' @param axis.colour,axis.linewidth Graphic specifications for the look of the 13#' axis. 14#' @param axis.arrow A call to `arrow()` to specify arrows at the end of the 15#' axis line, thus showing an open interval. 16#' @param show.limits Logical. Should the limits of the scale be shown with 17#' labels and ticks. 18#' 19#' @section Use with discrete scale: 20#' This guide is intended to show binned data and work together with ggplot2's 21#' binning scales. However, it is sometimes desirable to perform the binning in 22#' a separate step, either as part of a stat (e.g. [stat_contour_filled()]) or 23#' prior to the visualisation. If you want to use this guide for discrete data 24#' the levels must follow the naming scheme implemented by [base::cut()]. This 25#' means that a bin must be encoded as `"(<lower>, <upper>]"` with `<lower>` 26#' giving the lower bound of the bin and `<upper>` giving the upper bound 27#' (`"[<lower>, <upper>)"` is also accepted). If you use [base::cut()] to 28#' perform the binning everything should work as expected, if not, some recoding 29#' may be needed. 30#' 31#' @return A guide object 32#' @family guides 33#' @export 34#' 35#' @examples 36#' p <- ggplot(mtcars) + 37#' geom_point(aes(disp, mpg, size = hp)) + 38#' scale_size_binned() 39#' 40#' # Standard look 41#' p 42#' 43#' # Remove the axis or style it 44#' p + guides(size = guide_bins(axis = FALSE)) 45#' 46#' p + guides(size = guide_bins(show.limits = TRUE)) 47#' 48#' p + guides(size = guide_bins( 49#' axis.arrow = arrow(length = unit(1.5, 'mm'), ends = 'both') 50#' )) 51#' 52#' # Guides are merged together if possible 53#' ggplot(mtcars) + 54#' geom_point(aes(disp, mpg, size = hp, colour = hp)) + 55#' scale_size_binned() + 56#' scale_colour_binned(guide = "bins") 57#' 58guide_bins <- function( 59 # title 60 title = waiver(), 61 title.position = NULL, 62 title.theme = NULL, 63 title.hjust = NULL, 64 title.vjust = NULL, 65 66 # label 67 label = TRUE, 68 label.position = NULL, 69 label.theme = NULL, 70 label.hjust = NULL, 71 label.vjust = NULL, 72 73 # key 74 keywidth = NULL, 75 keyheight = NULL, 76 77 # ticks 78 axis = TRUE, 79 axis.colour = "black", 80 axis.linewidth = 0.5, 81 axis.arrow = NULL, 82 83 # general 84 direction = NULL, 85 default.unit = "line", 86 override.aes = list(), 87 reverse = FALSE, 88 order = 0, 89 show.limits = NULL, 90 ...) { 91 92 structure(list( 93 # title 94 title = title, 95 title.position = title.position, 96 title.theme = title.theme, 97 title.hjust = title.hjust, 98 title.vjust = title.vjust, 99 100 # label 101 label = label, 102 label.position = label.position, 103 label.theme = label.theme, 104 label.hjust = label.hjust, 105 label.vjust = label.vjust, 106 107 # key 108 keywidth = keywidth, 109 keyheight = keyheight, 110 111 # ticks 112 axis = axis, 113 axis.colour = axis.colour, 114 axis.linewidth = axis.linewidth, 115 axis.arrow = axis.arrow, 116 117 # general 118 direction = direction, 119 override.aes = rename_aes(override.aes), 120 default.unit = default.unit, 121 reverse = reverse, 122 order = order, 123 show.limits = show.limits, 124 125 # parameter 126 available_aes = c("any"), 127 ..., 128 name = "bins"), 129 class = c("guide", "bins") 130 ) 131} 132 133#' @export 134guide_train.bins <- function(guide, scale, aesthetic = NULL) { 135 breaks <- scale$get_breaks() 136 breaks <- breaks[!is.na(breaks)] 137 if (length(breaks) == 0 || all(is.na(breaks))) { 138 return() 139 } 140 # in the key data frame, use either the aesthetic provided as 141 # argument to this function or, as a fall back, the first in the vector 142 # of possible aesthetics handled by the scale 143 aes_column_name <- aesthetic %||% scale$aesthetics[1] 144 145 if (is.numeric(breaks)) { 146 limits <- scale$get_limits() 147 breaks <- breaks[!breaks %in% limits] 148 all_breaks <- c(limits[1], breaks, limits[2]) 149 bin_at <- all_breaks[-1] - diff(all_breaks) / 2 150 } else { 151 # If the breaks are not numeric it is used with a discrete scale. We check 152 # if the breaks follow the allowed format "(<lower>, <upper>]", and if it 153 # does we convert it into bin specs 154 bin_at <- breaks 155 breaks <- as.character(breaks) 156 breaks <- strsplit(gsub("\\(|\\)|\\[|\\]", "", breaks), ",\\s?") 157 breaks <- as.numeric(unlist(breaks)) 158 if (anyNA(breaks)) { 159 abort('Breaks not formatted correctly for a bin legend. Use `(<lower>, <upper>]` format to indicate bins') 160 } 161 all_breaks <- breaks[c(1, seq_along(bin_at) * 2)] 162 } 163 key <- new_data_frame(setNames(list(c(scale$map(bin_at), NA)), aes_column_name)) 164 key$.label <- scale$get_labels(all_breaks) 165 guide$show.limits <- guide$show.limits %||% scale$show_limits %||% FALSE 166 167 if (guide$reverse) { 168 key <- key[rev(seq_len(nrow(key))), ] 169 # Move last row back to last 170 aesthetics <- setdiff(names(key), ".label") 171 key[, aesthetics] <- key[c(seq_len(nrow(key))[-1], 1), aesthetics] 172 } 173 174 guide$key <- key 175 guide$hash <- with( 176 guide, 177 digest::digest(list(title, key$.label, direction, name)) 178 ) 179 guide 180} 181 182#' @export 183guide_merge.bins <- function(guide, new_guide) { 184 guide$key <- merge(guide$key, new_guide$key, sort = FALSE) 185 guide$override.aes <- c(guide$override.aes, new_guide$override.aes) 186 if (any(duplicated(names(guide$override.aes)))) { 187 warn("Duplicated override.aes is ignored.") 188 } 189 guide$override.aes <- guide$override.aes[!duplicated(names(guide$override.aes))] 190 guide 191} 192 193#' @export 194guide_geom.bins <- function(guide, layers, default_mapping) { 195 # arrange common data for vertical and horizontal guide 196 guide$geoms <- lapply(layers, function(layer) { 197 matched <- matched_aes(layer, guide) 198 199 # check if this layer should be included 200 include <- include_layer_in_guide(layer, matched) 201 202 if (!include) { 203 return(NULL) 204 } 205 206 if (length(matched) > 0) { 207 # Filter out set aesthetics that can't be applied to the legend 208 n <- vapply(layer$aes_params, length, integer(1)) 209 params <- layer$aes_params[n == 1] 210 211 aesthetics <- layer$computed_mapping 212 modifiers <- aesthetics[is_scaled_aes(aesthetics) | is_staged_aes(aesthetics)] 213 214 data <- tryCatch( 215 layer$geom$use_defaults(guide$key[matched], params, modifiers), 216 error = function(...) { 217 warn("Failed to apply `after_scale()` modifications to legend") 218 layer$geom$use_defaults(guide$key[matched], params, list()) 219 } 220 ) 221 } else { 222 data <- layer$geom$use_defaults(NULL, layer$aes_params)[rep(1, nrow(guide$key)), ] 223 } 224 225 # override.aes in guide_legend manually changes the geom 226 data <- modify_list(data, guide$override.aes) 227 228 list( 229 draw_key = layer$geom$draw_key, 230 data = data, 231 params = c(layer$computed_geom_params, layer$computed_stat_params) 232 ) 233 }) 234 235 # remove null geom 236 guide$geoms <- compact(guide$geoms) 237 238 # Finally, remove this guide if no layer is drawn 239 if (length(guide$geoms) == 0) guide <- NULL 240 guide 241} 242 243#' @export 244guide_gengrob.bins <- function(guide, theme) { 245 if (!guide$show.limits) { 246 guide$key$.label[c(1, nrow(guide$key))] <- NA 247 } 248 249 # default setting 250 if (guide$direction == "horizontal") { 251 label.position <- guide$label.position %||% "bottom" 252 if (!label.position %in% c("top", "bottom")) { 253 warn("Ignoring invalid label.position") 254 label.position <- "bottom" 255 } 256 } else { 257 label.position <- guide$label.position %||% "right" 258 if (!label.position %in% c("left", "right")) { 259 warn("Ignoring invalid label.position") 260 label.position <- "right" 261 } 262 } 263 264 n_keys <- nrow(guide$key) - 1 265 266 # obtain the theme for the legend title. We need this both for the title grob 267 # and to obtain the title fontsize. 268 title.theme <- guide$title.theme %||% calc_element("legend.title", theme) 269 270 title.hjust <- guide$title.hjust %||% theme$legend.title.align %||% title.theme$hjust %||% 0 271 title.vjust <- guide$title.vjust %||% title.theme$vjust %||% 0.5 272 273 grob.title <- ggname("guide.title", 274 element_grob( 275 title.theme, 276 label = guide$title, 277 hjust = title.hjust, 278 vjust = title.vjust, 279 margin_x = TRUE, 280 margin_y = TRUE 281 ) 282 ) 283 284 title_width <- width_cm(grob.title) 285 title_height <- height_cm(grob.title) 286 title_fontsize <- title.theme$size %||% calc_element("legend.title", theme)$size %||% 287 calc_element("text", theme)$size %||% 11 288 289 # gap between keys etc 290 # the default horizontal and vertical gap need to be the same to avoid strange 291 # effects for certain guide layouts 292 hgap <- width_cm(theme$legend.spacing.x %||% (0.5 * unit(title_fontsize, "pt"))) 293 vgap <- height_cm(theme$legend.spacing.y %||% (0.5 * unit(title_fontsize, "pt"))) 294 295 # Labels 296 297 # first get the label theme, we need it below even when there are no labels 298 label.theme <- guide$label.theme %||% calc_element("legend.text", theme) 299 300 if (!guide$label || is.null(guide$key$.label)) { 301 grob.labels <- rep(list(zeroGrob()), nrow(guide$key)) 302 } else { 303 # get the defaults for label justification. The defaults are complicated and depend 304 # on the direction of the legend and on label placement 305 just_defaults <- label_just_defaults.bins(guide$direction, label.position) 306 # don't set expressions left-justified 307 if (just_defaults$hjust == 0 && any(is.expression(guide$key$.label))) just_defaults$hjust <- 1 308 309 # We break inheritance for hjust and vjust, because that's more intuitive here; it still allows manual 310 # setting of hjust and vjust if desired. The alternative is to ignore hjust and vjust altogether, which 311 # seems worse 312 if (is.null(guide$label.theme$hjust) && is.null(theme$legend.text$hjust)) label.theme$hjust <- NULL 313 if (is.null(guide$label.theme$vjust) && is.null(theme$legend.text$vjust)) label.theme$vjust <- NULL 314 315 # label.theme in param of guide_legend() > theme$legend.text.align > default 316 hjust <- guide$label.hjust %||% theme$legend.text.align %||% label.theme$hjust %||% 317 just_defaults$hjust 318 vjust <- guide$label.vjust %||% label.theme$vjust %||% 319 just_defaults$vjust 320 321 grob.labels <- lapply(guide$key$.label, function(label, ...) { 322 g <- element_grob( 323 element = label.theme, 324 label = label, 325 hjust = hjust, 326 vjust = vjust, 327 margin_x = TRUE, 328 margin_y = TRUE 329 ) 330 ggname("guide.label", g) 331 }) 332 if (!guide$show.limits) { 333 grob.labels[c(1, length(grob.labels))] <- list(zeroGrob()) 334 } 335 } 336 337 label_widths <- width_cm(grob.labels) 338 label_heights <- height_cm(grob.labels) 339 340 # Keys 341 key_width <- width_cm( 342 guide$keywidth %||% theme$legend.key.width %||% theme$legend.key.size 343 ) 344 key_height <- height_cm( 345 guide$keyheight %||% theme$legend.key.height %||% theme$legend.key.size 346 ) 347 348 key_size_mat <- do.call("cbind", 349 lapply(guide$geoms, function(g) g$data$size / 10) 350 ) 351 352 # key_size_mat can be an empty matrix (e.g. the data doesn't contain size 353 # column), so subset it only when it has any rows and columns. 354 if (nrow(key_size_mat) == 0 || ncol(key_size_mat) == 0) { 355 key_size_mat <- matrix(0, ncol = 1, nrow = n_keys) 356 } else { 357 key_size_mat <- key_size_mat[seq_len(n_keys), , drop = FALSE] 358 } 359 key_sizes <- apply(key_size_mat, 1, max) 360 361 if (guide$direction == "horizontal") { 362 key.nrow <- 1 363 key.ncol <- n_keys 364 label.nrow <- 1 365 label.ncol <- n_keys + 1 366 } else { 367 key.nrow <- n_keys 368 key.ncol <- 1 369 label.nrow <- n_keys + 1 370 label.ncol <- 1 371 } 372 373 key_sizes <- matrix(key_sizes, key.nrow, key.ncol) 374 label_sizes <- matrix(label_widths, label.nrow, label.ncol) 375 376 key_widths <- max(key_width, apply(key_sizes, 2, max)) 377 key_heights <- max(key_height, apply(key_sizes, 1, max)) 378 379 label_widths <- max(apply(label_sizes, 2, max)) 380 label_heights <- max(apply(label_sizes, 1, max)) 381 382 key_loc <- data_frame( 383 R = seq(2, by = 2, length.out = n_keys), 384 C = if (label.position %in% c("right", "bottom")) 1 else 3 385 ) 386 label_loc <- data_frame( 387 R = seq(1, by = 2, length.out = n_keys + 1), 388 C = if (label.position %in% c("right", "bottom")) 3 else 1 389 ) 390 tick_loc <- label_loc 391 tick_loc$C <- if (label.position %in% c("right", "bottom")) 1 else 3 392 393 widths <- c(key_widths, hgap, label_widths) 394 if (label.position != "right") widths <- rev(widths) 395 heights <- c(interleave(rep(0, n_keys), key_heights), 0) 396 if (guide$direction == "horizontal") { 397 names(key_loc) <- c("C", "R") 398 names(label_loc) <- c("C", "R") 399 names(tick_loc) <- c("C", "R") 400 heights <- c(key_heights, vgap, label_heights) 401 if (label.position != "bottom") heights <- rev(heights) 402 widths <- c(interleave(rep(0, n_keys), key_widths), 0) 403 } 404 405 # layout the title over key-label 406 switch(guide$title.position, 407 "top" = { 408 widths <- c(widths, max(0, title_width - sum(widths))) 409 heights <- c(title_height, vgap, heights) 410 key_loc$R <- key_loc$R + 2 411 label_loc$R <- label_loc$R + 2 412 tick_loc$R <- tick_loc$R + 2 413 title_row = 1 414 title_col = seq_along(widths) 415 }, 416 "bottom" = { 417 widths <- c(widths, max(0, title_width - sum(widths))) 418 heights <- c(heights, vgap, title_height) 419 title_row = length(heights) 420 title_col = seq_along(widths) 421 }, 422 "left" = { 423 widths <- c(title_width, hgap, widths) 424 heights <- c(heights, max(0, title_height - sum(heights))) 425 key_loc$C <- key_loc$C + 2 426 label_loc$C <- label_loc$C + 2 427 tick_loc$C <- tick_loc$C + 2 428 title_row = seq_along(heights) 429 title_col = 1 430 }, 431 "right" = { 432 widths <- c(widths, hgap, title_width) 433 heights <- c(heights, max(0, title_height - sum(heights))) 434 title_row = seq_along(heights) 435 title_col = length(widths) 436 } 437 ) 438 439 # grob for key 440 key_size <- c(key_width, key_height) * 10 441 442 draw_key <- function(i) { 443 bg <- element_render(theme, "legend.key") 444 keys <- lapply(guide$geoms, function(g) { 445 g$draw_key(g$data[i, ], g$params, key_size) 446 }) 447 c(list(bg), keys) 448 } 449 grob.keys <- unlist(lapply(seq_len(n_keys), draw_key), recursive = FALSE) 450 451 # background 452 grob.background <- element_render(theme, "legend.background") 453 454 ngeom <- length(guide$geoms) + 1 455 kcols <- rep(key_loc$C, each = ngeom) 456 krows <- rep(key_loc$R, each = ngeom) 457 458 # padding 459 padding <- convertUnit(theme$legend.margin %||% margin(), "cm", valueOnly = TRUE) 460 widths <- c(padding[4], widths, padding[2]) 461 heights <- c(padding[1], heights, padding[3]) 462 463 # make the ticks grob (`grob.ticks`) 464 if (!guide$axis) { 465 grob.ticks <- zeroGrob() 466 grob.axis <- zeroGrob() 467 } else { 468 if (guide$direction == "horizontal") { 469 x0 <- 0.5 470 y0 <- 0 471 x1 <- 0.5 472 y1 <- 1/5 473 axis_x <- c(0, 1) 474 axis_y <- c(0, 0) 475 if (label.position == "top") { 476 y0 <- 4/5 477 y1 <- 1 478 axis_y <- c(1, 1) 479 } 480 } else { # guide$direction == "vertical" 481 y0 <- 0.5 482 x0 <- 4/5 483 y1 <- 0.5 484 x1 <- 1 485 axis_x <- c(1, 1) 486 axis_y <- c(0, 1) 487 if (label.position == "left") { 488 x0 <- 0 489 x1 <- 1/5 490 axis_x <- c(0, 0) 491 } 492 } 493 grob.ticks <- segmentsGrob( 494 x0 = x0, y0 = y0, x1 = x1, y1 = y1, 495 default.units = "npc", 496 gp = gpar( 497 col = guide$axis.colour, 498 lwd = guide$axis.linewidth, 499 lineend = "butt" 500 ) 501 ) 502 grob.axis <- segmentsGrob( 503 x0 = axis_x[1], y0 = axis_y[1], x1 = axis_x[2], y1 = axis_y[2], 504 default.units = "npc", 505 arrow = guide$axis.arrow, 506 gp = gpar( 507 col = guide$axis.colour, 508 lwd = guide$axis.linewidth, 509 lineend = if (is.null(guide$axis.arrow)) "square" else "round" 510 ) 511 ) 512 } 513 grob.ticks <- rep_len(list(grob.ticks), length(grob.labels)) 514 if (!guide$show.limits) { 515 grob.ticks[c(1, length(grob.ticks))] <- list(zeroGrob()) 516 } 517 # Create the gtable for the legend 518 gt <- gtable(widths = unit(widths, "cm"), heights = unit(heights, "cm")) 519 gt <- gtable_add_grob( 520 gt, 521 grob.background, 522 name = "background", 523 clip = "off", 524 t = 1, 525 r = -1, 526 b = -1, 527 l = 1 528 ) 529 gt <- gtable_add_grob( 530 gt, 531 justify_grobs( 532 grob.title, 533 hjust = title.hjust, 534 vjust = title.vjust, 535 int_angle = title.theme$angle, 536 debug = title.theme$debug 537 ), 538 name = "title", 539 clip = "off", 540 t = 1 + min(title_row), 541 r = 1 + max(title_col), 542 b = 1 + max(title_row), 543 l = 1 + min(title_col) 544 ) 545 gt <- gtable_add_grob( 546 gt, 547 grob.keys, 548 name = paste("key", krows, kcols, c("bg", seq(ngeom - 1)), sep = "-"), 549 clip = "off", 550 t = 1 + krows, 551 r = 1 + kcols, 552 b = 1 + krows, 553 l = 1 + kcols 554 ) 555 gt <- gtable_add_grob( 556 gt, 557 grob.ticks, 558 name = paste("tick", tick_loc$R, tick_loc$C, sep = "-"), 559 clip = "off", 560 t = 1 + tick_loc$R, 561 r = 1 + tick_loc$C, 562 b = 1 + tick_loc$R, 563 l = 1 + tick_loc$C 564 ) 565 gt <- gtable_add_grob( 566 gt, 567 grob.axis, 568 name = "axis", 569 clip = "off", 570 t = min(1 + tick_loc$R), 571 r = min(1 + tick_loc$C), 572 b = max(1 + tick_loc$R), 573 l = max(1 + tick_loc$C) 574 ) 575 gt <- gtable_add_grob( 576 gt, 577 justify_grobs( 578 grob.labels, 579 hjust = hjust, 580 vjust = vjust, 581 int_angle = label.theme$angle, 582 debug = label.theme$debug 583 ), 584 name = paste("label", label_loc$R, label_loc$C, sep = "-"), 585 clip = "off", 586 t = 1 + label_loc$R, 587 r = 1 + label_loc$C, 588 b = 1 + label_loc$R, 589 l = 1 + label_loc$C 590 ) 591 gt 592} 593 594#' Calculate the default hjust and vjust settings depending on legend 595#' direction and position. 596#' 597#' @noRd 598label_just_defaults.bins <- function(direction, position) { 599 if (direction == "horizontal") { 600 switch( 601 position, 602 "top" = list(hjust = 0.5, vjust = 0), 603 "bottom" = list(hjust = 0.5, vjust = 1), 604 "left" = list(hjust = 1, vjust = 0.5), 605 list(hjust = 0.5, vjust = 0.5) 606 ) 607 } 608 else { 609 switch( 610 position, 611 "top" = list(hjust = 0.5, vjust = 0), 612 "bottom" = list(hjust = 0.5, vjust = 1), 613 "left" = list(hjust = 1, vjust = 0.5), 614 list(hjust = 0, vjust = 0.5) 615 ) 616 617 } 618} 619