Skip to content

Fix the margins of subplots #622

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 2 commits into
base: master
Choose a base branch
from
Open
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
20 changes: 11 additions & 9 deletions R/ggplotly.R
Original file line number Diff line number Diff line change
Expand Up @@ -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(
Expand All @@ -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) {
Expand All @@ -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)) {
Expand Down
53 changes: 26 additions & 27 deletions R/subplots.R
Original file line number Diff line number Diff line change
Expand Up @@ -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) {
Expand Down
64 changes: 7 additions & 57 deletions tests/testthat/test-plotly-subplot.R
Original file line number Diff line number Diff line change
Expand Up @@ -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", {
Expand Down Expand Up @@ -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
)

})