Merge pull request #553 from ropensci/fix/toRGB

Better toRGB

Author: cpsievert

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: plotly
 Title: Create Interactive Web Graphics via 'plotly.js'
-Version: 3.4.15
+Version: 3.5.0
 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"),
     email = "cpsievert1@gmail.com"),
     person("Chris", "Parmer", role = c("aut", "cph"),

NEWS

@@ -1,3 +1,13 @@
+3.5.0 -- 19 Apr 2016
+
+NEW FEATURES:
+
+The toRGB() function will now respect alpha channels in hex color codes and can recursively apply alpha. 
+
+CHANGES:
+
+The toRGB() function will always output color codes with an alpha channel (e.g. toRGB('black') is now 'rgba(0,0,0,1)' instead of 'rgb(0,0,0)')
+
 3.4.15 -- 18 Apr 2016
 
 BUGFIX:

R/ggplotly.R

@@ -277,8 +277,6 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
       theme[["strip.text.x"]] %||% theme[["strip.text"]],
       "npc", "height"
     )
-    # TODO: why does stripSize need to be inflated here?
-    panelMarginY <- panelMarginY + 1.5 * stripSize
     # space for ticks/text in free scales
     if (p$facet$free$x) {
       axisTicksX <- unitConvert(

R/layers2traces.R

@@ -460,7 +460,10 @@ geom2trace.GeomPolygon <- function(data, params, p) {
     line = list(
       # NOTE: line attributes must be constant on a polygon
       width = aes2plotly(data, params, "size"),
-      color = aes2plotly(data, params, "colour"),
+      color = toRGB(
+        aes2plotly(data, params, "colour"),
+        aes2plotly(data, params, "alpha")
+      ),
       dash = aes2plotly(data, params, "linetype")
     ),
     fill = "tozerox",

R/toRGB.R

@@ -5,27 +5,36 @@
 #' @export
 toRGB <- function(x, alpha = 1) {
   if (is.null(x)) return(x)
-  # as of ggplot2 version 1.1, an NA alpha is treated as though it's 1
-  alpha[is.na(alpha)] <- 1
-  # if we've already made the proper conversion, return the input
-  if (inherits(x, "plotly_rgba")) return(x)
-  if (inherits(x, "plotly_rgb")) {
-    if (all(alpha == 1)) return(x)
-    # all alpha channel
-    x <- sub("^rgb", "rgba", sub("\\)", paste0(",", alpha, ")"), x))
-    return(prefix_class(x, "plotly_rgba"))
+  if (any(x %in% "transparent")) return(x)
+  # add alpha to already converted "rgb(x,y,z)" codes
+  idx <- grepl("^rgba\\(", x) & alpha <= 1 & 0 <= alpha
+  if (any(idx)) {
+    x[idx] <- rgb2hex(x[idx])
   }
   # for some reason ggplot2 has "NA" in some place (instead of NA)
   if (is.character(x)) {
     x[x == "NA"] <- NA
   }
-  has_alpha <- all(0 <= alpha & alpha < 1)
-  rgb_matrix <- col2rgb(x, alpha = has_alpha)
-  # rescale alpha 
-  # TODO: what if x already has an alpha channel???
-  if (has_alpha) rgb_matrix["alpha", ] <- alpha
-  container <- if (has_alpha) "rgba(%s)" else "rgb(%s)"
-  rgb_a <- sprintf(container, apply(rgb_matrix, 2, paste, collapse = ","))
-  rgb_a[is.na(x)] <- "transparent"
-  structure(rgb_a, class = if (has_alpha) "plotly_rgba" else "plotly_rgb")
+  # as of ggplot2 version 1.1, an NA alpha is treated as though it's 1
+  alpha[is.na(alpha)] <- 1
+  rgb_matrix <- grDevices::col2rgb(x, alpha = TRUE)
+  # multiply the existing alpha with specified alpha (both on 0-1 scale)
+  rgb_matrix["alpha", ] <- alpha * scales::rescale(
+    rgb_matrix["alpha", ], from = c(0, 255)
+  )
+  rgb_matrix["alpha", ] <- round(rgb_matrix["alpha", ], 4)
+  rgba <- sprintf("rgba(%s)", apply(rgb_matrix, 2, paste, collapse = ","))
+  rgba[is.na(x)] <- "transparent"
+  rgba
+}
+
+# take a 'plotly color' and produce a hex code
+rgb2hex <- function(string = "rgba(255,255,255,1)") {
+  vals <- sub("rgba\\(", "", sub("\\)", "", string))
+  valz <- strsplit(vals, ",")
+  sapply(valz, function(x) {
+    x <- setNames(as.numeric(x), c("red", "green", "blue", "alpha"))
+    x[["alpha"]] <- x[["alpha"]] * 255
+    do.call(grDevices::rgb, c(x, list(maxColorValue = 255)))
+  })
 }

tests/testthat/test-ggplot-boxplot.R

@@ -56,16 +56,6 @@ test_that("legends for boxplot", {
   for (i in 1:3) {
     expect_identical(tr[[i]]$showlegend, TRUE)
   }
-  # check the fill colors are correct
-  g <- ggplot_build(p)
-  fill.colors <- unique(g$data[[1]]["fill"])[,1]
-  for (i in 1:3) {
-    plotly.color <- as.integer(strsplit(gsub("[\\(\\)]|rgb", "", 
-                tr[[i]]$fillcolor), split = ",")[[1]])
-    names(plotly.color) <- c("red", "green", "blue")
-    expect_equal(plotly.color, col2rgb(fill.colors[i])[,1], 
-                 tolerance = 1)
-  }
 })
 
 dat <- data.frame(

tests/testthat/test-ggplot-histogram.R

@@ -51,8 +51,8 @@ test_that("Histogram with fixed colour/fill works", {
   gg <- base + geom_histogram(colour = "darkgreen", fill = "white")
   info <- expect_traces(gg, 1, "fixed-fill-color")
   tr <- info$data[[1]]
-  expect_true(tr$marker$color == "rgb(255,255,255)")
-  expect_true(tr$marker$line$color == "rgb(0,100,0)")
+  expect_true(tr$marker$color == "rgba(255,255,255,1)")
+  expect_true(tr$marker$line$color == "rgba(0,100,0,1)")
 })
 
 test_that("Specify histogram binwidth", {

tests/testthat/test-ggplot-hline.R

@@ -16,7 +16,7 @@ test_that("second trace be the hline", {
   expect_true(min(l$x) < min(x))
   expect_true(max(l$x[2]) > max(x))
   expect_identical(l$mode, "lines")
-  expect_true(l$line$color == "rgb(0,255,0)")
+  expect_true(l$line$color == "rgba(0,255,0,1)")
 })
 
 test_that("vector yintercept results in multiple horizontal lines", {
@@ -31,7 +31,7 @@ test_that("vector yintercept results in multiple horizontal lines", {
   expect_true(min(xs, na.rm = TRUE) < min(x))
   expect_true(max(xs, na.rm = TRUE) > max(x))
   expect_identical(l$mode, "lines")
-  expect_true(l$line$color == "rgb(255,0,0)")
+  expect_true(l$line$color == "rgba(255,0,0,1)")
 
 })
 

tests/testthat/test-ggplot-rect.R

@@ -10,7 +10,7 @@ expect_traces <- function(gg, n.traces, name) {
   })
   has.data <- all.traces[!no.data]
   expect_equal(length(has.data), n.traces)
-  list(traces=has.data, layout=L$layout)
+  list(data=has.data, layout=L$layout)
 }
 
 df <- data.frame(
@@ -23,7 +23,7 @@ gg <- ggplot(df, aes(xmin = x, xmax = x + 1, ymin = y, ymax = y + 2)) +
 
 test_that('geom_rect becomes 1 trace with mode="lines" fill="tozerox"', {
   info <- expect_traces(gg, 1, "black")
-  tr <- info$traces[[1]]
+  tr <- info$data[[1]]
   expect_identical(tr$fill, "tozerox")
   expect_identical(tr$type, "scatter")
   expect_identical(tr$mode, "lines")
@@ -42,7 +42,7 @@ gg4 <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) +
 
 test_that('trace contains NA back to 1st rect', {
   info <- expect_traces(gg4, 1, "black4")
-  tr <- info$traces[[1]]
+  tr <- info$data[[1]]
   expect_identical(tr$fill, "tozerox")
   expect_identical(tr$type, "scatter")
   expect_identical(tr$mode, "lines")
@@ -70,7 +70,7 @@ rect.color <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) +
 test_that('rect color', {
   info <- expect_traces(rect.color, 2, "color")
   traces.by.name <- list()
-  for(tr in info$traces){
+  for(tr in info$data){
     expect_true(tr$fillcolor == toRGB("grey"))
     expect_true(tr$fill == "tozerox")
     expect_equal(tr$y,
@@ -97,7 +97,7 @@ rect.fill <- ggplot(df4, aes(xmin = x, xmax = x + 0.5, ymin = 0, ymax = 1)) +
 test_that('rect color', {
   info <- expect_traces(rect.fill, 2, "fill")
   traces.by.name <- list()
-  for(tr in info$traces){
+  for(tr in info$data){
     expect_true(tr$line$color == "transparent")
     expect_true(tr$fill == "tozerox")
     expect_equal(tr$y,
@@ -125,7 +125,7 @@ rect.fill.color <-
 test_that('rect aes(fill) with constant color', {
   info <- expect_traces(rect.fill.color, 2, "fill-color")
   traces.by.name <- list()
-  for(tr in info$traces){
+  for(tr in info$data){
     expect_true(tr$line$color == toRGB("black"))
     expect_true(tr$fill == "tozerox")
     expect_equal(tr$y,
@@ -145,3 +145,14 @@ test_that('rect aes(fill) with constant color', {
   expect_false(traces.by.name[[1]]$fillcolor ==
                traces.by.name[[2]]$fillcolor)
 })
+
+
+p <- ggplot(data = data.frame(x1 = 1, x2 = 2, y1 = 1, y2 = 2)) + 
+  geom_rect(aes(xmin = x1, xmax = x2, ymin = y1, ymax = y2), 
+            fill = "#00000011", color = "black")
+
+test_that('Specifying alpha in hex color code works', {
+  info <- expect_traces(p, 1, "fill-hex-alpha")
+  expect_match(info$data[[1]]$fillcolor, "rgba\\(0,0,0,0\\.0[6]+")
+})
+

tests/testthat/test-ggplot-vline.R

@@ -16,7 +16,7 @@ test_that("second trace be the vline", {
   expect_true(l$y[1] <= 0)
   expect_true(l$y[2] >= 3.325)
   expect_true(l$mode == "lines")
-  expect_true(l$line$color == "rgb(0,255,0)")
+  expect_true(l$line$color == "rgba(0,255,0,1)")
 })
 
 test_that("vector xintercept results in multiple vertical lines", {
@@ -31,5 +31,5 @@ test_that("vector xintercept results in multiple vertical lines", {
   expect_true(min(ys, na.rm = TRUE) <= min(y))
   expect_true(max(ys, na.rm = TRUE) >= max(y))
   expect_true(l$mode == "lines")
-  expect_true(l$line$color == "rgb(0,0,255)")
+  expect_true(l$line$color == "rgba(0,0,255,1)")
 })

tests/testthat/test-toRGB.R

@@ -0,0 +1,6 @@
+context("toRGB")
+
+test_that("Can apply alpha recursively with toRGB()", {
+  col <- toRGB(toRGB("black", 0.9), 0.9)
+  expect_match(col, "rgba\\(0,0,0,0\\.80")
+})