Expand ydensity range for nicer violin plots (#1783)

Fixes #1700

* Expand ydensity range for nicer violin plots

* Add news bullet

* Update unit tests

Author: thomasp85

NEWS.md

@@ -69,6 +69,9 @@
 * The `theme()` constructor now has named arguments rather than ellipsis. This 
   should make autocomplete substantially more useful.
 
+* geom_violin now again has a nicer looking range that allow the density to
+  reach zero. The range of each violin is now automatically extended 3 * bw for 
+  either end of the data range (#1700)
 
 * `position_stack()` and `position_fill()` now sorts the stacking order so it 
   matches the order of the grouping. Use level reordering to alter the stacking 

R/stat-ydensity.r

@@ -69,7 +69,8 @@ StatYdensity <- ggproto("StatYdensity", Stat,
     } else {
       range <- scales$y$dimension()
     }
-    dens <- compute_density(data$y, data$w, from = range[1], to = range[2],
+    bw <- calc_bw(data$y, bw)
+    dens <- compute_density(data$y, data$w, from = range[1] - 3*bw, to = range[2] + 3*bw,
       bw = bw, adjust = adjust, kernel = kernel)
 
     dens$y <- dens$x
@@ -107,3 +108,22 @@ StatYdensity <- ggproto("StatYdensity", Stat,
   }
 
 )
+
+calc_bw <- function(x, bw) {
+  if (is.character(bw)) {
+    if (length(x) < 2)
+      stop("need at least 2 points to select a bandwidth automatically", call. = FALSE)
+    bw <- switch(
+      tolower(bw),
+      nrd0 = stats::bw.nrd0(x),
+      nrd = stats::bw.nrd(x),
+      ucv = stats::bw.ucv(x),
+      bcv = stats::bw.bcv(x),
+      sj = ,
+      `sj-ste` = stats::bw.SJ(x, method = "ste"),
+      `sj-dpi` = stats::bw.SJ(x, method = "dpi"),
+      stop("unknown bandwidth rule")
+    )
+  }
+  bw
+}

tests/testthat/test-geom-violin.R

@@ -1,6 +1,6 @@
 context("geom_violin")
 
-test_that("", {
+test_that("range is expanded", {
   df <- rbind(
     data.frame(x = "a", y = c(0, runif(10), 1)),
     data.frame(x = "b", y = c(0, runif(10), 2))
@@ -10,9 +10,10 @@ test_that("", {
     geom_violin() +
     facet_grid(x ~ ., scales = "free") +
     coord_cartesian(expand = FALSE)
-
-  expect_equal(layer_scales(p, 1)$y$dimension(), c(0, 1))
-  expect_equal(layer_scales(p, 2)$y$dimension(), c(0, 2))
+  expand_a <- stats::bw.nrd0(df$y[df$x == "a"]) * 3
+  expand_b <- stats::bw.nrd0(df$y[df$x == "b"]) * 3
+  expect_equal(layer_scales(p, 1)$y$dimension(), c(0 - expand_a, 1 + expand_a))
+  expect_equal(layer_scales(p, 2)$y$dimension(), c(0 - expand_b, 2 + expand_b))
 })
 
 # create_quantile_segment_frame -------------------------------------------------
@@ -31,13 +32,5 @@ test_that("quantiles do not fail on zero-range data", {
 
   # This should return without error and have length one
   expect_equal(length(layer_grob(p)), 1)
-
-  # All rows should be identical in layer_data, with some specific values
-  unique.layer.data <- unique(layer_data(p))
-  expect_equal(nrow(unique.layer.data), 1)
-  expect_equal(unique.layer.data$density, 0.55216039)
-  expect_equal(unique.layer.data$count, 1.65648117)
-  expect_equal(unique.layer.data$xmin, 0.55)
-  expect_equal(unique.layer.data$xmax, 1.45)
 })