Massive binning refactoring

* New bins class with print method
* Three constructors for common use cases

Author: hadley

DESCRIPTION

@@ -65,6 +65,7 @@ Collate:
     'annotation.r'
     'autoplot.r'
     'bench.r'
+    'bin.R'
     'coord-.r'
     'coord-cartesian-.r'
     'coord-fixed.r'

NAMESPACE

@@ -91,6 +91,7 @@ S3method(predictdf,loess)
 S3method(print,element)
 S3method(print,facet)
 S3method(print,ggplot)
+S3method(print,ggplot2_bins)
 S3method(print,ggproto)
 S3method(print,ggproto_method)
 S3method(print,rel)

NEWS.md

@@ -77,14 +77,9 @@
       defaults to `pad = FALSE` which considerably improves the default limits 
       for the histogram, especially when the bins are big (#1477).
 
-    * The default algorithm does a better job at picking nice width and 
+    * The default algorithm does a better job at picking nice widths and 
       origins across a wider range of input data.
 
-    This change brings with the removal of some rarely used features:
-    
-    * The `breaks` argument is no longer supported - this was rarely used
-      and didn't work correctly for frequency polygons.
-      
 * `geom_tile()` uses `draw_key_polygon()` for better legend keys, including 
   coloured outline (#1484).
 

R/bin.R

@@ -0,0 +1,171 @@
+bins <- function(breaks, closed = c("right", "left"),
+                 fuzz = 1e-08 * median(diff(breaks))) {
+  stopifnot(is.numeric(breaks))
+  closed <- match.arg(closed)
+
+  breaks <- sort(breaks)
+  # Adapted base::hist - this protects from floating point rounding errors
+  if (closed == "right") {
+    fuzzes <- c(-fuzz, rep.int(fuzz, length(breaks) - 1))
+  } else {
+    fuzzes <- c(rep.int(-fuzz, length(breaks) - 1), fuzz)
+  }
+
+  structure(
+    list(
+      breaks = breaks,
+      fuzzy = breaks + fuzzes,
+      right_closed = closed == "right"
+    ),
+    class = "ggplot2_bins"
+  )
+}
+
+is_bins <- function(x) inherits(x, "ggplot2_bins")
+
+#' @export
+print.ggplot2_bins <- function(x, ...) {
+  n <- length(x$breaks)
+  cat("<Bins>\n")
+
+  if (x$right_closed) {
+    left <- c("[", rep("(", n - 2))
+    right <- rep("]", n - 1)
+  } else {
+    left <- rep("[", n - 1)
+    right <- c(rep(")", n - 2), "]")
+  }
+
+  breaks <- format(x$breaks)
+  bins <- paste0("* ", left, breaks[-n], ",", breaks[-1], right)
+  cat(bins, sep = "\n")
+  cat("\n")
+}
+
+# Compute parameters -----------------------------------------------------------
+
+bin_breaks <- function(breaks, closed = c("right", "left")) {
+  bins(breaks, closed)
+}
+
+bin_breaks_width <- function(x_range, width = NULL, center = NULL,
+                             boundary = NULL, closed = c("right", "left")) {
+  stopifnot(length(x_range) == 2)
+
+  # if (length(x_range) == 0) {
+  #   return(bin_params(numeric()))
+  # }
+  stopifnot(is.numeric(width), length(width) == 1)
+  if (width <= 0) {
+    stop("`binwidth` must be positive", call. = FALSE)
+  }
+
+  if (!is.null(boundary) && !is.null(center)) {
+    stop("Only one of 'boundary' and 'center' may be specified.")
+  } else if (is.null(boundary)) {
+    if (is.null(center)) {
+      # If neither edge nor center given, compute both using tile layer's
+      # algorithm. This puts min and max of data in outer half of their bins.
+      boundary <- width / 2
+
+    } else {
+      # If center given but not boundary, compute boundary.
+      boundary <- center - width / 2
+    }
+  }
+
+  # Find the left side of left-most bin: inputs could be Dates or POSIXct, so
+  # coerce to numeric first.
+  x_range <- as.numeric(x_range)
+  width <- as.numeric(width)
+  boundary <- as.numeric(boundary)
+  shift <- floor((x_range[1] - boundary) / width)
+  origin <- boundary + shift * width
+
+  # Small correction factor so that we don't get an extra bin when, for
+  # example, origin = 0, max(x) = 20, width = 10.
+  max_x <- x_range[2] + (1 - 1e-08) * width
+  breaks <- seq(origin, max_x, width)
+
+  bin_breaks(breaks, closed = closed)
+}
+
+bin_breaks_bins <- function(x_range, bins = 30, center = NULL,
+                            boundary = NULL, closed = c("right", "left")) {
+  stopifnot(length(x_range) == 2)
+
+  bins <- as.integer(bins)
+  if (bins < 1) {
+    stop("Need at least one bin.", call. = FALSE)
+  } else if (bins == 1) {
+    width <- diff(x_range)
+    boundary <- x_range[1]
+  } else {
+    width <- (x_range[2] - x_range[1]) / (bins - 1)
+  }
+
+  bin_breaks_width(x_range, width, boundary = boundary, center = center,
+    closed = closed)
+}
+
+
+# Compute bins ------------------------------------------------------------
+
+bin_vector <- function(x, bins, weight = NULL, pad = FALSE) {
+  stopifnot(is_bins(bins))
+
+  if (all(is.na(x))) {
+    return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA))
+  }
+
+  if (is.null(weight)) {
+    weight <- rep(1, length(x))
+  } else {
+    weight[is.na(weight)] <- 0
+  }
+
+  bin_idx <- cut(x, bins$breaks, right = bins$right_closed,
+    include.lowest = TRUE)
+  bin_count <- as.numeric(tapply(weight, bin_idx, sum, na.rm = TRUE))
+  bin_count[is.na(bin_count)] <- 0
+
+  bin_x <- (bins$breaks[-length(bins$breaks)] + bins$breaks[-1]) / 2
+  bin_widths <- diff(bins$breaks)
+
+  # Pad row of 0s at start and end
+  if (pad) {
+    bin_count <- c(0, bin_count, 0)
+
+    width1 <- bin_widths[1]
+    widthn <- bin_widths[length(bin_widths)]
+
+    bin_widths <- c(width1, bin_widths, widthn)
+    bin_x <- c(bin_x[1] - width1, bin_x, bin_x[length(bin_x)] + widthn)
+  }
+
+  # Add row for missings
+  if (any(is.na(bins))) {
+    bin_count <- c(bin_count, sum(is.na(bins)))
+    bin_widths <- c(bin_widths, NA)
+    bin_x <- c(bin_x, NA)
+  }
+
+  bin_out(bin_count, bin_x, bin_widths)
+}
+
+bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0),
+  xmin = x - width / 2, xmax = x + width / 2) {
+  density <- count / width / sum(abs(count))
+
+  data.frame(
+    count = count,
+    x = x,
+    xmin = xmin,
+    xmax = xmax,
+    width = width,
+    density = density,
+    ncount = count / max(abs(count)),
+    ndensity = count / max(abs(density)),
+    stringsAsFactors = FALSE
+  )
+}

