New dodging algorithm for box plots

DESCRIPTION

@@ -162,6 +162,7 @@ Collate:
     'position-.r'
     'position-collide.r'
     'position-dodge.r'
+    'position-dodge2.r'
     'position-identity.r'
     'position-jitter.r'
     'position-jitterdodge.R'

NAMESPACE

@@ -161,6 +161,7 @@ export(GeomViolin)
 export(GeomVline)
 export(Position)
 export(PositionDodge)
+export(PositionDodge2)
 export(PositionFill)
 export(PositionIdentity)
 export(PositionJitter)
@@ -355,6 +356,7 @@ export(merge_element)
 export(panel_cols)
 export(panel_rows)
 export(position_dodge)
+export(position_dodge2)
 export(position_fill)
 export(position_identity)
 export(position_jitter)

NEWS.md

@@ -1,5 +1,12 @@
 # ggplot2 2.2.1.9000
 
+* Box plot position is now controlled by `position_dodge2()`, which can also be
+  used for bars and rectangles. `position_dodge2()` compares the `xmin` and
+  `xmax` values of each element to determine which ones overlap, and dodges them
+  accordingly. This makes it possible to dodge box plots created with
+  `geom_boxplot(varwidth = TRUE)`. The `padding` parameter adds a small amount
+  of padding between elements (@karawoo, #2143).
+
 * `fortify()` gains a method for tbls (@karawoo, #2218)
 
 * `stat_summary_bin()` now understands the `breaks` parameter (@karawoo, #2214)

R/geom-bar.r

@@ -15,18 +15,19 @@
 #' topic}. This is why it doesn't make sense to use a log-scaled y axis with a
 #' bar chart.
 #'
-#' By default, multiple bar occupying the same `x` position will be
-#' stacked atop one another by [position_stack()]. If you want them
-#' to be dodged side-to-side, use [position_dodge()]. Finally,
-#' [position_fill()] shows relative proportions at each `x` by
-#' stacking the bars and then standardising each bar to have the same height.
+#' By default, multiple bar occupying the same `x` position will be stacked atop
+#' one another by [position_stack()]. If you want them to be dodged
+#' side-to-side, use [position_dodge()] or [position_dodge2()]. Finally,
+#' [position_fill()] shows relative proportions at each `x` by stacking the bars
+#' and then standardising each bar to have the same height.
 #'
 #' @section Aesthetics:
 #' \aesthetics{geom}{bar}
 #'
 #' @seealso
 #'   [geom_histogram()] for continuous data,
-#'   [position_dodge()] for creating side-by-side barcharts.
+#'   [position_dodge()] and [position_dodge2()] for creating side-by-side
+#'   barcharts.
 #' @export
 #' @inheritParams layer
 #' @inheritParams geom_point

R/geom-boxplot.r

@@ -95,7 +95,7 @@
 #'  )
 #' }
 geom_boxplot <- function(mapping = NULL, data = NULL,
-                         stat = "boxplot", position = "dodge",
+                         stat = "boxplot", position = "dodge2",
                          ...,
                          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-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,23 @@ collide <- function(data, width = NULL, name, strategy, ..., check.width = TRUE,
     stop("Neither y nor ymax defined")
   }
 }
+
+# Alternate version of collide() used by position_dodge2()
+collide2 <- 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 is
+  # different than for collide() because of the order in which pos_dodge2 places
+  # elements
+  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

@@ -1,7 +1,9 @@
 #' Dodge overlapping objects side-to-side
 #'
 #' Dodging preserves the vertical position of an geom while adjusting the
-#' horizontal position.
+#' horizontal position. `position_dodge2` is a special case of `position_dodge`
+#' for arranging box plots, which can have variable widths. `position_dodge2`
+#' also works with bars and rectangles.
 #'
 #' @inheritParams position_identity
 #' @param width Dodging width, when different to the width of the individual
@@ -13,17 +15,17 @@
 #' @export
 #' @examples
 #' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) +
-#'   geom_bar(position = "dodge")
+#'   geom_bar(position = "dodge2")
 #'
-#' # By default, dodging preserves the total width. You can choose
-#' # to preserve the width of each element:
+#' # By default, dodging with `position_dodge2()` preserves the width of each
+#' # element. You can choose to preserve the total width with:
 #' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) +
-#'   geom_bar(position = position_dodge(preserve = "single"))
+#'   geom_bar(position = position_dodge(preserve = "total"))
 #'
 #' \donttest{
 #' ggplot(diamonds, aes(price, fill = cut)) +
-#'   geom_histogram(position="dodge")
-#' # see ?geom_boxplot and ?geom_bar for more examples
+#'   geom_histogram(position="dodge2")
+#' # see ?geom_bar for more examples
 #'
 #' # In this case a frequency polygon is probably a better choice
 #' ggplot(diamonds, aes(price, colour = cut)) +
@@ -58,6 +60,19 @@
 #'   width = 0.2,
 #'   position = position_dodge(width = 0.9)
 #' )
+#'
+#' # Box plots use position_dodge2 by default, and bars can use it too
+#' 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)
+#' 
+#' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) +
+#'   geom_bar(position = position_dodge2(preserve = "single"))
+#' 
+#' ggplot(mtcars, aes(factor(cyl), fill = factor(vs))) +
+#'   geom_bar(position = position_dodge2(preserve = "total"))
 position_dodge <- function(width = NULL, preserve = c("total", "single")) {
   ggproto(NULL, PositionDodge,
     width = width,
@@ -70,7 +85,6 @@ position_dodge <- function(width = NULL, preserve = c("total", "single")) {
 #' @usage NULL
 #' @export
 PositionDodge <- ggproto("PositionDodge", Position,
-  required_aes = "x",
   width = NULL,
   preserve = "total",
   setup_params = function(self, data) {
@@ -91,6 +105,13 @@ PositionDodge <- ggproto("PositionDodge", Position,
     )
   },
 
+  setup_data = function(self, data, params) {
+    if (!"x" %in% names(data) & all(c("xmin", "xmax") %in% names(data))) {
+      data$x <- (data$xmin + data$xmax) / 2
+    }
+    data
+  },
+
   compute_panel = function(data, params, scales) {
     collide(
       data,

R/position-dodge2.r

@@ -0,0 +1,133 @@
+#' @export
+#' @rdname position_dodge
+#' @param padding Padding between elements at the same position. Elements are
+#'   shrunk by this proportion to allow space between them. Defaults to 0.1.
+position_dodge2 <- function(width = NULL, preserve = c("single", "total"),
+                              padding = 0.1) {
+  ggproto(NULL, PositionDodge2,
+    width = width,
+    preserve = match.arg(preserve),
+    padding = padding
+  )  
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+PositionDodge2 <- ggproto("PositionDodge2", 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_dodge2(width = ?)`",
+        call. = FALSE)
+    }
+
+    if (identical(self$preserve, "total")) {
+      n <- NULL
+    } else if ("x" %in% names(data)){
+      n <- max(table(data$x))
+    } else {
+      n <- max(table(find_x_overlaps(data)))
+    }
+
+    list(
+      width = self$width,
+      n = n,
+      padding = self$padding
+    )
+  },
+
+  compute_panel = function(data, params, scales) {
+    collide2(
+      data,
+      params$width,
+      name = "position_dodge2",
+      strategy = pos_dodge2,
+      n = params$n,
+      padding = params$padding,
+      check.width = FALSE
+    )
+  }
+)
+
+pos_dodge2 <- function(df, width, n = NULL, padding = 0.1) {
+
+  if (length(unique(df$group)) == 1) {
+    return(df)
+  }
+
+  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 <- find_x_overlaps(df)
+
+  # based on xid find newx, i.e. the center of each group of overlapping
+  # elements. for boxes, bars, etc. this should be the same as original x, but
+  # for arbitrary rects it may not be
+  newx <- (tapply(df$xmin, df$xid, min) + tapply(df$xmax, df$xid, max)) / 2
+  df$newx <- newx[df$xid]
+
+  if (is.null(n)) {
+    # If n is null, preserve total widths of elements 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) / as.numeric(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 elements
+  group_sizes <- stats::aggregate(
+    list(size = df$new_width),
+    list(newx = df$newx),
+    sum
+  )  
+
+  # Starting xmin for each group of elements
+  starts <- group_sizes$newx - (group_sizes$size / 2)
+
+  # Set the elements 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 <- (df$xmin + df$xmax) / 2
+
+  # If no elements occupy the same position, there is no need to add padding
+  if (!any(duplicated(df$xid))) {
+    return(df)
+  }
+
+  # Shrink elements 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[, c("xid", "newx", "new_width", "pad_width")] <- NULL
+
+  df
+}
+
+# Find groups of overlapping elements that need to be dodged from one another
+find_x_overlaps <- function(df) {
+  overlaps <- vector(mode = "numeric", length = nrow(df))
+  overlaps[1] <- counter <- 1
+  for (i in 2:nrow(df)) {
+    if (df$xmin[i] >= df$xmax[i - 1]) {
+      counter <- counter + 1
+    }
+    overlaps[i] <- counter
+  }
+  overlaps
+}

R/stat-boxplot.r

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