subplot() now bumps annotation xref/yref correctly, fixes #1181

Author: cpsievert

R/subplots.R

@@ -214,7 +214,11 @@ subplot <- function(..., nrows = 1, widths = NULL, heights = NULL, margin = 0.02
       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)
+      annAnchor <- list(xaxis = "xref", yaxis = "yref")[[key]]
+      if (is.null(annAnchor)) next
+      annotations[[i]] <- Map(function(ann, a) { ann[[annAnchor]] <- a; ann}, annotations[[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")])
@@ -391,14 +395,16 @@ reposition <- function(obj, domains) {
     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")) {
+    xs <- if (identical(o$xref, "paper")) c("x", "x0", "x1")
+    for (j in xs) {
       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")) {
+    ys <- if (identical(o$xref, "paper")) c("y", "y0", "y1")
+    for (j in ys) {
       if (is.numeric(o[[j]])) {
         obj[[i]][[j]] <- scales::rescale(
           o[[j]], as.numeric(domains[c("yend", "ystart")]), from = c(0, 1)

tests/testthat/test-plotly-subplot.R

@@ -135,9 +135,38 @@ test_that("subplot accepts a list of plots", {
 })
 
 # Ignore for now https://github.com/ggobi/ggally/issues/264
-#test_that("ggplotly understands ggmatrix", {
-#  L <- save_outputs(GGally::ggpairs(iris), "plotly-subplot-ggmatrix")
-#})
+test_that("ggplotly understands ggmatrix", {
+  L <- save_outputs(GGally::ggpairs(iris), "plotly-subplot-ggmatrix")
+})
+
+test_that("annotation xref/yref are bumped correctly", {
+  
+  p1 <- plot_ly(mtcars) %>%
+    add_annotations(text = ~cyl, x = ~wt, y = ~mpg)
+  p2 <- plot_ly(mtcars) %>%
+    add_annotations(text = ~am, x = ~wt, y = ~mpg)
+  s <- subplot(p1, p2)
+  ann <- plotly_build(s)$x$layout$annotations
+  
+  txt <- sapply(ann, "[[", "text")
+  xref <- sapply(ann, "[[", "xref")
+  yref <- sapply(ann, "[[", "yref")
+  
+  expect_length(ann, 64)
+  expect_equal(txt, c(mtcars$cyl, mtcars$am))
+  expect_equal(xref, rep(c("x", "x2"), each = 32))
+  expect_equal(yref, rep(c("y", "y2"), each = 32))
+  
+  s2 <- subplot(p1, p2, shareY = TRUE)
+  ann2 <- plotly_build(s2)$x$layout$annotations
+  
+  xref2 <- sapply(ann2, "[[", "xref")
+  yref2 <- sapply(ann2, "[[", "yref")
+  expect_equal(xref2, rep(c("x", "x2"), each = 32))
+  expect_equal(yref2, rep(c("y", "y"), each = 32))
+})
+
+
 
 test_that("geo+cartesian behaves", {
   # specify some map projection/options