Merge pull request #368 from ropensci/fix/build

Fix/build

Author: cpsievert

DESCRIPTION

@@ -1,6 +1,6 @@
 Package: plotly
 Title: Create Interactive Web Graphics via Plotly's JavaScript Graphing Library
-Version: 2.0.19
+Version: 2.1.0
 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.1.0 -- 29 Dec 2015
+
+plot_ly() now defaults to inherit=FALSE and plotly_build() is now idempotent. Fixes #280 and #277. See #368 for details.
+
 2.0.19 -- 23 Dec 2015
 
 Added as.widget() function for conveniency in converting plotly object to htmlwidget objects. See #294.

R/plotly.R

@@ -65,7 +65,7 @@
 #' 
 plot_ly <- function(data = data.frame(), ..., type = "scatter",
                     group, color, colors, symbol, symbols, size,
-                    width = NULL, height = NULL, inherit = TRUE, 
+                    width = NULL, height = NULL, inherit = FALSE, 
                     evaluate = FALSE) {
   # "native" plotly arguments
   argz <- substitute(list(...))
@@ -170,7 +170,7 @@ layout <- function(p = last_plot(), ...,
     enclos = parent.frame()
   )
   p <- last_plot(p)
-  p$layout <- c(p$layout, list(layout))
+  p$layout <- c(p$layout, list(layout = layout))
   if (evaluate) p <- plotly_build(p)
   hash_plot(data, p)
 }
