From 887372eae9c616a043bf797dfdcd89ea1e6e0b95 Mon Sep 17 00:00:00 2001 From: cpsievert Date: Wed, 20 Jan 2016 21:24:28 -0600 Subject: [PATCH 1/7] more accurate list of data_array properties. fixes #415 --- R/utils.R | 30 ++++++++++++++++++++++++------ 1 file changed, 24 insertions(+), 6 deletions(-) diff --git a/R/utils.R b/R/utils.R index 7b33882c71..0539e61a80 100644 --- a/R/utils.R +++ b/R/utils.R @@ -112,23 +112,41 @@ 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) } x } +# plotlyjs properties that must _always_ be an array (even if length 1) +get_boxed <- function(type = "scatter") { + boxers[[type]] +} + +# 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") +) + + rm_asis <- function(x) { # jsonlite converts NULL to {} and NA to null (plotly prefers null to {}) # https://github.com/jeroenooms/jsonlite/issues/29 From 94aa22a48d2b7c3c74284221c665d1038ae5a531 Mon Sep 17 00:00:00 2001 From: cpsievert Date: Wed, 20 Jan 2016 21:35:41 -0600 Subject: [PATCH 2/7] bump version; update news --- .travis.yml | 2 ++ DESCRIPTION | 2 +- NEWS | 4 ++++ 3 files changed, 7 insertions(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index c0682b22b6..0b6d30d9da 100644 --- a/.travis.yml +++ b/.travis.yml @@ -24,6 +24,8 @@ cache: before_script: - mkdir -p "$R_LIBS_USER" + - git config --global user.email "cpsievert1@gmail.com" + - 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" diff --git a/DESCRIPTION b/DESCRIPTION index 70227bb4e6..2089a27455 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: plotly Title: Create Interactive Web Graphics via Plotly's JavaScript Graphing Library -Version: 2.3.0 +Version: 2.3.1 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"), email = "cpsievert1@gmail.com"), person("Chris", "Parmer", role = c("aut", "cph"), diff --git a/NEWS b/NEWS index 303d11692c..88d3c50579 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,7 @@ +2.3.1 -- 20 Jan 2015 + +more accurate list of data_array properties. fixes #415 + 2.3.0 -- 19 Jan 2015 Add sharing argument and deprecate world_readable. Fixes #332 From 873f476363077b83d2b89e4b47869f64dbc60634 Mon Sep 17 00:00:00 2001 From: cpsievert Date: Fri, 22 Jan 2016 12:30:21 -0600 Subject: [PATCH 3/7] if the trace type isn't found, provide some sensible defaults --- R/utils.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 0539e61a80..a5e9447021 100644 --- a/R/utils.R +++ b/R/utils.R @@ -126,7 +126,8 @@ add_boxed <- function(x) { # plotlyjs properties that must _always_ be an array (even if length 1) get_boxed <- function(type = "scatter") { - boxers[[type]] + # 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 From b6a541e1091546ee74f7458255763aa650e1d680 Mon Sep 17 00:00:00 2001 From: cpsievert Date: Mon, 25 Jan 2016 15:47:35 -0600 Subject: [PATCH 4/7] (safely) mark individual nested properties --- R/utils.R | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/R/utils.R b/R/utils.R index a5e9447021..85e247f371 100644 --- a/R/utils.R +++ b/R/utils.R @@ -120,6 +120,11 @@ add_boxed <- function(x) { d <- x$data[[i]] 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 + d$error_x$array <- i(d$error_x$array) + d$error_y$array <- i(d$error_y$array) + d$error_x$arrayminus <- i(d$error_x$arrayminus) + d$error_y$arrayminus <- i(d$error_y$arrayminus) } x } @@ -147,6 +152,23 @@ boxers <- list( surface = c("x", "y", "z", "text") ) +i <- function(x) if (is.null(x)) x else I(x) + +#' Pick an element from a nested list +#' @param x a list +#' @param nms a character vector specifying a search path +#' @example +#' x <- list(a = list(b = list(c = "Come and get it!"))) +#' pick(x, c("a", "b", "c")) +#' #> [1] "Come and get it!" +pick <- function(x, nms) { + for (i in seq_along(nms)) { + nm <- nms[i] + x <- x[[nm]] + } + x +} + rm_asis <- function(x) { # jsonlite converts NULL to {} and NA to null (plotly prefers null to {}) From a1c70b445ca932710eb4077189cc9480bbaa0234 Mon Sep 17 00:00:00 2001 From: cpsievert Date: Mon, 25 Jan 2016 16:16:07 -0600 Subject: [PATCH 5/7] add a simple test --- R/utils.R | 24 ++++-------------------- tests/testthat/test-plotly.R | 9 +++++++++ 2 files changed, 13 insertions(+), 20 deletions(-) diff --git a/R/utils.R b/R/utils.R index 85e247f371..7cf9656420 100644 --- a/R/utils.R +++ b/R/utils.R @@ -121,10 +121,10 @@ add_boxed <- function(x) { 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 - d$error_x$array <- i(d$error_x$array) - d$error_y$array <- i(d$error_y$array) - d$error_x$arrayminus <- i(d$error_x$arrayminus) - d$error_y$arrayminus <- i(d$error_y$arrayminus) + 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 } @@ -154,22 +154,6 @@ boxers <- list( i <- function(x) if (is.null(x)) x else I(x) -#' Pick an element from a nested list -#' @param x a list -#' @param nms a character vector specifying a search path -#' @example -#' x <- list(a = list(b = list(c = "Come and get it!"))) -#' pick(x, c("a", "b", "c")) -#' #> [1] "Come and get it!" -pick <- function(x, nms) { - for (i in seq_along(nms)) { - nm <- nms[i] - x <- x[[nm]] - } - x -} - - rm_asis <- function(x) { # jsonlite converts NULL to {} and NA to null (plotly prefers null to {}) # https://github.com/jeroenooms/jsonlite/issues/29 diff --git a/tests/testthat/test-plotly.R b/tests/testthat/test-plotly.R index 00bc271528..00da1103e5 100644 --- a/tests/testthat/test-plotly.R +++ b/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")) +}) From 2fb00ff172f5615614e4025ad616d03b6827916e Mon Sep 17 00:00:00 2001 From: cpsievert Date: Mon, 25 Jan 2016 16:25:53 -0600 Subject: [PATCH 6/7] demonstrate with a test that we also fixed #424 --- tests/testthat/test-ggplot-errorbar.R | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/tests/testthat/test-ggplot-errorbar.R b/tests/testthat/test-ggplot-errorbar.R index 9e75789055..0d77c9fcee 100644 --- a/tests/testthat/test-ggplot-errorbar.R +++ b/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 From 02350bb978d202321c1ef136693f207285af024c Mon Sep 17 00:00:00 2001 From: cpsievert Date: Mon, 25 Jan 2016 16:35:13 -0600 Subject: [PATCH 7/7] only attach AsIs to length 1 vectors to make expect_equal happy --- R/utils.R | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/R/utils.R b/R/utils.R index 7cf9656420..ae502809ee 100644 --- a/R/utils.R +++ b/R/utils.R @@ -152,7 +152,15 @@ boxers <- list( surface = c("x", "y", "z", "text") ) -i <- function(x) if (is.null(x)) x else I(x) +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 {})