Merge pull request #526 from ropensci/fix/subplot

Better subplot interface

Author: cpsievert

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"),

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)

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:

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
 
   # ------------------------------------------------------------------------

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)