WIP: Missing values in colourbars

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
     }

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,42 +384,42 @@ 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(
         x = x, y = y,
         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
+    )
   }
 )

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,21 +193,34 @@ 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
       }
       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)
   }
 )

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) {