From 85818b1c838542ea53f3fb2be0f284b969995b00 Mon Sep 17 00:00:00 2001 From: Carson Date: Tue, 23 Jun 2020 12:45:23 -0500 Subject: [PATCH 1/7] Pull plotly's custom ggplot_build into a function and hook into thematic if relevant --- R/ggplotly.R | 409 +++++++++++++++++++++++++++------------------------ R/plotly.R | 3 +- 2 files changed, 216 insertions(+), 196 deletions(-) diff --git a/R/ggplotly.R b/R/ggplotly.R index 556aa12326..9477f8e45e 100644 --- a/R/ggplotly.R +++ b/R/ggplotly.R @@ -214,212 +214,231 @@ gg2list <- function(p, width = NULL, height = NULL, # Our internal version of ggplot2::ggplot_build(). Modified from # https://github.com/hadley/ggplot2/blob/0cd0ba/R/plot-build.r#L18-L92 # ------------------------------------------------------------------------ - - plot <- ggfun("plot_clone")(p) - if (length(plot$layers) == 0) { - plot <- plot + geom_blank() - } - layers <- plot$layers - layer_data <- lapply(layers, function(y) y$layer_data(plot$data)) - - # save crosstalk sets before this attribute gets squashed - sets <- lapply(layer_data, function(y) attr(y, "set")) - - scales <- plot$scales - - # Apply function to layer and matching data - by_layer <- function(f) { - out <- vector("list", length(data)) - for (i in seq_along(data)) { - out[[i]] <- f(l = layers[[i]], d = data[[i]]) + ggplotly_build <- function(p) { + plot <- ggfun("plot_clone")(p) + + if (length(plot$layers) == 0) { + plot <- plot + geom_blank() } - out - } - - # ggplot2 3.1.0.9000 introduced a Layer method named setup_layer() - # currently, LayerSf is the only core-ggplot2 Layer that makes use - # of it https://github.com/tidyverse/ggplot2/pull/2875#issuecomment-438708426 - data <- layer_data - if (packageVersion("ggplot2") > "3.1.0") { - data <- by_layer(function(l, d) if (is.function(l$setup_layer)) l$setup_layer(d, plot) else d) - } - - # Initialise panels, add extra data for margins & missing facetting - # variables, and add on a PANEL variable to data - layout <- ggfun("create_layout")(plot$facet, plot$coordinates) - data <- layout$setup(data, plot$data, plot$plot_env) - - # save the domain of the group for display in tooltips - groupDomains <- Map(function(x, y) { - aes_g <- y$mapping[["group"]] %||% plot$mapping[["group"]] - tryNULL(rlang::eval_tidy(aes_g, x)) - }, data, layers) - - # for simple (StatIdentity) geoms, add crosstalk key to aes mapping - # (effectively adding it as a group) - # later on, for more complicated geoms (w/ non-trivial summary statistics), - # we construct a nested key mapping (within group) - layers <- Map(function(x, y) { - if (crosstalk_key() %in% names(y) && !"key" %in% names(x[["mapping"]]) && - inherits(x[["stat"]], "StatIdentity")) { - x[["mapping"]] <- c(x[["mapping"]], key = as.name(crosstalk_key())) + layers <- plot$layers + layer_data <- lapply(layers, function(y) y$layer_data(plot$data)) + + # save crosstalk sets before this attribute gets squashed + sets <- lapply(layer_data, function(y) attr(y, "set")) + + scales <- plot$scales + + # Apply function to layer and matching data + by_layer <- function(f) { + out <- vector("list", length(data)) + for (i in seq_along(data)) { + out[[i]] <- f(l = layers[[i]], d = data[[i]]) + } + out } - x - }, layers, layer_data) - - # Compute aesthetics to produce data with generalised variable names - data <- by_layer(function(l, d) l$compute_aesthetics(d, plot)) - - # add frame to group if it exists - data <- lapply(data, function(d) { - if (!"frame" %in% names(d)) return(d) - d$group <- with(d, paste(group, frame, sep = "-")) - d - }) - - # The computed aesthetic codes the groups as integers - # Here we build a map each of the integer values to the group label - group_maps <- Map(function(x, y) { - tryCatch({ - x_group <- x[["group"]] - names(x_group) <- y - x_group <- x_group[!duplicated(x_group)] - x_group - }, error = function(e) NULL - ) - }, data, groupDomains) - - # Before mapping x/y position, save the domain (for discrete scales) - # to display in tooltip. - data <- lapply(data, function(d) { - d[["x_plotlyDomain"]] <- d[["x"]] - d[["y_plotlyDomain"]] <- d[["y"]] - d - }) - - # Transform all scales - data <- lapply(data, ggfun("scales_transform_df"), scales = scales) - - # Map and train positions so that statistics have access to ranges - # and all positions are numeric - scale_x <- function() scales$get_scales("x") - scale_y <- function() scales$get_scales("y") - - layout$train_position(data, scale_x(), scale_y()) - - data <- layout$map_position(data) - - # build a mapping between group and key - # if there are multiple keys within a group, the key is a list-column - reComputeGroup <- function(x, layer = NULL) { - # 1-to-1 link between data & visual marks -- group == key - if (inherits(layer$geom, "GeomDotplot")) { - x <- split(x, x[["PANEL"]]) - x <- lapply(x, function(d) { - d[["group"]] <- do.call("order", d[c("x", "group")]) - d - }) - x <- dplyr::bind_rows(x) + + # ggplot2 3.1.0.9000 introduced a Layer method named setup_layer() + # currently, LayerSf is the only core-ggplot2 Layer that makes use + # of it https://github.com/tidyverse/ggplot2/pull/2875#issuecomment-438708426 + data <- layer_data + if (packageVersion("ggplot2") > "3.1.0") { + data <- by_layer(function(l, d) if (is.function(l$setup_layer)) l$setup_layer(d, plot) else d) + } + + # Initialise panels, add extra data for margins & missing facetting + # variables, and add on a PANEL variable to data + layout <- ggfun("create_layout")(plot$facet, plot$coordinates) + data <- layout$setup(data, plot$data, plot$plot_env) + + # save the domain of the group for display in tooltips + groupDomains <- Map(function(x, y) { + aes_g <- y$mapping[["group"]] %||% plot$mapping[["group"]] + tryNULL(rlang::eval_tidy(aes_g, x)) + }, data, layers) + + # for simple (StatIdentity) geoms, add crosstalk key to aes mapping + # (effectively adding it as a group) + # later on, for more complicated geoms (w/ non-trivial summary statistics), + # we construct a nested key mapping (within group) + layers <- Map(function(x, y) { + if (crosstalk_key() %in% names(y) && !"key" %in% names(x[["mapping"]]) && + inherits(x[["stat"]], "StatIdentity")) { + x[["mapping"]] <- c(x[["mapping"]], key = as.name(crosstalk_key())) + } + x + }, layers, layer_data) + + # Compute aesthetics to produce data with generalised variable names + data <- by_layer(function(l, d) l$compute_aesthetics(d, plot)) + + # add frame to group if it exists + data <- lapply(data, function(d) { + if (!"frame" %in% names(d)) return(d) + d$group <- with(d, paste(group, frame, sep = "-")) + d + }) + + # The computed aesthetic codes the groups as integers + # Here we build a map each of the integer values to the group label + group_maps <- Map(function(x, y) { + tryCatch({ + x_group <- x[["group"]] + names(x_group) <- y + x_group <- x_group[!duplicated(x_group)] + x_group + }, error = function(e) NULL + ) + }, data, groupDomains) + + # Before mapping x/y position, save the domain (for discrete scales) + # to display in tooltip. + data <- lapply(data, function(d) { + d[["x_plotlyDomain"]] <- d[["x"]] + d[["y_plotlyDomain"]] <- d[["y"]] + d + }) + + # Transform all scales + data <- lapply(data, ggfun("scales_transform_df"), scales = scales) + + # Map and train positions so that statistics have access to ranges + # and all positions are numeric + scale_x <- function() scales$get_scales("x") + scale_y <- function() scales$get_scales("y") + + layout$train_position(data, scale_x(), scale_y()) + + data <- layout$map_position(data) + + # build a mapping between group and key + # if there are multiple keys within a group, the key is a list-column + reComputeGroup <- function(x, layer = NULL) { + # 1-to-1 link between data & visual marks -- group == key + if (inherits(layer$geom, "GeomDotplot")) { + x <- split(x, x[["PANEL"]]) + x <- lapply(x, function(d) { + d[["group"]] <- do.call("order", d[c("x", "group")]) + d + }) + x <- dplyr::bind_rows(x) + } + if (inherits(layer$geom, "GeomSf")) { + x <- split(x, x[["PANEL"]]) + x <- lapply(x, function(d) { + d[["group"]] <- seq_len(nrow(d)) + d + }) + # I think this is safe? + x <- suppressWarnings(dplyr::bind_rows(x)) + } + x } - if (inherits(layer$geom, "GeomSf")) { - x <- split(x, x[["PANEL"]]) - x <- lapply(x, function(d) { - d[["group"]] <- seq_len(nrow(d)) - d - }) - # I think this is safe? - x <- suppressWarnings(dplyr::bind_rows(x)) + + nestedKeys <- Map(function(x, y, z) { + key <- y[[crosstalk_key()]] + if (is.null(key) || inherits(z[["stat"]], "StatIdentity")) return(NULL) + x <- reComputeGroup(x, z) + tib <- tibble::as_tibble(x[c("PANEL", "group")]) + tib[["key"]] <- key + nested <- tidyr::nest(tib, key, .key = key) + # reduce the dimensions of list column elements from 2 to 1 + nested$key <- lapply(nested$key, function(x) x[[1]]) + nested + }, data, layer_data, layers) + + # for some geoms (e.g. boxplots) plotly.js needs the "pre-statistics" data + # we also now provide the option to return one of these two + prestats_data <- data + data <- by_layer(function(l, d) l$compute_statistic(d, layout)) + data <- by_layer(function(l, d) l$map_statistic(d, plot)) + + # Make sure missing (but required) aesthetics are added + ggfun("scales_add_missing")(plot, c("x", "y"), plot$plot_env) + + # Reparameterise geoms from (e.g.) y and width to ymin and ymax + data <- by_layer(function(l, d) l$compute_geom_1(d)) + + # compute_geom_1 can reorder the rows from `data`, making groupDomains + # invalid. We rebuild groupDomains based on the current `data` and the + # group map we built before. + groupDomains <- Map(function(x, y) { + tryCatch({ + names(y)[match(x$group, y)] + }, error = function(e) NULL + ) + }, data, group_maps) + + # there are some geoms (e.g. geom_dotplot()) where attaching the key + # before applying the statistic can cause problems, but there is still a + # 1-to-1 corresponding between graphical marks and + + # Apply position adjustments + data <- by_layer(function(l, d) l$compute_position(d, layout)) + + # Reset position scales, then re-train and map. This ensures that facets + # have control over the range of a plot: is it generated from what's + # displayed, or does it include the range of underlying data + layout$reset_scales() + layout$train_position(data, scale_x(), scale_y()) + layout$setup_panel_params() + data <- layout$map_position(data) + + # Train and map non-position scales + npscales <- scales$non_position_scales() + if (npscales$n() > 0) { + lapply(data, ggfun("scales_train_df"), scales = npscales) + # this for loop is unique to plotly -- it saves the "domain" + # of each non-positional scale for display in tooltips + for (sc in npscales$scales) { + data <- lapply(data, function(d) { + # scale may not be relevant for every layer data + if (any(names(d) %in% sc$aesthetics)) { + d[paste0(sc$aesthetics, "_plotlyDomain")] <- d[sc$aesthetics] + } + d + }) + } + data <- lapply(data, ggfun("scales_map_df"), scales = npscales) } - x + + # Fill in defaults etc. + data <- by_layer(function(l, d) l$compute_geom_2(d)) + + # Let layer stat have a final say before rendering + data <- by_layer(function(l, d) l$finish_statistics(d)) + + # Let Layout modify data before rendering + data <- layout$finish_data(data) + + # if necessary, attach key + data <- Map(function(x, y, z) { + if (!length(y)) return(x) + x <- reComputeGroup(x, z) + # dplyr issue??? https://github.com/tidyverse/dplyr/issues/2701 + attr(y$group, "n") <- NULL + suppressMessages(dplyr::left_join(x, y)) + }, data, nestedKeys, layers) + + # return all the objects in this environmet + mget(ls(environment()), inherits = FALSE) } - nestedKeys <- Map(function(x, y, z) { - key <- y[[crosstalk_key()]] - if (is.null(key) || inherits(z[["stat"]], "StatIdentity")) return(NULL) - x <- reComputeGroup(x, z) - tib <- tibble::as_tibble(x[c("PANEL", "group")]) - tib[["key"]] <- key - nested <- tidyr::nest(tib, key, .key = key) - # reduce the dimensions of list column elements from 2 to 1 - nested$key <- lapply(nested$key, function(x) x[[1]]) - nested - }, data, layer_data, layers) - - # for some geoms (e.g. boxplots) plotly.js needs the "pre-statistics" data - # we also now provide the option to return one of these two - prestats_data <- data - data <- by_layer(function(l, d) l$compute_statistic(d, layout)) - data <- by_layer(function(l, d) l$map_statistic(d, plot)) - - # Make sure missing (but required) aesthetics are added - ggfun("scales_add_missing")(plot, c("x", "y"), plot$plot_env) - - # Reparameterise geoms from (e.g.) y and width to ymin and ymax - data <- by_layer(function(l, d) l$compute_geom_1(d)) - - # compute_geom_1 can reorder the rows from `data`, making groupDomains - # invalid. We rebuild groupDomains based on the current `data` and the - # group map we built before. - groupDomains <- Map(function(x, y) { - tryCatch({ - names(y)[match(x$group, y)] - }, error = function(e) NULL - ) - }, data, group_maps) - - # there are some geoms (e.g. geom_dotplot()) where attaching the key - # before applying the statistic can cause problems, but there is still a - # 1-to-1 corresponding between graphical marks and - - # Apply position adjustments - data <- by_layer(function(l, d) l$compute_position(d, layout)) - - # Reset position scales, then re-train and map. This ensures that facets - # have control over the range of a plot: is it generated from what's - # displayed, or does it include the range of underlying data - layout$reset_scales() - layout$train_position(data, scale_x(), scale_y()) - layout$setup_panel_params() - data <- layout$map_position(data) - - # Train and map non-position scales - npscales <- scales$non_position_scales() - if (npscales$n() > 0) { - lapply(data, ggfun("scales_train_df"), scales = npscales) - # this for loop is unique to plotly -- it saves the "domain" - # of each non-positional scale for display in tooltips - for (sc in npscales$scales) { - data <- lapply(data, function(d) { - # scale may not be relevant for every layer data - if (any(names(d) %in% sc$aesthetics)) { - d[paste0(sc$aesthetics, "_plotlyDomain")] <- d[sc$aesthetics] - } - d - }) - } - data <- lapply(data, ggfun("scales_map_df"), scales = npscales) + # Allow thematic to add new defaults to the plot object based on it's theme + ggthematic_build <- getFromNamespace("ggthematic_build", "thematic") + built <- if (is.function(ggthematic_build)) { + ggthematic_build(p, ggplotly_build, thematic::thematic_get_theme(resolve = TRUE)) + } else { + ggplotly_build(p) } - # Fill in defaults etc. - data <- by_layer(function(l, d) l$compute_geom_2(d)) + # ggplotly_build() returns list of objects...make them known to gg2list() env - # Let layer stat have a final say before rendering - data <- by_layer(function(l, d) l$finish_statistics(d)) + env <- environment() + for (var in names(built)) { + assign(var, built[[var]], envir = env) + } - # Let Layout modify data before rendering - data <- layout$finish_data(data) - # ------------------------------------------------------------------------ - # end of ggplot_build() - # ------------------------------------------------------------------------ - # if necessary, attach key - data <- Map(function(x, y, z) { - if (!length(y)) return(x) - x <- reComputeGroup(x, z) - # dplyr issue??? https://github.com/tidyverse/dplyr/issues/2701 - attr(y$group, "n") <- NULL - suppressMessages(dplyr::left_join(x, y)) - }, data, nestedKeys, layers) # initiate plotly.js layout with some plot-wide theming stuff theme <- ggfun("plot_theme")(plot) diff --git a/R/plotly.R b/R/plotly.R index b4d910d1b1..995816b588 100644 --- a/R/plotly.R +++ b/R/plotly.R @@ -420,7 +420,8 @@ as_widget <- function(x, ...) { sizingPolicy = htmlwidgets::sizingPolicy( browser.fill = TRUE, defaultWidth = '100%', - defaultHeight = 400 + defaultHeight = 400, + padding = 0 ), preRenderHook = plotly_build, dependencies = c( From 9c864d617dddf35d898285ab4d5d850e395e4367 Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 25 Jun 2020 13:29:11 -0500 Subject: [PATCH 2/7] add thematic to suggests and use it only when loaded --- DESCRIPTION | 4 +++- R/ggplotly.R | 4 ++-- 2 files changed, 5 insertions(+), 3 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8c5c69eef9..9fc57b87e1 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -72,8 +72,10 @@ Suggests: IRdisplay, processx, plotlyGeoAssets, - forcats + forcats, + thematic LazyData: true RoxygenNote: 7.1.0 Encoding: UTF-8 Roxygen: list(markdown = TRUE) +Remotes: rstudio/thematic diff --git a/R/ggplotly.R b/R/ggplotly.R index 9477f8e45e..f354fcb389 100644 --- a/R/ggplotly.R +++ b/R/ggplotly.R @@ -424,8 +424,8 @@ gg2list <- function(p, width = NULL, height = NULL, } # Allow thematic to add new defaults to the plot object based on it's theme - ggthematic_build <- getFromNamespace("ggthematic_build", "thematic") - built <- if (is.function(ggthematic_build)) { + built <- if (isNamespaceLoaded("thematic")) { + ggthematic_build <- getFromNamespace("ggthematic_build", "thematic") ggthematic_build(p, ggplotly_build, thematic::thematic_get_theme(resolve = TRUE)) } else { ggplotly_build(p) From 611318566977c15fb1d120d20d00ab6ab9d15070 Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 25 Jun 2020 13:39:17 -0500 Subject: [PATCH 3/7] update shinytest tests --- .../tests/{ => shinytest}/mytest-expected/001.json | 8 ++++---- .../tests/{ => shinytest}/mytest-expected/001.png | Bin .../tests/{ => shinytest}/mytest-expected/002.json | 8 ++++---- .../tests/{ => shinytest}/mytest-expected/002.png | Bin .../tests/{ => shinytest}/mytest-expected/003.json | 8 ++++---- .../tests/{ => shinytest}/mytest-expected/003.png | Bin .../tests/{ => shinytest}/mytest-expected/004.json | 8 ++++---- .../tests/{ => shinytest}/mytest-expected/004.png | Bin .../shiny/event_data/tests/{ => shinytest}/mytest.R | 2 +- 9 files changed, 17 insertions(+), 17 deletions(-) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/001.json (98%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/001.png (100%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/002.json (98%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/002.png (100%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/003.json (99%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/003.png (100%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/004.json (98%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest-expected/004.png (100%) rename inst/examples/shiny/event_data/tests/{ => shinytest}/mytest.R (96%) diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/001.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json similarity index 98% rename from inst/examples/shiny/event_data/tests/mytest-expected/001.json rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json index a3c073e484..042ba00d76 100644 --- a/inst/examples/shiny/event_data/tests/mytest-expected/001.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json @@ -413,9 +413,9 @@ }, { "name": "jquery", - "version": "1.11.3", + "version": "3.5.1", "src": { - "href": "jquery-1.11.3" + "href": "jquery-3.5.1" }, "meta": null, "script": "jquery.min.js", @@ -426,9 +426,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.1", + "version": "1.1.0.9000", "src": { - "href": "crosstalk-1.1.0.1" + "href": "crosstalk-1.1.0.9000" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/001.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png similarity index 100% rename from inst/examples/shiny/event_data/tests/mytest-expected/001.png rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.png diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/002.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json similarity index 98% rename from inst/examples/shiny/event_data/tests/mytest-expected/002.json rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json index 7a0880309a..d46839e415 100644 --- a/inst/examples/shiny/event_data/tests/mytest-expected/002.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json @@ -430,9 +430,9 @@ }, { "name": "jquery", - "version": "1.11.3", + "version": "3.5.1", "src": { - "href": "jquery-1.11.3" + "href": "jquery-3.5.1" }, "meta": null, "script": "jquery.min.js", @@ -443,9 +443,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.1", + "version": "1.1.0.9000", "src": { - "href": "crosstalk-1.1.0.1" + "href": "crosstalk-1.1.0.9000" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/002.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png similarity index 100% rename from inst/examples/shiny/event_data/tests/mytest-expected/002.png rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.png diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/003.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json similarity index 99% rename from inst/examples/shiny/event_data/tests/mytest-expected/003.json rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json index 56897f0274..ec14b55f3e 100644 --- a/inst/examples/shiny/event_data/tests/mytest-expected/003.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json @@ -434,9 +434,9 @@ }, { "name": "jquery", - "version": "1.11.3", + "version": "3.5.1", "src": { - "href": "jquery-1.11.3" + "href": "jquery-3.5.1" }, "meta": null, "script": "jquery.min.js", @@ -447,9 +447,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.1", + "version": "1.1.0.9000", "src": { - "href": "crosstalk-1.1.0.1" + "href": "crosstalk-1.1.0.9000" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/003.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png similarity index 100% rename from inst/examples/shiny/event_data/tests/mytest-expected/003.png rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.png diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/004.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json similarity index 98% rename from inst/examples/shiny/event_data/tests/mytest-expected/004.json rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json index 8304d1d071..213bd7767c 100644 --- a/inst/examples/shiny/event_data/tests/mytest-expected/004.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json @@ -435,9 +435,9 @@ }, { "name": "jquery", - "version": "1.11.3", + "version": "3.5.1", "src": { - "href": "jquery-1.11.3" + "href": "jquery-3.5.1" }, "meta": null, "script": "jquery.min.js", @@ -448,9 +448,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.1", + "version": "1.1.0.9000", "src": { - "href": "crosstalk-1.1.0.1" + "href": "crosstalk-1.1.0.9000" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/mytest-expected/004.png b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png similarity index 100% rename from inst/examples/shiny/event_data/tests/mytest-expected/004.png rename to inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.png diff --git a/inst/examples/shiny/event_data/tests/mytest.R b/inst/examples/shiny/event_data/tests/shinytest/mytest.R similarity index 96% rename from inst/examples/shiny/event_data/tests/mytest.R rename to inst/examples/shiny/event_data/tests/shinytest/mytest.R index 6516d1a5b1..1138cc49fd 100644 --- a/inst/examples/shiny/event_data/tests/mytest.R +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest.R @@ -1,4 +1,4 @@ -app <- ShinyDriver$new("../", shinyOptions = list(display.mode = "normal")) +app <- ShinyDriver$new("../../", shinyOptions = list(display.mode = "normal")) app$snapshotInit("mytest") app$snapshot() From 9114b8ad82172a368bf5ec3f83b5c7b52b4121b1 Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 25 Jun 2020 16:25:54 -0500 Subject: [PATCH 4/7] Go back to the assign() based approach --- R/ggplotly.R | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/R/ggplotly.R b/R/ggplotly.R index f354fcb389..04ea2b39aa 100644 --- a/R/ggplotly.R +++ b/R/ggplotly.R @@ -419,8 +419,13 @@ gg2list <- function(p, width = NULL, height = NULL, suppressMessages(dplyr::left_join(x, y)) }, data, nestedKeys, layers) - # return all the objects in this environmet - mget(ls(environment()), inherits = FALSE) + structure( + list( + data = data, layout = layout, plot = plot, + env = environment() + ), + class = "ggplot_built" + ) } # Allow thematic to add new defaults to the plot object based on it's theme @@ -431,15 +436,13 @@ gg2list <- function(p, width = NULL, height = NULL, ggplotly_build(p) } - # ggplotly_build() returns list of objects...make them known to gg2list() env - - env <- environment() - for (var in names(built)) { - assign(var, built[[var]], envir = env) + # Assign all the objects available to ggplotly_build() to this functions environment + built_env <- built$env + envir <- environment() + for (var in ls(built_env)) { + assign(var, built_env[[var]], envir = envir) } - - # initiate plotly.js layout with some plot-wide theming stuff theme <- ggfun("plot_theme")(plot) elements <- names(which(sapply(theme, inherits, "element"))) From c5a8a2f9bd8d9d6adbce6d2be4ac83fffed2511f Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 25 Jun 2020 16:39:41 -0500 Subject: [PATCH 5/7] bust cache --- .travis.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.travis.yml b/.travis.yml index cfa1e5be59..c29b9a5e7a 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,5 @@ language: R -cache: packages +#cache: packages warnings_are_errors: false r: From deaa381155c89b1d8e870068ac0ad4c18131df2f Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 25 Jun 2020 17:16:10 -0500 Subject: [PATCH 6/7] CRAN version of crosstalk --- .travis.yml | 2 +- .../event_data/tests/shinytest/mytest-expected/001.json | 8 ++++---- .../event_data/tests/shinytest/mytest-expected/002.json | 8 ++++---- .../event_data/tests/shinytest/mytest-expected/003.json | 8 ++++---- .../event_data/tests/shinytest/mytest-expected/004.json | 8 ++++---- 5 files changed, 17 insertions(+), 17 deletions(-) diff --git a/.travis.yml b/.travis.yml index c29b9a5e7a..cfa1e5be59 100644 --- a/.travis.yml +++ b/.travis.yml @@ -1,5 +1,5 @@ language: R -#cache: packages +cache: packages warnings_are_errors: false r: diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json index 042ba00d76..a3c073e484 100644 --- a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/001.json @@ -413,9 +413,9 @@ }, { "name": "jquery", - "version": "3.5.1", + "version": "1.11.3", "src": { - "href": "jquery-3.5.1" + "href": "jquery-1.11.3" }, "meta": null, "script": "jquery.min.js", @@ -426,9 +426,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.9000", + "version": "1.1.0.1", "src": { - "href": "crosstalk-1.1.0.9000" + "href": "crosstalk-1.1.0.1" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json index d46839e415..7a0880309a 100644 --- a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/002.json @@ -430,9 +430,9 @@ }, { "name": "jquery", - "version": "3.5.1", + "version": "1.11.3", "src": { - "href": "jquery-3.5.1" + "href": "jquery-1.11.3" }, "meta": null, "script": "jquery.min.js", @@ -443,9 +443,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.9000", + "version": "1.1.0.1", "src": { - "href": "crosstalk-1.1.0.9000" + "href": "crosstalk-1.1.0.1" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json index ec14b55f3e..56897f0274 100644 --- a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/003.json @@ -434,9 +434,9 @@ }, { "name": "jquery", - "version": "3.5.1", + "version": "1.11.3", "src": { - "href": "jquery-3.5.1" + "href": "jquery-1.11.3" }, "meta": null, "script": "jquery.min.js", @@ -447,9 +447,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.9000", + "version": "1.1.0.1", "src": { - "href": "crosstalk-1.1.0.9000" + "href": "crosstalk-1.1.0.1" }, "meta": null, "script": "js/crosstalk.min.js", diff --git a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json index 213bd7767c..8304d1d071 100644 --- a/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json +++ b/inst/examples/shiny/event_data/tests/shinytest/mytest-expected/004.json @@ -435,9 +435,9 @@ }, { "name": "jquery", - "version": "3.5.1", + "version": "1.11.3", "src": { - "href": "jquery-3.5.1" + "href": "jquery-1.11.3" }, "meta": null, "script": "jquery.min.js", @@ -448,9 +448,9 @@ }, { "name": "crosstalk", - "version": "1.1.0.9000", + "version": "1.1.0.1", "src": { - "href": "crosstalk-1.1.0.9000" + "href": "crosstalk-1.1.0.1" }, "meta": null, "script": "js/crosstalk.min.js", From af9a22909b0682df25d51ddd1e855c0473eea04f Mon Sep 17 00:00:00 2001 From: Carson Date: Thu, 25 Jun 2020 17:31:42 -0500 Subject: [PATCH 7/7] add visual tests --- tests/figs/axes/ticktext-linebreaks.svg | 2 +- .../thematic-geom-and-theme-defaults.svg | 1 + tests/figs/thematic/thematic-qualitative.svg | 1 + tests/figs/thematic/thematic-sequential.svg | 1 + tests/testthat/test-thematic.R | 20 +++++++++++++++++++ 5 files changed, 24 insertions(+), 1 deletion(-) create mode 100644 tests/figs/thematic/thematic-geom-and-theme-defaults.svg create mode 100644 tests/figs/thematic/thematic-qualitative.svg create mode 100644 tests/figs/thematic/thematic-sequential.svg create mode 100644 tests/testthat/test-thematic.R diff --git a/tests/figs/axes/ticktext-linebreaks.svg b/tests/figs/axes/ticktext-linebreaks.svg index 34fc751204..e3f67fdfe6 100644 --- a/tests/figs/axes/ticktext-linebreaks.svg +++ b/tests/figs/axes/ticktext-linebreaks.svg @@ -1 +1 @@ -012345ticktextticktextlong_ticktextticktextxy +012345ticktextticktextlong_ticktextticktextxy diff --git a/tests/figs/thematic/thematic-geom-and-theme-defaults.svg b/tests/figs/thematic/thematic-geom-and-theme-defaults.svg new file mode 100644 index 0000000000..30f5e5fed4 --- /dev/null +++ b/tests/figs/thematic/thematic-geom-and-theme-defaults.svg @@ -0,0 +1 @@ +2.55.07.510.02.55.07.510.01:101:10 diff --git a/tests/figs/thematic/thematic-qualitative.svg b/tests/figs/thematic/thematic-qualitative.svg new file mode 100644 index 0000000000..abe946acff --- /dev/null +++ b/tests/figs/thematic/thematic-qualitative.svg @@ -0,0 +1 @@ +197019801990200020100.000.250.500.751.00pcepoppsavertuempmedunemploydatevalue01variable diff --git a/tests/figs/thematic/thematic-sequential.svg b/tests/figs/thematic/thematic-sequential.svg new file mode 100644 index 0000000000..e7f2681045 --- /dev/null +++ b/tests/figs/thematic/thematic-sequential.svg @@ -0,0 +1 @@ +2.55.07.510.02.55.07.510.02.55.07.510.01:101:101:10 diff --git a/tests/testthat/test-thematic.R b/tests/testthat/test-thematic.R new file mode 100644 index 0000000000..f131a9e001 --- /dev/null +++ b/tests/testthat/test-thematic.R @@ -0,0 +1,20 @@ +context("thematic") + +test_that("ggplotly() works with thematic", { + skip_if_not_installed("thematic") + library(thematic) + thematic_on(bg = "black", fg = "white", accent = "purple") + on.exit(thematic_off(), add = TRUE) + expect_doppelganger_built( + qplot(1:10, 1:10), + "thematic-geom-and-theme-defaults" + ) + expect_doppelganger_built( + qplot(1:10, 1:10, color = 1:10), + "thematic-sequential" + ) + expect_doppelganger_built( + ggplot(economics_long, aes(date, value01, color = variable)) + geom_line(), + "thematic-qualitative" + ) +})