Reimplement ribbon as a basic polygon. Fix #191. Fix #192.

Author: cpsievert

R/trace_generation.R

@@ -26,13 +26,15 @@ layer2traces <- function(l, d, misc) {
   # geom_smooth() means geom_line() + geom_ribbon()
   # Note the line is always drawn, but ribbon is not if se = FALSE.
   if (g$geom == "smooth") {
-    # If smoothLine has been compiled already, consider smoothRibbon.
+    # If smoothLine has been compiled already, consider drawing the ribbon
     if (isTRUE(misc$smoothLine)) {
       misc$smoothLine <- FALSE
       if (isTRUE(l$stat_params$se == FALSE)) {
         return(NULL) 
       } else {
         g$geom <- "smoothRibbon"
+        # disregard colour
+        g$data <- g$data[!grepl("^colour[.name]?", names(g$data))]
       }
     } else {
       misc$smoothLine <- TRUE
@@ -248,7 +250,6 @@ layer2traces <- function(l, d, misc) {
       if (length(unique(name.list)) < 2)
         tr$name <- as.character(name.list[[1]])
     }
-    
     dpd <- data.params$data
     if ("PANEL" %in% names(dpd) && nrow(dpd) > 0)
     {
@@ -335,6 +336,11 @@ toBasic <- list(
     g$geom <- "polygon"
     g
   },
+  ribbon=function(g) {
+    g$data <- ribbon_dat(g$data)
+    g$geom <- "polygon"
+    g
+  },
   path=function(g) {
     group2NA(g, "path")
   },
@@ -410,8 +416,10 @@ toBasic <- list(
     group2NA(g, "path")
   },
   smoothRibbon=function(g) {
-    if (is.null(g$params$alpha)) g$params$alpha <- 0.1
-    group2NA(g, "ribbon")
+    if (is.null(g$params$alpha)) g$params$alpha <- 0.2
+    g$data <- ribbon_dat(g$data)
+    g$geom <- "polygon"
+    g
   }
 )
 
@@ -493,6 +501,26 @@ make.errorbar <- function(data, params, xy){
   tr
 }
 
+# function to transform geom_ribbon data into format plotly likes
+# (note this function is also used for geom_smooth)
+ribbon_dat <- function(dat) {
+  n <- nrow(dat)
+  o <- order(dat$x)
+  o2 <- order(dat$x, decreasing = TRUE)
+  used <- c("x", "ymin", "ymax")
+  not_used <- setdiff(names(dat), used)
+  # top-half of ribbon
+  tmp <- dat[o, ]
+  others <- tmp[not_used]
+  dat1 <- cbind(x = tmp$x, y = tmp$ymax, others)
+  dat1[n+1, ] <- cbind(x = tmp$x[n], y = tmp$ymin[n], others[n, ])
+  # bottom-half of ribbon
+  tmp2 <- dat[o2, ]
+  others2 <- tmp2[not_used]
+  dat2 <- cbind(x = tmp2$x, y = tmp2$ymin, others2)
+  rbind(dat1, dat2)
+}
+
 # Convert basic geoms to traces.
 geom2trace <- list(
   path=function(data, params) {
@@ -515,7 +543,8 @@ geom2trace <- list(
          mode="lines",
          line=paramORdefault(params, aes2line, polygon.line.defaults),
          fill="tozerox",
-         fillcolor=toFill(params$fill))
+         fillcolor=toFill(params$fill, ifelse(is.null(params$alpha), 1,
+                                              params$alpha)))
   },
   point=function(data, params){
     L <- list(x=data$x,
@@ -667,15 +696,6 @@ geom2trace <- list(
          fillcolor=toFill(params$fill, ifelse(is.null(params$alpha), 1,
                                               params$alpha)))
   },
-  ribbon=function(data, params) {
-    list(x=c(data$x[1], data$x, rev(data$x)),
-         y=c(data$ymin[1], data$ymax, rev(data$ymin)),
-         type="scatter",
-         line=paramORdefault(params, aes2line, ribbon.line.defaults),
-         fill="tonexty",
-         fillcolor=toFill(params$fill, ifelse(is.null(params$alpha), 1,
-                                              params$alpha)))
-  },
   abline=function(data, params) {
     list(x=c(params$xstart, params$xend),
          y=c(params$intercept + params$xstart * params$slope,

tests/testthat/test-ggplot-ribbon.R

@@ -1,26 +1,51 @@
 context("ribbon")
 
-huron <- data.frame(year=1875:1972, level=as.vector(LakeHuron))
+expect_traces <- function(gg, n.traces, name){
+  stopifnot(is.ggplot(gg))
+  stopifnot(is.numeric(n.traces))
+  save_outputs(gg, paste0("ribbon-", name))
+  L <- gg2list(gg)
+  is.trace <- names(L) == ""
+  all.traces <- L[is.trace]
+  no.data <- sapply(all.traces, function(tr) {
+    is.null(tr[["x"]]) && is.null(tr[["y"]])
+  })
+  has.data <- all.traces[!no.data]
+  expect_equal(length(has.data), n.traces)
+  list(traces=has.data, kwargs=L$kwargs)
+}
 
-rb <- ggplot(huron, aes(x=year)) + geom_ribbon(aes(ymin=level-1, ymax=level+1))
-L <- gg2list(rb)
+huron <- data.frame(year = 1875:1972, level = as.vector(LakeHuron))
+huron$decade <- with(huron, round(year/10) * 10)
+huron$diff <- huron$year - huron$decade
 
-test_that("sanity check for geom_ribbon", {
-  expect_equal(length(L), 2)
-  expect_identical(L[[1]]$type, "scatter")
-  expect_equal(L[[1]]$x, c(huron$year[1], huron$year, rev(huron$year)))
-  expect_equal(L[[1]]$y, c(huron$level[1]-1, huron$level+1, rev(huron$level-1)))
-  expect_identical(L[[1]]$line$color, "transparent")
+p1 <- ggplot(data = huron) + 
+  geom_ribbon(aes(x = year, ymin = level-1, ymax = level+1), 
+              alpha = 0.1)
+
+test_that("geom_ribbon() creates 1 trace & respects alpha transparency", {
+  info <- expect_traces(p1, 1, "alpha")
+  tr <- info$traces[[1]]
+  expect_match(L2[[1]]$fillcolor, "0.1)", fixed=TRUE)
 })
 
-save_outputs(rb, "ribbon")
+p2 <- ggplot(data = huron, aes(group = factor(decade))) + 
+  geom_ribbon(aes(x = diff, ymin = level-0.1, ymax = level+0.1))
 
-rb2 <- ggplot(huron, aes(x=year)) + 
-  geom_ribbon(aes(ymin=level-1, ymax=level+1), alpha = 0.1)
-L2 <- gg2list(rb2)
+test_that("geom_ribbon() group aesthetic", {
+  info <- expect_traces(p2, 1, "group")
+})
 
-test_that("geom_ribbon respects alpha transparency", {
-  expect_match(L2[[1]]$fillcolor, "0.1)", fixed=TRUE)
+p3 <- ggplot(data = huron, aes(colour = factor(decade))) + 
+  geom_ribbon(aes(x = diff, ymin = level-0.1, ymax = level+0.1))
+
+test_that("geom_ribbon() colour aesthetic", {
+  info <- expect_traces(p3, 1, "colour")
 })
 
-save_outputs(rb2, "ribbon-alpha")
+p4 <- ggplot(data = huron, aes(fill = factor(decade))) + 
+  geom_ribbon(aes(x = diff, ymin = level-0.1, ymax = level+0.1))
+
+test_that("geom_ribbon() fill aesthetic", {
+  info <- expect_traces(p4, 1, "fill")
+})

tests/testthat/test-ggplot-smooth.R

@@ -1,18 +1,51 @@
 context("smooth")
 
+expect_traces <- function(gg, n.traces, name){
+  stopifnot(is.ggplot(gg))
+  stopifnot(is.numeric(n.traces))
+  save_outputs(gg, paste0("smooth-", name))
+  L <- gg2list(gg)
+  is.trace <- names(L) == ""
+  all.traces <- L[is.trace]
+  no.data <- sapply(all.traces, function(tr) {
+    is.null(tr[["x"]]) && is.null(tr[["y"]])
+  })
+  has.data <- all.traces[!no.data]
+  expect_equal(length(has.data), n.traces)
+  list(traces=has.data, kwargs=L$kwargs)
+}
+
 p <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_smooth()
 
 test_that("geom_point() + geom_smooth() produces 3 traces", {
-  info <- gg2list(p)
-  expect_true(sum(names(info) == "") == 3)
-  save_outputs(p, "smooth")
+  expect_traces(p, 3, "basic")
 })
 
-p2 <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + geom_smooth(se = FALSE)
+p2 <- ggplot(mtcars, aes(mpg, wt)) + geom_point() + 
+  geom_smooth(se = FALSE)
 
 test_that("geom_point() + geom_smooth(se = FALSE) produces 2 traces", {
-  info2 <- gg2list(p2)
-  expect_true(sum(names(info2) == "") == 2)
-  save_outputs(p2, "smooth-se-false")
+  expect_traces(p2, 2, "se-false")
 })
 
+d <- diamonds[sample(nrows(diamonds, 1000)), ]
+p3 <- qplot(carat, price, group = cut, data = d) + geom_smooth()
+
+test_that("geom_smooth() respects group aesthetic", {
+  # 1 trace for points
+  # 5 traces for lines (1 for each group)
+  # 5 traces for ribbons (1 for each group)
+  expect_traces(p3, 11, "group")
+})
+
+p4 <- qplot(carat, price, colour = cut, data = d) + geom_smooth()
+
+test_that("geom_smooth() respects colour aesthetic", {
+  expect_traces(p4, 11, "colour")
+})
+
+p5 <- qplot(carat, price, fill = cut, data = d) + geom_smooth()
+
+test_that("geom_smooth() respects fill aesthetic", {
+  expect_traces(p5, 11, "fill")
+})