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,51 @@ 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])
+  }
+  # ensure a list like this: list(list(0, 0.5, 1), list("red", "white", "blue"))
+  # converts to the correct dimensions: [[0, 'red'], [0.5, 'white'], [1, 'blue']]
+  if (is.list(x) && length(x) == 2) {
+    n1 <- length(x[[1]])
+    n2 <- length(x[[2]])
+    if (n1 != n2 || n1 == 0 || n2 == 0) {
+      warning("A colorscale list must of elements of the same (non-zero) length")
+    } else 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) {
+  xnum <- suppressWarnings(as.numeric(x))
+  sum(is.na(x)) == sum(is.na(xnum))
+}
+
 # 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)