add back ability to reference non-existant axis-like objects in trace anchors

Author: cpsievert

R/coord.R

@@ -0,0 +1,66 @@
+#' *** This won't be possible until plotly.js implements aspect ratios... ***
+#' 
+#' #' Force the aspect ratio according to x and y scales
+#' #' 
+#' #' When x and y are numeric variables measured on the same scale,
+#' #' or are related in some meaningful way, forcing the aspect ratio of the
+#' #' plot to be proportional to the ratio of a unit change in x versus y improves
+#' #' our ability to correctly perceive the data.
+#' #' 
+#' #' @param p a plotly object
+#' #' @param ratio aspect ratio, expressed as y / x
+#' #' @export
+#' #' @examples 
+#' #' 
+#' #' canada <- map_data("world", "canada")
+#' #' 
+#' #' canada %>%
+#' #'   group_by(group) %>%
+#' #'   plot_ly(x = ~long, y = ~lat, alpha = 0.2) %>%
+#' #'   add_polygons(hoverinfo = "none", color = I("black")) %>%
+#' #'   coord_fix()
+#' #' 
+#' #' # works on (non-faceted) ggplot2 plots, too
+#' #' gg <- ggplot(canada, aes(long, lat, group = group)) + 
+#' #'   geom_polygon() + coord_fixed()
+#' #' 
+#' #' gg %>%
+#' #'   ggplotly() %>%
+#' #'   coord_fix()
+#' #'   
+#' 
+#' coord_fix <- function(p, ratio = 1) {
+#'   p <- plotly_build(p)
+#'   # this won't work for subplots, or categorical data
+#'   x <- grepl("^xaxis", names(p$x$layout))
+#'   y <- grepl("^yaxis", names(p$x$layout))
+#'   if (sum(x) > 1 || sum(y) > 1) {
+#'     stop("Can not impose aspect ratio a plot with more than one x/y axis", call. = FALSE)
+#'   }
+#'   xDat <- unlist(lapply(p$x$data, "[[", "x"))
+#'   yDat <- unlist(lapply(p$x$data, "[[", "y"))
+#'   if (!is.numeric(xDat) || !is.numeric(yDat)) {
+#'     stop("Must have numeric data on both x and y axes to enforce aspect ratios", call. = FALSE)
+#'   }
+#'   
+#'   # warn about any pre-populated domains, they will get squashed
+#'   xDom <- p$x$layout[["xaxis"]]$domain %||% c(0, 1)
+#'   yDom <- p$x$layout[["yaxis"]]$domain %||% c(0, 1)
+#'   if (!identical(yDom, c(0, 1)) || !identical(xDom, c(0, 1))) {
+#'     warning(
+#'       "coord_fix() won't respect prespecified axis domains (other than the default)",
+#'       call. = FALSE
+#'     )
+#'   }
+#'   
+#'   xRng <- range(xDat, na.rm = TRUE)
+#'   yRng <- range(yDat, na.rm = TRUE)
+#'   asp <- ratio * diff(yRng) / diff(xRng)
+#'   if (asp < 1) {
+#'     p$x$layout[["yaxis"]]$domain <- c(0 + asp / 2, 1 - asp / 2)
+#'   } else {
+#'     asp <- 1 / asp
+#'     p$x$layout[["xaxis"]]$domain <- c(0 + asp / 2, 1 - asp / 2)
+#'   }
+#'   p
+#' }

R/subplots.R

@@ -50,7 +50,40 @@ subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, margin = 0.02
     dotz <- dotz[[1]]
   }
   # build each plot
-  plots <- lapply(dotz, function(d) plotly_build(d)[["x"]])
+  plotz <- lapply(dotz, function(d) plotly_build(d)[["x"]])
+  
+  # Are any traces referencing "axislike" 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("mapbox", "geo", "xaxis", "yaxis"))
+    xTraceAttrs <- sub("^x", "xaxis", sapply(p$data, function(tr) tr[["subplot"]] %||% tr[["geo"]] %||% tr[["xaxis"]]))
+    yTraceAttrs <- sub("^y", "yaxis", sapply(p$data, function(tr) tr[["subplot"]] %||% 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("mapbox", "geo", "xaxis", "yaxis")) {
+          tr[[k]] <- sub("[0-9]+", "", tr[[k]]) %||% NULL
+        }
+        tr
+      })
+      plots <- c(plots, list(newPlot))
+    }
+  }
 
   # grab main plot objects
   traces <- lapply(plots, "[[", "data")

R/utils.R

@@ -109,8 +109,7 @@ supply_defaults <- function(p) {
   p$x$data <- lapply(p$x$data, function(tr) {
     for (i in seq_along(anchors)) {
       nm <- names(anchors)[[i]]
-      
-      tr[[nm]] <- unique(tr[[nm]]) %||% anchors[[i]]
+      tr[[nm]] <- sub("^y1$", "y", sub("^x1$", "x", tr[[nm]][1])) %||% anchors[[i]]
     }
     tr
   })

tests/testthat/test-plotly-subplot.R

@@ -83,7 +83,7 @@ s <- subplot(
 )
 
 test_that("Row/column height/width", {
-  l <- expect_traces(s, 4, "width-height")
+  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)