From 3b44409c3e4349de514fe9e0ba29e3b76537962c Mon Sep 17 00:00:00 2001 From: Alexey Stukalov Date: Wed, 26 Jul 2017 14:52:27 +0000 Subject: [PATCH 1/2] update subplot layout - don't subtract the margins from the subplots width/height as both margins are subtracted from the inner subplots and only one margin from the outer ones, so the proportions are broken - automatically scale widths/heights to fit into 0..1 when summed with the margins - update subplot margins tests to the new logic (+ include the tests for inner subplots dimensions) --- R/subplots.R | 53 +++++++++++------------ tests/testthat/test-plotly-subplot.R | 64 +++------------------------- 2 files changed, 33 insertions(+), 84 deletions(-) diff --git a/R/subplots.R b/R/subplots.R index b855af0a75..b9cf0c218a 100644 --- a/R/subplots.R +++ b/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) { diff --git a/tests/testthat/test-plotly-subplot.R b/tests/testthat/test-plotly-subplot.R index fb07db2573..d66beb02b4 100644 --- a/tests/testthat/test-plotly-subplot.R +++ b/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 - ) - -}) - From 6bf2dd2e71aac885381ef5253f9293cabf27f377 Mon Sep 17 00:00:00 2001 From: Alexey Stukalov Date: Wed, 26 Jul 2017 14:59:52 +0000 Subject: [PATCH 2/2] ggplotly: fix margin calculation - add space for the title and axis only to one of the L/R or T/B margins - add panel.space/2 to each margin side, not panel.space --- R/ggplotly.R | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/R/ggplotly.R b/R/ggplotly.R index 86e9c4dbd8..d66ee65cb3 100644 --- a/R/ggplotly.R +++ b/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)) {