Merge pull request #417 from ropensci/fix/box

more accurate 'boxing' of data_array properties. fixes #415

Author: cpsievert

.travis.yml

@@ -24,7 +24,7 @@ cache:
 before_script:
   - mkdir -p "$R_LIBS_USER"
   - git config --global user.email "[email protected]"
-  - git config --global user.name "Carson Sievert"
+  - git config --global user.name "cpsievert"
   - echo "Sys.setenv('plotly_username' = 'cpsievert')" > ~/.Rprofile
   - git clone https://github.com/cpsievert/plotly-test-table.git ../plotly-test-table
   - "wget -q -O - https://github.com/yihui/crandalf/raw/master/inst/scripts/install-pandoc | bash"

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: plotly
 Title: Create Interactive Web Graphics via Plotly's JavaScript Graphing Library
-Version: 2.3.1
+Version: 2.3.2
 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"),
     email = "[email protected]"),
     person("Chris", "Parmer", role = c("aut", "cph"),

NEWS

@@ -1,3 +1,7 @@
+2.3.2 -- 25 Jan 2015
+
+More accurate list of data_array properties. Fixes #415
+
 2.3.1 -- 25 Jan 2015
 
 More accurate conversion of path width. Fixes #373.

R/utils.R

@@ -112,23 +112,56 @@ from_JSON <- function(x, ...) {
   jsonlite::fromJSON(x, simplifyDataFrame = FALSE, simplifyMatrix = FALSE, ...)
 }
 
-# plotlyjs properties that must _always_ be an array (even if length 1)
-get_boxed <- function() {
-  c("x", "y", "lat", "lon", "text")
-}
-
 add_boxed <- function(x) {
   for (i in seq_along(x$data)) {
     # some object keys require an array, even if length one
     # one way to ensure atomic vectors of length 1 are not automatically unboxed,
     # by to_JSON(), is to attach a class of AsIs (via I())
     d <- x$data[[i]]
-    idx <- names(d) %in% get_boxed() & sapply(d, length) == 1
+    idx <- names(d) %in% get_boxed(d$type %||% "scatter") & sapply(d, length) == 1
     if (any(idx)) x$data[[i]][idx] <- lapply(d[idx], I)
+    # (safely) mark individual nested properties
+    x$data[[i]]$error_x$array <- i(d$error_x$array)
+    x$data[[i]]$error_y$array <- i(d$error_y$array)
+    x$data[[i]]$error_x$arrayminus <- i(d$error_x$arrayminus)
+    x$data[[i]]$error_y$arrayminus <- i(d$error_y$arrayminus)
   }
   x
 }
 
+# plotlyjs properties that must _always_ be an array (even if length 1)
+get_boxed <- function(type = "scatter") {
+  # if the trace type isn't found, provide some sensible defaults
+  boxers[[type]] %||% c("x", "y", "z", "lat", "lon", "text", "locations")
+}
+
+# if this ever needs updating see
+# https://github.com/ropensci/plotly/issues/415#issuecomment-173353138
+boxers <- list(
+  choropleth = c("locations", "z", "text"),
+  box = c("x", "y"),
+  heatmap = c("z", "text"),
+  histogram = c("x", "y"),
+  histogram2d = c("z", "color"),
+  mesh3d = c("x", "y", "z", "i", "j", "k", "intensity", "vertexcolor", "facecolor"),
+  # TODO: what to do about marker.colors?
+  pie = c("labels", "values", "text"),
+  scatter = c("x", "y", "r", "t"),
+  scatter3d = c("x", "y", "z"),
+  scattergeo = c("lon", "lat", "locations"),
+  surface = c("x", "y", "z", "text")
+)
+
+i <- function(x) {
+  if (is.null(x)) {
+    return(NULL)
+  } else if (length(x) == 1) {
+    return(I(x))
+  } else{
+    return(x)
+  }
+}
+
 rm_asis <- function(x) {
   # jsonlite converts NULL to {} and NA to null (plotly prefers null to {})
   # https://github.com/jeroenooms/jsonlite/issues/29

tests/testthat/test-ggplot-errorbar.R

@@ -16,3 +16,22 @@ test_that("geom_errorbar gives errorbars", {
   # right data for errorbar ymax
   expect_equal(L$data[[1]]$error_y$array, c(3.74, 1.26, 1.15))
 })
+
+df <- data.frame(
+  trt = factor(c(1, 1, 2, 2)),
+  resp = c(1, 5, 3, 4),
+  group = factor(c(1, 2, 3, 4)),
+  upper = c(1.1, 5.3, 3.3, 4.2),
+  lower = c(0.8, 4.6, 2.4, 3.6)
+)
+
+p <- ggplot(df, aes(trt, resp, colour = group))
+g <- p + geom_errorbar(aes(ymin = lower, ymax = upper))
+
+test_that("geom_errorbar boxes an array of length 1", {
+  L <- save_outputs(g, "errorbar-unique-groups")
+  expect_true(inherits(L$data[[1]]$error_y$array, "AsIs"))
+  expect_true(inherits(L$data[[1]]$error_y$arrayminus, "AsIs"))
+})
+
+# TODO fix and add a test for width of errorbars

tests/testthat/test-plotly.R

@@ -111,3 +111,12 @@ test_that("inheriting properties works as expected", {
   expect_equal(l$data[[2]]$opacity, 0.5)
   expect_true(all(l$data[[1]]$y > l$data[[2]]$y))
 })
+
+test_that("x/y/z properties have a class of AsIs", {
+  p <- plot_ly(x = 1, y = 1, z = 1, type = "scatter3d")
+  l <- plotly_build(p)
+  tr <- l$data[[1]]
+  expect_true(inherits(tr$x, "AsIs"))
+  expect_true(inherits(tr$y, "AsIs"))
+  expect_true(inherits(tr$z, "AsIs"))
+})