safeguard against missing values in subplot; ggplotly is now generic with ggmatrix/ggplot methods

Author: cpsievert

NAMESPACE

@@ -11,6 +11,8 @@ S3method(geom2trace,GeomPolygon)
 S3method(geom2trace,GeomText)
 S3method(geom2trace,GeomTile)
 S3method(geom2trace,default)
+S3method(ggplotly,ggmatrix)
+S3method(ggplotly,ggplot)
 S3method(print,figure)
 S3method(print,plotly)
 S3method(to_basic,GeomAbline)

R/ggplotly.R

@@ -32,6 +32,25 @@
 #'
 ggplotly <- function(p = ggplot2::last_plot(), width = NULL, height = NULL,
                      tooltip = "all", source = "A") {
+  UseMethod("ggplotly")
+}
+
+#' @export
+ggplotly.ggmatrix <- function(p = ggplot2::last_plot(), width = NULL,
+                              height = NULL, tooltip = "all", source = "A") {
+  plotList <- list()
+  for (i in seq_len(p$nrow)) {
+    for (j in seq_len(p$ncol)) {
+      plotList <- c(plotList, list(pm[i, j]))
+    }
+  }
+  # TODO: how to show x/y titles? Should these be arguments in subplot?
+  do.call(subplot, c(plotList, list(nrows = p$nrow)))
+}
+  
+#' @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)
 }
@@ -428,10 +447,12 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
 
     } # 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 (has_facet(p)) {
       col_vars <- ifelse(inherits(p$facet, "wrap"), "facets", "cols")
@@ -461,25 +482,7 @@ gg2list <- function(p, width = NULL, height = NULL, tooltip = "all", source = "A
         strip <- make_strip_rect(xdom, ydom, theme, "right")
         gglayout$shapes <- c(gglayout$shapes, strip)
       }
-      
-      
-      
     }
-
-
-    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")
-      
-      
-      
-    }
-    if (inherits(p$facet, "grid") && lay$COL == nCols && nRows > 1 &&
-        !is_blank(theme[["strip.text.y"]])) {
-      
-      
-    }
-
   } # end of panel loop
 
   # ------------------------------------------------------------------------

R/plotly.R

@@ -232,9 +232,10 @@ style <- function(p = last_plot(), ..., traces = 1, evaluate = FALSE) {
 #' @param l a ggplot object, or a plotly object, or a list.
 #' @export
 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))
+  # ggplot objects (including ggmatrix) don't need any special type of handling
+  if (inherits(l, "gg")) {
+    return(structure(get_plot(ggplotly(l)), class = "plotly"))
+  }
   l <- get_plot(l)
   # assume unnamed list elements are data/traces
   nms <- names(l)

R/subplots.R

@@ -31,19 +31,16 @@ subplot <- function(..., nrows = 1, which_layout = "merge", margin = 0.02) {
     axes <- vapply(x$annotations, function(a) identical(a$annotationType, "axis"), logical(1))
     x$annotations[!axes]
   })
-  # collect axis objects, and remove their titles
+  # collect axis objects
   xAxes <- lapply(layouts, function(x) {
-    xaxis <- x[grepl("^xaxis", names(x))] %||% 
-      list(xaxis = list(domain = c(0, 1), anchor = "y"))
-    xaxis$title <- NULL
-    xaxis
+    x[grepl("^xaxis", names(x))] %||% list(xaxis = list(domain = c(0, 1), anchor = "y"))
   })
   yAxes <- lapply(layouts, function(x) {
-    yaxis <- x[grepl("^yaxis", names(x))] %||%  
-      list(yaxis = list(domain = c(0, 1), anchor = "x"))
-    yaxis$title <- NULL
-    yaxis
+    x[grepl("^yaxis", names(x))] %||% list(yaxis = list(domain = c(0, 1), anchor = "x"))
   })
+  # remove their titles
+  xAxes <- lapply(xAxes, function(x) lapply(x, function(y) { y$title <- NULL; y }))
+  yAxes <- lapply(yAxes, function(x) lapply(x, 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))
@@ -74,25 +71,27 @@ subplot <- function(..., nrows = 1, which_layout = "merge", margin = 0.02) {
     for (j in seq_along(xAxes[[i]])) {
       # before bumping axis anchor, bump trace info, where appropriate
       traces[[i]] <- lapply(traces[[i]], function(tr) {
+        tr$xaxis <- tr$xaxis %||% "x"
         tr$xaxis[sub("axis", "", xMap[[j]]) %in% tr$xaxis] <- sub("axis", "", names(xMap[j]))
         tr
       })
       # bump anchors
-      map <- yMap[yMap %in% sub("y", "yaxis", xAxes[[i]][[j]]$anchor)]
+      map <- yMap[yMap %in% sub("y", "yaxis", xAxes[[i]][[j]]$anchor %||% "y")]
       xAxes[[i]][[j]]$anchor <- sub("axis", "", names(map))
       xAxes[[i]][[j]]$domain <- sort(scales::rescale(
-        xAxes[[i]][[j]]$domain, xDom, from = c(0, 1)
+        xAxes[[i]][[j]]$domain %||% c(0, 1), xDom, from = c(0, 1)
       ))
     }
     for (j in seq_along(yAxes[[i]])) {
       traces[[i]] <- lapply(traces[[i]], function(tr) {
+        tr$yaxis <- tr$yaxis %||% "y"
         tr$yaxis[sub("axis", "", yMap[[j]]) %in% tr$yaxis] <- sub("axis", "", names(yMap[j]))
         tr
       })
-      map <- xMap[xMap %in% sub("x", "xaxis", yAxes[[i]][[j]]$anchor)]
+      map <- xMap[xMap %in% sub("x", "xaxis", yAxes[[i]][[j]]$anchor %||% "x")]
       yAxes[[i]][[j]]$anchor <- sub("axis", "", names(map))
       yAxes[[i]][[j]]$domain <- sort(scales::rescale(
-        yAxes[[i]][[j]]$domain, yDom, from = c(0, 1)
+        yAxes[[i]][[j]]$domain %||% c(0, 1), yDom, from = c(0, 1)
       ))
     }
     xAxes[[i]] <- setNames(xAxes[[i]], names(xMap))

tests/testthat/test-plotly-subplot.R

@@ -44,6 +44,3 @@ test_that("group + [x/y]axis works", {
   expect_true(all(2/3 > xdom[[2]] & xdom[[2]] > 1/3))
   expect_true(all(1 >= xdom[[3]] & xdom[[3]] > 2/3))
 })
-
-
-