New dodging algorithm for box plots

DESCRIPTION

@@ -157,8 +157,9 @@ Collate:
     'plot-last.r'
     'plot.r'
     'position-.r'
-    'position-collide.r'
     'position-dodge.r'
+    'position-boxdodge.r'
+    'position-collide.r'
     'position-identity.r'
     'position-jitter.r'
     'position-jitterdodge.R'

NAMESPACE

@@ -159,6 +159,7 @@ export(GeomTile)
 export(GeomViolin)
 export(GeomVline)
 export(Position)
+export(PositionBoxdodge)
 export(PositionDodge)
 export(PositionFill)
 export(PositionIdentity)
@@ -353,6 +354,7 @@ export(median_hilow)
 export(merge_element)
 export(panel_cols)
 export(panel_rows)
+export(position_boxdodge)
 export(position_dodge)
 export(position_fill)
 export(position_identity)

NEWS.md

@@ -1,5 +1,8 @@
 # ggplot2 2.2.1.9000
 
+* Box plot position is now controlled by `position_boxdodge()` (@karawoo,
+  #2143).
+
 * Default colour maps for continuous data are controlled by global options
   `ggplot2.continuous.colour` and `ggplot2.continuous.fill`, which can be set to
   either `"gradient"` or `"viridis"` (@karawoo).

R/geom-boxplot.r

@@ -95,7 +95,7 @@
 #'  )
 #' }
 geom_boxplot <- function(mapping = NULL, data = NULL,
-                         stat = "boxplot", position = "dodge",
+                         stat = "boxplot", position = "boxdodge",
                          ...,
                          outlier.colour = NULL,
                          outlier.color = NULL,
@@ -110,6 +110,15 @@ geom_boxplot <- function(mapping = NULL, data = NULL,
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE) {
+
+  # varwidth = TRUE is not compatible with preserve = "total"
+  if (!is.character(position)) {
+    if (identical(position$preserve, "total") & varwidth == TRUE) {
+      warning("Can't preserve total widths when varwidth = TRUE.", call. = FALSE)
+      position$preserve <- "single"
+    }
+  }
+
   layer(
     data = data,
     mapping = mapping,

R/position-boxdodge.r

@@ -0,0 +1,116 @@
+#' Position dodge for box plots
+#'
+#' Dodging preserves the vertical position of an geom while adjusting the
+#' horizontal position. `position_boxdodge` is a special case of
+#' `position_dodge` for arranging box plots, which can have variable widths.
+#' 
+#' @include position-dodge.r
+#' @inheritParams position_dodge
+#' @param padding Padding between boxes at the same position. Boxes are shrunk
+#'   by this proportion to make room for space between them.
+#' @family position adjustments
+#' @export
+#' @examples
+#' ggplot(data = iris, aes(Species, Sepal.Length)) +
+#' geom_boxplot(aes(colour = Sepal.Width < 3.2))
+#'
+#' ggplot(data = iris, aes(Species, Sepal.Length)) +
+#' geom_boxplot(aes(colour = Sepal.Width < 3.2), varwidth = TRUE)
+position_boxdodge <- function(width = NULL, preserve = c("single", "total"),
+                              padding = 0.1) {
+  ggproto(NULL, PositionBoxdodge,
+    width = width,
+    preserve = match.arg(preserve),
+    padding = padding
+  )  
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+PositionBoxdodge <- ggproto("PositionBoxdodge", PositionDodge,
+  preserve = "single",
+  padding = 0.1,
+  setup_params = function(self, data) {
+    if (is.null(data$xmin) && is.null(data$xmax) && is.null(self$width)) {
+      warning("Width not defined. Set with `position_boxdodge(width = ?)`",
+        call. = FALSE)
+    }
+
+    if (identical(self$preserve, "total")) {
+      n <- NULL
+    } else {
+      n <- max(table(data$x))
+    }
+
+    list(
+      width = self$width,
+      n = n,
+      padding = self$padding
+    )
+  },
+
+  compute_panel = function(data, params, scales) {
+    collide_box(
+      data,
+      params$width,
+      name = "position_boxdodge",
+      strategy = pos_boxdodge,
+      n = params$n,
+      padding = params$padding,
+      check.width = FALSE
+    )
+  }
+)
+
+pos_boxdodge <- function(df, width, n = NULL, padding = 0.1) {
+
+  if (!all(c("xmin", "xmax") %in% names(df))) {
+    df$xmin <- df$x
+    df$xmax <- df$x
+  }
+
+  # xid represents groups of boxes that share the same position
+  df$xid <- match(df$x, sort(unique(df$x)))
+
+  if (is.null(n)) {
+    # If n is null, preserve total widths of boxes at each position by dividing
+    # widths by the number of elements at that position
+    n <- table(df$xid)
+    df$new_width <- (df$xmax - df$xmin) / n[df$xid]
+  } else {
+    df$new_width <- (df$xmax - df$xmin) / n
+  }
+
+  df$xmin <- df$x - (df$new_width / 2)
+  df$xmax <- df$x + (df$new_width / 2)
+
+  # Find the total width of each group of boxes
+  group_sizes <- plyr::ddply(df, "xid", plyr::summarize, size = sum(new_width))
+
+  # Starting xmin for each group of boxes
+  starts <- group_sizes$xid - (group_sizes$size / 2)
+
+  # Set the boxes in place
+  for (i in seq_along(starts)) {
+    divisions <- cumsum(c(starts[i], df[df$xid == i, "new_width"]))
+    df[df$xid == i, "xmin"] <- divisions[-length(divisions)]
+    df[df$xid == i, "xmax"] <- divisions[-1]
+  }
+
+  # x values get moved to between xmin and xmax
+  df$x <- rowMeans(df[, c("xmin", "xmax")])
+
+  # If no boxes occupy the same position, there is no need to add padding
+  if (!any(duplicated(df$xid))) {
+    return(df)
+  }
+
+  # Shrink boxes to add space between them
+  df$pad_width <- df$new_width * (1 - padding)
+  df$xmin <- df$x + (df$pad_width / 2)
+  df$xmax <- df$x - (df$pad_width / 2)
+
+  df
+}

R/position-collide.r

@@ -1,6 +1,7 @@
 # Detect and prevent collisions.
 # Powers dodging, stacking and filling.
-collide <- function(data, width = NULL, name, strategy, ..., check.width = TRUE, reverse = FALSE) {
+collide_setup <- function(data, width = NULL, name, strategy,
+                          check.width = TRUE, reverse = FALSE) {
   # Determine width
   if (!is.null(width)) {
     # Width set manually
@@ -26,6 +27,15 @@ collide <- function(data, width = NULL, name, strategy, ..., check.width = TRUE,
     width <- widths[1]
   }
 
+  list(data = data, width = width)  
+}
+
+collide <- function(data, width = NULL, name, strategy,
+                    ..., check.width = TRUE, reverse = FALSE) {
+  dlist <- collide_setup(data, width, name, strategy, check.width, reverse)
+  data <- dlist$data
+  width <- dlist$width
+
   # Reorder by x position, then on group. The default stacking order reverses
   # the group in order to match the legend order.
   if (reverse) {
@@ -34,7 +44,6 @@ collide <- function(data, width = NULL, name, strategy, ..., check.width = TRUE,
     data <- data[order(data$xmin, -data$group), ]
   }
 
-
   # Check for overlap
   intervals <- as.numeric(t(unique(data[c("xmin", "xmax")])))
   intervals <- intervals[!is.na(intervals)]
@@ -44,7 +53,7 @@ collide <- function(data, width = NULL, name, strategy, ..., check.width = TRUE,
     # This is where the algorithm from [L. Wilkinson. Dot plots.
     # The American Statistician, 1999.] should be used
   }
-
+  
   if (!is.null(data$ymax)) {
     plyr::ddply(data, "xmin", strategy, ..., width = width)
   } else if (!is.null(data$y)) {
@@ -56,3 +65,21 @@ collide <- function(data, width = NULL, name, strategy, ..., check.width = TRUE,
     stop("Neither y nor ymax defined")
   }
 }
+
+collide_box <- function(data, width = NULL, name, strategy,
+                        ..., check.width = TRUE, reverse = FALSE) {
+  dlist <- collide_setup(data, width, name, strategy, check.width, reverse)
+  data <- dlist$data
+  width <- dlist$width
+
+  # Reorder by x position, then on group. The default stacking order reverses
+  # the group in order to match the legend order.
+  if (reverse) {
+    data <- data[order(data$x, data$group), ]
+  } else {
+    data <- data[order(data$x, -data$group), ]
+  }
+
+  pos <- match.fun(strategy)
+  pos(data, width, ...)
+}

R/position-dodge.r

@@ -23,7 +23,7 @@
 #' \donttest{
 #' ggplot(diamonds, aes(price, fill = cut)) +
 #'   geom_histogram(position="dodge")
-#' # see ?geom_boxplot and ?geom_bar for more examples
+#' # see ?geom_bar for more examples
 #'
 #' # In this case a frequency polygon is probably a better choice
 #' ggplot(diamonds, aes(price, colour = cut)) +

R/stat-boxplot.r

@@ -14,7 +14,7 @@
 #' }
 #' @export
 stat_boxplot <- function(mapping = NULL, data = NULL,
-                         geom = "boxplot", position = "dodge",
+                         geom = "boxplot", position = "boxdodge",
                          ...,
                          coef = 1.5,
                          na.rm = FALSE,