diff --git a/DESCRIPTION b/DESCRIPTION
index 41b56c70f5..ea263153ba 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -22,7 +22,7 @@ URL: https://plot.ly/r, https://cpsievert.github.io/plotly_book/, https://github
BugReports: https://github.com/ropensci/plotly/issues
Depends:
R (>= 3.2.0),
- ggplot2 (>= 2.2.1)
+ ggplot2 (> 2.2.1)
Imports:
tools,
scales,
diff --git a/R/ggplotly-legacy.R b/R/ggplotly-legacy.R
deleted file mode 100644
index 82aa7a0cc9..0000000000
--- a/R/ggplotly-legacy.R
+++ /dev/null
@@ -1,534 +0,0 @@
-# copy/pasted from View(plotly::gg2list) with packageVersion("plotly") == "4.5.6"
-gg2list_legacy <- function(p, width = NULL, height = NULL, tooltip = "all", layerData = 1,
- originalData = TRUE, source = "A", ...)
-{
- # deviceWidth <- width %||% unitConvert(grid::unit(1, "npc"),
- # "pixels", "width")
- # deviceHeight <- height %||% unitConvert(grid::unit(1, "npc"),
- # "pixels", "height")
- # dev_fun <- if (capabilities("png")) {
- # grDevices::png
- # }
- # else if (capabilities("jpeg")) {
- # grDevices::jpeg
- # }
- # else {
- # warning("Couldn't find a bitmap device (e.g. png or jpeg).",
- # "To ensure sizes are converted correctly please",
- # "compile R to use a bitmap device", call. = FALSE)
- # grDevices::dev.new
- # }
- # tmpPlotFile <- tempfile(fileext = ".png")
- # dev_fun(tmpPlotFile, width = deviceWidth, height = deviceHeight)
- 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))
- sets <- lapply(layer_data, function(y) attr(y, "set"))
- scales <- plot$scales
- 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
- }
- layout <- ggfun("create_layout")(plot$facet)
- data <- layout$setup(layer_data, plot$data, plot$plot_env,
- plot$coordinates)
- data <- layout$map(data)
- groupDomains <- Map(function(x, y) {
- tryCatch(eval(y$mapping[["group"]] %||% plot$mapping[["group"]],
- x), error = function(e) NULL)
- }, data, layers)
- data <- by_layer(function(l, d) l$compute_aesthetics(d,
- plot))
- 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)
- data <- lapply(data, ggfun("scales_transform_df"), scales = scales)
- scale_x <- function() scales$get_scales("x")
- scale_y <- function() scales$get_scales("y")
- layout$train_position(data, scale_x(), scale_y())
- data <- lapply(data, function(d) {
- if (!is.null(scale_x()) && scale_x()$is_discrete())
- d$x_plotlyDomain <- d$x
- if (!is.null(scale_y()) && scale_y()$is_discrete())
- d$y_plotlyDomain <- d$y
- d
- })
- data <- layout$map_position(data)
- 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))
- ggfun("scales_add_missing")(plot, c("x", "y"), plot$plot_env)
- data <- by_layer(function(l, d) l$compute_geom_1(d))
- groupDomains <- Map(function(x, y) {
- tryCatch({
- names(y)[match(x$group, y)]
- }, error = function(e) NULL)
- }, data, group_maps)
- data <- by_layer(function(l, d) l$compute_position(d, layout))
- layout$reset_scales()
- layout$train_position(data, scale_x(), scale_y())
- data <- layout$map_position(data)
- npscales <- scales$non_position_scales()
- if (npscales$n() > 0) {
- lapply(data, ggfun("scales_train_df"), scales = npscales)
- for (sc in npscales$scales) {
- data <- lapply(data, function(d) {
- 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)
- }
- layout$train_ranges(plot$coordinates)
- data <- by_layer(function(l, d) l$compute_geom_2(d))
- data <- by_layer(function(l, d) l$finish_statistics(d))
- data <- layout$finish_data(data)
- theme <- ggfun("plot_theme")(plot)
- elements <- names(which(sapply(theme, inherits, "element")))
- for (i in elements) {
- theme[[i]] <- ggplot2::calc_element(i, theme)
- }
- pm <- unitConvert(theme$plot.margin, "pixels")
- gglayout <- list(margin = list(t = pm[[1]], r = pm[[2]],
- b = pm[[3]], l = pm[[4]]), plot_bgcolor = toRGB(theme$panel.background$fill),
- paper_bgcolor = toRGB(theme$plot.background$fill), font = text2font(theme$text))
- if (nchar(plot$labels$title %||% "") > 0) {
- gglayout$title <- faced(plot$labels$title, theme$plot.title$face)
- gglayout$titlefont <- text2font(theme$plot.title)
- gglayout$margin$t <- gglayout$margin$t + gglayout$titlefont$size
- }
- gglayout$margin$t <- gglayout$margin$t + 16
- if (inherits(plot$coordinates, "CoordFlip")) {
- plot$labels[c("x", "y")] <- plot$labels[c("y", "x")]
- }
- nPanels <- nrow(layout$panel_layout)
- nRows <- max(layout$panel_layout$ROW)
- nCols <- max(layout$panel_layout$COL)
- layout$panel_layout$xaxis <- layout$panel_layout$COL
- layout$panel_layout$yaxis <- layout$panel_layout$ROW
- layout$panel_layout$xanchor <- nRows
- layout$panel_layout$yanchor <- 1
- if (inherits(plot$facet, "FacetWrap")) {
- if (plot$facet$params$free$x) {
- layout$panel_layout$xaxis <- layout$panel_layout$PANEL
- layout$panel_layout$xanchor <- layout$panel_layout$ROW
- }
- if (plot$facet$params$free$y) {
- layout$panel_layout$yaxis <- layout$panel_layout$PANEL
- layout$panel_layout$yanchor <- layout$panel_layout$COL
- layout$panel_layout$xanchor <- nPanels
- }
- if (plot$facet$params$free$x && plot$facet$params$free$y) {
- layout$panel_layout$xaxis <- layout$panel_layout$PANEL
- layout$panel_layout$yaxis <- layout$panel_layout$PANEL
- layout$panel_layout$xanchor <- layout$panel_layout$PANEL
- layout$panel_layout$yanchor <- layout$panel_layout$PANEL
- }
- }
- layout$panel_layout$xaxis <- paste0("xaxis", sub("^1$",
- "", layout$panel_layout$xaxis))
- layout$panel_layout$yaxis <- paste0("yaxis", sub("^1$",
- "", layout$panel_layout$yaxis))
- layout$panel_layout$xanchor <- paste0("y", sub("^1$", "",
- layout$panel_layout$xanchor))
- layout$panel_layout$yanchor <- paste0("x", sub("^1$", "",
- layout$panel_layout$yanchor))
- layout$panel_layout$x_min <- sapply(layout$panel_ranges,
- function(z) min(z$x.range))
- layout$panel_layout$x_max <- sapply(layout$panel_ranges,
- function(z) max(z$x.range))
- layout$panel_layout$y_min <- sapply(layout$panel_ranges,
- function(z) min(z$y.range))
- layout$panel_layout$y_max <- sapply(layout$panel_ranges,
- function(z) max(z$y.range))
- plot$tooltip <- tooltip
- data <- Map(function(x, y) {
- tryCatch({
- x$group_plotlyDomain <- y
- x
- }, error = function(e) x)
- }, data, groupDomains)
- traces <- layers2traces(data, prestats_data, layout$panel_layout,
- plot)
- gglayout <- layers2layout(gglayout, layers, layout$panel_layout)
- traces <- lapply(traces, function(tr) {
- tr$hoverinfo <- tr$hoverinfo %||% "text"
- tr
- })
- grps <- sapply(traces, "[[", "legendgroup")
- traces <- Map(function(x, y) {
- x$showlegend <- isTRUE(x$showlegend) && y
- x
- }, traces, !duplicated(grps))
- panelMarginX <- unitConvert(theme[["panel.spacing.x"]] %||%
- theme[["panel.spacing"]], "npc", "width")
- panelMarginY <- unitConvert(theme[["panel.spacing.y"]] %||%
- theme[["panel.spacing"]], "npc", "height")
- if (inherits(plot$facet, "FacetWrap")) {
- stripSize <- unitConvert(theme[["strip.text.x"]] %||%
- theme[["strip.text"]], "npc", "height")
- panelMarginY <- panelMarginY + stripSize
- if (plot$facet$params$free$x) {
- axisTicksX <- unitConvert(theme[["axis.ticks.x"]] %||%
- theme[["axis.ticks"]], "npc", "height")
- axisTextX <- theme[["axis.text.x"]] %||% theme[["axis.text"]]
- labz <- unlist(lapply(layout$panel_ranges, "[[",
- "x.labels"))
- lab <- labz[which.max(nchar(labz))]
- panelMarginY <- panelMarginY + axisTicksX + bbox(lab,
- axisTextX$angle, unitConvert(axisTextX, "npc",
- "height"))[["height"]]
- }
- if (plot$facet$params$free$y) {
- axisTicksY <- unitConvert(theme[["axis.ticks.y"]] %||%
- theme[["axis.ticks"]], "npc", "width")
- axisTextY <- theme[["axis.text.y"]] %||% theme[["axis.text"]]
- labz <- unlist(lapply(layout$panel_ranges, "[[",
- "y.labels"))
- lab <- labz[which.max(nchar(labz))]
- panelMarginX <- panelMarginX + axisTicksY + bbox(lab,
- axisTextY$angle, unitConvert(axisTextY, "npc",
- "width"))[["width"]]
- }
- }
- margins <- c(rep(panelMarginX, 2), rep(panelMarginY, 2))
- doms <- get_domains(nPanels, nRows, margins)
- for (i in seq_len(nPanels)) {
- lay <- layout$panel_layout[i, ]
- for (xy in c("x", "y")) {
- theme_el <- function(el) {
- theme[[paste0(el, ".", xy)]] %||% theme[[el]]
- }
- axisTicks <- theme_el("axis.ticks")
- axisText <- theme_el("axis.text")
- axisTitle <- theme_el("axis.title")
- axisLine <- theme_el("axis.line")
- panelGrid <- theme_el("panel.grid.major")
- stripText <- theme_el("strip.text")
- axisName <- lay[, paste0(xy, "axis")]
- anchor <- lay[, paste0(xy, "anchor")]
- rng <- layout$panel_ranges[[i]]
- sc <- if (inherits(plot$coordinates, "CoordFlip")) {
- scales$get_scales(setdiff(c("x", "y"), xy))
- }
- else {
- scales$get_scales(xy)
- }
- type <- if (xy == "x")
- "height"
- else "width"
- axisTitleText <- sc$name %||% plot$labels[[xy]] %||%
- ""
- if (is_blank(axisTitle))
- axisTitleText <- ""
- axisObj <- list(type = "linear", autorange = FALSE,
- tickmode = "array", range = rng[[paste0(xy,
- ".range")]], ticktext = rng[[paste0(xy, ".labels")]],
- tickvals = rng[[paste0(xy, ".major")]], ticks = if (is_blank(axisTicks)) "" else "outside",
- tickcolor = toRGB(axisTicks$colour), ticklen = unitConvert(theme$axis.ticks.length,
- "pixels", type), tickwidth = unitConvert(axisTicks,
- "pixels", type), showticklabels = !is_blank(axisText),
- tickfont = text2font(axisText, type), tickangle = -(axisText$angle %||%
- 0), showline = !is_blank(axisLine), linecolor = toRGB(axisLine$colour),
- linewidth = unitConvert(axisLine, "pixels",
- type), showgrid = !is_blank(panelGrid), domain = sort(as.numeric(doms[i,
- paste0(xy, c("start", "end"))])), gridcolor = toRGB(panelGrid$colour),
- gridwidth = unitConvert(panelGrid, "pixels",
- type), zeroline = FALSE, anchor = anchor,
- title = axisTitleText, titlefont = text2font(axisTitle))
- if (identical("date", sc$scale_name)) {
- axisObj$range <- axisObj$range * 86400000
- if (i == 1) {
- traces <- lapply(traces, function(z) {
- z[[xy]] <- z[[xy]] * 86400000
- z
- })
- }
- }
- axisObj$tickvals <- scales::rescale(axisObj$tickvals,
- to = axisObj$range, from = c(0, 1))
- gglayout[[axisName]] <- axisObj
- if (i == 1) {
- axisTickText <- axisObj$ticktext[which.max(nchar(axisObj$ticktext))]
- side <- if (xy == "x")
- "b"
- else "l"
- gglayout$margin[[side]] <- gglayout$margin[[side]] +
- axisObj$ticklen + bbox(axisTickText, axisObj$tickangle,
- axisObj$tickfont$size)[[type]] + bbox(axisTitleText,
- axisTitle$angle, unitConvert(axisTitle, "pixels",
- type))[[type]]
- if (nchar(axisTitleText) > 0) {
- axisTextSize <- unitConvert(axisText, "npc",
- type)
- axisTitleSize <- unitConvert(axisTitle, "npc",
- type)
- offset <- (0 - bbox(axisTickText, axisText$angle,
- axisTextSize)[[type]] - bbox(axisTitleText,
- axisTitle$angle, axisTitleSize)[[type]]/2 -
- unitConvert(theme$axis.ticks.length, "npc",
- type))
- }
- if (has_facet(plot)) {
- stripSize <- unitConvert(stripText, "pixels",
- type)
- if (xy == "x") {
- gglayout$margin$t <- gglayout$margin$t +
- stripSize
- }
- if (xy == "y" && inherits(plot$facet, "FacetGrid")) {
- gglayout$margin$r <- gglayout$margin$r +
- stripSize
- }
- if (nchar(axisTitleText) > 0) {
- x <- if (xy == "x")
- 0.5
- else offset
- y <- if (xy == "x")
- offset
- else 0.5
- gglayout$annotations <- c(gglayout$annotations,
- make_label(faced(axisTitleText, axisTitle$face),
- x, y, el = axisTitle, xanchor = if (xy ==
- "x") "center" else "right", yanchor = if (xy ==
- "x") "top" else "center", annotationType = "axis"))
- }
- }
- }
- if (has_facet(plot))
- gglayout[[axisName]]$title <- ""
- }
- xdom <- gglayout[[lay[, "xaxis"]]]$domain
- ydom <- gglayout[[lay[, "yaxis"]]]$domain
- border <- make_panel_border(xdom, ydom, theme)
- gglayout$shapes <- c(gglayout$shapes, border)
- if (has_facet(plot)) {
- col_vars <- ifelse(inherits(plot$facet, "FacetWrap"),
- "facets", "cols")
- col_txt <- paste(plot$facet$params$labeller(lay[names(plot$facet$params[[col_vars]])]),
- collapse = "
")
- if (is_blank(theme[["strip.text.x"]]))
- col_txt <- ""
- if (inherits(plot$facet, "FacetGrid") && lay$ROW !=
- 1)
- col_txt <- ""
- if (nchar(col_txt) > 0) {
- col_lab <- make_label(col_txt, x = mean(xdom),
- y = max(ydom), el = theme[["strip.text.x"]] %||%
- theme[["strip.text"]], xanchor = "center",
- yanchor = "bottom")
- gglayout$annotations <- c(gglayout$annotations,
- col_lab)
- strip <- make_strip_rect(xdom, ydom, theme,
- "top")
- gglayout$shapes <- c(gglayout$shapes, strip)
- }
- row_txt <- paste(plot$facet$params$labeller(lay[names(plot$facet$params$rows)]),
- collapse = "
")
- if (is_blank(theme[["strip.text.y"]]))
- row_txt <- ""
- if (inherits(plot$facet, "FacetGrid") && lay$COL !=
- nCols)
- row_txt <- ""
- if (nchar(row_txt) > 0) {
- row_lab <- make_label(row_txt, x = max(xdom),
- y = mean(ydom), el = theme[["strip.text.y"]] %||%
- theme[["strip.text"]], xanchor = "left",
- yanchor = "middle")
- gglayout$annotations <- c(gglayout$annotations,
- row_lab)
- strip <- make_strip_rect(xdom, ydom, theme,
- "right")
- gglayout$shapes <- c(gglayout$shapes, strip)
- }
- }
- }
- gglayout$showlegend <- sum(unlist(lapply(traces, "[[", "showlegend"))) >=
- 1
- gglayout$legend <- list(bgcolor = toRGB(theme$legend.background$fill),
- bordercolor = toRGB(theme$legend.background$colour),
- borderwidth = unitConvert(theme$legend.background$size,
- "pixels", "width"), font = text2font(theme$legend.text))
- if (npscales$n() == 0 || identical(theme$legend.position,
- "none")) {
- gglayout$showlegend <- FALSE
- }
- else {
- theme$legend.box <- theme$legend.box %||% "vertical"
- theme$legend.key.width <- theme$legend.key.width %||%
- theme$legend.key.size
- theme$legend.key.height <- theme$legend.key.height %||%
- theme$legend.key.size
- theme$legend.direction <- theme$legend.direction %||%
- "vertical"
- if (!identical(theme$legend.direction, "vertical")) {
- warning("plotly.js does not (yet) support horizontal legend items \n",
- "You can track progress here: \n", "https://github.com/plotly/plotly.js/issues/53 \n",
- call. = FALSE)
- theme$legend.direction <- "vertical"
- }
- theme$legend.box.just <- theme$legend.box.just %||%
- c("center", "center")
- gdefs <- ggfun("guides_train")(scales, theme, plot$guides,
- plot$labels)
- if (length(gdefs) > 0) {
- gdefs <- ggfun("guides_merge")(gdefs)
- gdefs <- ggfun("guides_geom")(gdefs, layers, plot$mapping)
- }
- colorbar <- compact(lapply(gdefs, gdef2trace, theme,
- gglayout))
- nguides <- length(colorbar) + gglayout$showlegend
- if (nguides >= 2) {
- gglayout$legend$y <- 1/nguides
- gglayout$legend$yanchor <- "top"
- for (i in seq_along(colorbar)) {
- colorbar[[i]]$marker$colorbar$yanchor <- "top"
- colorbar[[i]]$marker$colorbar$len <- 1/nguides
- colorbar[[i]]$marker$colorbar$y <- 1 - (i -
- 1) * (1/nguides)
- }
- }
- traces <- c(traces, colorbar)
- if (isTRUE(gglayout$showlegend)) {
- legendTitles <- compact(lapply(gdefs, function(g) if (inherits(g,
- "legend"))
- g$title
- else NULL))
- legendTitle <- paste(legendTitles, collapse = "
")
- titleAnnotation <- make_label(legendTitle, x = gglayout$legend$x %||%
- 1.02, y = gglayout$legend$y %||% 1, theme$legend.title,
- xanchor = "left", yanchor = "bottom", legendTitle = TRUE)
- gglayout$annotations <- c(gglayout$annotations,
- titleAnnotation)
- gglayout$legend$y <- (gglayout$legend$y %||% 1) -
- length(legendTitles) * unitConvert(theme$legend.title$size,
- "npc", "height")
- }
- }
- geoms <- sapply(layers, ggtype, "geom")
- if (any(idx <- geoms %in% "bar")) {
- positions <- sapply(layers, ggtype, "position")
- position <- unique(positions[geoms %in% "bar"])
- if (length(position) > 1) {
- warning("plotly doesn't support multiple positions\n",
- "across geom_bar() layers", call. = FALSE)
- position <- position[1]
- }
- if (position == "identity") {
- gglayout$barmode <- "overlay"
- gglayout$legend$traceorder <- "reversed"
- }
- else {
- gglayout$barmode <- "stack"
- }
- is_hist <- inherits(plot$scales$get_scales("x"), "ScaleContinuous")
- if (position == "dodge" || is_hist) {
- gglayout$bargap <- 0
- }
- }
- if (inherits(plot$coordinates, "CoordFlip")) {
- for (i in seq_along(traces)) {
- tr <- traces[[i]]
- traces[[i]][c("x", "y")] <- tr[c("y", "x")]
- if (tr$type %in% c("bar", "box"))
- traces[[i]]$orientation <- "h"
- if (tr$type == "box")
- traces[[i]]$hoverinfo <- "x"
- names(traces[[i]])[grepl("^error_y$", names(tr))] <- "error_x"
- names(traces[[i]])[grepl("^error_x$", names(tr))] <- "error_y"
- }
- }
- for (xy in c("x", "y")) {
- type <- if (xy == "x")
- "width"
- else "height"
- err <- if (xy == "x")
- "error_y"
- else "error_x"
- for (i in seq_along(traces)) {
- e <- traces[[i]][[err]]
- if (!is.null(e)) {
- w <- grid::unit(e$width %||% 0, "npc")
- traces[[i]][[err]]$width <- unitConvert(w, "pixels",
- type)
- }
- }
- }
- props <- c("x", "y", "text", "type", "xaxis", "yaxis", "name")
- hashes <- vapply(traces, function(x) digest::digest(x[names(x) %in%
- props]), character(1))
- modes <- vapply(traces, function(x) x$mode %||% "", character(1))
- nhashes <- length(unique(hashes))
- if (nhashes < length(traces)) {
- mergedTraces <- vector("list", nhashes)
- for (i in unique(hashes)) {
- idx <- which(hashes %in% i)
- if (all(modes[idx] %in% c("lines", "markers"))) {
- mergedTraces[[i]] <- Reduce(modify_list, traces[idx])
- mergedTraces[[i]]$mode <- "markers+lines"
- if (any(sapply(traces[idx], "[[", "showlegend"))) {
- mergedTraces[[i]]$showlegend <- TRUE
- }
- }
- }
- traces <- mergedTraces
- }
- gglayout$hovermode <- "closest"
- ax <- grep("^[x-y]axis", names(gglayout))
- for (i in ax) {
- gglayout[[i]]$hoverformat <- ".2f"
- }
- traces <- lapply(compact(traces), function(x) {
- x$name <- x$name %||% ""
- x
- })
- gglayout$width <- width
- gglayout$height <- height
- #grDevices::dev.off()
- #unlink(tmpPlotFile)
- l <- list(data = setNames(traces, NULL), layout = compact(gglayout),
- source = source)
- l <- rm_asis(l)
- mappingFormulas <- lapply(layers, function(x) {
- mappings <- c(x$mapping, if (isTRUE(x$inherit.aes)) plot$mapping)
- if (originalData) {
- lapply(mappings, lazyeval::f_new)
- }
- else {
- nms <- names(mappings)
- setNames(lapply(nms, function(x) lazyeval::f_new(as.symbol(x))),
- nms)
- }
- })
- return_dat <- if (originalData)
- layer_data
- else data
- return_dat <- Map(function(x, y) {
- if (is.null(y[["group"]]))
- return(x)
- dplyr::group_by_(x, y[["group"]])
- }, return_dat, mappingFormulas)
- mappingFormulas <- lapply(mappingFormulas, function(x) x[!grepl("^group$",
- names(x))])
- ids <- lapply(seq_along(data), function(x) new_id())
- l$attrs <- setNames(mappingFormulas, ids)
- l$attrs <- lapply(l$attrs, function(x) structure(x, class = "plotly_eval"))
- l$attrs[[1]][["type"]] <- "ggplotly"
- l$cur_data <- ids[[layerData]]
- l$visdat <- setNames(lapply(return_dat, function(x) function(y) x),
- ids)
- l
-}
diff --git a/R/ggplotly.R b/R/ggplotly.R
index 86e9c4dbd8..5cc50ba6cc 100644
--- a/R/ggplotly.R
+++ b/R/ggplotly.R
@@ -208,29 +208,8 @@ gg2list <- function(p, width = NULL, height = NULL,
)
}
- # we currently support ggplot2 >= 2.2.1 (see DESCRIPTION)
- # there are too many naming changes in 2.2.1.9000 to realistically
- if (!is_dev_ggplot2()) {
- message(
- "We recommend that you use the dev version of ggplot2 with `ggplotly()`\n",
- "Install it with: `devtools::install_github('hadley/ggplot2')`"
- )
- if (!identical(dynamicTicks, FALSE)) {
- warning(
- "You need the dev version of ggplot2 to use `dynamicTicks`", call. = FALSE
- )
- }
- return(
- gg2list_legacy(
- p, width = width, height = height, tooltip = tooltip,
- layerData = layerData, originalData = originalData, source = source, ...
- )
- )
- }
-
# ------------------------------------------------------------------------
- # Our internal version of ggplot2::ggplot_build(). Modified from
- # https://github.com/hadley/ggplot2/blob/0cd0ba/R/plot-build.r#L18-L92
+ # Our internal version of ggplot2::ggplot_build()
# ------------------------------------------------------------------------
plot <- ggfun("plot_clone")(p)
@@ -421,25 +400,50 @@ gg2list <- function(p, width = NULL, height = NULL,
# Let Layout modify data before rendering
data <- layout$finish_data(data)
- # ------------------------------------------------------------------------
- # end of ggplot_build()
- # ------------------------------------------------------------------------
- # if necessary, attach key
+ # if necessary, attach key (for crosstalk)
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)
+ # should basically mimic what ggplot_build(p) would give you....
+ built <- structure(
+ list(data = data, layout = layout, plot = plot),
+ class = "ggplot_built"
+ )
+
+ # ------------------------------------------------------------------------
+ # end of ggplot_build()
+ # ------------------------------------------------------------------------
+
+ # next in print.ggplot is ggplot_gtable() which returns the table of
+ # grobs grid uses to do the actual rendering. Throughout this file
+ # we'll query specific characteristics of these grobs
+ gtable <- ggplot2::ggplot_gtable(built)
+
+ # mimics https://github.com/tidyverse/ggplot2/blob/41f154f5eb89f9939c149645611a5834eb674309/R/layout.R#L104-L108
+ labels <- layout$coord$labels(list(
+ x = layout$xlabel(plot$labels),
+ y = layout$ylabel(plot$labels)
+ ))
+
# initiate plotly.js layout with some plot-wide theming stuff
theme <- ggfun("plot_theme")(plot)
elements <- names(which(sapply(theme, inherits, "element")))
for (i in elements) {
theme[[i]] <- ggplot2::calc_element(i, theme)
}
- # Translate plot wide theme elements to plotly.js layout
+ # ensure element_text() sizes are interpreted as "points" and defaults to
+ # "Helvetica" familyfont
+ isTextElement <- vapply(theme, inherits, logical(1), "element_text")
+ textElements <- names(isTextElement)[isTextElement]
+ for (i in textElements) {
+ theme[[i]]$size <- grid::unit(theme[[i]]$size, "points")
+ if (identical(theme[[i]]$family, "")) theme[[i]]$family <- "Helvetica"
+ }
+
+ # Translate plot-wide theme elements to plotly.js layout
pm <- unitConvert(theme$plot.margin, "pixels")
gglayout <- list(
margin = list(t = pm[[1]], r = pm[[2]], b = pm[[3]], l = pm[[4]]),
@@ -447,49 +451,40 @@ gg2list <- function(p, width = NULL, height = NULL,
paper_bgcolor = toRGB(theme$plot.background$fill),
font = text2font(theme$text)
)
- # main plot title
- if (nchar(plot$labels$title %||% "") > 0) {
- gglayout$title <- faced(plot$labels$title, theme$plot.title$face)
- gglayout$titlefont <- text2font(theme$plot.title)
- gglayout$margin$t <- gglayout$margin$t + gglayout$titlefont$size
- }
+
# ensure there's enough space for the modebar (this is based on a height of 1em)
+ # TODO: subtract this from the overall height?
# https://github.com/plotly/plotly.js/blob/dd1547/src/components/modebar/index.js#L171
- gglayout$margin$t <- gglayout$margin$t + 16
+ #gglayout$margin$t <- gglayout$margin$t + 16
- # important stuff like layout$panel_params is already flipped, but
- # plot$scales/plot$labels/data aren't. We flip x/y trace data at the very end
- # and scales in the axis loop below.
- if (inherits(plot$coordinates, "CoordFlip")) {
- plot$labels[c("x", "y")] <- plot$labels[c("y", "x")]
- }
+ layout$layout <- summarise_layout(built)
# important panel summary stats
nPanels <- nrow(layout$layout)
- nRows <- max(layout$layout$ROW)
- nCols <- max(layout$layout$COL)
+ nRows <- max(layout$layout$row)
+ nCols <- max(layout$layout$col)
# panel -> plotly.js axis/anchor info
# (assume a grid layout by default)
- layout$layout$xaxis <- layout$layout$COL
- layout$layout$yaxis <- layout$layout$ROW
+ layout$layout$xaxis <- layout$layout$col
+ layout$layout$yaxis <- layout$layout$row
layout$layout$xanchor <- nRows
layout$layout$yanchor <- 1
if (inherits(plot$facet, "FacetWrap")) {
if (plot$facet$params$free$x) {
- layout$layout$xaxis <- layout$layout$PANEL
- layout$layout$xanchor <- layout$layout$ROW
+ layout$layout$xaxis <- layout$layout$col
+ layout$layout$xanchor <- layout$layout$row
}
if (plot$facet$params$free$y) {
- layout$layout$yaxis <- layout$layout$PANEL
- layout$layout$yanchor <- layout$layout$COL
+ layout$layout$yaxis <- layout$layout$panel
+ layout$layout$yanchor <- layout$layout$col
layout$layout$xanchor <- nPanels
}
if (plot$facet$params$free$x && plot$facet$params$free$y) {
- layout$layout$xaxis <- layout$layout$PANEL
- layout$layout$yaxis <- layout$layout$PANEL
- layout$layout$xanchor <- layout$layout$PANEL
- layout$layout$yanchor <- layout$layout$PANEL
+ layout$layout$xaxis <- layout$layout$panel
+ layout$layout$yaxis <- layout$layout$panel
+ layout$layout$xanchor <- layout$layout$panel
+ layout$layout$yanchor <- layout$layout$panel
}
}
# format the axis/anchor to a format plotly.js respects
@@ -497,11 +492,6 @@ gg2list <- function(p, width = NULL, height = NULL,
layout$layout$yaxis <- paste0("yaxis", sub("^1$", "", layout$layout$yaxis))
layout$layout$xanchor <- paste0("y", sub("^1$", "", layout$layout$xanchor))
layout$layout$yanchor <- paste0("x", sub("^1$", "", layout$layout$yanchor))
- # for some layers2traces computations, we need the range of each panel
- layout$layout$x_min <- sapply(layout$panel_params, function(z) min(z$x.range %||% z$x_range))
- layout$layout$x_max <- sapply(layout$panel_params, function(z) max(z$x.range %||% z$x_range))
- layout$layout$y_min <- sapply(layout$panel_params, function(z) min(z$y.range %||% z$y_range))
- layout$layout$y_max <- sapply(layout$panel_params, function(z) max(z$y.range %||% z$y_range))
# layers -> plotly.js traces
plot$tooltip <- tooltip
@@ -591,13 +581,12 @@ gg2list <- function(p, width = NULL, height = NULL,
}
axisTicks <- theme_el("axis.ticks")
axisText <- theme_el("axis.text")
- axisTitle <- theme_el("axis.title")
axisLine <- theme_el("axis.line")
panelGrid <- theme_el("panel.grid.major")
stripText <- theme_el("strip.text")
- axisName <- lay[, paste0(xy, "axis")]
- anchor <- lay[, paste0(xy, "anchor")]
+ axisName <- lay[[paste0(xy, "axis")]]
+ anchor <- lay[[paste0(xy, "anchor")]]
rng <- layout$panel_params[[i]]
# panel_params is quite different for "CoordSf"
@@ -651,7 +640,7 @@ gg2list <- function(p, width = NULL, height = NULL,
}
- # stuff like layout$panel_params is already flipped, but scales aren't
+ # TODO: could we just do scale_x()/scale_y() here?
sc <- if (inherits(plot$coordinates, "CoordFlip")) {
scales$get_scales(setdiff(c("x", "y"), xy))
} else {
@@ -659,9 +648,6 @@ gg2list <- function(p, width = NULL, height = NULL,
}
# type of unit conversion
type <- if (xy == "x") "height" else "width"
- # get axis title
- axisTitleText <- sc$name %||% plot$labels[[xy]] %||% ""
- if (is_blank(axisTitle)) axisTitleText <- ""
# is this axis dynamic?
isDynamic <- isTRUE(dynamicTicks) || identical(dynamicTicks, xy)
@@ -699,18 +685,18 @@ gg2list <- function(p, width = NULL, height = NULL,
showline = !is_blank(axisLine),
linecolor = toRGB(axisLine$colour),
linewidth = unitConvert(axisLine, "pixels", type),
- # TODO: always `showgrid=FALSE` and implement our own using traces
+ # TODO: always `showgrid=FALSE` and implement our own using traces (unless dynamicTicks=T)?
showgrid = !is_blank(panelGrid) && !"CoordSf" %in% class(p$coordinates),
domain = sort(as.numeric(doms[i, paste0(xy, c("start", "end"))])),
gridcolor = toRGB(panelGrid$colour),
gridwidth = unitConvert(panelGrid, "pixels", type),
zeroline = FALSE,
anchor = anchor,
- title = faced(axisTitleText, axisTitle$face),
- titlefont = text2font(axisTitle)
+ side = sc$position %||% switch(xy, x = "bottom", y = "left")
)
# set scaleanchor/scaleratio if these are fixed coordinates
+ # TODO: can the criteria just be if the ratio is NULL?
fixed_coords <- c("CoordSf", "CoordFixed", "CoordMap", "CoordQuickmap")
if (inherits(p$coordinates, fixed_coords)) {
axisObj$scaleanchor <- anchor
@@ -770,75 +756,72 @@ gg2list <- function(p, width = NULL, height = NULL,
# do some stuff that should be done once for the entire plot
if (i == 1) {
+
+ # estimate the size of the axis ticks and ticktext
axisTickText <- axisObj$ticktext[which.max(nchar(axisObj$ticktext))]
- side <- if (xy == "x") "b" else "l"
- # account for axis ticks, ticks text, and titles in plot margins
- # (apparently ggplot2 doesn't support axis.title/axis.text margins)
- gglayout$margin[[side]] <- gglayout$margin[[side]] + axisObj$ticklen +
- bbox(axisTickText, axisObj$tickangle, axisObj$tickfont$size)[[type]] +
- bbox(axisTitleText, axisTitle$angle, unitConvert(axisTitle, "pixels", type))[[type]]
+ axisSize <- axisObj$ticklen +
+ bbox(axisTickText, axisObj$tickangle, axisObj$tickfont$size)[[type]]
- if (nchar(axisTitleText) > 0) {
- axisTextSize <- unitConvert(axisText, "npc", type)
- axisTitleSize <- unitConvert(axisTitle, "npc", type)
- offset <-
- (0 -
- bbox(axisTickText, axisText$angle, axisTextSize)[[type]] -
- bbox(axisTitleText, axisTitle$angle, axisTitleSize)[[type]] / 2 -
- unitConvert(theme$axis.ticks.length, "npc", type))
- }
+ # add that to the relevant margin
+ side <- substr(axisObj$side, 0, 1)
- # add space for exterior facet strips in `layout.margin`
+ gglayout$margin[[side]] <- gglayout$margin[[side]] + axisSize
+ # draw axis title as annotation
+ axisTitle <- theme_el("axis.title")
+ # TODO: do we need another loop for secondary axis?
+ axisTitleText <- labels[[xy]]$primary
+ axisLabel <- label_create(
+ faced(axisTitleText, axisTitle$face), el = axisTitle,
+ 0, switch(side, b = 0, t = 1),
+ yanchor = switch(xy, y = "bottom", x = switch(side, b = "top", t = "bottom")),
+ annotationType = paste0(xy, "axis"),
+ # horizontal labels scale with graph width, vertical labels scale with graph height
+ direction = switch(xy, x = "horizontal", y = "vertical")
+ )
+ # shift the title
+ shift <- switch(xy, x = "yshift", y = "xshift")
+ # one of these _has_ to be fixed...it should be correct one
+ axisFixedSize <- (axisLabel$height %||% axisLabel$width)
+ axisLabel[[shift]] <- switch(side, t = axisSize, r = axisSize, b = -axisSize, l = -axisSize)
+ gglayout <- label_add(gglayout, axisLabel)
+ gglayout$margin[[side]] <- gglayout$margin[[side]] + axisFixedSize
+
+
+ # add space for exterior facet strips in `layout.margin`
if (has_facet(plot)) {
stripSize <- unitConvert(stripText, "pixels", type)
- if (xy == "x") {
- gglayout$margin$t <- gglayout$margin$t + stripSize
- }
- if (xy == "y" && inherits(plot$facet, "FacetGrid")) {
- gglayout$margin$r <- gglayout$margin$r + stripSize
- }
- # facets have multiple axis objects, but only one title for the plot,
- # so we empty the titles and try to draw the title as an annotation
- if (nchar(axisTitleText) > 0) {
- # npc is on a 0-1 scale of the _entire_ device,
- # but these units _should_ be wrt to the plotting region
- # multiplying the offset by 2 seems to work, but this is a terrible hack
- x <- if (xy == "x") 0.5 else offset
- y <- if (xy == "x") offset else 0.5
- gglayout$annotations <- c(
- gglayout$annotations,
- make_label(
- faced(axisTitleText, axisTitle$face), x, y, el = axisTitle,
- xanchor = if (xy == "x") "center" else "right",
- yanchor = if (xy == "x") "top" else "center",
- annotationType = "axis"
- )
- )
- }
+ # TODO: this needs to be a function of the switch parameter
+ #if (xy == "x") {
+ # gglayout$margin$t <- gglayout$margin$t + stripSize
+ #}
+ #if (xy == "y" && inherits(plot$facet, "FacetGrid")) {
+ # gglayout$margin$r <- gglayout$margin$r + stripSize
+ #}
}
}
- if (has_facet(plot)) gglayout[[axisName]]$title <- ""
+
} # end of axis loop
# theme(panel.border = ) -> plotly rect shape
- xdom <- gglayout[[lay[, "xaxis"]]]$domain
- ydom <- gglayout[[lay[, "yaxis"]]]$domain
+ xdom <- gglayout[[lay$xaxis]]$domain
+ ydom <- gglayout[[lay$yaxis]]$domain
border <- make_panel_border(xdom, ydom, theme)
gglayout$shapes <- c(gglayout$shapes, border)
# facet strips -> plotly annotations
+ # https://github.com/tidyverse/ggplot2/blob/41f154f5eb89f9939c149645611a5834eb674309/R/labeller.r#L495
if (has_facet(plot)) {
- col_vars <- ifelse(inherits(plot$facet, "FacetWrap"), "facets", "cols")
- col_txt <- paste(
- plot$facet$params$labeller(
- lay[names(plot$facet$params[[col_vars]])]
- ), collapse = br()
- )
+
+
+ # TODO: support multiple strips? Or
+ labeller <- plot$facet$params$labeller
+ strips <- labeller(lay$vars)
+
if (is_blank(theme[["strip.text.x"]])) col_txt <- ""
if (inherits(plot$facet, "FacetGrid") && lay$ROW != 1) col_txt <- ""
if (nchar(col_txt) > 0) {
- col_lab <- make_label(
+ col_lab <- label_create(
col_txt, x = mean(xdom), y = max(ydom),
el = theme[["strip.text.x"]] %||% theme[["strip.text"]],
xanchor = "center", yanchor = "bottom"
@@ -855,7 +838,7 @@ gg2list <- function(p, width = NULL, height = NULL,
if (is_blank(theme[["strip.text.y"]])) row_txt <- ""
if (inherits(plot$facet, "FacetGrid") && lay$COL != nCols) row_txt <- ""
if (nchar(row_txt) > 0) {
- row_lab <- make_label(
+ row_lab <- label_create(
row_txt, x = max(xdom), y = mean(ydom),
el = theme[["strip.text.y"]] %||% theme[["strip.text"]],
xanchor = "left", yanchor = "middle"
@@ -867,6 +850,48 @@ gg2list <- function(p, width = NULL, height = NULL,
}
} # end of panel loop
+ # ------------------------------------------------------------------------
+ # Label conversion. A few notes:
+ # (1) label_create() should return NULL, if label doesn't exist
+ # (2) margin() adds padding *around* the textbox, not *inside*
+ # (3) annotation[i].height is fixed (i.e., absolute size),
+ # and can be entirely determined from element_text().
+ # (4) annotation[i].width has to match the graph width (which is relative),
+ # so the width is determined on the client
+ # ------------------------------------------------------------------------
+
+ subtitle <- label_create(
+ faced(plot$labels$subtitle, theme$plot.subtitle$face),
+ 0, 1, yshift = unitConvert(theme$plot.subtitle$margin, "pixels")[[3]],
+ el = theme$plot.subtitle,
+ annotationType = "subtitle"
+ )
+ title <- label_create(
+ faced(plot$labels$title, theme$plot.title$face),
+ 0, 1, el = theme$plot.title,
+ yshift = subtitle$height + (subtitle$yshift %||% 0) +
+ unitConvert(theme$plot.title$margin, "pixels")[[3]],
+ annotationType = "title"
+ )
+ caption <- label_create(
+ faced(plot$labels$caption, theme$plot.caption$face),
+ 0, 0, el = theme$plot.caption,
+ # TODO: yshift to dodge the xaxis ticks/title
+ # note, this will have to happen after drawing axis title as annotation
+ yshift = 0,
+ annotationType = "caption"
+ )
+
+ # add the annotations to the layout
+ gglayout <- label_add(gglayout, subtitle)
+ gglayout <- label_add(gglayout, title)
+ gglayout <- label_add(gglayout, caption)
+
+ # TODO: add textbox margins as well!
+ gglayout$margin$t <- gglayout$margin$t + (subtitle$height %||% 0)
+ gglayout$margin$t <- gglayout$margin$t + (title$height %||% 0)
+ gglayout$margin$b <- gglayout$margin$b + (caption$height %||% 0)
+
# ------------------------------------------------------------------------
# guide conversion
@@ -935,23 +960,26 @@ gg2list <- function(p, width = NULL, height = NULL,
# legend title annotation - https://github.com/plotly/plotly.js/issues/276
if (isTRUE(gglayout$showlegend)) {
- legendTitles <- compact(lapply(gdefs, function(g) if (inherits(g, "legend")) g$title else NULL))
- legendTitle <- paste(legendTitles, collapse = br())
- titleAnnotation <- make_label(
+ idx <- which(vapply(gdefs, inherits, logical(1), "legend"))
+ if (length(idx) != 1) warning("Expected one legend definition", call. = FALSE)
+ legendLines <- strsplit(gdefs[[idx]]$title, "\n", fixed = TRUE)[[1]]
+ legendTitle <- paste(legendLines, collapse = br())
+ titleAnnotation <- label_create(
legendTitle,
x = gglayout$legend$x %||% 1.02,
y = gglayout$legend$y %||% 1,
theme$legend.title,
xanchor = "left",
- yanchor = "bottom",
+ yanchor = "top",
# just so the R client knows this is a title
+ # TODO: move this logic to annotationType!
legendTitle = TRUE
)
- gglayout$annotations <- c(gglayout$annotations, titleAnnotation)
+ gglayout <- label_add(gglayout, titleAnnotation)
# adjust the height of the legend to accomodate for the title
# this assumes the legend always appears below colorbars
gglayout$legend$y <- (gglayout$legend$y %||% 1) -
- length(legendTitles) * unitConvert(theme$legend.title$size, "npc", "height")
+ length(legendLines) * unitConvert(theme$legend.title$size, "npc", "height")
}
}
@@ -1018,9 +1046,24 @@ gg2list <- function(p, width = NULL, height = NULL,
# If a trace isn't named, it shouldn't have additional hoverinfo
traces <- lapply(compact(traces), function(x) { x$name <- x$name %||% ""; x })
+ # a fixed height/width is required for aspect ratios at runtime...
+ # hopefully plotly.js will eventually support aspect ratios "natively"
+ # so that you can resize and maintain aspect ratio
+ # https://github.com/plotly/plotly.js/issues/272
+
+ if (inherits(p$coordinates, c("CoordFixed", "CoordSf"))) {
+ warning(
+ "Fixed coordinates currently require a fixed height/width,\n",
+ "meaning that window resizing won't effect the size of the graph",
+ call. = FALSE
+ )
+ }
+
gglayout$width <- width
gglayout$height <- height
gglayout$barmode <- gglayout$barmode %||% "relative"
+ # we set names in labels_add() to make them easier to query...
+ gglayout$annotations <- setNames(gglayout$annotations, NULL)
l <- list(
data = setNames(traces, NULL),
@@ -1075,6 +1118,16 @@ gg2list <- function(p, width = NULL, height = NULL,
# ggplotly 'utility' functions
#-----------------------------------------------------------------------------
+# grab grobs from a gtable object matching some regular expression
+gtable_grab <- function(gtable, pattern = "^xlab", nullGrobs = FALSE) {
+ if (!gtable::is.gtable(gtable)) stop("Must be a gtable object")
+ gs <- gtable$grobs[grepl(pattern, gtable$layout$name)]
+ if (!nullGrobs) {
+ gs <- gs[!vapply(gs, function(g) identical(ggplot2::zeroGrob(), g), logical(1))]
+ }
+ gs %||% NULL
+}
+
# convert ggplot2 sizes and grid unit(s) to pixels or normalized point coordinates
unitConvert <- function(u, to = c("npc", "pixels"), type = c("x", "y", "height", "width")) {
u <- verifyUnit(u)
@@ -1086,24 +1139,17 @@ unitConvert <- function(u, to = c("npc", "pixels"), type = c("x", "y", "height",
width = grid::convertWidth,
height = grid::convertHeight
)
- # convert everything to npc first
- if (inherits(u, "margin")) {
- # margins consist of 4 parts: top, right, bottom, and left
- uh <- grid::convertHeight(u, "npc")
- uw <- grid::convertWidth(u, "npc")
- u <- grid::unit(c(uh[1], uw[2], uh[3], uw[4]), "npc")
- } else {
- u <- convert(u, "npc")
- }
if (to[1] == "pixels") {
if (inherits(u, "margin")) {
- uh <- mm2pixels(grid::convertHeight(uh, "mm"))
- uw <- mm2pixels(grid::convertWidth(uw, "mm"))
+ uh <- mm2pixels(grid::convertHeight(u, "mm"))
+ uw <- mm2pixels(grid::convertWidth(u, "mm"))
u <- c(uh[1], uw[2], uh[3], uw[4])
} else {
u <- mm2pixels(convert(u, "mm"))
}
}
+ # TODO: what about npc? Are we going to use it at all?
+
as.numeric(u)
}
@@ -1137,25 +1183,72 @@ is_blank <- function(x) {
# given text, and x/y coordinates on 0-1 scale,
# convert ggplot2::element_text() to plotly annotation
-make_label <- function(txt = "", x, y, el = ggplot2::element_text(), ...) {
- if (is_blank(el) || is.null(txt) || nchar(txt) == 0 || length(txt) == 0) {
+label_create <- function(txt = "", x, y, xanchor = "left", yanchor = "bottom",
+ el = ggplot2::element_text(),
+ direction = c("horizontal", "vertical"), ...) {
+ if (is_blank(el) || is.na(txt) || is.null(txt) || nchar(txt) == 0 || length(txt) == 0) {
return(NULL)
}
- angle <- el$angle %||% 0
- list(list(
- text = txt,
- x = x,
- y = y,
+
+ if (!inherits(el, "element_text")) {
+ warning("`el` should be an element_text object", call. = FALSE)
+ }
+
+ direction <- match.arg(direction, direction)
+ fontObj <- text2font(el)
+
+ ann <- list(
+ # should this label scale with graph width (horizontal) or height (vertical)?
+ ggplotlyDirection = direction,
+ # defaults that I *think* are ok for translating element_text
+ xref = "paper",
+ yref = "paper",
showarrow = FALSE,
- # TODO: hjust/vjust?
+ font = fontObj,
+ bgcolor = if (isTRUE(el$debug)) toRGB("yellow", 0.2) else "rgba(0,0,0,0)",
ax = 0,
ay = 0,
- font = text2font(el),
- xref = "paper",
- yref = "paper",
- textangle = -angle,
+ x = x,
+ y = y,
+ xanchor = xanchor,
+ yanchor = yanchor,
+ # approximate [0, 1] -> {1, 2, 3} -> {"left", "middle", "right"}
+ align = switch(round(el$hjust * 2, 0) + 1, "left", "middle", "right"),
+ valign = switch(round(el$vjust * 2, 0) + 1, "top", "middle", "bottom"),
+ textangle = - (el$angle %||% 0),
+ text = txt,
...
- ))
+ )
+
+ # fix the height for horizontal labels and the width for vertical labels
+ dir <- switch(direction, horizontal = "height", vertical = "width")
+ ann[[dir]] <- bbox(txt, el$angle, ann$font$size)[[dir]]
+
+ ann
+}
+
+label_add <- function(layout, ann, name = NULL) {
+ if (!length(ann)) return(layout)
+ layout$annotations <- c(
+ layout$annotations %||% list(),
+ setNames(list(ann), name %||% ann$annotationType %||% "")
+ )
+ layout
+}
+
+label_get <- function(layout, type = "title") {
+ anns <- layout$annotations
+ anns[vapply(anns, function(x) identical(type, x$annotationType), logical(1))]
+}
+
+
+# assumes line breaks are specified via '\n'...
+nLineBreaks <- function(txt) {
+ if (length(txt) == 0) return(0)
+ if (!is.character(txt) && length(txt) != 1) {
+ stop("Must be a character string of length 1", call. = FALSE)
+ }
+ length(strsplit(txt, "\n", fixed = TRUE)[[1]] %||% "")
}
has_facet <- function(x) {
@@ -1190,17 +1283,21 @@ bbox <- function(txt = "foo", angle = 0, size = 12) {
# create a plotly font object from ggplot2::element_text()
text2font <- function(x = ggplot2::element_text(), type = "height") {
+ if (!inherits(x, "element_text")) {
+ warning("`x` must be an `element_text()` object.", call. = FALSE)
+ }
list(
- color = toRGB(x$colour),
- family = x$family,
- # TODO: what about the size of vertical text?
- size = unitConvert(grid::unit(x$size %||% 0, "points"), "pixels", type)
+ color = toRGB(x$colour %||% "black"),
+ family = x$family %||% "Helvetica",
+ size = unitConvert(grid::unit(x$size %||% 0, "pt"), "pixels", type),
+ # waiting patiently for https://github.com/plotly/plotly.js/issues/1661
+ lineheight = x$lineheight %||% 0.9
)
}
# wrap text in bold/italics according to the text "face"
faced <- function(txt, face = "plain") {
- if (is.null(face)) face <- "plain"
+ face <- face %||% "plain"
x <- switch(face,
plain = txt,
bold = bold(txt),
diff --git a/R/highlight.R b/R/highlight.R
index d5d4df9810..02e765e4a4 100644
--- a/R/highlight.R
+++ b/R/highlight.R
@@ -122,7 +122,6 @@ highlight <- function(p, on = "plotly_click", off,
p$dependencies <- c(p$dependencies, list(colourPickerLib()))
}
-
# TODO: expose unhover?
off_options <- paste0(
"plotly_", c("doubleclick", "deselect", "relayout")
diff --git a/R/layers2traces.R b/R/layers2traces.R
index 3d962ba2c6..ec9374e749 100644
--- a/R/layers2traces.R
+++ b/R/layers2traces.R
@@ -79,7 +79,6 @@ layers2traces <- function(data, prestats_data, layout, p) {
# 2. geom_smooth() is really geom_path() + geom_ribbon()
datz <- list()
paramz <- list()
- layout <- if (is_dev_ggplot2()) layout else list(layout = layout)
for (i in seq_along(data)) {
# This has to be done in a loop, since some layers are really two layers,
# (and we need to replicate the data/params in those cases)
@@ -387,7 +386,7 @@ to_basic.GeomAbline <- function(data, prestats_data, layout, params, p, ...) {
data$group <- interaction(
data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
)
- lay <- tidyr::gather_(layout$layout, "variable", "x", c("x_min", "x_max"))
+ lay <- tidyr::gather_(layout$layout, "variable", "x", c("xmin", "xmax"))
data <- merge(lay[c("PANEL", "x")], data, by = "PANEL")
data[["y"]] <- with(data, intercept + slope * x)
prefix_class(data, c("GeomHline", "GeomPath"))
@@ -399,7 +398,7 @@ to_basic.GeomHline <- function(data, prestats_data, layout, params, p, ...) {
data$group <- do.call(paste,
data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
)
- lay <- tidyr::gather_(layout$layout, "variable", "x", c("x_min", "x_max"))
+ lay <- tidyr::gather_(layout$layout, "variable", "x", c("xmin", "xmax"))
data <- merge(lay[c("PANEL", "x")], data, by = "PANEL")
data[["y"]] <- data$yintercept
prefix_class(data, c("GeomHline", "GeomPath"))
@@ -411,7 +410,7 @@ to_basic.GeomVline <- function(data, prestats_data, layout, params, p, ...) {
data$group <- do.call(paste,
data[!grepl("group", names(data)) & !vapply(data, anyNA, logical(1))]
)
- lay <- tidyr::gather_(layout$layout, "variable", "y", c("y_min", "y_max"))
+ lay <- tidyr::gather_(layout$layout, "variable", "y", c("ymin", "ymax"))
data <- merge(lay[c("PANEL", "y")], data, by = "PANEL")
data[["x"]] <- data$xintercept
prefix_class(data, c("GeomVline", "GeomPath"))
@@ -428,7 +427,7 @@ to_basic.GeomErrorbar <- function(data, prestats_data, layout, params, p, ...) {
# width for ggplot2 means size of the entire bar, on the data scale
# (plotly.js wants half, in pixels)
data <- merge(data, layout$layout, by = "PANEL", sort = FALSE)
- data$width <- (data[["xmax"]] - data[["x"]]) /(data[["x_max"]] - data[["x_min"]])
+ data$width <- (data[["xmax"]] - data[["x"]]) /(data[["xmax"]] - data[["xmin"]])
data$fill <- NULL
prefix_class(data, "GeomErrorbar")
}
@@ -438,7 +437,7 @@ to_basic.GeomErrorbarh <- function(data, prestats_data, layout, params, p, ...)
# height for ggplot2 means size of the entire bar, on the data scale
# (plotly.js wants half, in pixels)
data <- merge(data, layout$layout, by = "PANEL", sort = FALSE)
- data$width <- (data[["ymax"]] - data[["y"]]) / (data[["y_max"]] - data[["y_min"]])
+ data$width <- (data[["ymax"]] - data[["y"]]) / (data[["ymax"]] - data[["ymin"]])
data$fill <- NULL
prefix_class(data, "GeomErrorbarh")
}
@@ -476,11 +475,11 @@ to_basic.GeomPointrange <- function(data, prestats_data, layout, params, p, ...)
#' @export
to_basic.GeomDotplot <- function(data, prestats_data, layout, params, p, ...) {
if (identical(params$binaxis, "y")) {
- dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$y_max - layout$layout$y_min)
+ dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$ymax - layout$layout$ymin)
data$size <- as.numeric(grid::convertHeight(grid::unit(dotdia, "npc"), "mm")) / 2
data$x <- (data$countidx - 0.5) * (as.numeric(dotdia) * 6)
} else {
- dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$x_max - layout$layout$x_min)
+ dotdia <- params$dotsize * data$binwidth[1]/(layout$layout$xmax - layout$layout$xmin)
data$size <- as.numeric(grid::convertWidth(grid::unit(dotdia, "npc"), "mm")) / 2
# TODO: why times 6?!?!
data$y <- (data$countidx - 0.5) * (as.numeric(dotdia) * 6)
@@ -516,9 +515,9 @@ utils::globalVariables(c("xmin", "xmax", "y", "size"))
to_basic.GeomRug <- function(data, prestats_data, layout, params, p, ...) {
# allow the tick length to vary across panels
layout <- layout$layout
- layout$tickval_y <- 0.03 * abs(layout$y_max - layout$y_min)
- layout$tickval_x <- 0.03 * abs(layout$x_max - layout$x_min)
- data <- merge(data, layout[c("PANEL", "x_min", "x_max", "y_min", "y_max", "tickval_y", "tickval_x")])
+ layout$tickval_y <- 0.03 * abs(layout$ymax - layout$ymin)
+ layout$tickval_x <- 0.03 * abs(layout$xmax - layout$xmin)
+ data <- merge(data, layout[c("PANEL", "xmin", "xmax", "ymin", "ymax", "tickval_y", "tickval_x")])
# see GeomRug$draw_panel()
rugs <- list()
@@ -530,8 +529,8 @@ to_basic.GeomRug <- function(data, prestats_data, layout, params, p, ...) {
data, data.frame(
x = x,
xend = x,
- y = y_min,
- yend = y_min + tickval_y,
+ y = ymin,
+ yend = ymin + tickval_y,
others
)
)
@@ -541,8 +540,8 @@ to_basic.GeomRug <- function(data, prestats_data, layout, params, p, ...) {
data, data.frame(
x = x,
xend = x,
- y = y_max - tickval_y,
- yend = y_max,
+ y = ymax - tickval_y,
+ yend = ymax,
others
)
)
@@ -552,8 +551,8 @@ to_basic.GeomRug <- function(data, prestats_data, layout, params, p, ...) {
if (grepl("l", sides)) {
rugs$l <- with(
data, data.frame(
- x = x_min,
- xend = x_min + tickval_x,
+ x = xmin,
+ xend = xmin + tickval_x,
y = y,
yend = y,
others
@@ -563,8 +562,8 @@ to_basic.GeomRug <- function(data, prestats_data, layout, params, p, ...) {
if (grepl("r", sides)) {
rugs$r <- with(
data, data.frame(
- x = x_max - tickval_x,
- xend = x_max,
+ x = xmax - tickval_x,
+ xend = xmax,
y = y,
yend = y,
others
diff --git a/R/plotly.R b/R/plotly.R
index 720b45f49a..4b65b067ba 100644
--- a/R/plotly.R
+++ b/R/plotly.R
@@ -350,7 +350,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/R/utils.R b/R/utils.R
index 265f18b2d9..d8ee711293 100644
--- a/R/utils.R
+++ b/R/utils.R
@@ -73,7 +73,7 @@ to_milliseconds <- function(x) {
retain <- function(x, f = identity) {
y <- structure(f(x), class = oldClass(x))
attrs <- attributes(x)
- # TODO: do we set any other "special" attributes internally
+ # TODO: do we set any other "special" attributes internally?
# (grepping "structure(" suggests no)
attrs <- attrs[names(attrs) %in% c("defaultAlpha", "apiSrc")]
if (length(attrs)) {
diff --git a/inst/htmlwidgets/plotly.js b/inst/htmlwidgets/plotly.js
index eaa17a32ac..21e4c07a98 100644
--- a/inst/htmlwidgets/plotly.js
+++ b/inst/htmlwidgets/plotly.js
@@ -15,13 +15,17 @@ HTMLWidgets.widget({
},
resize: function(el, width, height, instance) {
+
+ var gd = document.getElementById(el.id);
+
if (instance.autosize) {
var width = instance.width || width;
var height = instance.height || height;
- Plotly.relayout(el.id, {width: width, height: height});
+ Plotly.relayout(gd, {width: width, height: height});
+ ggplotlyAdjustLabels(gd);
}
},
-
+
renderValue: function(el, x, instance) {
if (typeof(window) !== "undefined") {
@@ -159,8 +163,11 @@ HTMLWidgets.widget({
}
- // Trigger plotly.js calls defined via `plotlyProxy()`
- plot.then(function() {
+ plot.then(function(gd) {
+
+ ggplotlyAdjustLabels(gd);
+
+ // Trigger plotly.js calls defined via `plotlyProxy()`
if (HTMLWidgets.shinyMode) {
Shiny.addCustomMessageHandler("plotly-calls", function(msg) {
var gd = document.getElementById(msg.id);
@@ -174,6 +181,7 @@ HTMLWidgets.widget({
Plotly[msg.method].apply(null, args);
});
}
+
});
// Attach attributes (e.g., "key", "z") to plotly event data
@@ -375,7 +383,8 @@ HTMLWidgets.widget({
selectize.addItems(e.value, true);
selectize.close();
}
- }
+ };
+
selection.on("change", selectionChange);
// Set a crosstalk variable selection value, triggering an update
@@ -438,14 +447,7 @@ HTMLWidgets.widget({
}
});
}
-
-
-
-
-
-
-
-
+
}
} // end of renderValue
@@ -821,3 +823,21 @@ function removeBrush(el) {
outlines[i].remove();
}
}
+
+
+// for ggplotly labels, scale annotation height/width to match graph size
+function ggplotlyAdjustLabels(gd) {
+ var layout = gd.layout || {};
+ var anns = layout.annotations || [];
+ for (var i = 0; i < anns.length; i++) {
+ var container = {};
+ if (anns[i].ggplotlyDirection === "horizontal") {
+ container['annotations[' + i + '].width'] = gd._fullLayout._size.w;
+ Plotly.relayout(gd, container);
+ }
+ if (anns[i].ggplotlyDirection === "vertical") {
+ container['annotations[' + i + '].height'] = gd._fullLayout._size.h;
+ Plotly.relayout(gd, container);
+ }
+ }
+}
diff --git a/tests/testthat/test-ggplot-labels.R b/tests/testthat/test-ggplot-labels.R
index 723b93484c..ce596e2144 100644
--- a/tests/testthat/test-ggplot-labels.R
+++ b/tests/testthat/test-ggplot-labels.R
@@ -5,6 +5,7 @@ test_that("ggtitle is translated correctly", {
geom_point(aes(Petal.Width, Sepal.Width)) +
ggtitle("My amazing plot!")
info <- save_outputs(ggiris, "labels-ggtitle")
+ # TODO: change me to annotation to support justification
expect_identical(info$layout$title, "My amazing plot!")
})
@@ -17,15 +18,14 @@ test_that("ylab is translated correctly", {
expect_identical(labs, c("Petal.Width", "sepal width"))
})
-# TODO: why is this failing on R-devel???
-#test_that("scale_x_continuous(name) is translated correctly", {
-# ggiris <- ggplot(iris) +
-# geom_point(aes(Petal.Width, Sepal.Width)) +
-# scale_x_continuous("petal width")
-# info <- save_outputs(ggiris, "labels-scale_x_continuous_name")
-# labs <- unlist(lapply(info$layout$annotations, "[[", "text"))
-# expect_identical(sort(labs), c("petal width", "Sepal.Width"))
-#})
+test_that("scale_x_continuous(name) is translated correctly", {
+ ggiris <- ggplot(iris) +
+ geom_point(aes(Petal.Width, Sepal.Width)) +
+ scale_x_continuous("petal width")
+ info <- save_outputs(ggiris, "labels-scale_x_continuous_name")
+ labs <- c(info$layout$xaxis$title, info$layout$yaxis$title)
+ expect_identical(labs, c("petal width", "Sepal.Width"))
+})
test_that("angled ticks are translated correctly", {
ggiris <- ggplot(iris) +
@@ -34,3 +34,43 @@ test_that("angled ticks are translated correctly", {
info <- save_outputs(ggiris, "labels-angles")
expect_identical(info$layout$xaxis$tickangle, -45)
})
+
+test_that("labels are translated correctly", {
+ ggiris <- ggplot(iris) +
+ geom_point(aes(Petal.Width, Sepal.Width)) +
+ ggtitle("My amazing plot!") +
+ labs(
+ subtitle = "Some loooooooooooooooooooooooooooooooooooooooooooooong text",
+ caption = "Some loooooooooooooooooooooooooooong text"
+ )
+ info <- save_outputs(ggiris, "labels-ggtitle")
+ # TODO: change me to annotation to support justification
+ expect_identical(info$layout$title, "My amazing plot!")
+})
+
+# TODO: why is the right plot margin off?
+ggplotly(qplot(data = mtcars, vs, mpg))
+
+# TODO:
+# (1) how to handle text being clipped to the width?
+# (2) test lineheight once we have a ability to set it
+
+qplot(data = mtcars, vs, mpg, color = factor(am)) +
+ labs(
+ title = "sadlknewldknewflkcewelkmcdewdlm;dscklmcdslkmcds",
+ subtitle = "Some looooooooooooo0000000000000000oooooooooooooooooooooooooooong text",
+ caption = "Some loooooooooooooooooooooooooooong text",
+ x = "Silly",
+ y = "Yar har har"
+ ) +
+ theme(
+ plot.title = element_text(hjust = 0.5, debug = TRUE),
+ plot.subtitle = element_text(hjust = 0.5, size = 20, debug = TRUE),
+ plot.caption = element_text(debug = TRUE),
+ axis.title.x = element_text(hjust = 0.5, vjust = 0.75, angle = 90, debug = TRUE),
+ axis.title.y = element_text(hjust = 0.5, vjust = 0.25, angle = 45, debug = TRUE),
+ # TODO: why doesn't debug get respected here?
+ legend.title = element_text(size = 7, debug = TRUE),
+ # TODO:
+ legend.title.align = 0.5
+ )
diff --git a/tests/testthat/test-ggplot2-api.R b/tests/testthat/test-ggplot2-api.R
new file mode 100644
index 0000000000..e07de04c8f
--- /dev/null
+++ b/tests/testthat/test-ggplot2-api.R
@@ -0,0 +1,19 @@
+context("ggplot-api")
+
+
+test_that("summarise_layout() gives the expected summary", {
+ p <- ggplot(mpg, aes(displ, hwy)) + geom_point() + facet_wrap(drv ~ cyl)
+ built <- ggplot_build(p)
+ layout <- summarise_layout(built)
+
+ expect_true(nrow(layout) == 9)
+ expect_equal(lengths(layout$vars), rep(2, 9))
+ # we access most (if not all) of these variables in the summary
+ expect_length(
+ setdiff(
+ c('panel', 'row', 'col', 'vars', 'xmin', 'xmax', 'ymin', 'ymax', 'xscale', 'yscale'),
+ names(layout)
+ ), 0
+ )
+
+})