diff --git a/DESCRIPTION b/DESCRIPTION index e476c4b03b..0ff68574fe 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: plotly Title: Create Interactive Web Graphics via 'plotly.js' -Version: 3.5.7 +Version: 3.6.0 Authors@R: c(person("Carson", "Sievert", role = c("aut", "cre"), email = "cpsievert1@gmail.com"), person("Chris", "Parmer", role = c("aut", "cph"), diff --git a/NAMESPACE b/NAMESPACE index f490b95c66..ca6602e736 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -11,6 +11,12 @@ S3method(geom2trace,GeomPolygon) S3method(geom2trace,GeomText) S3method(geom2trace,GeomTile) S3method(geom2trace,default) +S3method(ggplotly,ggmatrix) +S3method(ggplotly,ggplot) +S3method(plotly_build,gg) +S3method(plotly_build,plotly_built) +S3method(plotly_build,plotly_hash) +S3method(plotly_build,plotly_subplot) S3method(print,figure) S3method(print,plotly_built) S3method(print,plotly_hash) diff --git a/NEWS b/NEWS index d413d0476d..95c7bbd810 100644 --- a/NEWS +++ b/NEWS @@ -1,3 +1,20 @@ +3.6.0 -- 16 May 2016 + +NEW FEATURES & CHANGES: + +* Many improvements to the subplot() function: + * ggplot2 objects are now officially supported (#520). + * Several new arguments allow one to synchronize x/y axes (#298), height/width (#376), hide/show x/y axis titles. + * A list of plots can now be passed to the first argument. + * A new vignette with examples and more explanation can be accessed via `vignette("subplot")`. + +* ggplotly() is now a generic function with a method for ggmatrix objects. +* plotly_build() is now a generic function. + +BUG FIX: + +Column facet strips will no longer be drawn when there is only one column. + 3.5.7 -- 13 May 2016 CHANGES: diff --git a/R/ggplotly.R b/R/ggplotly.R index 2e9556b9d5..a1ab6b6522 100644 --- a/R/ggplotly.R +++ b/R/ggplotly.R @@ -13,6 +13,7 @@ #' \code{tooltip = c("y", "x", "colour")} if you want y first, x second, and #' colour last. #' @param source Only relevant for \link{event_data}. +#' @param ... arguments passed onto methods. #' @seealso \link{signup}, \link{plot_ly} #' @return a plotly object #' @export @@ -31,7 +32,46 @@ #' } #' ggplotly <- function(p = ggplot2::last_plot(), width = NULL, height = NULL, - tooltip = "all", source = "A") { + tooltip = "all", source = "A", ...) { + UseMethod("ggplotly", p) +} + +#' @export +ggplotly.ggmatrix <- function(p = ggplot2::last_plot(), width = NULL, + height = NULL, tooltip = "all", source = "A", ...) { + subplotList <- list() + for (i in seq_len(p$ncol)) { + columnList <- list() + for (j in seq_len(p$nrow)) { + thisPlot <- p[j, i] + if (i == 1) { + if (p$showYAxisPlotLabels) thisPlot <- thisPlot + ylab(p$yAxisLabels[j]) + } else { + # y-axes are never drawn on the interior, and diagonal plots are densities, + # so it doesn't make sense to synch zoom actions on y + thisPlot <- thisPlot + + theme( + axis.ticks.y = element_blank(), + axis.text.y = element_blank() + ) + } + columnList <- c(columnList, list(ggplotly(thisPlot, tooltip = tooltip))) + } + # conditioned on a column in a ggmatrix, the x-axis should be on the + # same scale. + s <- subplot(columnList, nrows = p$nrow, margin = 0.01, shareX = TRUE, titleY = TRUE) + subplotList <- c(subplotList, list(s)) + } + s <- layout(subplot(subplotList, nrows = 1), width = width, height = height) + if (nchar(p$title) > 0) { + s <- layout(s, title = p$title) + } + hash_plot(p$data, plotly_build(s)) +} + +#' @export +ggplotly.ggplot <- function(p = ggplot2::last_plot(), width = NULL, + height = NULL, tooltip = "all", source = "A", ...) { l <- gg2list(p, width = width, height = height, tooltip = tooltip, source = source) hash_plot(p$data, l) } @@ -44,9 +84,10 @@ ggplotly <- function(p = ggplot2::last_plot(), width = NULL, height = NULL, #' tooltip. The default, "all", means show all the aesthetic tooltips #' (including the unofficial "text" aesthetic). #' @param source Only relevant for \link{event_data}. +#' @param ... currently not used #' @return a 'built' plotly object (list with names "data" and "layout"). #' @export -gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A") { +gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A", ...) { # ------------------------------------------------------------------------ # Our internal version of ggplot2::ggplot_build(). Modified from # https://github.com/hadley/ggplot2/blob/0cd0ba/R/plot-build.r#L18-L92 @@ -425,55 +466,55 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A gglayout$annotations, make_label( faced(axisTitleText, axisTitle$face), x, y, el = axisTitle, - xanchor = "center", yanchor = "middle" + xanchor = "center", yanchor = "middle", annotationType = "axis" ) ) } } } - - if (has_facet(p)) { - gglayout[[axisName]]$title <- "" - } - + if (has_facet(p)) gglayout[[axisName]]$title <- "" } # end of axis loop + # theme(panel.border = ) -> plotly rect shape 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 - if (!is_blank(theme[["strip.text.x"]]) && - (inherits(p$facet, "wrap") || inherits(p$facet, "grid") && lay$ROW == 1)) { - vars <- ifelse(inherits(p$facet, "wrap"), "facets", "cols") - txt <- paste( - p$facet$labeller(lay[names(p$facet[[vars]])]), collapse = ", " + if (has_facet(p)) { + col_vars <- ifelse(inherits(p$facet, "wrap"), "facets", "cols") + col_txt <- paste( + p$facet$labeller(lay[names(p$facet[[col_vars]])]), collapse = ", " ) - lab <- make_label( - txt, x = mean(xdom), y = max(ydom), - el = theme[["strip.text.x"]] %||% theme[["strip.text"]], - xanchor = "center", yanchor = "bottom" - ) - gglayout$annotations <- c(gglayout$annotations, lab) - strip <- make_strip_rect(xdom, ydom, theme, "top") - gglayout$shapes <- c(gglayout$shapes, strip) - } - if (inherits(p$facet, "grid") && lay$COL == nCols && nRows > 1 && - !is_blank(theme[["strip.text.y"]])) { - txt <- paste( + if (is_blank(theme[["strip.text.x"]])) col_txt <- "" + if (inherits(p$facet, "grid") && 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( p$facet$labeller(lay[names(p$facet$rows)]), collapse = ", " ) - lab <- make_label( - txt, x = max(xdom), y = mean(ydom), - el = theme[["strip.text.y"]] %||% theme[["strip.text"]], - xanchor = "left", yanchor = "middle" - ) - gglayout$annotations <- c(gglayout$annotations, lab) - strip <- make_strip_rect(xdom, ydom, theme, "right") - gglayout$shapes <- c(gglayout$shapes, strip) + if (is_blank(theme[["strip.text.y"]])) row_txt <- "" + if (inherits(p$facet, "grid") && 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) + } } - } # end of panel loop # ------------------------------------------------------------------------ diff --git a/R/plotly.R b/R/plotly.R index 995c108119..5e2a6eaaa1 100644 --- a/R/plotly.R +++ b/R/plotly.R @@ -221,20 +221,51 @@ style <- function(p = last_plot(), ..., traces = 1, evaluate = FALSE) { hash_plot(data, p) } -#' Build a plotly object before viewing it +#' Create a 'plotly_built' object #' -#' For convenience and efficiency purposes, plotly objects are subject to lazy -#' evaluation. That is, the actual content behind a plotly object is not -#' created until it is absolutely necessary. In some instances, you may want -#' to perform this evaluation yourself, and work directly with the resulting -#' list. +#' This generic function creates the list object sent to plotly.js +#' for rendering. Using this function can be useful for overriding defaults +#' provided by \code{ggplotly}/\code{plot_ly} or for debugging rendering +#' errors. #' -#' @param l a ggplot object, or a plotly object, or a list. +#' @param l a ggplot object, or a plotly_hash object, or a list. #' @export +#' @examples +#' +#' p <- plot_ly() +#' # data frame +#' str(p) +#' # the actual list of options sent to plotly.js +#' str(plotly_build(p)) +#' +#' p <- qplot(data = mtcars, wt, mpg, geom = c("point", "smooth")) +#' l <- plotly_build(p) +#' # turn off hoverinfo for the smooth (but keep it for the points) +#' l$data[[2]]$hoverinfo <- "none" +#' l$data[[3]]$hoverinfo <- "none" +#' l +#' plotly_build <- function(l = last_plot()) { - #if (inherits(l, "ggmatrix")) - # ggplot objects don't need any special type of handling - if (ggplot2::is.ggplot(l)) return(gg2list(l)) + UseMethod("plotly_build") +} + +#' @export +plotly_build.plotly_built <- function(l = last_plot()) { + l +} + +#' @export +plotly_build.plotly_subplot <- function(l = last_plot()) { + prefix_class(get_plot(l), "plotly_built") +} + +#' @export +plotly_build.gg <- function(l = last_plot()) { + prefix_class(get_plot(ggplotly(l)), "plotly_built") +} + +#' @export +plotly_build.plotly_hash <- function(l = last_plot()) { l <- get_plot(l) # assume unnamed list elements are data/traces nms <- names(l) diff --git a/R/subplots.R b/R/subplots.R index 50b1794855..c3fd97b357 100644 --- a/R/subplots.R +++ b/R/subplots.R @@ -3,14 +3,23 @@ #' @param ... any number of plotly objects #' @param nrows number of rows for laying out plots in a grid-like structure. #' Only used if no domain is already specified. -#' @param which_layout adopt the layout of which plot? If the default value of -#' "merge" is used, all plot level layout options will be included in the final -#' layout. This argument also accepts a numeric vector which will restric +#' @param widths relative width of each column on a 0-1 scale. By default all +#' columns have an equal relative width. +#' @param heights relative height of each row on a 0-1 scale. By default all +#' rows have an equal relative height. #' @param margin either a single value or four values (all between 0 and 1). #' If four values are provided, the first is used as the left margin, the second #' is used as the right margin, the third is used as the top margin, and the #' fourth is used as the bottom margin. #' If a single value is provided, it will be used as all four margins. +#' @param shareX should the x-axis be shared amongst the subplots? +#' @param shareY should the y-axis be shared amongst the subplots? +#' @param titleX should x-axis titles be retained? +#' @param titleY should y-axis titles be retained? +#' @param which_layout adopt the layout of which plot? If the default value of +#' "merge" is used, layout options found later in the sequence of plots will +#' override options found earlier in the sequence. This argument also accepts a +#' numeric vector specifying which plots to consider when merging. #' @return A plotly object #' @export #' @author Carson Sievert @@ -20,136 +29,252 @@ #' subplot(p1, p2, p1, p2, nrows = 2) #' } - -subplot <- function(..., nrows = 1, which_layout = "merge", margin = 0.02) { - # note that dots is a _list of plotlys_ - dots <- lapply(list(...), plotly_build) - # put existing plot anchors and domain information into a tidy format - # (geo, xaxis, or yaxis can be used to anchor traces on different plots) - p_info <- list() - ctr <- 1 - for (i in seq_along(dots)) { - dat <- dots[[i]]$data - layout <- dots[[i]]$layout - for (j in seq_along(dat)) { - tr <- dat[[j]] - idx <- if (j == 1) "" else j - geo <- unique(tr$geo) %||% "" - # if a valid geo property exists, use that and ignore x/y axis properties - info <- if (grepl("^geo[0-9]+$", geo)) { - d <- layout[[paste0("geo", idx)]][["domain"]] %||% list(x = NA, y = NA) - c( - geo = sub("^geo1$", "geo", geo), - xaxis = "", - xstart = d$x[1], - xend = d$x[2], - yaxis = "", - ystart = d$y[1], - yend = d$y[2] - ) +subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, margin = 0.02, + shareX = FALSE, shareY = FALSE, titleX = shareX, + titleY = shareY, which_layout = "merge") { + # are the dots a list of plotly objects? + dotz <- list(...) + if (length(dotz) == 1 && is.list(dotz[[1]]) && !is.plotly(dotz[[1]])) { + dotz <- dotz[[1]] + } + # build each plot + plotz <- lapply(dotz, plotly_build) + # ensure "axis-reference" trace attributes are properly formatted + # TODO: should this go inside plotly_build()? + plotz <- lapply(plotz, function(p) { + p$data <- lapply(p$data, function(tr) { + if (length(tr[["geo"]])) { + tr[["geo"]] <- sub("^geo1$", "geo", tr[["geo"]][1]) %||% NULL + tr[["xaxis"]] <- NULL + tr[["yaxis"]] <- NULL } else { - dx <- layout[[paste0("xaxis", idx)]][["domain"]] %||% NA - dy <- layout[[paste0("yaxis", idx)]][["domain"]] %||% NA - c( - geo = "", - xaxis = unique(tr$xaxis) %||% "", - xstart = dx[1], - xend = dx[2], - yaxis = unique(tr$yaxis) %||% "", - ystart = dy[1], - yend = dy[2] - ) + tr[["geo"]] <- NULL + tr[["xaxis"]] <- sub("^x1$", "x", tr[["xaxis"]][1] %||% "x") + tr[["yaxis"]] <- sub("^y1$", "y", tr[["yaxis"]][1] %||% "y") } - p_info[[ctr]] <- c(info, plot = i, trace = j) - ctr <- ctr + 1 + tr + }) + p + }) + # Are any traces referencing "axis-like" layout attributes that are missing? + # If so, move those traces to a "new plot", and inherit layout attributes, + # which makes this sort of thing possible: + # https://plot.ly/r/map-subplots-and-small-multiples/ + plots <- list() + for (i in seq_along(plotz)) { + p <- plots[[i]] <- plotz[[i]] + layoutAttrs <- c(names(p$layout), c("geo", "xaxis", "yaxis")) + xTraceAttrs <- sub("^x", "xaxis", sapply(p$data, function(tr) tr[["geo"]] %||% tr[["xaxis"]])) + yTraceAttrs <- sub("^y", "yaxis", sapply(p$data, function(tr) tr[["geo"]] %||% tr[["yaxis"]])) + missingAttrs <- setdiff(c(xTraceAttrs, yTraceAttrs), layoutAttrs) + # move to next iteration if trace references are complete + if (!length(missingAttrs)) next + # remove each "missing" trace from this plot + missingTraces <- xTraceAttrs %in% missingAttrs | yTraceAttrs %in% missingAttrs + plots[[i]]$data[missingTraces] <- NULL + # move traces with "similar missingness" to a new plot + for (j in missingAttrs) { + newPlot <- list( + data = p$data[xTraceAttrs %in% j | yTraceAttrs %in% j], + layout = p$layout + ) + # reset the anchors + newPlot$data <- lapply(newPlot$data, function(tr) { + for (k in c("geo", "xaxis", "yaxis")) { + tr[[k]] <- sub("[0-9]+", "", tr[[k]]) %||% NULL + } + tr + }) + plots <- c(plots, list(newPlot)) + } + } + # main plot objects + traces <- lapply(plots, "[[", "data") + layouts <- lapply(plots, "[[", "layout") + shapes <- lapply(layouts, "[[", "shapes") + annotations <- lapply(layouts, function(x) { + # keep non axis title annotations + axes <- vapply(x$annotations, function(a) identical(a$annotationType, "axis"), logical(1)) + x$annotations[!axes] + }) + # collect axis objects (note a _single_ geo object counts a both an x and y) + geoDomainDefault <- list(x = c(0, 1), y = c(0, 1)) + xAxes <- lapply(layouts, function(lay) { + keys <- grep("^geo|^xaxis", names(lay), value = TRUE) %||% "xaxis" + for (k in keys) { + lay[[k]]$domain <- lay[[k]]$domain %||% if (grepl("^geo", k)) geoDomainDefault else c(0, 1) + } + lay[keys] + }) + yAxes <- lapply(layouts, function(lay) { + keys <- grep("^geo|^yaxis", names(lay), value = TRUE) %||% "yaxis" + for (k in keys) { + lay[[k]]$domain <- lay[[k]]$domain %||% if (grepl("^geo", k)) geoDomainDefault else c(0, 1) + } + lay[keys] + }) + if (!titleX) { + xAxes <- lapply(xAxes, function(ax) lapply(ax, function(y) { y$title <- NULL; y })) + } + if (!titleY) { + yAxes <- lapply(yAxes, function(ax) lapply(ax, function(y) { y$title <- NULL; y })) + } + # number of x/y axes per plot + xAxisN <- vapply(xAxes, length, numeric(1)) + yAxisN <- vapply(yAxes, length, numeric(1)) + # old -> new axis name dictionary + ncols <- ceiling(length(plots) / nrows) + xAxisID <- seq_len(sum(xAxisN)) + if (shareX) { + if (length(unique(xAxisN)) > 1) { + warning("Must have a consistent number of axes per 'subplot' to share them.") + } else { + xAxisID <- rep(rep(seq_len(ncols * unique(xAxisN)), length.out = length(plots)), unique(xAxisN)) + } + } + yAxisID <- seq_len(sum(yAxisN)) + if (shareY) { + if (length(unique(yAxisN)) > 1) { + warning("Must have a consistent number of axes per 'subplot' to share them.") + } else { + yAxisID <- rep(rep(seq_len(nrows * unique(xAxisN)), each = ncols, length.out = length(plots)), unique(yAxisN)) } } - # put p_info into a data.frame() - p_info <- Reduce(rbind, p_info) - row.names(p_info) <- NULL - p_info <- data.frame(p_info, stringsAsFactors = FALSE) - # obtain the _actual_ plot id - key <- with(p_info, paste0(geo, xaxis, yaxis, plot)) - p_info$key <- match(key, unique(key)) - # bump x/y axis anchors appropriately - p_info$xaxis <- sub("^x1$", "x", paste0("x", p_info$key)) - p_info$yaxis <- sub("^y1$", "y", paste0("y", p_info$key)) - # Only do domain computations if they are _completely_ missing - # (I don't think it makes sense to support partial specification of domains) - if (all(is.na(with(p_info, c(xstart, xend, ystart, yend))))) { - doms <- get_domains(max(p_info$key), nrows, margin) - doms$key <- as.character(seq_len(nrow(doms))) - p_info <- p_info[!names(p_info) %in% c("xstart", "xend", "ystart", "yend")] - p_info <- merge(p_info, doms, by = "key", sort = FALSE) + # current "axis" names + xCurrentNames <- unlist(lapply(xAxes, names)) + yCurrentNames <- unlist(lapply(yAxes, names)) + xNewNames <- paste0( + sub("[0-9]+$", "", xCurrentNames), + sub("^1$", "", xAxisID) + ) + yNewNames <- paste0( + sub("[0-9]+$", "", yCurrentNames), + sub("^1$", "", yAxisID) + ) + xAxisMap <- setNames(xCurrentNames, xNewNames) + yAxisMap <- setNames(yCurrentNames, yNewNames) + # split the map by plot ID + xAxisMap <- split(xAxisMap, rep(seq_along(plots), xAxisN)) + yAxisMap <- split(yAxisMap, rep(seq_along(plots), yAxisN)) + # domains of each subplot + domainInfo <- get_domains( + length(plots), nrows, margin, widths = widths, heights = heights + ) + for (i in seq_along(plots)) { + # map axis object names + xMap <- xAxisMap[[i]] + yMap <- yAxisMap[[i]] + xAxes[[i]] <- setNames(xAxes[[i]], names(xMap)) + yAxes[[i]] <- setNames(yAxes[[i]], names(yMap)) + # for cartesian, bump corresponding axis anchor + for (j in seq_along(xAxes[[i]])) { + if (grepl("^geo", names(xAxes[[i]][j]))) next + map <- yMap[yMap %in% sub("y", "yaxis", xAxes[[i]][[j]]$anchor %||% "y")] + xAxes[[i]][[j]]$anchor <- sub("axis", "", names(map)) + } + for (j in seq_along(yAxes[[i]])) { + if (grepl("^geo", names(yAxes[[i]][j]))) next + map <- xMap[xMap %in% sub("x", "xaxis", yAxes[[i]][[j]]$anchor %||% "x")] + yAxes[[i]][[j]]$anchor <- sub("axis", "", names(map)) + } + # map trace xaxis/yaxis/geo attributes + for (key in c("geo", "xaxis", "yaxis")) { + oldAnchors <- unlist(lapply(traces[[i]], "[[", key)) + if (!length(oldAnchors)) next + axisMap <- if (key == "yaxis") yMap else xMap + axisMap <- setNames(sub("axis", "", axisMap), sub("axis", "", names(axisMap))) + newAnchors <- names(axisMap)[match(oldAnchors, axisMap)] + traces[[i]] <- Map(function(tr, a) { tr[[key]] <- a; tr }, traces[[i]], newAnchors) + } + # rescale domains according to the tabular layout + xDom <- as.numeric(domainInfo[i, c("xstart", "xend")]) + yDom <- as.numeric(domainInfo[i, c("yend", "ystart")]) + reScale <- function(old, new) { + sort(scales::rescale( + old %||% c(0, 1), new, from = c(0, 1) + )) + } + xAxes[[i]] <- lapply(xAxes[[i]], function(ax) { + if (all(c("x", "y") %in% names(ax$domain))) { + # geo domains are different from cartesian + ax$domain$x <- reScale(ax$domain$x, xDom) + ax$domain$y <- reScale(ax$domain$y, yDom) + } else { + ax$domain <- reScale(ax$domain, xDom) + } + ax + }) + yAxes[[i]] <- lapply(yAxes[[i]], function(ax) { + if (all(c("x", "y") %in% names(ax$domain))) { + # geo domains are different from cartesian + ax$domain$x <- reScale(ax$domain$x, xDom) + ax$domain$y <- reScale(ax$domain$y, yDom) + } else { + ax$domain <- reScale(ax$domain, yDom) + } + ax + }) } - # empty plot container that we'll fill up with new info + # start merging the plots into a single subplot p <- list( - data = vector("list", nrow(p_info)) + data = Reduce(c, traces), + layout = Reduce(modifyList, c(xAxes, rev(yAxes))) ) - # merge layouts of the subplots - ls <- if (which_layout == "merge") { - lapply(dots, "[[", "layout") - } else { + # reposition shapes and annotations + annotations <- Map(reposition, annotations, split(domainInfo, seq_along(plots))) + shapes <- Map(reposition, shapes, split(domainInfo, seq_along(plots))) + p$layout$annotations <- Reduce(c, annotations) + p$layout$shapes <- Reduce(c, shapes) + # merge non-axis layout stuff + layouts <- lapply(layouts, function(x) x[!grepl("^[x-y]axis|^geo", names(x))] %||% list()) + if (which_layout != "merge") { if (!is.numeric(which_layout)) warning("which_layout must be numeric") - if (!all(idx <- which_layout %in% seq_along(dots))) { + if (!all(idx <- which_layout %in% seq_along(plots))) { warning("which_layout is referencing non-existant layouts") which_layout <- which_layout[idx] } - lapply(dots[which_layout], "[[", "layout") + layouts <- layouts[which_layout] } - ls <- ls[!vapply(ls, is.null, logical(1))] - p[["layout"]] <- Reduce(modifyList, ls) + p$layout <- c(p$layout, Reduce(modifyList, layouts)) - # tack on trace, domain, and anchor information - p_info$plot <- as.numeric(p_info$plot) - p_info$trace <- as.numeric(p_info$trace) - for (i in seq_along(p$data)) { - info <- p_info[i, ] - xdom <- sort(c(info$xstart, info$xend)) - ydom <- sort(c(info$ystart, info$yend)) - p$data[[i]] <- dots[[info$plot]]$data[[info$trace]] - if (grepl("^geo", info$geo)) { - # carry over first geo object if this one is missing - p$layout[[info$geo]] <- p$layout[[info$geo]] %||% p$layout[["geo"]] - # add domains to the layout - p$layout[[info$geo]] <- modifyList( - p$layout[[info$geo]] %||% list(), - list(domain = list(x = xdom, y = ydom)) - ) - # ensure the geo anchor is a single value - p$data[[i]]$geo <- info$geo - } else { - xaxis <- sub("x", "xaxis", info$xaxis) - yaxis <- sub("y", "yaxis", info$yaxis) - # does this plot contain x/y axis styling? If so, use it - # (but overwrite domain/anchor info) - l <- dots[[info$plot]]$layout - p$layout[[xaxis]] <- modifyList( - if (any(idx <- names(l) %in% "xaxis")) l[idx][[1]] else list(), - list(domain = xdom, anchor = info$yaxis) - ) - p$layout[[yaxis]] <- modifyList( - if (any(idx <- names(l) %in% "yaxis")) l[idx][[1]] else list(), - list(domain = ydom, anchor = info$xaxis) - ) - p$data[[i]]$xaxis <- info$xaxis - p$data[[i]]$yaxis <- info$yaxis - } - } - hash_plot(data.frame(), p) + res <- hash_plot(data.frame(), p) + prefix_class(res, "plotly_subplot") } -get_domains <- function(nplots = 1, nrows = 1, margins = 0.01) { +get_domains <- function(nplots = 1, nrows = 1, margins = 0.01, + widths = NULL, heights = NULL) { if (length(margins) == 1) margins <- rep(margins, 4) if (length(margins) != 4) stop("margins must be length 1 or 4", call. = FALSE) ncols <- ceiling(nplots / nrows) + widths <- widths %||% rep(1 / ncols, ncols) + heights <- heights %||% rep(1 / nrows, nrows) + if (length(widths) != ncols) { + stop("The length of the widths argument must be equal ", + "to the number of columns", call. = FALSE) + } + if (length(heights) != nrows) { + stop("The length of the heights argument is ", length(heights), + ", but the number of rows is ", nrows, call. = FALSE) + } + if (any(widths < 0) | any(heights < 0)) { + stop("The widths and heights arguments must contain positive values") + } + if (sum(widths) > 1 | sum(heights) > 1) { + stop("The sum of the widths and heights arguments must be less than 1") + } + + widths <- cumsum(c(0, widths)) + heights <- cumsum(c(0, heights)) + # 'center' these values if there is still room left + widths <- widths + (1 - max(widths)) / 2 + heights <- heights + (1 - max(heights)) / 2 xs <- vector("list", ncols) for (i in seq_len(ncols)) { xs[[i]] <- c( - xstart = ((i - 1) / ncols) + ifelse(i == 1, 0, margins[1]), - xend = (i / ncols) - ifelse(i == ncols, 0, margins[2]) + xstart = widths[i] + if (i == 1) 0 else margins[1], + xend = widths[i + 1] - if (i == ncols) 0 else margins[2] ) } xz <- rep_len(xs, nplots) @@ -158,8 +283,8 @@ get_domains <- function(nplots = 1, nrows = 1, margins = 0.01) { for (i in seq_len(nplots)) { j <- ceiling(i / ncols) ys[[i]] <- c( - ystart = 1 - ((j - 1) / nrows) - ifelse(j == 1, 0, margins[3]), - yend = 1 - (j / nrows) + ifelse(j == nrows, 0, margins[4]) + ystart = 1 - (heights[j]) - if (j == 1) 0 else margins[3], + yend = 1 - (heights[j + 1]) + if (j == nrows) 0 else margins[4] ) } list2df(Map(c, xz, ys)) @@ -172,3 +297,29 @@ list2df <- function(x, nms) { df <- data.frame(m) if (!missing(nms)) setNames(df, nms) else df } + +# translate x/y positions according to domain objects +# (useful mostly for repositioning annotations/shapes in subplots) +reposition <- function(obj, domains) { + # we need x and y in order to rescale them! + for (i in seq_along(obj)) { + o <- obj[[i]] + # TODO: this implementation currently assumes xref/yref == "paper" + # should we support references to axis objects as well? + for (j in c("x", "x0", "x1")) { + if (is.numeric(o[[j]])) { + obj[[i]][[j]] <- scales::rescale( + o[[j]], as.numeric(domains[c("xstart", "xend")]), from = c(0, 1) + ) + } + } + for (j in c("y", "y0", "y1")) { + if (is.numeric(o[[j]])) { + obj[[i]][[j]] <- scales::rescale( + o[[j]], as.numeric(domains[c("yend", "ystart")]), from = c(0, 1) + ) + } + } + } + obj +} diff --git a/R/utils.R b/R/utils.R index 06eccf9dd1..ab838f958a 100644 --- a/R/utils.R +++ b/R/utils.R @@ -1,4 +1,6 @@ -is.plotly <- function(x) inherits(x, "plotly") +is.plotly <- function(x) { + inherits(x, c("plotly_hash", "plotly_built", "plotly_subplot")) +} "%||%" <- function(x, y) { if (length(x) > 0 || is_blank(x)) x else y diff --git a/man/gg2list.Rd b/man/gg2list.Rd index d125d1f699..4104a0e6db 100644 --- a/man/gg2list.Rd +++ b/man/gg2list.Rd @@ -4,7 +4,8 @@ \alias{gg2list} \title{Convert a ggplot to a list.} \usage{ -gg2list(p, width = NULL, height = NULL, tooltip = "all", source = "A") +gg2list(p, width = NULL, height = NULL, tooltip = "all", source = "A", + ...) } \arguments{ \item{p}{ggplot2 plot.} @@ -18,6 +19,8 @@ tooltip. The default, "all", means show all the aesthetic tooltips (including the unofficial "text" aesthetic).} \item{source}{Only relevant for \link{event_data}.} + +\item{...}{currently not used} } \value{ a 'built' plotly object (list with names "data" and "layout"). diff --git a/man/ggplotly.Rd b/man/ggplotly.Rd index 1df2e6c8f4..be0b7d66ff 100644 --- a/man/ggplotly.Rd +++ b/man/ggplotly.Rd @@ -5,7 +5,7 @@ \title{Create plotly graphs using ggplot2 syntax} \usage{ ggplotly(p = ggplot2::last_plot(), width = NULL, height = NULL, - tooltip = "all", source = "A") + tooltip = "all", source = "A", ...) } \arguments{ \item{p}{a ggplot object.} diff --git a/man/plotly_build.Rd b/man/plotly_build.Rd index 689ede07d0..b074b94518 100644 --- a/man/plotly_build.Rd +++ b/man/plotly_build.Rd @@ -2,18 +2,33 @@ % Please edit documentation in R/plotly.R \name{plotly_build} \alias{plotly_build} -\title{Build a plotly object before viewing it} +\title{Create a 'plotly_built' object} \usage{ plotly_build(l = last_plot()) } \arguments{ -\item{l}{a ggplot object, or a plotly object, or a list.} +\item{l}{a ggplot object, or a plotly_hash object, or a list.} } \description{ -For convenience and efficiency purposes, plotly objects are subject to lazy -evaluation. That is, the actual content behind a plotly object is not -created until it is absolutely necessary. In some instances, you may want -to perform this evaluation yourself, and work directly with the resulting -list. +This generic function creates the list object sent to plotly.js +for rendering. Using this function can be useful for overriding defaults +provided by \code{ggplotly}/\code{plot_ly} or for debugging rendering +errors. +} +\examples{ + +p <- plot_ly() +# data frame +str(p) +# the actual list of options sent to plotly.js +str(plotly_build(p)) + +p <- qplot(data = mtcars, wt, mpg, geom = c("point", "smooth")) +l <- plotly_build(p) +# turn off hoverinfo for the smooth (but keep it for the points) +l$data[[2]]$hoverinfo <- "none" +l$data[[3]]$hoverinfo <- "none" +l + } diff --git a/man/subplot.Rd b/man/subplot.Rd index f4a6c0499e..e76fbbe50a 100644 --- a/man/subplot.Rd +++ b/man/subplot.Rd @@ -4,7 +4,9 @@ \alias{subplot} \title{View multiple plots in a single view} \usage{ -subplot(..., nrows = 1, which_layout = "merge", margin = 0.02) +subplot(..., nrows = 1, widths = NULL, heights = NULL, margin = 0.02, + shareX = FALSE, shareY = FALSE, titleX = shareX, titleY = shareY, + which_layout = "merge") } \arguments{ \item{...}{any number of plotly objects} @@ -12,15 +14,30 @@ subplot(..., nrows = 1, which_layout = "merge", margin = 0.02) \item{nrows}{number of rows for laying out plots in a grid-like structure. Only used if no domain is already specified.} -\item{which_layout}{adopt the layout of which plot? If the default value of -"merge" is used, all plot level layout options will be included in the final -layout. This argument also accepts a numeric vector which will restric} +\item{widths}{relative width of each column on a 0-1 scale. By default all +columns have an equal relative width.} + +\item{heights}{relative height of each row on a 0-1 scale. By default all +rows have an equal relative height.} \item{margin}{either a single value or four values (all between 0 and 1). If four values are provided, the first is used as the left margin, the second is used as the right margin, the third is used as the top margin, and the fourth is used as the bottom margin. If a single value is provided, it will be used as all four margins.} + +\item{shareX}{should the x-axis be shared amongst the subplots?} + +\item{shareY}{should the y-axis be shared amongst the subplots?} + +\item{titleX}{should x-axis titles be retained?} + +\item{titleY}{should y-axis titles be retained?} + +\item{which_layout}{adopt the layout of which plot? If the default value of +"merge" is used, layout options found later in the sequence of plots will +override options found earlier in the sequence. This argument also accepts a +numeric vector specifying which plots to consider when merging.} } \value{ A plotly object diff --git a/tests/testthat/test-plotly-subplot.R b/tests/testthat/test-plotly-subplot.R index d73b9b624e..c1a8ac13b2 100644 --- a/tests/testthat/test-plotly-subplot.R +++ b/tests/testthat/test-plotly-subplot.R @@ -45,5 +45,126 @@ test_that("group + [x/y]axis works", { expect_true(all(1 >= xdom[[3]] & xdom[[3]] > 2/3)) }) +test_that("shareX produces one x-axis", { + s <- subplot(plot_ly(x = 1), plot_ly(x = 1), nrows = 2, shareX = TRUE) + l <- expect_traces(s, 2, "shareX") + expect_true(sum(grepl("^xaxis", names(l$layout))) == 1) +}) + +test_that("shareY produces one y-axis", { + s <- subplot(plot_ly(x = 1), plot_ly(x = 1), shareY = TRUE) + l <- expect_traces(s, 2, "shareY") + expect_true(sum(grepl("^yaxis", names(l$layout))) == 1) +}) + +test_that("share both axes", { + s <- subplot( + plot_ly(x = 1), plot_ly(x = 1), plot_ly(x = 1), plot_ly(x = 1), + nrows = 2, shareX = TRUE, shareY = TRUE + ) + l <- expect_traces(s, 4, "shareBoth") + expect_true(sum(grepl("^yaxis", names(l$layout))) == 2) + expect_true(sum(grepl("^xaxis", names(l$layout))) == 2) +}) + +# https://github.com/ropensci/plotly/issues/376 +d <- data.frame( + x = rnorm(100), + y = rnorm(100) +) +hist_top <- ggplot(d) + geom_histogram(aes(x = x)) +empty <- ggplot() + geom_blank() +scatter <- ggplot(d) + geom_point(aes(x = x, y = y)) +hist_right <- ggplot(d) + geom_histogram(aes(x = y)) + coord_flip() +s <- subplot( + hist_top, empty, scatter, hist_right, + nrows = 2, widths = c(0.8, 0.2), heights = c(0.2, 0.8), + margin = 0.005, shareX = TRUE, shareY = TRUE +) + +test_that("Row/column height/width", { + l <- expect_traces(s, 3, "width-height") + expect_equal(diff(l$layout$xaxis$domain), 0.8 - 0.005) + expect_equal(diff(l$layout$xaxis2$domain), 0.2 - 0.005) + expect_equal(diff(l$layout$yaxis$domain), 0.2 - 0.005) + expect_equal(diff(l$layout$yaxis2$domain), 0.8 - 0.005) +}) +test_that("recursive subplots work", { + p1 <- plot_ly(economics, x = date, y = unemploy) + p2 <- plot_ly(economics, x = date, y = uempmed) + s1 <- subplot(p1, p1, shareY = TRUE) + s2 <- subplot(p2, p2, shareY = TRUE) + s <- subplot(s1, s2, nrows = 2, shareX = TRUE) + l <- expect_traces(s, 4, "recursive") + xaxes <- l$layout[grepl("^xaxis", names(l$layout))] + yaxes <- l$layout[grepl("^yaxis", names(l$layout))] + expect_true(length(xaxes) == 2) + expect_true(length(yaxes) == 2) + # both x-axes are anchored on the same y-axis + yanchor <- unique(unlist(lapply(xaxes, "[[", "anchor"))) + expect_true(length(yanchor) == 1) + # both y-axes are anchored on the same x-axis + xanchor <- unique(unlist(lapply(yaxes, "[[", "anchor"))) + expect_true(length(xanchor) == 1) + # x/y are anchored on the bottom/left + expect_true(l$layout[[sub("x", "xaxis", xanchor)]]$domain[1] == 0) + expect_true(l$layout[[sub("y", "yaxis", yanchor)]]$domain[1] == 0) + # every trace is anchored on a different x/y axis pair + xTraceAnchors <- sapply(l$data, "[[", "xaxis") + yTraceAnchors <- sapply(l$data, "[[", "yaxis") + expect_true(length(unique(paste(xTraceAnchors, yTraceAnchors))) == 4) +}) + +test_that("subplot accepts a list of plots", { + vars <- setdiff(names(economics), "date") + plots <- lapply(vars, function(var) { + plot_ly(x = economics$date, y = economics[[var]], name = var) + }) + s <- subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE) + l <- expect_traces(s, 5, "plot-list") + xaxes <- l$layout[grepl("^xaxis", names(l$layout))] + yaxes <- l$layout[grepl("^yaxis", names(l$layout))] + expect_true(length(xaxes) == 1) + expect_true(length(yaxes) == 5) + # x-axis is anchored at the bottom + expect_true(l$layout[[sub("y", "yaxis", xaxes[[1]]$anchor)]]$domain[1] == 0) +}) + + +test_that("ggplotly understands ggmatrix", { + L <- save_outputs(GGally::ggpairs(iris), "plotly-subplot-ggmatrix") +}) + +test_that("geo+cartesian behaves", { + # specify some map projection/options + g <- list( + scope = 'usa', + projection = list(type = 'albers usa'), + lakecolor = toRGB('white') + ) + # create a map of population density + density <- state.x77[, "Population"] / state.x77[, "Area"] + map <- plot_ly( + z = density, + text = state.name, locations = state.abb, + type = 'choropleth', locationmode = 'USA-states', geo = "geo" + ) %>% layout(geo = g) + # create a bunch of horizontal bar charts + vars <- colnames(state.x77) + barcharts <- lapply(vars, function(var) { + plot_ly(x = state.x77[, var], y = state.name, type = "bar", + orientation = "h", name = var) %>% + layout(showlegend = FALSE, hovermode = "y", + yaxis = list(showticklabels = FALSE)) + }) + s <- subplot( + subplot(barcharts, margin = 0.01), map, + nrows = 2, heights = c(0.3, 0.7) + ) + l <- expect_traces(s, 9, "geo-cartesian") + geoDom <- l$layout[[grep("^geo", names(l$layout))]]$domain + expect_equal(geoDom$x, c(0, 1)) + expect_equal(geoDom$y, c(0, 0.68)) +}) diff --git a/vignettes/intro.Rmd b/vignettes/intro.Rmd index d3d5ffe61d..8f0a3280f7 100644 --- a/vignettes/intro.Rmd +++ b/vignettes/intro.Rmd @@ -36,7 +36,7 @@ You can manually add a trace to an existing plot with `add_trace()`. In that cas ```{r} m <- loess(unemploy / pop ~ as.numeric(date), data = economics) p <- plot_ly(economics, x = date, y = unemploy / pop, name = "raw") -add_trace(p, y = fitted(m), name = "loess") +add_trace(p, x = date, y = fitted(m), name = "loess") ``` __plotly__ was designed with a [pure, predictable, and pipeable interface](https://dl.dropboxusercontent.com/u/41902/pipe-dsls.pdf) in mind, so you can also use the `%>%` operator to create a visualization pipeline: @@ -44,7 +44,7 @@ __plotly__ was designed with a [pure, predictable, and pipeable interface](https ```{r} economics %>% plot_ly(x = date, y = unemploy / pop) %>% - add_trace(y = fitted(m)) %>% + add_trace(x = date, y = fitted(m)) %>% layout(showlegend = F) ``` @@ -161,46 +161,3 @@ To change the default symbols used, use the symbols argument. All the valid symb plot_ly(iris, x = Petal.Length, y = Petal.Width, mode = "markers", symbol = Species, symbols = c("cross", "square", "triangle-down")) ``` - - -### The group argument and `subplot()` - -Using the group argument splits the data into different plotly "traces". - -```{r} -plot_ly(iris, x = Petal.Length, y = Petal.Width, - group = Species, mode = "markers") -``` - -Although we haven't specified a coloring scheme, plotly will employ one on it's own default scheme. The group argument is quite powerful when used in conjunction with `subplot()` in order to anchor traces onto different axes. - -```{r} -iris$id <- as.integer(iris$Species) -p <- plot_ly(iris, x = Petal.Length, y = Petal.Width, group = Species, - xaxis = paste0("x", id), mode = "markers") -subplot(p) -``` - -Since `subplot()` does not assume x/y axes are on a common scale, it does not impose any restrictions on the range by default. However, you can change this by pre-specifying the range of the [axis objects](https://plot.ly/r/reference/#xaxis) via the `layout()` function. - -```{r} -p2 <- layout( - p, - xaxis = list(range = range(Petal.Length) + c(-0.1, 0.1)), - yaxis = list(range = range(Petal.Width) + c(-0.1, 0.1)) -) -subplot(p2) -``` - -Part of the magic of `subplot()` is that it generates axis objects with appropriate anchor and domain properties. After generating a subplot, you can always reference these axis objects to customize each plot. - -```{r} -layout( - subplot(p2), - yaxis2 = list(title = ""), - yaxis3 = list(title = "") -) -``` - - -[See here](https://plot.ly/r/map-subplots-and-small-multiples/) for another example of using the group argument to make small multiples (with maps!). diff --git a/vignettes/proportions.svg b/vignettes/proportions.svg new file mode 100644 index 0000000000..969f049d0e --- /dev/null +++ b/vignettes/proportions.svg @@ -0,0 +1,2 @@ + +
nrows = 2,
heights = c(.4, .6),
widths = c(1/4, 1/4, 1/2)
[Not supported by viewer]
1
1
2
2
3
3
4
4
5
5
1
1
2
2
3
3
4
4
5
5 \ No newline at end of file diff --git a/vignettes/proportions.xml b/vignettes/proportions.xml new file mode 100644 index 0000000000..19ec767f68 --- /dev/null +++ b/vignettes/proportions.xml @@ -0,0 +1 @@ +7VpLb+MgEP41kXYvkR9pHsemr72sVKmH3T1SQ2xUYiLsNOn++g72YGPjtpGaxtF6c4jggxkm3wwwQEbh1Xp/p8gm+SkpE6PAo/tReD0Kgtl8Ad8aeCmBi9AvgVhxWkIW8MD/MgQ9RLecsqzRMZdS5HzTBCOZpizKGxhRSu6a3VZSNEfdkNiMWAMPEREu+ovTPEF0juZp/AfjcYIjBx42PJLoKVZym+JwoyBcFZ+yeU2MKuyfJYTKnQWFN8CqkhIU69J6f8WEZtawVsrdvtFama1Yiqa9LwBNWuCZiC3+crQrfzFU7BKes4cNiXR9B94ehcskXwuo+VBccSGupJAK6qlModMSdTKVM4yHDrsKCI26Y3LNcvUCXVAgCEsJDB9D1672hYGShhswAtD7caW3pgAKyEI3I7MzZWQy74sR/+JMKfGbQeKbxcPixJ92kGJm8adImX5MiuDFL6VcwRLFZQpoJrfatA+4yXIln6qFR3eiJEuYHlpXjh9NndR9FXMHzLAzZm6Oju+DOXTaAcxZLDUIcPk5zdQMcQ35aGoa6j5Dk1nzLJrSIiOABl3zoBGUTAWMuXxUUIp1ySDZhqQGK02rJaNv40kh7I2n3y0tYJIt9rZyyp8NVFBhqwZGb1F7qxjAWNVAlgrH++Cwwuza+6XDWw7u8DkRPNbTLAIHM8CX2v0cEqJLbFhzSvUwy66lXkLvlSgSmQT6MRA4+sQLMIRMRtkx7wxmR5TBPhVR4Iuz3AFnaNjpkwLjjbOjZIEnjx4oOSAl6CdP6i+bPkI6fbItqzmXuvb1EGPLZmlyDJbcjR3NH8ra3l+Aokst6t0I/Zep7+9cGbp5GobBQKjvb/c2t3EW9WjLQKjvL0sI3Ss3TKUGQn2P2UiII//fZ83lhXss/zLu3TPUsDbaaY/cu4e1Ye207TXnpOS7x8Jh7bVt7jtubr6Me/f4OazNtr3onJD7yQGXZvD8udHFlWD7S/1sC7+apRSL15EgWcajt+9I6udVLQcG/gbQG3uzCwP8KQG4j0bgnikOv0W76xquXpdsz3MjtcC6FvLHHsRKWXdkUlrdR2Adn7DnY29eeY5R55G55TcgQ25VERTWZUlOVMxMtyJeXf9aDnzv1lMxQXL+3DSjy6s4wr3kYGC9bqIaDB9zY28UlMajjP3K3FJj5FpXK0ZN+XsdNUWAVT+5K+agWj+Vl93rfyOEN68= \ No newline at end of file diff --git a/vignettes/subplot.Rmd b/vignettes/subplot.Rmd new file mode 100644 index 0000000000..72e25739fa --- /dev/null +++ b/vignettes/subplot.Rmd @@ -0,0 +1,149 @@ +--- +title: "The `subplot()` function" +author: "Carson Sievert" +output: + rmarkdown::html_vignette: + toc: true + standalone: false +vignette: > + %\VignetteEngine{knitr::rmarkdown} + %\VignetteIndexEntry{subplot} +--- + +```{r, echo = FALSE} +knitr::opts_chunk$set( + message = FALSE, + warning = FALSE, + comment = "#>", + fig.width = 7 +) +``` + +## Introduction + +The `subplot()` function provides a flexible interface for arranging multiple **plotly** plots in a single view. The simplest way to use it is to pass plotly visualizations directly to `subplot()`. + +```{r} +library(plotly) +p1 <- plot_ly(economics, x = date, y = unemploy, name = "unemploy") +p2 <- plot_ly(economics, x = date, y = uempmed, name = "uempmed") +subplot(p1, p2) +``` + +Although `subplot()` accepts an arbitrary number of plot objects, passing a _list_ of plots can save typing and redundant code when dealing with a large number of plots. To demonstrate, let's create one time series for each variable in the `economics` dataset and share the x-axis so that zoom/pan events are synchronized across each series: + +```{r, fig.height = 5} +vars <- setdiff(names(economics), "date") +plots <- lapply(vars, function(var) { + plot_ly(x = economics$date, y = economics[[var]], name = var) +}) +subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE) +``` + +```{r, echo = FALSE, eval = FALSE} +# this works too, but I'm not sure we should advertise... +elong <- tidyr::gather(economics, variable, value, -date) +elong$id <- as.integer(factor(elong$variable)) +p <- plot_ly(elong, x = date, y = value, group = variable, yaxis = paste0("y", id)) +subplot(p, nrows = 5, shareX = TRUE) +``` + +Conceptually, `subplot()` provides a way to place a collection of plots into a table with a given number of rows and columns. The number of rows (and, by consequence, the number of columns) is specified via the `nrows` argument. By default each row/column shares an equal proportion of the overall height/width, but as shown in the diagram below, that default can be changed via the `heights` and `widths` arguments. + +
+ +
+ +This flexibility is quite useful for a number of visualizations, for example, a joint density plot (the new [heatmaply](https://github.com/talgalili/heatmaply) package is another good example). + +```{r} +x <- rnorm(100) +y <- rnorm(100) +m <- list(color = "black") +s <- subplot( + plot_ly(x = x, type = "histogram", marker = m), + plotly_empty(), + plot_ly(x = x, y = y, mode = "markers", marker = m), + plot_ly(y = y, type = "histogram", marker = m), + nrows = 2, heights = c(0.2, 0.8), widths = c(0.8, 0.2), + shareX = TRUE, shareY = TRUE, titleX = FALSE, titleY = FALSE +) +layout(s, showlegend = FALSE) +``` + +Note that, since `subplot()` returns a plotly object, any [layout attribute](https://plot.ly/r/reference/#layout) can be modified downstream via `layout()`. + +## Recursive subplots + +The `subplot()` function is designed to work recursively so that you can have subplots of subplots. This idea is useful when your desired layout doesn't conform to the table structure described in the previous section. In fact, you can think of a subplot of subplots like a spreadsheet with merged cells. + +
+ +
+ +```{r, fig.height = 5} +plotList <- function(nplots) { + # TODO: use new images infrastructure to overlay an R image on each plot + lapply(seq_len(nplots), function(x) plot_ly()) +} +s1 <- subplot(plotList(6), nrows = 2, shareX = TRUE, shareY = TRUE) +s2 <- subplot(plotList(2), shareY = TRUE) +subplot(s1, s2, plot_ly(), nrows = 3, margin = 0.04, heights = c(0.6, 0.3, 0.1)) +``` + +The concept is particularly useful when you want plot(s) in a given row to have different widths from plot(s) in another row. + +```{r, fig.height = 6} +# specify some map projection/options +g <- list( + scope = 'usa', + projection = list(type = 'albers usa'), + lakecolor = toRGB('white') +) +# create a map of population density +density <- state.x77[, "Population"] / state.x77[, "Area"] +map <- plot_ly( + z = density, + text = state.name, locations = state.abb, + type = 'choropleth', locationmode = 'USA-states', geo = "geo" +) %>% layout(geo = g) +# create a bunch of horizontal bar charts +vars <- colnames(state.x77) +barcharts <- lapply(vars, function(var) { + plot_ly(x = state.x77[, var], y = state.name, type = "bar", + orientation = "h", name = var) %>% + layout(showlegend = FALSE, hovermode = "y", + yaxis = list(showticklabels = FALSE)) +}) +subplot( + subplot(barcharts, margin = 0.01), map, + nrows = 2, heights = c(0.3, 0.7) +) +``` + +## ggplot2 subplots + +The `subplot()` function also understands ggplot2 objects, and converts them to an interactive web-based version via `ggplotly()` before arranging them in the final layout. + +```{r, fig.height = 6} +e <- tidyr::gather(economics, variable, value, -date) +gg1 <- ggplot(e, aes(date, value)) + geom_line() + + facet_wrap(~variable, scales = "free_y", ncol = 1) +gg2 <- ggplot(e, aes(factor(1), value)) + geom_violin() + + facet_wrap(~variable, scales = "free_y", ncol = 1) + + theme(axis.text = element_blank(), axis.ticks = element_blank()) +subplot(gg1, gg2) %>% layout(margin = list(l = 50)) +``` + +This infrastructure allows `ggplotly()` to understand ggmatrix +objects -- the class of object returned by the `ggpairs()` function in the +**GGally** package. + +```{r, fig.height = 5} +pm <- GGally::ggpairs(iris) +ggplotly(pm) +``` + + + + diff --git a/vignettes/subplot.png b/vignettes/subplot.png new file mode 100644 index 0000000000..a51f055472 Binary files /dev/null and b/vignettes/subplot.png differ diff --git a/vignettes/subplot.svg b/vignettes/subplot.svg new file mode 100644 index 0000000000..6acc8168dd --- /dev/null +++ b/vignettes/subplot.svg @@ -0,0 +1,2 @@ + + \ No newline at end of file diff --git a/vignettes/subplot.xml b/vignettes/subplot.xml new file mode 100644 index 0000000000..7e0fb040fb --- /dev/null +++ b/vignettes/subplot.xml @@ -0,0 +1 @@ +zZfPc6sgEMf/Gu9RTGKuTdP00lMOPfOUKPPQdQipSf/6YFz8UW2nU1595JCBLwvsfmABPbLNL3tJy+wFEia8YJFcPPLoBcE62uj/Wrg2QhitGyGVPGkkvxMO/J2huED1zBN2GhgqAKF4ORRjKAoWq4FGpYRqaHYEMZy1pKmZsRMOMRVj9ZUnKkN1uez0Z8bTDGcOF+j3Hxr/TSWcC5zOC8jx/muac2qGQvtTRhOoehLZaaoSQA9cl/LLlomarKHW9Hv6pLV1W7ICXfu6g26qO7xRccbI0S91NSiqjCt2KGlc1yu92h55yFQudM3XRRyAScVw8SecuEvowZ5BzpS8ahPssEQYuFcIVqsO/BqlrMd8hRrFpU7bcbt4dQFDng6fuBC+bwKeP/7QhfjbpJ8/fkxnp7a/b86SGeJfubj/5wSAt5JbCTAngMgawJELsQUBUtcLKLTRv2ASDpGY+7JHpM2bPhLfiDZM8O3iOhM/+i4Us79soJgxnKPy8fjcjKm0APpUjJ0VFPTWOSi+OS/+CxX7Z9UsCUQmztnJBDKJZgXF/q3xO1BGt++YydTlQ34ARVe7T5t7W+/rkexu \ No newline at end of file