Fix the margins of subplots

R/ggplotly.R

@@ -535,21 +535,24 @@ gg2list <- function(p, width = NULL, height = NULL,
 
   # panel margins must be computed before panel/axis loops
   # (in order to use get_domains())
-  panelMarginX <- unitConvert(
+  panelMarginL <- 0.5*unitConvert(
     theme[["panel.spacing.x"]] %||% theme[["panel.spacing"]],
     "npc", "width"
   )
-  panelMarginY <- unitConvert(
+  panelMarginR <- panelMarginL
+  panelMarginT <- 0.5*unitConvert(
     theme[["panel.spacing.y"]] %||% theme[["panel.spacing"]],
     "npc", "height"
   )
+  panelMarginB <- panelMarginT
   # space for _interior_ facet strips
   if (inherits(plot$facet, "FacetWrap")) {
     stripSize <- unitConvert(
       theme[["strip.text.x"]] %||% theme[["strip.text"]],
       "npc", "height"
     )
-    panelMarginY <- panelMarginY + stripSize
+    # FIXME add to MarginB if strip position is below?
+    panelMarginT <- panelMarginT + stripSize
     # space for ticks/text in free scales
     if (plot$facet$params$free$x) {
       axisTicksX <- unitConvert(
@@ -560,7 +563,8 @@ gg2list <- function(p, width = NULL, height = NULL,
       axisTextX <- theme[["axis.text.x"]] %||% theme[["axis.text"]]
       labz <- unlist(lapply(layout$panel_params, "[[", "x.labels"))
       lab <- labz[which.max(nchar(labz))]
-      panelMarginY <- panelMarginY + axisTicksX +
+      # FIXME add to MarginT if axis position is above?
+      panelMarginB <- panelMarginB + axisTicksX +
         bbox(lab, axisTextX$angle, unitConvert(axisTextX, "npc", "height"))[["height"]]
     }
     if (plot$facet$params$free$y) {
@@ -572,14 +576,12 @@ gg2list <- function(p, width = NULL, height = NULL,
       axisTextY <- theme[["axis.text.y"]] %||% theme[["axis.text"]]
       labz <- unlist(lapply(layout$panel_params, "[[", "y.labels"))
       lab <- labz[which.max(nchar(labz))]
-      panelMarginX <- panelMarginX + axisTicksY +
+      # FIXME add to MarginR if axis position is on the right?
+      panelMarginL <- panelMarginL + axisTicksY +
         bbox(lab, axisTextY$angle, unitConvert(axisTextY, "npc", "width"))[["width"]]
     }
   }
-  margins <- c(
-    rep(panelMarginX, 2),
-    rep(panelMarginY, 2)
-  )
+  margins <- c(panelMarginL, panelMarginR, panelMarginT, panelMarginB)
   doms <- get_domains(nPanels, nRows, margins)
 
   for (i in seq_len(nPanels)) {

R/subplots.R

@@ -339,37 +339,36 @@ get_domains <- function(nplots = 1, nrows = 1, margins = 0.01,
     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)) {
+  if (sum(margins[1:2]) < 0 || sum(margins[3:4]) < 0) {
+    stop("Subplot margins cannot be negative")
+  }
+  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")
+  total_margins_width <- sum(margins[1:2])*(ncols-1)
+  if (total_margins_width >= 1.0) stop("The total width of margins should be less than 1.0, reduce margin[1:2]")
+  total_margins_height <- sum(margins[3:4])*(nrows-1)
+  if (total_margins_height >= 1.0) stop("The total height of margins should be less than 1.0, reduce margin[3:4]")
+  # if needed, rescale subplot widths and heights to fit in 0..1 range
+  total_width <- sum(widths) + total_margins_width
+  if (total_width > 1.0) {
+    widths <- widths/sum(widths)*(1.0 - total_margins_width)
+    total_width <- 1.0
   }
-
-  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 = widths[i] + if (i == 1) 0 else margins[1],
-      xend = widths[i + 1] - if (i == ncols) 0 else margins[2]
-    )
+  total_height <- sum(heights) + total_margins_height
+  if (total_height > 1.0) {
+    heights <- heights/sum(heights)*(1.0 - total_margins_height)
+    total_height <- 1.0
   }
-  xz <- rep_len(xs, nplots)
-
-  ys <- vector("list", nrows)
-  for (i in seq_len(nplots)) {
-    j <- ceiling(i / ncols)
-    ys[[i]] <- c(
-      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))
+
+  # panel offsets (centered in the whole plot) 
+  xstarts <- c(0, cumsum(widths[-length(widths)]+sum(margins[1:2]))) + (1-total_width)/2
+  ystarts <- c(0, cumsum(heights[-length(heights)]+sum(margins[3:4]))) + (1-total_height)/2
+
+  data.frame(xstart = rep_len(xstarts, nplots),
+             xend = pmin(1.0, rep_len(xstarts+widths, nplots)),
+             ystart = rep(1-ystarts, each=ncols, length.out=nplots),
+             yend = pmax(0.0, rep(1-ystarts-heights, each=ncols, length.out=nplots)))
 }
 
 list2df <- function(x, nms) {

tests/testthat/test-plotly-subplot.R

@@ -80,17 +80,18 @@ 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),
+  hist_top, empty, empty, scatter, empty, hist_right, 
+  nrows = 2, widths = c(0.5, 0.3, 0.2), heights = c(0.4, 0.6),
   margin = 0.005, shareX = TRUE, shareY = TRUE
 )
 
 test_that("Row/column height/width", {
   l <- expect_traces(s, 3, "width-height")
-  expect_equivalent(diff(l$layout$xaxis$domain), 0.8 - 0.005)
-  expect_equivalent(diff(l$layout$xaxis2$domain), 0.2 - 0.005)
-  expect_equivalent(diff(l$layout$yaxis$domain), 0.2 - 0.005)
-  expect_equivalent(diff(l$layout$yaxis2$domain), 0.8 - 0.005)
+  expect_equivalent(diff(l$layout$xaxis$domain), 0.5 - 0.005)
+  expect_equivalent(diff(l$layout$xaxis2$domain), 0.3 - 0.005)
+  expect_equivalent(diff(l$layout$xaxis3$domain), 0.2 - 0.005)
+  expect_equivalent(diff(l$layout$yaxis$domain), 0.4 - 0.005)
+  expect_equivalent(diff(l$layout$yaxis2$domain), 0.6 - 0.005)
 })
 
 test_that("recursive subplots work", {
@@ -170,54 +171,3 @@ test_that("geo+cartesian behaves", {
   expect_equivalent(geoDom$y, c(0, 0.68))
 })
 
-
-
-test_that("May specify legendgroup with through a vector of values", {
-
-  # example adapted from https://github.com/ropensci/plotly/issues/817
-  df <- dplyr::bind_rows(
-    data.frame(x = rnorm(100,2), Name = "x1"),
-    data.frame(x = rnorm(100,6), Name = "x2"),
-    data.frame(x = rnorm(100,4), Name = "x3")
-  )
-  df$y <- rnorm(300)
-
-  # marker definition...
-  m <- list(
-    size = 10, 
-    line = list(
-      width = 1, 
-      color = "black"
-    )
-  )
-
-  base <- plot_ly(
-    df, 
-    marker = m, 
-    color = ~factor(Name), 
-    legendgroup = ~factor(Name)
-  ) 
-
-  s <- subplot(
-    add_histogram(base, x = ~x, showlegend = FALSE),
-    plotly_empty(), 
-    add_markers(base, x = ~x, y = ~y),
-    add_histogram(base, y = ~y, showlegend = FALSE),
-    nrows = 2, heights = c(0.2, 0.8), widths = c(0.8, 0.2), 
-    shareX = TRUE, shareY = TRUE, titleX = FALSE, titleY = FALSE
-  ) %>% layout(barmode = "stack")
-
-  # one trace for the empty plot
-  l <- expect_traces(s, 10, "subplot-legendgroup")
-
-  # really this means show three legend items (one is blank)
-  expect_equivalent(
-    sum(sapply(l$data, function(tr) tr$showlegend %||% TRUE)), 4
-  )
-
-  expect_length(
-    unlist(lapply(l$data, "[[", "legendgroup")), 9
-  )
-
-})
-