Make bin guides compatible with discrete scales (#3703)

Author: thomasp85

R/guide-bins.R

@@ -16,6 +16,18 @@
 #' @param show.limits Logical. Should the limits of the scale be shown with
 #'   labels and ticks.
 #'
+#' @section Use with discrete scale:
+#' This guide is intended to show binned data and work together with ggplot2's
+#' binning scales. However, it is sometimes desirable to perform the binning in
+#' a separate step, either as part of a stat (e.g. [stat_contour_filled()]) or
+#' prior to the visualisation. If you want to use this guide for discrete data
+#' the levels must follow the naming scheme implemented by [base::cut()]. This
+#' means that a bin must be encoded as `"(<lower>, <upper>]"` with `<lower>`
+#' giving the lower bound of the bin and `<upper>` giving the upper bound
+#' (`"[<lower>, <upper>)"` is also accepted). If you use [base::cut()] to
+#' perform the binning everything should work as expected, if not, some recoding
+#' may be needed.
+#'
 #' @return A guide object
 #' @family guides
 #' @export
@@ -123,13 +135,28 @@ guide_train.bins <- function(guide, scale, aesthetic = NULL) {
   if (length(breaks) == 0 || all(is.na(breaks))) {
     return()
   }
-  limits <- scale$get_limits()
-  all_breaks <- c(limits[1], breaks, limits[2])
-  bin_at <- all_breaks[-1] - diff(all_breaks) / 2
   # in the key data frame, use either the aesthetic provided as
   # argument to this function or, as a fall back, the first in the vector
   # of possible aesthetics handled by the scale
   aes_column_name <- aesthetic %||% scale$aesthetics[1]
+
+  if (is.numeric(breaks)) {
+    limits <- scale$get_limits()
+    all_breaks <- c(limits[1], breaks, limits[2])
+    bin_at <- all_breaks[-1] - diff(all_breaks) / 2
+  } else {
+    # If the breaks are not numeric it is used with a discrete scale. We check
+    # if the breaks follow the allowed format "(<lower>, <upper>]", and if it
+    # does we convert it into bin specs
+    bin_at <- breaks
+    breaks <- as.character(breaks)
+    breaks <- strsplit(gsub("\\(|\\)|\\[|\\]", "", breaks), ",\\s?")
+    breaks <- as.numeric(unlist(breaks))
+    if (anyNA(breaks)) {
+      abort('Breaks not formatted correctly for a bin legend. Use `(<lower>, <upper>]` format to indicate bins')
+    }
+    all_breaks <- breaks[c(1, seq_along(bin_at) * 2)]
+  }
   key <- new_data_frame(setNames(list(c(scale$map(bin_at), NA)), aes_column_name))
   key$.label <- scale$get_labels(all_breaks)
   guide$show.limits <- guide$show.limits %||% scale$show_limits %||% FALSE

R/guide-colorsteps.R

@@ -12,6 +12,8 @@
 #'   visible.
 #' @inheritDotParams guide_colourbar -nbin -raster -ticks -available_aes
 #'
+#' @inheritSection guide_bins Use with discrete scale
+#'
 #' @return A guide object
 #' @export
 #'
@@ -54,30 +56,49 @@ guide_colorsteps <- guide_coloursteps
 
 #' @export
 guide_train.colorsteps <- function(guide, scale, aesthetic = NULL) {
-  if (guide$even.steps) {
-    breaks <- scale$get_breaks()
-    if (length(breaks) == 0 || all(is.na(breaks)))
+  breaks <- scale$get_breaks()
+  if (guide$even.steps || !is.numeric(breaks)) {
+    if (length(breaks) == 0 || all(is.na(breaks))) {
       return()
-    limits <- scale$get_limits()
-    all_breaks <- c(limits[1], breaks, limits[2])
-    bin_at <- all_breaks[-1] - diff(all_breaks) / 2
+    }
+    if (is.numeric(breaks)) {
+      limits <- scale$get_limits()
+      all_breaks <- c(limits[1], breaks, limits[2])
+      bin_at <- all_breaks[-1] - diff(all_breaks) / 2
+    } else {
+      # If the breaks are not numeric it is used with a discrete scale. We check
+      # if the breaks follow the allowed format "(<lower>, <upper>]", and if it
+      # does we convert it into bin specs
+      bin_at <- breaks
+      breaks_num <- as.character(breaks)
+      breaks_num <- strsplit(gsub("\\(|\\)|\\[|\\]", "", breaks_num), ",\\s?")
+      breaks_num <- as.numeric(unlist(breaks_num))
+      if (anyNA(breaks_num)) {
+        abort('Breaks not formatted correctly for a bin legend. Use `(<lower>, <upper>]` format to indicate bins')
+      }
+      all_breaks <- breaks_num[c(1, seq_along(breaks) * 2)]
+      limits <- all_breaks[c(1, length(all_breaks))]
+      breaks <- all_breaks[-c(1, length(all_breaks))]
+    }
     ticks <- new_data_frame(setNames(list(scale$map(breaks)), aesthetic %||% scale$aesthetics[1]))
     ticks$.value <- seq_along(breaks) - 0.5
     ticks$.label <- scale$get_labels(breaks)
     guide$nbin <- length(breaks) + 1
     guide$key <- ticks
     guide$bar <- new_data_frame(list(colour = scale$map(bin_at), value = seq_along(bin_at) - 1), n = length(bin_at))
+
     if (guide$reverse) {
       guide$key <- guide$key[nrow(guide$key):1, ]
       guide$bar <- guide$bar[nrow(guide$bar):1, ]
     }
     guide$hash <- with(guide, digest::digest(list(title, key$.label, bar, name)))
   } else {
     guide <- NextMethod()
+    limits <- scale$get_limits()
   }
   if (guide$show.limits %||% scale$show.limits %||% FALSE) {
     edges <- rescale(c(0, 1), to = guide$bar$value[c(1, nrow(guide$bar))], from = c(0.5, guide$nbin - 0.5) / guide$nbin)
-    limits <- scale$get_limits()
+    if (guide$reverse) edges <- rev(edges)
     guide$key <- guide$key[c(NA, seq_len(nrow(guide$key)), NA), , drop = FALSE]
     guide$key$.value[c(1, nrow(guide$key))] <- edges
     guide$key$.label[c(1, nrow(guide$key))] <- scale$get_labels(limits)

R/scale-.r

@@ -848,7 +848,6 @@ ScaleDiscrete <- ggproto("ScaleDiscrete", Scale,
     }
 
     if (is.waive(self$labels)) {
-      breaks <- self$get_breaks()
       if (is.numeric(breaks)) {
         # Only format numbers, because on Windows, format messes up encoding
         format(breaks, justify = "none")

R/stat-contour.r

@@ -108,7 +108,7 @@ StatContourFilled <- ggproto("StatContourFilled", Stat,
     names(isobands) <- pretty_isoband_levels(names(isobands))
     path_df <- iso_to_polygon(isobands, data$group[1])
 
-    path_df$level <- factor(path_df$level, levels = names(isobands))
+    path_df$level <- ordered(path_df$level, levels = names(isobands))
 
     path_df
   }