@@ -265,9 +265,6 @@ plotly_build <- function(l = last_plot()) {
   # ggplot objects don't need any special type of handling
   if (is.ggplot(l)) return(gg2list(l))
   l <- get_plot(l)
-  # plots without NSE don't need it either
-  nmz <- c(lapply(l$data, names), lapply(l$layout, names), lapply(l$style, names))
-  if (!all(c("args", "env") %in% unlist(nmz))) return(structure(l, class = unique("plotly", class(l))))
   # assume unnamed list elements are data/traces
   nms <- names(l)
   idx <- nms %in% ""
@@ -276,14 +273,22 @@ plotly_build <- function(l = last_plot()) {
   } else if (any(idx)) {
     c(data = c(l$data, l[idx]), l[!idx])
   } else l
-  dats <- list()
+  # carry over properties, if necessary (but don't carry over evaluation envir)
+  if (length(l$data) > 1 && isTRUE(l$data[[1]]$inherit)) {
+    d <- l$data[[1]]
+    d <- d[!names(d) %in% c("env", "enclos")]
+    for (i in seq.int(2, length(l$data))) {
+      l$data[[i]] <- modifyList(l$data[[i]], d)
+    }
+  }
+  # 'x' is the same as 'l', but with arguments evaluated
+  # this is ugly, but I think it is necessary, since we don't know how many 
+  # traces we have until we evaluate args and call traceify() (or similar)
+  x <- list()
   for (i in seq_along(l$data)) {
     d <- l$data[[i]]
-    # if appropriate, evaluate trace arguments in a suitable environment
-    idx <- names(d) %in% c("args", "env", "enclos")
-    if (sum(idx) == 3) {
-      dat <- c(d[!idx], eval(d$args, as.list(d$env, all.names = TRUE), d$enclos))
-      dat[c("args", "env", "enclos")] <- NULL
+    if (should_eval(d)) {
+      dat <- do_eval(d)
       # start processing specially named arguments
       s <- dat[["size"]]
       if (!is.null(s)) {
@@ -309,49 +314,30 @@ plotly_build <- function(l = last_plot()) {
       has_group <- !is.null(dat[["group"]])
       if (has_color) {
         title <- as.list(d$args)[["color"]] %||% as.list(d$args)[["z"]] %||% ""
-        dats <- c(dats, colorize(dat, title))
+        x$data <- c(x$data, colorize(dat, title))
       }
       # TODO: add a legend title (is this only possible via annotations?!?)
-      if (has_symbol) dats <- c(dats, symbolize(dat))
-      if (has_group) dats <- c(dats, traceify(dat, "group"))
-      if (!has_color && !has_symbol && !has_group) dats <- c(dats, list(dat))
+      if (has_symbol) x$data <- c(x$data, symbolize(dat))
+      if (has_group) x$data <- c(x$data, traceify(dat, "group"))
+      if (!has_color && !has_symbol && !has_group) x$data <- c(x$data, list(dat))
     } else {
-      dats <- c(dats, list(d))
-    }
-  }
-  x <- list(data = dats)
-  # carry over properties/data from first trace (if appropriate)
-  if (length(x$data) > 1 && isTRUE(l$data[[1]]$inherit)) {
-    for (i in seq.int(2, length(x$data))) {
-      x$data[[i]] <- modifyList(x$data[[1]], x$data[[i]])
+      x$data <- c(x$data, list(d))
     }
   }
-  # layout() tacks on an unnamed list element to potentially pre-existing
-  # layout(s). Note that ggplotly() will return a named list 
-  # of length n >= 1 (so we need to carefully merge them ).
+  # it's possible have nested layouts (e.g., plot_ly() %>% layout() %>% layout())
   nms <- names(l$layout)
-  if (!is.null(nms) && any(idx <- nms %in% "")) {
-    # TODO: does this always preserve the correct order to layouts?
-    # (important since we use modifyList at a later point)
-    l$layout <- c(list(l$layout[!idx]), l$layout[idx])
-  }
+  idx <- nms %in% "layout"
+  l$layout <- c(list(l$layout[!idx]), setNames(l$layout[idx], NULL))
   for (i in seq_along(l$layout)) {
-    layout <- l$layout[[i]]
-    idx <- names(layout) %in% c("args", "env", "enclos")
-    x$layout[[i]] <- if (sum(idx) == 3) {
-      c(layout[!idx], eval(layout$args, as.list(layout$env, all.names = TRUE), layout$enclos)) 
-    } else {
-      layout
-    }
+    x$layout[[i]] <- perform_eval(l$layout[[i]])
   }
   x$layout <- Reduce(modifyList, x$layout)
   # if style is not null, use it to modify existing traces
   if (!is.null(l$style)) {
     for (i in seq_along(l$style)) {
-      sty <- l$style[[i]]
-      idx <- names(sty) %in% c("args", "env", "enclos")
-      new_sty <- if (sum(idx) == 3) c(sty[!idx], eval(sty$args, as.list(sty$env, all.names = TRUE), sty$enclos)) else sty
-      for (k in sty$traces) x$data[[k]] <- modifyList(x$data[[k]], new_sty)
+      sty <- perform_eval(l$style[[i]])
+      for (k in l$style[[i]]$traces) 
+        x$data[[k]] <- modifyList(x$data[[k]], sty)
     }
   }
   # add appropriate axis title (if they don't already exist)
@@ -365,26 +351,6 @@ plotly_build <- function(l = last_plot()) {
   if (!is.null(a) && !is.null(names(a))) {
     x$layout$annotations <- list(x$layout$annotations)
   }
-  # search for keyword args in traces and place them at the top level
-  kwargs <- lapply(x$data, function(z) z[get_kwargs()])
-  # 'top-level' keywords args take precedence
-  kwargs <- Reduce(modifyList, c(kwargs, list(x[get_kwargs()])))
-  # empty keyword arguments can cause problems
-  kwargs <- kwargs[sapply(kwargs, length) > 0]
-  # try our damndest to assign a sensible filename
-  if (is.null(kwargs$filename)) {
-    kwargs$filename <- 
-      as.character(kwargs$layout$title) %||% 
-      paste(
-        c(kwargs$layout$xaxis$title, 
-          kwargs$layout$yaxis$title, 
-          kwargs$layout$zaxis$title), 
-        collapse = " vs. "
-      ) %||%
-      "plot from api" 
-  }
-  # tack on keyword arguments
-  x <- c(x, kwargs)
   # traces shouldn't have any names
   x$data <- setNames(x$data, NULL)
   # add plotly class mainly for printing method

R/plotly_POST.R

@@ -26,7 +26,14 @@
 
 plotly_POST <- function(x, filename, fileopt = "new", world_readable = TRUE) {
   x <- plotly_build(x)
-  if (!missing(filename)) x$filename <- filename
+  x$filename <- if (!missing(filename)) { 
+    filename
+  } else {
+    # try our damndest to assign a sensible filename
+    x$filename %||% as.character(x$layout$title) %||% 
+      paste(c(x$layout$xaxis$title, x$layout$yaxis$title, x$layout$zaxis$title), 
+            collapse = " vs. ") %||% "plot from api" 
+  }
   if (!is.null(x$fileopt)) 
     warning("fileopt was specified in the wrong place. Please specify in plotly_POST()")
   x$fileopt <- fileopt

R/process.R

@@ -28,6 +28,7 @@ process.figure <- function(resp) {
   fig <- con$payload$figure
   fig$url <- sub("apigetfile/", "~", resp$url)
   fig <- add_boxed(fig)
+  fig$data[[1]]$inherit <- FALSE
   # any reasonable way to return a data frame?
   hash_plot(data.frame(), fig)
 }

R/utils.R

@@ -190,6 +190,25 @@ plotly_headers <- function(type = "main") {
   httr::add_headers(.headers = h)
 }
 
+
+perform_eval <- function(x) {
+  if (should_eval(x)) do_eval(x) else x
+}
+
+# env/enclos are special properties specific to the R API 
+# if they appear _and_ are environments, then evaluate arguments
+# (sometimes figures return these properties but evaluation doesn't make sense)
+should_eval <- function(x) { 
+  any(vapply(x[c("env", "enclos")], is.environment, logical(1))) 
+}
+
+# perform evaluation of arguments, keeping other list elements
+do_eval <- function(x) {
+  y <- c(x, eval(x$args, as.list(x$env, all.names = TRUE), x$enclos))
+  y[c("args", "env", "enclos")] <- NULL
+  y
+}
+
 # try to write environment variables to an .Rprofile
 cat_profile <- function(key, value, path = "~") {
   r_profile <- file.path(normalizePath(path, mustWork = TRUE),

tests/testthat/test-plotly-getfigure.R

@@ -28,3 +28,12 @@ test_that("retrieving a public figure ... works.", {
   p <- plotly_build(fig)
   expect_equivalent(p$data[[1]]$x, c("1", "2", "3"))
 })
+
+test_that("can add traces to a subplot figure", {
+  skip_on_cran()
+  fig <- get_figure('chelsea_lyn', 6366)
+  p <- add_trace(fig, x=c(1, 2, 3), y=c(4, 2, 4))
+  l <- plotly_build(p)
+  expect_equivalent(length(fig$data) + 1, length(l$data))
+})
+

tests/testthat/test-plotly.R

@@ -98,3 +98,16 @@ test_that("axis titles get attached to scene object for 3D plots", {
   expect_identical(scene$yaxis$title, "Petal.Width")
   expect_identical(scene$zaxis$title, "Sepal.Width")
 })
+
+test_that("inheriting properties works as expected", {
+  library(dplyr)
+  p <- iris %>%
+    count(Species) %>%
+    plot_ly(x = Species, y = n, opacity = 0.5, type = "bar", inherit = TRUE) %>%
+    layout(barmode = "overlay", showlegend = FALSE)
+  s <- count(iris[sample(nrow(iris), 10), ], Species)
+  p2 <- add_trace(p, data = s)
+  l <- plotly_build(p2)
+  expect_equal(l$data[[2]]$opacity, 0.5)
+  expect_true(all(l$data[[1]]$y > l$data[[2]]$y))
+})