better handling of colorscale inputs

R/plotly_build.R

@@ -373,6 +373,9 @@ plotly_build.plotly <- function(p, registerFrames = TRUE) {
 
   p <- verify_guides(p)
 
+  # verify colorscale attributes are in a sensible data structure
+  p <- verify_colorscale(p)
+
   # verify plot attributes are legal according to the plotly.js spec
   p <- verify_attr_names(p)
   # box up 'data_array' attributes where appropriate
@@ -804,11 +807,6 @@ map_color <- function(traces, stroke = FALSE, title = "", colorway, na.color = "
         colorObj[c("cmin", "cmax")] <- NULL
         colorObj[["showscale"]] <- default(TRUE)
         traces[[i]] <- modify_list(colorObj, traces[[i]])
-        traces[[i]]$colorscale <- as_df(traces[[i]]$colorscale)
-        # sigh, contour colorscale doesn't support alpha
-        if (grepl("contour", traces[[i]][["type"]])) {
-          traces[[i]]$colorscale[, 2] <- strip_alpha(traces[[i]]$colorscale[, 2])
-        }
         traces[[i]] <- structure(traces[[i]], class = c("plotly_colorbar", "zcolor"))
         next
       }
@@ -852,8 +850,6 @@ map_color <- function(traces, stroke = FALSE, title = "", colorway, na.color = "
           traces[[i]] <- modify_list(list(fillcolor = col), traces[[i]])
         }
 
-        # make sure the colorscale is going to convert to JSON nicely
-        traces[[i]]$marker$colorscale <- as_df(traces[[i]]$marker$colorscale)
       }
     }
 

R/utils.R

@@ -130,15 +130,6 @@ colorway <- function(p = NULL) {
 # TODO: make this more unique?
 crosstalk_key <- function() ".crossTalkKey"
 
-# modifyList turns elements that are data.frames into lists
-# which changes the behavior of toJSON
-as_df <- function(x) {
-  if (is.null(x) || is.matrix(x)) return(x)
-  if (is.list(x) && !is.data.frame(x)) {
-    setNames(as.data.frame(x), NULL)
-  }
-}
-
 # arrange data if the vars exist, don't throw error if they don't
 arrange_safe <- function(data, vars) {
   vars <- vars[vars %in% names(data)]
@@ -658,6 +649,47 @@ verify_mode <- function(p) {
   p
 }
 
+
+verify_colorscale <- function(p) {
+  p$x$data <- lapply(p$x$data, function(trace) {
+    trace$colorscale <- colorscale_json(trace$colorscale)
+    trace$marker$colorscale <- colorscale_json(trace$marker$colorscale)
+    trace
+  }) 
+  p
+}
+
+# Coerce `x` into a data structure that can map to a colorscale attribute.
+# Note that colorscales can either be the name of a scale (e.g., 'Rainbow') or 
+# a 2D array (e.g., [[0, 'rgb(0,0,255)'], [1, 'rgb(255,0,0)']])
+colorscale_json <- function(x) {
+  if (!length(x)) return(x)
+  if (is.character(x)) return(x)
+  if (is.matrix(x)) {
+    if (ncol(x) != 2) stop("A colorscale matrix requires two columns")
+    x <- as.data.frame(x)
+    x[, 1] <- as.numeric(x[, 1])
+  }
+  if (is.list(x) && length(x) == 2) {
+    # ensure a list like this: list(list(0, 0.5, 1), list("red", "white", "blue"))
+    # converts to the correct dimensions
+    if (!is.data.frame(x) && can_be_numeric(x[[1]])) {
+      x <- data.frame(
+        val = as.numeric(x[[1]]),
+        col = as.character(x[[2]]),
+        stringsAsFactors = FALSE
+      )
+    }
+    x <- setNames(x, NULL)
+  }
+  x
+}
+
+can_be_numeric <- function(x) {
+  x <- suppressWarnings(as.numeric(x))
+  sum(is.na(x)) == 0
+}
+
 # if an object (e.g. trace.marker) contains a non-default attribute, it has been user-specified
 user_specified <- function(obj = NULL) {
   if (!length(obj)) return(FALSE)

tests/testthat/test-plotly-colorscale.R

@@ -0,0 +1,72 @@
+context("colorscales")
+
+
+test_that("Can specify marker.colorscale", {
+  p <- plot_ly(
+    x = c(-9, -6, -5, -3, -1), 
+    y = c(0, 1, 4, 5, 7), 
+    marker = list(
+      color = 1:5, 
+      colorscale='Rainbow', 
+      showscale = TRUE
+    )
+  ) 
+  l <- expect_doppelganger_built(p, "marker.colorscale")
+})
+
+test_that("Can specify contour colorscale", {
+  p <- plot_ly(
+    x = c(-9, -6, -5, -3, -1), 
+    y = c(0, 1, 4, 5, 7), 
+    z = matrix(c(10, 10.625, 12.5, 15.625, 20, 5.625, 6.25, 8.125, 11.25, 15.625, 2.5, 3.125, 5, 8.125, 12.5, 0.625, 1.25, 3.125,
+                 6.25, 10.625, 0, 0.625, 2.5, 5.625, 10), nrow = 5, ncol = 5), 
+    type = "contour",
+    colorscale = 'Rainbow'
+  )
+  l <- expect_doppelganger_built(p, "contour-colorscale")
+})
+
+test_that("Can provide a color interpolation function", {
+  p <- plot_ly(x = 1:10, y = 1:10, color = 1:10, colors = scales::colour_ramp(c("red", "green")))
+  l <- expect_doppelganger_built(p, "colorRamp")
+})
+
+test_that("Can specify contour colorscale", {
+
+  plot_colorscale <- function(colorscale) {
+    plot_ly(
+      x = 1:10, 
+      y = 1:10, 
+      marker = list(
+        color = 1:10, 
+        colorscale = colorscale, 
+        showscale = TRUE
+      )
+    )
+  }
+
+  pal <- scales::colour_ramp(c("red", "green"))
+  colorScale <- list(
+    val = seq(0, 1, by = 0.1), 
+    col = pal(seq(0, 1, by = 0.1))
+  )
+  test_list   <- plot_colorscale(colorScale)
+  test_df     <- plot_colorscale(as.data.frame(colorScale))
+  test_matrix <- plot_colorscale(as.matrix(as.data.frame(colorScale)))
+
+  expect_doppelganger_built(test_list, "test_list")
+  expect_doppelganger_built(test_df, "test_df")
+  expect_doppelganger_built(test_matrix, "test_matrix")
+
+  test_list_2 <- plot_colorscale(list(list(0, "rgb(0,0,255)"), list(1, "rgb(0,255,0)")))
+  test_list_3 <- plot_colorscale(list(list(0, 1), list("rgb(0,0,255)", "rgb(0,255,0)")))
+
+  expect_doppelganger_built(test_list_2, "test_list_2")
+  expect_doppelganger_built(test_list_3, "test_list_3")
+})
+
+
+test_that("contour colorscale supports alpha", {
+  p <- plot_ly(z = volcano, type = "contour", stroke = I("black"), alpha = 0.1)
+  l <- expect_doppelganger_built(p, "contour-alpha")
+})