R/stat-bin.r

@@ -99,17 +99,13 @@ StatBin <- ggproto("StatBin", Stat,
       params$closed <- if (params$right) "right" else "left"
       params$right <- NULL
     }
-    if (!is.null(params$breaks)) {
-      stop("`breaks` is deprecated.", call. = FALSE)
-    }
     if (!is.null(params$width)) {
       stop("`width` is deprecated. Do you want `geom_bar()`?", call. = FALSE)
     }
     if (!is.null(params$boundary) && !is.null(params$center)) {
       stop("Only one of `boundary` and `center` may be specified.", call. = FALSE)
     }
 
-
     if (is.null(params$breaks) && is.null(params$binwidth) && is.null(params$bins)) {
       message_wrap("`stat_bin()` using `bins = 30`. Pick better value with `binwidth`.")
       params$bins <- 30
@@ -126,151 +122,19 @@ StatBin <- ggproto("StatBin", Stat,
                            breaks = NULL, origin = NULL, right = NULL,
                            drop = NULL, width = NULL) {
 
-    params <- bin_params(
-      scales$x$dimension(),
-      width = binwidth,
-      bins = bins,
-      center = center,
-      boundary = boundary,
-      closed = closed
-    )
-
-    bin_vector(data$x, weight = data$weight, width = params$width,
-      origin = params$origin, closed = params$closed, pad = pad)
+    if (!is.null(breaks)) {
+      bins <- bin_breaks(breaks, closed)
+    } else if (!is.null(binwidth)) {
+      bins <- bin_breaks_width(scales$x$dimension(), binwidth, center = center,
+        boundary = boundary, closed = closed)
+    } else {
+      bins <- bin_breaks_bins(scales$x$dimension(), bins, center = center,
+        boundary = boundary, closed = closed)
+    }
+    bin_vector(data$x, bins, weight = data$weight, pad = pad)
   },
 
   default_aes = aes(y = ..count..),
   required_aes = c("x")
 )
 
