geom approach to fixing geom_eye

NAMESPACE

@@ -26,6 +26,7 @@ S3method(predicted_samples,brmsfit)
 S3method(predicted_samples,default)
 S3method(predicted_samples,stanreg)
 S3method(print,data_list)
+export(GeomDensityOrViolin)
 export(GeomInterval)
 export(GeomIntervalh)
 export(GeomLineribbon)
@@ -136,6 +137,7 @@ importFrom(purrr,map_dbl)
 importFrom(purrr,map_df)
 importFrom(purrr,map_dfr)
 importFrom(purrr,reduce)
+importFrom(rlang,"%||%")
 importFrom(rlang,as_quosure)
 importFrom(rlang,enquo)
 importFrom(rlang,eval_tidy)

R/geom_eye.R

@@ -94,7 +94,7 @@ geom_eye = function(
     ) %>%
     {if (!is.null(fill)) modifyList(., list(fill = fill)) else .}
 
-  violin = do.call(geom_violin, violin.args)
+  violin = do.call(geom_density_or_violin, violin.args)
 
   #build interval annotations
   interval.args =
@@ -112,3 +112,104 @@ geom_eye = function(
   # > ggplot(...) + geom_a() + geom_b()
   list(violin, interval)
 }
+
+
+
+geom_density_or_violin <- function(mapping = NULL, data = NULL,
+  stat = "ydensity", position = "dodge",
+  ...,
+  trim = TRUE,
+  scale = "area",
+  na.rm = FALSE,
+  show.legend = NA,
+  inherit.aes = TRUE) {
+  layer(
+    data = data,
+    mapping = mapping,
+    stat = stat,
+    geom = GeomDensityOrViolin,
+    position = position,
+    show.legend = show.legend,
+    inherit.aes = inherit.aes,
+    params = list(
+      trim = trim,
+      scale = scale,
+      na.rm = na.rm,
+      ...
+    )
+  )
+}
+
+#' @rdname ggplot2-ggproto
+#' @format NULL
+#' @usage NULL
+#' @export
+#' @importFrom rlang %||%
+GeomDensityOrViolin <- ggproto("GeomDensityOrViolin", Geom,
+  setup_data = function(data, params) {
+    data$width <- data$width %||%
+      params$width %||% (resolution(data$x, FALSE) * 0.9)
+
+    # ymin, ymax, xmin, and xmax define the bounding rectangle for each group
+    plyr::ddply(data, ~ group + x, transform,
+      xmin = x - width / 2,
+      xmax = x + width / 2
+    )
+  },
+
+  draw_key = draw_key_polygon,
+
+  default_aes = aes(weight = 1, colour = NA, fill = "gray65", size = 0.5,
+    alpha = NA, linetype = "solid"),
+
+  required_aes = c("x", "y"),
+
+  draw_panel = function(self, data, ...) {
+    # ribbons do not autogroup by color/fill/linetype, so if someone groups by changing the color
+    # of the line or by setting fill, the ribbons might give an error. So we will do the
+    # grouping ourselves
+    grouping_columns = names(data) %>%
+      intersect(c("colour", "fill", "linetype", "group", "x"))
+
+    print(grouping_columns)
+    print(summary(data))
+
+    grobs = data %>%
+      dlply(grouping_columns, function(d) {
+        # Find the points for the line to go all the way around
+        d <- transform(d,
+          xminv = x - violinwidth * (x - xmin),
+          xmaxv = x + violinwidth * (xmax - x)
+        )
+
+        # Make sure it's sorted properly to draw the outline
+        newdata <- rbind(
+          plyr::arrange(transform(d, x = xminv), y),
+          plyr::arrange(transform(d, x = xmaxv), -y)
+        )
+
+        # Close the polygon: set first and last point the same
+        # Needed for coord_polar and such
+        newdata <- rbind(newdata, newdata[1,])
+
+        group_grobs = list(GeomPolygon$draw_panel(newdata, ...))
+
+        list(
+          grobs = group_grobs
+        )
+      })
+
+    print(str(grobs))
+
+    # this is a slightly hackish approach to getting the draw order correct for the common
+    # use case of fit lines / curves: draw the ribbons in order from largest mean width to
+    # smallest mean width, so that the widest intervals are on the bottom.
+    grobs = grobs %>%
+      map("grobs") %>%
+      reduce(c)
+
+    ggname("geom_density_or_violin",
+      gTree(children = do.call(gList, grobs))
+    )
+  }
+)

tests/testthat/test.geom_eye.R

@@ -27,14 +27,17 @@ test_that("one-parameter eye plots work", {
 
 test_that("two-parameter eye plots work", {
   set.seed(123)
-  df = data.frame(x = rnorm(1000), y = "a") %>%
-    rbind(data.frame(x = rnorm(1000, 1), y = "b"))
+  df = data.frame(x = rnorm(1000), y = "a", z = 1) %>%
+    rbind(data.frame(x = rnorm(1000, 1), y = "b", z = 2))
 
   p = ggplot(df, aes(x = x, y = y))
   expect_doppelganger("two-parameter (factor) horizontal eye", p + geom_eyeh())
   expect_doppelganger("two-parameter (factor) horizontal half-eye", p + geom_halfeyeh())
 
   p = ggplot(df, aes(x = y, y = x))
   expect_doppelganger("two-parameter (factor) vertical eye", p + geom_eye())
+
+  p = ggplot(df, aes(x = x, y = z))
+
 })