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 556aa12326..04ea2b39aa 100644
--- a/R/ggplotly.R
+++ b/R/ggplotly.R
@@ -214,212 +214,234 @@ 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
- }
-
- 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
+
+ # 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)
+
+ structure(
+ list(
+ data = data, layout = layout, plot = plot,
+ env = environment()
+ ),
+ class = "ggplot_built"
)
- }, 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)
}
- # 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)
+ # Allow thematic to add new defaults to the plot object based on it's theme
+ 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)
+ }
- # ------------------------------------------------------------------------
- # 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)
+ # 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)
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(
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 100%
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
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 100%
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
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 100%
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
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 100%
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
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()
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 @@
-
+
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 @@
+
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 @@
+
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 @@
+
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"
+ )
+})