-
-# Compute parameters -----------------------------------------------------------
-
-bin_params <- function(x_range, width = NULL, bins = 30, center = NULL,
-                       boundary = NULL, closed = c("right", "left")) {
-  closed <- match.arg(closed)
-
-  if (length(x_range) == 0) {
-    return(list(width = width, origin = NULL, closed = closed))
-  }
-
-  stopifnot(length(x_range) == 2)
-  if (!is.null(boundary) && !is.null(center)) {
-    stop("Only one of 'boundary' and 'center' may be specified.")
-  }
-
-  if (is.null(width)) {
-    width <- (x_range[2] - x_range[1]) / (bins - 1)
-  }
-
-  if (is.null(boundary)) {
-    if (is.null(center)) {
-      # If neither edge nor center given, compute both using tile layer's
-      # algorithm. This puts min and max of data in outer half of their bins.
-      boundary <- width / 2
-
-    } else {
-      # If center given but not boundary, compute boundary.
-      boundary <- center - width / 2
-    }
-  }
-
-  # Inputs could be Dates or POSIXct, so make sure these are all numeric
-  x_range <- as.numeric(x_range)
-  width <- as.numeric(width)
-  boundary <- as.numeric(boundary)
-
-  origin <- find_origin(x_range, width, boundary)
-
-  list(width = width, origin = origin, closed = closed)
-}
-
-# Find the left side of left-most bin
-find_origin <- function(x_range, width, boundary) {
-  shift <- floor((x_range[1] - boundary) / width)
-  boundary + shift * width
-}
-
-bin_vector <- function(x, weight = NULL, ..., width = 1,
-                       origin = 0, closed = c("right", "left"),
-                       pad = FALSE) {
-  closed <- match.arg(closed)
-
-  if (all(is.na(x))) {
-    return(bin_out(length(x), NA, NA, xmin = NA, xmax = NA))
-  }
-
-  stopifnot(is.numeric(width) && length(width) == 1)
-  stopifnot(is.numeric(origin) && length(origin) == 1)
-
-  if (is.null(weight)) {
-    weight <- rep(1, length(x))
-  } else {
-    weight[is.na(weight)] <- 0
-  }
-
-  min_x <- origin
-  # Small correction factor so that we don't get an extra bin when, for
-  # example, origin=0, max(x)=20, width=10.
-  max_x <- max(x, na.rm = TRUE) + (1 - 1e-08) * width
-  breaks <- seq(min_x, max_x, width)
-  fuzzybreaks <- adjust_breaks2(breaks, closed = closed)
-
-  bins <- cut(x, fuzzybreaks, include.lowest = TRUE, right = (closed == "right"))
-
-  left <- breaks[-length(breaks)]
-  right <- breaks[-1]
-  x <- (left + right) / 2
-  bin_widths <- diff(breaks)
-
-  count <- as.numeric(tapply(weight, bins, sum, na.rm = TRUE))
-  count[is.na(count)] <- 0
-
-  if (pad) {
-    count <- c(0, count, 0)
-    bin_widths <- c(width, bin_widths, width)
-    x <- c(x[1] - width, x, x[length(x)] + width)
-  }
-
-  # Add row for missings
-  if (any(is.na(bins))) {
-    count <- c(count, sum(is.na(bins)))
-    left <- c(left, NA)
-    right <- c(right, NA)
-    x <- c(x, NA)
-    bin_widths <- c(bin_widths, NA)
-  }
-
-  bin_out(count, x, bin_widths)
-}
-
-bin_out <- function(count = integer(0), x = numeric(0), width = numeric(0),
-                    xmin = x - width / 2, xmax = x + width / 2) {
-  density <- count / width / sum(abs(count))
-
-  data.frame(
-    count = count,
-    x = x,
-    xmin = xmin,
-    xmax = xmax,
-    width = width,
-    density = density,
-    ncount = count / max(abs(count)),
-    ndensity = count / max(abs(density)),
-    stringsAsFactors = FALSE
-  )
-}
-
-# Adapt break fuzziness from base::hist - this protects from floating
-# point rounding errors
-adjust_breaks2 <- function(breaks, closed = "left") {
-  closed <- match.arg(closed, c("right", "left"))
-
-  diddle <- 1e-08 * median(diff(breaks))
-  if (closed == "right") {
-    fuzz <- c(-diddle, rep.int(diddle, length(breaks) - 1))
-  } else {
-    fuzz <- c(rep.int(-diddle, length(breaks) - 1), diddle)
-  }
-  sort(breaks) + fuzz
-}