diff --git a/R/guide-.R b/R/guide-.R index 0a334c4580..55b0462755 100644 --- a/R/guide-.R +++ b/R/guide-.R @@ -233,7 +233,11 @@ Guide <- ggproto( if (is.numeric(breaks)) { range <- scale$continuous_range %||% scale$get_limits() - key <- vec_slice(key, is.finite(oob_censor_any(breaks, range))) + keep <- is.finite(oob_censor_any(breaks, range)) + if (!is.na(scale$na.value %||% NA)) { + keep <- keep | is.na(breaks) & !is.na(mapped) + } + key <- vec_slice(key, keep) } else { key } diff --git a/R/guide-colorbar.R b/R/guide-colorbar.R index ca63f29b54..7969f113b5 100644 --- a/R/guide-colorbar.R +++ b/R/guide-colorbar.R @@ -124,6 +124,7 @@ guide_colourbar <- function( alpha = NA, draw.ulim = TRUE, draw.llim = TRUE, + override.aes = list(), position = NULL, direction = NULL, reverse = FALSE, @@ -152,6 +153,7 @@ guide_colourbar <- function( display = display, alpha = alpha, draw_lim = c(isTRUE(draw.llim), isTRUE(draw.ulim)), + override.aes = override.aes, position = position, direction = direction, reverse = reverse, @@ -188,6 +190,7 @@ GuideColourbar <- ggproto( alpha = NA, draw_lim = c(TRUE, TRUE), + override.aes = list(), # general direction = NULL, @@ -208,6 +211,7 @@ GuideColourbar <- ggproto( background = "legend.background", margin = "legend.margin", key = "legend.key", + key_size = "legend.key.size", key_height = "legend.key.height", key_width = "legend.key.width", text = "legend.text", @@ -217,6 +221,8 @@ GuideColourbar <- ggproto( axis_line = "legend.axis.line", ticks = "legend.ticks", ticks_length = "legend.ticks.length", + spacing_x = "legend.key.spacing.x", + spacing_y = "legend.key.spacing.y", frame = "legend.frame" ), @@ -269,7 +275,15 @@ GuideColourbar <- ggproto( return(list(guide = self, params = params)) }, - get_layer_key = function(params, layers, data = NULL) { + get_layer_key = function(params, ...) { + if (!anyNA(params$key$.value)) { + params$decor <- list(params$decor) + return(params) + } + temp <- params + temp$key <- vec_slice(temp$key, is.na(temp$key$.value)) + missing_decor <- GuideLegend$get_layer_key(temp, ...)$decor + params$decor <- c(list(params$decor), missing_decor) params }, @@ -291,6 +305,9 @@ GuideColourbar <- ggproto( theme$legend.key.height <- theme$legend.key.height * 5 valid_position <- c("right", "left") } + # Ensure legend spacing.y is populated to prevent backward compatibility + # in GuideLegend from overruling it + theme$legend.key.spacing.y <- theme$legend.key.spacing %||% rel(1) # Set defaults theme <- replace_null( @@ -348,11 +365,14 @@ GuideColourbar <- ggproto( }, build_decor = function(decor, grobs, elements, params) { + + bar_data <- decor[[1]] + if (params$display == "raster") { image <- switch( params$direction, - "horizontal" = t(decor$colour), - "vertical" = rev(decor$colour) + "horizontal" = t(bar_data$colour), + "vertical" = rev(bar_data$colour) ) grob <- rasterGrob( image = image, @@ -364,14 +384,14 @@ GuideColourbar <- ggproto( ) } else if (params$display == "rectangles") { if (params$direction == "horizontal") { - width <- 1 / nrow(decor) + width <- 1 / nrow(bar_data) height <- 1 - x <- (seq(nrow(decor)) - 1) * width + x <- (seq(nrow(bar_data)) - 1) * width y <- 0 } else { width <- 1 - height <- 1 / nrow(decor) - y <- (seq(nrow(decor)) - 1) * height + height <- 1 / nrow(bar_data) + y <- (seq(nrow(bar_data)) - 1) * height x <- 0 } grob <- rectGrob( @@ -379,27 +399,27 @@ GuideColourbar <- ggproto( vjust = 0, hjust = 0, width = width, height = height, default.units = "npc", - gp = gg_par(col = NA, fill = decor$colour) + gp = gg_par(col = NA, fill = bar_data$colour) ) } else if (params$display == "gradient") { check_device("gradients", call = expr(guide_colourbar())) value <- if (isTRUE(params$reverse)) { - rescale(decor$value, to = c(1, 0)) + rescale(bar_data$value, to = c(1, 0)) } else { - rescale(decor$value, to = c(0, 1)) + rescale(bar_data$value, to = c(0, 1)) } position <- switch( params$direction, horizontal = list(y1 = unit(0.5, "npc"), y2 = unit(0.5, "npc")), vertical = list(x1 = unit(0.5, "npc"), x2 = unit(0.5, "npc")) ) - gradient <- inject(linearGradient(decor$colour, value, !!!position)) + gradient <- inject(linearGradient(bar_data$colour, value, !!!position)) grob <- rectGrob(gp = gg_par(fill = gradient, col = NA)) } frame <- element_grob(elements$frame, fill = NA) - - list(bar = grob, frame = frame, ticks = grobs$ticks) + bar <- grobTree(bar = grob, frame = frame, ticks = grobs$ticks) + list(bar = bar) }, measure_grobs = function(grobs, params, elements) { @@ -408,5 +428,54 @@ GuideColourbar <- ggproto( heights = elements$height_cm ) GuideLegend$measure_grobs(grobs, params, elements) + }, + + assemble_drawing = function(self, grobs, layout, sizes, params, elements) { + + if (anyNA(params$key$.value) && length(params$decor) > 1) { + + missing_first <- xor(is.na(params$key$.value[1]), isTRUE(params$reverse)) + + # Render missing key + params$key <- vec_slice(params$key, is.na(params$key$.value)) + key <- GuideLegend$build_decor(params$decor[-1], list(), elements, params) + grobs$decor$missing <- inject(gTree(children = gList(!!!key))) + + # Render missing label + label <- GuideLegend$build_labels(params$key, elements, params) + grobs$labels$missing <- label[[1]] + + # Adjust layout and sizing + new <- vec_slice(layout, 1) + if (params$direction == "vertical") { + + if (missing_first) { + layout[c("key_row", "label_row")] <- layout[c("key_row", "label_row")] + 2 + sizes$heights <- c(height_cm(elements$key_size), elements$spacing_y, sizes$heights) + } else { + new[c("key_row", "label_row")] <- new[c("key_row", "label_row")] + 2 + sizes$heights <- c(sizes$heights, elements$spacing_y, height_cm(elements$key_size)) + } + sizes$widths[new$label_col] <- max(sizes$widths[new$label_col], width_cm(label)) + + } else { + + if (missing_first) { + layout[c("key_col", "label_col")] <- layout[c("key_col", "label_col")] + 2 + sizes$widths <- c(width_cm(elements$key_size), elements$spacing_x, sizes$widths) + } else { + new[c("key_col", "label_col")] <- new[c("key_col", "label_col")] + 2 + sizes$widths <- c(sizes$widths, elements$spacing_x, width_cm(elements$key_size)) + } + sizes$heights[new$label_row] <- max(sizes$heights[new$label_row], height_cm(label)) + + } + + layout <- vec_c(layout, new) + } + + ggproto_parent(GuideLegend, self)$assemble_drawing( + grobs, layout, sizes, params, elements + ) } ) diff --git a/R/guide-colorsteps.R b/R/guide-colorsteps.R index 52b6e1809d..f48e3efdbd 100644 --- a/R/guide-colorsteps.R +++ b/R/guide-colorsteps.R @@ -51,6 +51,7 @@ guide_coloursteps <- function( alpha = NA, even.steps = TRUE, show.limits = NULL, + override.aes = list(), direction = NULL, position = NULL, reverse = FALSE, @@ -68,6 +69,7 @@ guide_coloursteps <- function( alpha = alpha, even.steps = even.steps, show.limits = show.limits, + override.aes = override.aes, position = position, direction = direction, reverse = reverse, @@ -95,13 +97,14 @@ GuideColoursteps <- ggproto( extract_key = function(scale, aesthetic, even.steps, ...) { - breaks <- scale$get_breaks() + orig_breaks <- scale$get_breaks() + is_missing <- which(is.na(orig_breaks)) - if (!(even.steps || !is.numeric(breaks))) { + if (!(even.steps || !is.numeric(orig_breaks))) { return(Guide$extract_key(scale, aesthetic)) } - parsed <- parse_binned_breaks(scale, breaks) + parsed <- parse_binned_breaks(scale, orig_breaks) if (is.null(parsed)) { return(parsed) } @@ -114,7 +117,13 @@ GuideColoursteps <- ggproto( } else { key$.value <- breaks } - key$.label <- scale$get_labels(breaks) + + orig_labels <- NULL + if (length(is_missing) > 0) { + is_missing <- is_missing[1] + orig_labels <- scale$get_labels(orig_breaks)[match(breaks, orig_breaks)] + } + key$.label <- orig_labels %||% scale$get_labels(breaks) if (breaks[1] %in% limits) { key$.value <- key$.value - 1L @@ -123,6 +132,20 @@ GuideColoursteps <- ggproto( if (breaks[length(breaks)] %in% limits) { key[[1]][nrow(key)] <- NA } + + if (length(is_missing) > 0) { + missing <- data_frame0( + !!aesthetic := scale$map(orig_breaks[is_missing]), + .value = orig_breaks[is_missing], + .label = scale$get_labels(orig_breaks)[is_missing] + ) + if (is_missing == 1) { + key <- vec_c(missing, key) + } else { + key <- vec_c(key, missing) + } + } + # To avoid having to recalculate these variables in other methods, we # attach the parsed values as attributes. It might not be very elegant, # but it works. @@ -170,13 +193,20 @@ GuideColoursteps <- ggproto( show.limits <- FALSE } + key <- params$key if (show.limits) { - key <- params$key + # Separate NA-breaks from proper breaks + missing <- vec_slice(key, is.na(key$.value)) + key <- vec_slice(key, !is.na(key$.value)) + + # Add extra top and bottom rows for limits limits <- attr(key, "parsed")$limits %||% scale$get_limits() key <- key[c(NA, seq_len(nrow(key)), NA), , drop = FALSE] n <- nrow(key) key$.value[c(1, n)] <- range(params$decor$min, params$decor$max) key$.label[c(1, n)] <- scale$get_labels(limits) + + # Remove duplicates when e.g. outer breaks are included in limits if (key$.value[1] == key$.value[2]) { key <- vec_slice(key, -1) n <- n - 1 @@ -184,7 +214,13 @@ GuideColoursteps <- ggproto( if (key$.value[n - 1] == key$.value[n]) { key <- vec_slice(key, -n) } - params$key <- key + + # Reintroduce NA-breaks + if (is.na(params$key$.value[1])) { + key <- vec_c(missing, key) + } else { + key <- vec_c(key, missing) + } } params$title <- scale$make_title( @@ -195,34 +231,41 @@ GuideColoursteps <- ggproto( if (params$reverse) { limits <- rev(limits) } - params$key$.value <- rescale(params$key$.value, from = limits) - params$decor$min <- rescale(params$decor$min, from = limits) - params$decor$max <- rescale(params$decor$max, from = limits) - params$key <- - vec_slice(params$key, !is.na(oob_censor_any(params$key$.value))) + key$.value <- rescale(key$.value, from = limits) + params$decor$min <- rescale(params$decor$min, from = limits) + params$decor$max <- rescale(params$decor$max, from = limits) + + keep <- !is.na(oob_censor_any(key$.value)) + if (!is.na(scale$na.value %||% NA)) { + keep <- keep | is.na(key$.value) & !is.na(key[[params$aesthetic]]) + } + params$key <- vec_slice(key, keep) params }, build_decor = function(decor, grobs, elements, params) { - size <- abs(decor$max - decor$min) - just <- as.numeric(decor$min > decor$max) - gp <- gg_par(col = NA, fill = decor$colour) + bar_data <- decor[[1]] + + size <- abs(bar_data$max - bar_data$min) + just <- as.numeric(bar_data$min > bar_data$max) + gp <- gg_par(col = NA, fill = bar_data$colour) if (params$direction == "vertical") { grob <- rectGrob( - x = 0, y = decor$min, + x = 0, y = bar_data$min, width = 1, height = size, vjust = just, hjust = 0, gp = gp ) } else { grob <- rectGrob( - x = decor$min, y = 0, + x = bar_data$min, y = 0, height = 1, width = size, hjust = just, vjust = 0, gp = gp ) } frame <- element_grob(elements$frame, fill = NA) - list(bar = grob, frame = frame, ticks = grobs$ticks) + bar <- grobTree(bar = grob, frame = frame, ticks = grobs$ticks) + list(bar = bar) } ) diff --git a/R/guide-legend.R b/R/guide-legend.R index 95dba1cfa0..29188126f7 100644 --- a/R/guide-legend.R +++ b/R/guide-legend.R @@ -398,7 +398,7 @@ GuideLegend <- ggproto( }) c(list(bg), keys) } - unlist(lapply(seq_len(params$n_breaks), draw), FALSE) + unlist(lapply(seq_len(params$n_breaks %||% nrow(params$key)), draw), FALSE) }, build_labels = function(key, elements, params) { diff --git a/man/guide_colourbar.Rd b/man/guide_colourbar.Rd index 8e29943a44..9b010598f3 100644 --- a/man/guide_colourbar.Rd +++ b/man/guide_colourbar.Rd @@ -14,6 +14,7 @@ guide_colourbar( alpha = NA, draw.ulim = TRUE, draw.llim = TRUE, + override.aes = list(), position = NULL, direction = NULL, reverse = FALSE, @@ -31,6 +32,7 @@ guide_colorbar( alpha = NA, draw.ulim = TRUE, draw.llim = TRUE, + override.aes = list(), position = NULL, direction = NULL, reverse = FALSE, @@ -77,6 +79,9 @@ be visible.} \item{draw.llim}{A logical specifying if the lower limit tick marks should be visible.} +\item{override.aes}{A list specifying aesthetic parameters of legend key. +See details and examples.} + \item{position}{A character string indicating where the legend should be placed relative to the plot panels.} diff --git a/man/guide_coloursteps.Rd b/man/guide_coloursteps.Rd index a2938df745..04b0adcc7e 100644 --- a/man/guide_coloursteps.Rd +++ b/man/guide_coloursteps.Rd @@ -11,6 +11,7 @@ guide_coloursteps( alpha = NA, even.steps = TRUE, show.limits = NULL, + override.aes = list(), direction = NULL, position = NULL, reverse = FALSE, @@ -25,6 +26,7 @@ guide_colorsteps( alpha = NA, even.steps = TRUE, show.limits = NULL, + override.aes = list(), direction = NULL, position = NULL, reverse = FALSE, @@ -56,6 +58,9 @@ scale. This argument is ignored if \code{labels} is given as a vector of values. If one or both of the limits is also given in \code{breaks} it will be shown irrespective of the value of \code{show.limits}.} +\item{override.aes}{A list specifying aesthetic parameters of legend key. +See details and examples.} + \item{direction}{A character string indicating the direction of the guide. One of "horizontal" or "vertical."}