tests/testthat/test-plotly-subplot.R
In ropensci/plotly: Create Interactive Web Graphics via 'plotly.js'
expect_traces <- function(p, n.traces, name){
stopifnot(is.numeric(n.traces))
L <- expect_doppelganger_built(p, paste0("plotly-subplot-", name))
expect_equivalent(length(L$data), n.traces)
L
}
test_that("simple subplot works", {
p1 <- plot_ly(x = c(1, 2))
p2 <- plot_ly(x = c(1, 2))
s <- expect_traces(subplot(p1, p2), 2, "simple")
expect_identical(s$data[[2]]$xaxis, s$layout[["yaxis2"]][["anchor"]])
expect_identical(s$data[[2]]$yaxis, s$layout[["xaxis2"]][["anchor"]])
doms <- lapply(s$layout[grepl("^xaxis", names(s$layout))], "[[", "domain")
expect_true(doms$xaxis[2] <= doms$xaxis2[1])
})
test_that("nrows argument works", {
p1 <- plot_ly(x = c(1, 2))
p2 <- plot_ly(x = c(1, 2))
s <- expect_traces(subplot(p1, p2, nrows = 2), 2, "simple2")
expect_identical(s$data[[2]]$xaxis, s$layout[["yaxis2"]][["anchor"]])
expect_identical(s$data[[2]]$yaxis, s$layout[["xaxis2"]][["anchor"]])
doms <- lapply(s$layout[grepl("^[x-y]axis", names(s$layout))], "[[", "domain")
expect_true(doms$yaxis[2] > doms$yaxis[1])
expect_true(doms$yaxis[1] > doms$yaxis2[2])
expect_true(doms$yaxis2[2] > doms$yaxis2[1])
})
test_that("group + [x/y]axis works", {
penguins <- palmerpenguins::penguins %>% tidyr::drop_na() %>% arrange(species)
p <- plot_ly(penguins, x = ~bill_length_mm, y = ~bill_depth_mm, color = ~species,
xaxis = ~paste0("x", as.integer(species)), mode = "markers")
s <- expect_traces(subplot(p, margin = 0.05), 3, "group")
ax <- s$layout[grepl("^[x-y]axis", names(s$layout))]
doms <- lapply(ax, "[[", "domain")
# make sure y domain is [0, 1] on every axis
ydom <- doms[grepl("^y", names(doms))]
expect_equivalent(sort(unique(unlist(ydom))), c(0, 1))
xdom <- doms[grepl("^x", names(doms))]
expect_true(all(1/3 > xdom[[1]] & xdom[[1]] >= 0))
expect_true(all(2/3 > xdom[[2]] & xdom[[2]] > 1/3))
expect_true(all(1 >= xdom[[3]] & xdom[[3]] > 2/3))
})
test_that("shareX produces one x-axis and a legend", {
s <- subplot(plot_ly(x = 1), plot_ly(x = 1), nrows = 2, shareX = TRUE)
l <- expect_traces(s, 2, "shareX")
expect_true(sum(grepl("^xaxis", names(l$layout))) == 1)
expect_true(l$data[[1]]$showlegend %||% TRUE)
expect_true(l$data[[2]]$showlegend %||% TRUE)
expect_true(l$layout$showlegend %||% TRUE)
})
test_that("shareY produces one y-axis", {
s <- subplot(plot_ly(x = 1), plot_ly(x = 1), shareY = TRUE)
l <- expect_traces(s, 2, "shareY")
expect_true(sum(grepl("^yaxis", names(l$layout))) == 1)
})
test_that("share both axes", {
s <- subplot(
plot_ly(x = 1), plot_ly(x = 1), plot_ly(x = 1), plot_ly(x = 1),
nrows = 2, shareX = TRUE, shareY = TRUE
)
l <- expect_traces(s, 4, "shareBoth")
expect_true(sum(grepl("^yaxis", names(l$layout))) == 2)
expect_true(sum(grepl("^xaxis", names(l$layout))) == 2)
})
# https://github.com/ropensci/plotly/issues/376
d <- data.frame(
x = rnorm(100),
y = rnorm(100)
)
hist_top <- ggplot(d) + geom_histogram(aes(x = x))
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),
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)
})
test_that("recursive subplots work", {
p1 <- plot_ly(economics, x = ~date, y = ~unemploy)
p2 <- plot_ly(economics, x = ~date, y = ~uempmed)
s1 <- subplot(p1, p1, shareY = TRUE)
s2 <- subplot(p2, p2, shareY = TRUE)
s <- subplot(s1, s2, nrows = 2, shareX = TRUE)
l <- expect_traces(s, 4, "recursive")
xaxes <- l$layout[grepl("^xaxis", names(l$layout))]
yaxes <- l$layout[grepl("^yaxis", names(l$layout))]
expect_true(length(xaxes) == 2)
expect_true(length(yaxes) == 2)
# both x-axes are anchored on the same y-axis
yanchor <- unique(unlist(lapply(xaxes, "[[", "anchor")))
expect_true(length(yanchor) == 1)
# both y-axes are anchored on the same x-axis
xanchor <- unique(unlist(lapply(yaxes, "[[", "anchor")))
expect_true(length(xanchor) == 1)
# x/y are anchored on the bottom/left
expect_true(l$layout[[sub("x", "xaxis", xanchor)]]$domain[1] == 0)
expect_true(l$layout[[sub("y", "yaxis", yanchor)]]$domain[1] == 0)
# every trace is anchored on a different x/y axis pair
xTraceAnchors <- sapply(l$data, "[[", "xaxis")
yTraceAnchors <- sapply(l$data, "[[", "yaxis")
expect_true(length(unique(paste(xTraceAnchors, yTraceAnchors))) == 4)
})
test_that("subplot accepts a list of plots", {
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(x = economics$date, y = economics[[var]], name = var)
})
s <- subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE)
l <- expect_traces(s, 5, "plot-list")
xaxes <- l$layout[grepl("^xaxis", names(l$layout))]
yaxes <- l$layout[grepl("^yaxis", names(l$layout))]
expect_true(length(xaxes) == 1)
expect_true(length(yaxes) == 5)
# x-axis is anchored at the bottom
expect_true(l$layout[[sub("y", "yaxis", xaxes[[1]]$anchor)]]$domain[1] == 0)
})
test_that("ggplotly understands GGally", {
skip_if_not_installed("GGally")
expect_doppelganger(
GGally::ggpairs(iris),
"plotly-subplot-ggmatrix"
)
d <- tibble::tibble(
v1 = 1:100 + rnorm(100, sd = 20),
v2 = 1:100 + rnorm(100, sd = 27),
v3 = rep(1, 100) + rnorm(100, sd = 1),
v4 = v1 ** 2,
v5 = v1 ** 2
)
expect_doppelganger(
GGally::ggcorr(d, method = c("everything", "pearson")),
"ggally-ggcorr"
)
})
test_that("annotation paper repositioning", {
p1 <- plot_ly(type = "scatter") %>%
add_annotations(text = "foo", x = 0.5, y = 0.5, xref = "paper", yref = "paper")
p2 <- plot_ly(mtcars, type = "scatter") %>%
add_annotations(text = "bar", x = 0.5, y = 0.5, xref = "paper", yref = "paper")
s <- subplot(p1, p2, margin = 0)
ann <- expect_doppelganger_built(s, "subplot-reposition-annotation")$layout$annotations
expect_length(ann, 2)
text <- sapply(ann, "[[", "text")
x <- sapply(ann, "[[", "x")
y <- sapply(ann, "[[", "y")
xref <- sapply(ann, "[[", "xref")
yref <- sapply(ann, "[[", "yref")
expect_equal(x, c(0.25, 0.75))
expect_equal(y, c(0.5, 0.5))
expect_equal(xref, rep("paper", 2))
expect_equal(yref, rep("paper", 2))
})
test_that("shape paper repositioning", {
p1 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "rect",
x0 = 0.25,
x1 = 0.75,
y0 = 0.25,
y1 = 0.75,
xref = "paper",
yref = "paper",
fillcolor = "red"
)
)
p2 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "line",
type = "rect",
x0 = 0.25,
x1 = 0.75,
y0 = 0.25,
y1 = 0.75,
xref = "paper",
yref = "paper",
line = list(color = "blue")
)
)
s <- subplot(p1, p2)
shapes <- expect_doppelganger_built(s, "subplot-reposition-shape")$layout$shapes
expect_length(shapes, 2)
x0 <- sapply(shapes, "[[", "x0")
x1 <- sapply(shapes, "[[", "x1")
y0 <- sapply(shapes, "[[", "y0")
y1 <- sapply(shapes, "[[", "y1")
xref <- sapply(shapes, "[[", "xref")
yref <- sapply(shapes, "[[", "yref")
expect_equal(x0, c(0.12, 0.64))
expect_equal(x1, c(0.36, 0.88))
expect_equal(y0, rep(0.25, 2))
expect_equal(y1, rep(0.75, 2))
expect_equal(xref, rep("paper", 2))
expect_equal(yref, rep("paper", 2))
# now with a fixed height/width
p1 <- plot_ly(type = "scatter") %>%
layout(
shapes = list(
type = "rect",
x0 = 0.25,
x1 = 0.75,
xref = "paper",
y0 = 0,
y1 = 30,
yanchor = 0.5,
ysizemode = "pixel",
yref = "paper",
fillcolor = "red"
)
)
p2 <- plot_ly(type = "scatter") %>%
layout(
shapes = list(
type = "rect",
y0 = 0.25,
y1 = 0.75,
yref = "paper",
x0 = 0,
x1 = 30,
xanchor = 0.5,
xsizemode = "pixel",
xref = "paper",
line = list(color = "blue")
)
)
s <- subplot(p1, p2)
shapes <- expect_doppelganger_built(s, "subplot-reposition-shape-fixed")$layout$shapes
expect_length(shapes, 2)
xanchor <- lapply(shapes, "[[", "xanchor")[[2]]
yanchor <- lapply(shapes, "[[", "yanchor")[[1]]
x0 <- sapply(shapes, "[[", "x0")
x1 <- sapply(shapes, "[[", "x1")
y0 <- sapply(shapes, "[[", "y0")
y1 <- sapply(shapes, "[[", "y1")
expect_equal(xanchor, 0.76)
expect_equal(yanchor, 0.5)
expect_equal(x0, c(0.12, 0))
expect_equal(x1, c(0.36, 30))
expect_equal(y0, c(0, 0.25))
expect_equal(y1, c(30, 0.75))
})
test_that("raster2uri supports nativeRaster objects", {
skip_if_not_installed("png")
r <- as.raster(matrix(c("black", "red", "green", "blue"), ncol = 4L))
nr <- structure(
c(-16777216L, -16776961L, -16711936L, -65536L),
dim = c(1L, 4L),
class = "nativeRaster",
channels = 4L
)
uri_r <- raster2uri(r)
uri_nr <- raster2uri(nr)
expect_equal(uri_r, uri_nr)
})
test_that("image paper repositioning", {
skip_if_not_installed("png")
r <- as.raster(matrix(hcl(0, 80, seq(50, 80, 10)), nrow = 4, ncol = 5))
# embed the raster as an image
p <- plot_ly(x = 1, y = 1) %>%
layout(
images = list(list(
source = raster2uri(r),
sizing = "fill",
xref = "paper",
yref = "paper",
x = 0,
y = 0,
sizex = 0.5,
sizey = 0.5,
xanchor = "left",
yanchor = "bottom"
))
)
s <- subplot(p, p, nrows = 1, margin = 0.02)
imgs <- expect_doppelganger_built(s, "subplot-reposition-image")$layout$images
expect_length(imgs, 2)
x <- sapply(imgs, "[[", "x")
y <- sapply(imgs, "[[", "y")
sizex <- sapply(imgs, "[[", "sizex")
sizey <- sapply(imgs, "[[", "sizey")
expect_equal(x, c(0, 0.52))
expect_equal(y, c(0, 0))
expect_equal(sizex, rep(0.24, 2))
expect_equal(sizey, rep(0.5, 2))
})
test_that("annotation xref/yref bumping", {
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 <- expect_doppelganger_built(s, "subplot-bump-axis-annotation")$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 <- expect_doppelganger_built(s2, "subplot-bump-axis-annotation-shared")$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))
# now, with more traces than annotations
# https://github.com/ropensci/plotly/issues/1444
p1 <- plot_ly() %>%
add_markers(x = 1, y = 1) %>%
add_markers(x = 2, y = 2) %>%
add_annotations(text = "foo", x = 1.5, y = 1.5)
p2 <- plot_ly() %>%
add_markers(x = 1, y = 1) %>%
add_markers(x = 2, y = 2) %>%
add_annotations(text = "bar", x = 1.5, y = 1.5)
s <- subplot(p1, p2)
ann <- expect_doppelganger_built(s, "subplot-bump-axis-annotation-traces")$layout$annotations
txt <- sapply(ann, "[[", "text")
xref <- sapply(ann, "[[", "xref")
yref <- sapply(ann, "[[", "yref")
expect_length(ann, 2)
expect_equal(txt, c("foo", "bar"))
expect_equal(xref, c("x", "x2"))
expect_equal(yref, c("y", "y2"))
s2 <- subplot(p1, p2, shareY = TRUE)
ann2 <- expect_doppelganger_built(s2, "subplot-bump-axis-annotation-traces-shared")$layout$annotations
xref2 <- sapply(ann2, "[[", "xref")
yref2 <- sapply(ann2, "[[", "yref")
expect_equal(xref2, c("x", "x2"))
expect_equal(yref2, c("y", "y"))
})
test_that("shape xref/yref bumping", {
p1 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "rect",
x0 = min(cyl),
x1 = max(cyl),
y0 = min(am),
y1 = max(am),
fillcolor = "red"
)
)
p2 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "line",
x0 = min(cyl),
x1 = max(cyl),
y0 = min(am),
y1 = max(am),
line = list(color = "blue")
)
)
s <- subplot(p1, p2)
shapes <- expect_doppelganger_built(s, "subplot-bump-axis-shape")$layout$shapes
expect_length(shapes, 2)
types <- sapply(shapes, "[[", "type")
expect_equal(types, c("rect", "line"))
xref <- sapply(shapes, "[[", "xref")
yref <- sapply(shapes, "[[", "yref")
expect_equal(xref, c("x", "x2"))
expect_equal(yref, c("y", "y2"))
s2 <- subplot(p1, p2, shareY = TRUE)
shapes2 <- expect_doppelganger_built(s2, "subplot-bump-axis-shape-shared")$layout$shapes
xref2 <- sapply(shapes2, "[[", "xref")
yref2 <- sapply(shapes2, "[[", "yref")
expect_equal(xref2, c("x", "x2"))
expect_equal(yref2, c("y", "y"))
})
test_that("image xref/yref bumping", {
skip_if_not_installed("png")
r <- as.raster(matrix(hcl(0, 80, seq(50, 80, 10)), nrow = 4, ncol = 5))
# embed the raster as an image
p <- plot_ly(x = 1, y = 1) %>%
layout(
images = list(list(
source = raster2uri(r),
sizing = "fill",
xref = "x",
yref = "y",
x = 0,
y = 0,
sizex = 1,
sizey = 1,
xanchor = "left",
yanchor = "bottom"
))
)
s <- subplot(p, p, nrows = 1, margin = 0.02)
imgs <- expect_doppelganger_built(s, "subplot-bump-axis-image")$layout$images
expect_length(imgs, 2)
x <- sapply(imgs, "[[", "x")
y <- sapply(imgs, "[[", "y")
xref <- sapply(imgs, "[[", "xref")
yref <- sapply(imgs, "[[", "yref")
expect_equal(x, c(0, 0))
expect_equal(y, c(0, 0))
expect_equal(xref, c("x", "x2"))
expect_equal(yref, c("y", "y2"))
})
test_that("geo+cartesian behaves", {
# specify some map projection/options
g <- list(
scope = 'usa',
projection = list(type = 'albers usa'),
lakecolor = toRGB('white')
)
# create a map of population density
density <- state.x77[, "Population"] / state.x77[, "Area"]
map <- plot_geo(
z = ~density, text = state.name,
locations = state.abb, locationmode = 'USA-states'
) %>% layout(geo = g)
# create a bunch of horizontal bar charts
vars <- colnames(state.x77)
barcharts <- lapply(vars, function(var) {
plot_ly(x = state.x77[, var], y = state.name, type = "bar",
orientation = "h", name = var) %>%
layout(showlegend = FALSE, hovermode = "y",
yaxis = list(showticklabels = FALSE))
})
s <- subplot(
subplot(barcharts, margin = 0.01), map,
nrows = 2, heights = c(0.3, 0.7)
)
l <- expect_traces(s, 9, "geo-cartesian")
geoDom <- l$layout[[grep("^geo", names(l$layout))]]$domain
expect_equivalent(geoDom$x, c(0, 1))
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)
)
expect_warning(
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"),
regexp = "No trace type|No scatter mode"
)
# 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
)
})
ropensci/plotly documentation built on Jan. 25, 2024, 6:09 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
expect_traces <- function(p, n.traces, name){
stopifnot(is.numeric(n.traces))
L <- expect_doppelganger_built(p, paste0("plotly-subplot-", name))
expect_equivalent(length(L$data), n.traces)
L
}
test_that("simple subplot works", {
p1 <- plot_ly(x = c(1, 2))
p2 <- plot_ly(x = c(1, 2))
s <- expect_traces(subplot(p1, p2), 2, "simple")
expect_identical(s$data[[2]]$xaxis, s$layout[["yaxis2"]][["anchor"]])
expect_identical(s$data[[2]]$yaxis, s$layout[["xaxis2"]][["anchor"]])
doms <- lapply(s$layout[grepl("^xaxis", names(s$layout))], "[[", "domain")
expect_true(doms$xaxis[2] <= doms$xaxis2[1])
})
test_that("nrows argument works", {
p1 <- plot_ly(x = c(1, 2))
p2 <- plot_ly(x = c(1, 2))
s <- expect_traces(subplot(p1, p2, nrows = 2), 2, "simple2")
expect_identical(s$data[[2]]$xaxis, s$layout[["yaxis2"]][["anchor"]])
expect_identical(s$data[[2]]$yaxis, s$layout[["xaxis2"]][["anchor"]])
doms <- lapply(s$layout[grepl("^[x-y]axis", names(s$layout))], "[[", "domain")
expect_true(doms$yaxis[2] > doms$yaxis[1])
expect_true(doms$yaxis[1] > doms$yaxis2[2])
expect_true(doms$yaxis2[2] > doms$yaxis2[1])
})
test_that("group + [x/y]axis works", {
penguins <- palmerpenguins::penguins %>% tidyr::drop_na() %>% arrange(species)
p <- plot_ly(penguins, x = ~bill_length_mm, y = ~bill_depth_mm, color = ~species,
xaxis = ~paste0("x", as.integer(species)), mode = "markers")
s <- expect_traces(subplot(p, margin = 0.05), 3, "group")
ax <- s$layout[grepl("^[x-y]axis", names(s$layout))]
doms <- lapply(ax, "[[", "domain")
# make sure y domain is [0, 1] on every axis
ydom <- doms[grepl("^y", names(doms))]
expect_equivalent(sort(unique(unlist(ydom))), c(0, 1))
xdom <- doms[grepl("^x", names(doms))]
expect_true(all(1/3 > xdom[[1]] & xdom[[1]] >= 0))
expect_true(all(2/3 > xdom[[2]] & xdom[[2]] > 1/3))
expect_true(all(1 >= xdom[[3]] & xdom[[3]] > 2/3))
})
test_that("shareX produces one x-axis and a legend", {
s <- subplot(plot_ly(x = 1), plot_ly(x = 1), nrows = 2, shareX = TRUE)
l <- expect_traces(s, 2, "shareX")
expect_true(sum(grepl("^xaxis", names(l$layout))) == 1)
expect_true(l$data[[1]]$showlegend %||% TRUE)
expect_true(l$data[[2]]$showlegend %||% TRUE)
expect_true(l$layout$showlegend %||% TRUE)
})
test_that("shareY produces one y-axis", {
s <- subplot(plot_ly(x = 1), plot_ly(x = 1), shareY = TRUE)
l <- expect_traces(s, 2, "shareY")
expect_true(sum(grepl("^yaxis", names(l$layout))) == 1)
})
test_that("share both axes", {
s <- subplot(
plot_ly(x = 1), plot_ly(x = 1), plot_ly(x = 1), plot_ly(x = 1),
nrows = 2, shareX = TRUE, shareY = TRUE
)
l <- expect_traces(s, 4, "shareBoth")
expect_true(sum(grepl("^yaxis", names(l$layout))) == 2)
expect_true(sum(grepl("^xaxis", names(l$layout))) == 2)
})
# https://github.com/ropensci/plotly/issues/376
d <- data.frame(
x = rnorm(100),
y = rnorm(100)
)
hist_top <- ggplot(d) + geom_histogram(aes(x = x))
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),
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)
})
test_that("recursive subplots work", {
p1 <- plot_ly(economics, x = ~date, y = ~unemploy)
p2 <- plot_ly(economics, x = ~date, y = ~uempmed)
s1 <- subplot(p1, p1, shareY = TRUE)
s2 <- subplot(p2, p2, shareY = TRUE)
s <- subplot(s1, s2, nrows = 2, shareX = TRUE)
l <- expect_traces(s, 4, "recursive")
xaxes <- l$layout[grepl("^xaxis", names(l$layout))]
yaxes <- l$layout[grepl("^yaxis", names(l$layout))]
expect_true(length(xaxes) == 2)
expect_true(length(yaxes) == 2)
# both x-axes are anchored on the same y-axis
yanchor <- unique(unlist(lapply(xaxes, "[[", "anchor")))
expect_true(length(yanchor) == 1)
# both y-axes are anchored on the same x-axis
xanchor <- unique(unlist(lapply(yaxes, "[[", "anchor")))
expect_true(length(xanchor) == 1)
# x/y are anchored on the bottom/left
expect_true(l$layout[[sub("x", "xaxis", xanchor)]]$domain[1] == 0)
expect_true(l$layout[[sub("y", "yaxis", yanchor)]]$domain[1] == 0)
# every trace is anchored on a different x/y axis pair
xTraceAnchors <- sapply(l$data, "[[", "xaxis")
yTraceAnchors <- sapply(l$data, "[[", "yaxis")
expect_true(length(unique(paste(xTraceAnchors, yTraceAnchors))) == 4)
})
test_that("subplot accepts a list of plots", {
vars <- setdiff(names(economics), "date")
plots <- lapply(vars, function(var) {
plot_ly(x = economics$date, y = economics[[var]], name = var)
})
s <- subplot(plots, nrows = length(plots), shareX = TRUE, titleX = FALSE)
l <- expect_traces(s, 5, "plot-list")
xaxes <- l$layout[grepl("^xaxis", names(l$layout))]
yaxes <- l$layout[grepl("^yaxis", names(l$layout))]
expect_true(length(xaxes) == 1)
expect_true(length(yaxes) == 5)
# x-axis is anchored at the bottom
expect_true(l$layout[[sub("y", "yaxis", xaxes[[1]]$anchor)]]$domain[1] == 0)
})
test_that("ggplotly understands GGally", {
skip_if_not_installed("GGally")
expect_doppelganger(
GGally::ggpairs(iris),
"plotly-subplot-ggmatrix"
)
d <- tibble::tibble(
v1 = 1:100 + rnorm(100, sd = 20),
v2 = 1:100 + rnorm(100, sd = 27),
v3 = rep(1, 100) + rnorm(100, sd = 1),
v4 = v1 ** 2,
v5 = v1 ** 2
)
expect_doppelganger(
GGally::ggcorr(d, method = c("everything", "pearson")),
"ggally-ggcorr"
)
})
test_that("annotation paper repositioning", {
p1 <- plot_ly(type = "scatter") %>%
add_annotations(text = "foo", x = 0.5, y = 0.5, xref = "paper", yref = "paper")
p2 <- plot_ly(mtcars, type = "scatter") %>%
add_annotations(text = "bar", x = 0.5, y = 0.5, xref = "paper", yref = "paper")
s <- subplot(p1, p2, margin = 0)
ann <- expect_doppelganger_built(s, "subplot-reposition-annotation")$layout$annotations
expect_length(ann, 2)
text <- sapply(ann, "[[", "text")
x <- sapply(ann, "[[", "x")
y <- sapply(ann, "[[", "y")
xref <- sapply(ann, "[[", "xref")
yref <- sapply(ann, "[[", "yref")
expect_equal(x, c(0.25, 0.75))
expect_equal(y, c(0.5, 0.5))
expect_equal(xref, rep("paper", 2))
expect_equal(yref, rep("paper", 2))
})
test_that("shape paper repositioning", {
p1 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "rect",
x0 = 0.25,
x1 = 0.75,
y0 = 0.25,
y1 = 0.75,
xref = "paper",
yref = "paper",
fillcolor = "red"
)
)
p2 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "line",
type = "rect",
x0 = 0.25,
x1 = 0.75,
y0 = 0.25,
y1 = 0.75,
xref = "paper",
yref = "paper",
line = list(color = "blue")
)
)
s <- subplot(p1, p2)
shapes <- expect_doppelganger_built(s, "subplot-reposition-shape")$layout$shapes
expect_length(shapes, 2)
x0 <- sapply(shapes, "[[", "x0")
x1 <- sapply(shapes, "[[", "x1")
y0 <- sapply(shapes, "[[", "y0")
y1 <- sapply(shapes, "[[", "y1")
xref <- sapply(shapes, "[[", "xref")
yref <- sapply(shapes, "[[", "yref")
expect_equal(x0, c(0.12, 0.64))
expect_equal(x1, c(0.36, 0.88))
expect_equal(y0, rep(0.25, 2))
expect_equal(y1, rep(0.75, 2))
expect_equal(xref, rep("paper", 2))
expect_equal(yref, rep("paper", 2))
# now with a fixed height/width
p1 <- plot_ly(type = "scatter") %>%
layout(
shapes = list(
type = "rect",
x0 = 0.25,
x1 = 0.75,
xref = "paper",
y0 = 0,
y1 = 30,
yanchor = 0.5,
ysizemode = "pixel",
yref = "paper",
fillcolor = "red"
)
)
p2 <- plot_ly(type = "scatter") %>%
layout(
shapes = list(
type = "rect",
y0 = 0.25,
y1 = 0.75,
yref = "paper",
x0 = 0,
x1 = 30,
xanchor = 0.5,
xsizemode = "pixel",
xref = "paper",
line = list(color = "blue")
)
)
s <- subplot(p1, p2)
shapes <- expect_doppelganger_built(s, "subplot-reposition-shape-fixed")$layout$shapes
expect_length(shapes, 2)
xanchor <- lapply(shapes, "[[", "xanchor")[[2]]
yanchor <- lapply(shapes, "[[", "yanchor")[[1]]
x0 <- sapply(shapes, "[[", "x0")
x1 <- sapply(shapes, "[[", "x1")
y0 <- sapply(shapes, "[[", "y0")
y1 <- sapply(shapes, "[[", "y1")
expect_equal(xanchor, 0.76)
expect_equal(yanchor, 0.5)
expect_equal(x0, c(0.12, 0))
expect_equal(x1, c(0.36, 30))
expect_equal(y0, c(0, 0.25))
expect_equal(y1, c(30, 0.75))
})
test_that("raster2uri supports nativeRaster objects", {
skip_if_not_installed("png")
r <- as.raster(matrix(c("black", "red", "green", "blue"), ncol = 4L))
nr <- structure(
c(-16777216L, -16776961L, -16711936L, -65536L),
dim = c(1L, 4L),
class = "nativeRaster",
channels = 4L
)
uri_r <- raster2uri(r)
uri_nr <- raster2uri(nr)
expect_equal(uri_r, uri_nr)
})
test_that("image paper repositioning", {
skip_if_not_installed("png")
r <- as.raster(matrix(hcl(0, 80, seq(50, 80, 10)), nrow = 4, ncol = 5))
# embed the raster as an image
p <- plot_ly(x = 1, y = 1) %>%
layout(
images = list(list(
source = raster2uri(r),
sizing = "fill",
xref = "paper",
yref = "paper",
x = 0,
y = 0,
sizex = 0.5,
sizey = 0.5,
xanchor = "left",
yanchor = "bottom"
))
)
s <- subplot(p, p, nrows = 1, margin = 0.02)
imgs <- expect_doppelganger_built(s, "subplot-reposition-image")$layout$images
expect_length(imgs, 2)
x <- sapply(imgs, "[[", "x")
y <- sapply(imgs, "[[", "y")
sizex <- sapply(imgs, "[[", "sizex")
sizey <- sapply(imgs, "[[", "sizey")
expect_equal(x, c(0, 0.52))
expect_equal(y, c(0, 0))
expect_equal(sizex, rep(0.24, 2))
expect_equal(sizey, rep(0.5, 2))
})
test_that("annotation xref/yref bumping", {
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 <- expect_doppelganger_built(s, "subplot-bump-axis-annotation")$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 <- expect_doppelganger_built(s2, "subplot-bump-axis-annotation-shared")$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))
# now, with more traces than annotations
# https://github.com/ropensci/plotly/issues/1444
p1 <- plot_ly() %>%
add_markers(x = 1, y = 1) %>%
add_markers(x = 2, y = 2) %>%
add_annotations(text = "foo", x = 1.5, y = 1.5)
p2 <- plot_ly() %>%
add_markers(x = 1, y = 1) %>%
add_markers(x = 2, y = 2) %>%
add_annotations(text = "bar", x = 1.5, y = 1.5)
s <- subplot(p1, p2)
ann <- expect_doppelganger_built(s, "subplot-bump-axis-annotation-traces")$layout$annotations
txt <- sapply(ann, "[[", "text")
xref <- sapply(ann, "[[", "xref")
yref <- sapply(ann, "[[", "yref")
expect_length(ann, 2)
expect_equal(txt, c("foo", "bar"))
expect_equal(xref, c("x", "x2"))
expect_equal(yref, c("y", "y2"))
s2 <- subplot(p1, p2, shareY = TRUE)
ann2 <- expect_doppelganger_built(s2, "subplot-bump-axis-annotation-traces-shared")$layout$annotations
xref2 <- sapply(ann2, "[[", "xref")
yref2 <- sapply(ann2, "[[", "yref")
expect_equal(xref2, c("x", "x2"))
expect_equal(yref2, c("y", "y"))
})
test_that("shape xref/yref bumping", {
p1 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "rect",
x0 = min(cyl),
x1 = max(cyl),
y0 = min(am),
y1 = max(am),
fillcolor = "red"
)
)
p2 <- plot_ly(mtcars, type = "scatter") %>%
layout(
shapes = ~list(
type = "line",
x0 = min(cyl),
x1 = max(cyl),
y0 = min(am),
y1 = max(am),
line = list(color = "blue")
)
)
s <- subplot(p1, p2)
shapes <- expect_doppelganger_built(s, "subplot-bump-axis-shape")$layout$shapes
expect_length(shapes, 2)
types <- sapply(shapes, "[[", "type")
expect_equal(types, c("rect", "line"))
xref <- sapply(shapes, "[[", "xref")
yref <- sapply(shapes, "[[", "yref")
expect_equal(xref, c("x", "x2"))
expect_equal(yref, c("y", "y2"))
s2 <- subplot(p1, p2, shareY = TRUE)
shapes2 <- expect_doppelganger_built(s2, "subplot-bump-axis-shape-shared")$layout$shapes
xref2 <- sapply(shapes2, "[[", "xref")
yref2 <- sapply(shapes2, "[[", "yref")
expect_equal(xref2, c("x", "x2"))
expect_equal(yref2, c("y", "y"))
})
test_that("image xref/yref bumping", {
skip_if_not_installed("png")
r <- as.raster(matrix(hcl(0, 80, seq(50, 80, 10)), nrow = 4, ncol = 5))
# embed the raster as an image
p <- plot_ly(x = 1, y = 1) %>%
layout(
images = list(list(
source = raster2uri(r),
sizing = "fill",
xref = "x",
yref = "y",
x = 0,
y = 0,
sizex = 1,
sizey = 1,
xanchor = "left",
yanchor = "bottom"
))
)
s <- subplot(p, p, nrows = 1, margin = 0.02)
imgs <- expect_doppelganger_built(s, "subplot-bump-axis-image")$layout$images
expect_length(imgs, 2)
x <- sapply(imgs, "[[", "x")
y <- sapply(imgs, "[[", "y")
xref <- sapply(imgs, "[[", "xref")
yref <- sapply(imgs, "[[", "yref")
expect_equal(x, c(0, 0))
expect_equal(y, c(0, 0))
expect_equal(xref, c("x", "x2"))
expect_equal(yref, c("y", "y2"))
})
test_that("geo+cartesian behaves", {
# specify some map projection/options
g <- list(
scope = 'usa',
projection = list(type = 'albers usa'),
lakecolor = toRGB('white')
)
# create a map of population density
density <- state.x77[, "Population"] / state.x77[, "Area"]
map <- plot_geo(
z = ~density, text = state.name,
locations = state.abb, locationmode = 'USA-states'
) %>% layout(geo = g)
# create a bunch of horizontal bar charts
vars <- colnames(state.x77)
barcharts <- lapply(vars, function(var) {
plot_ly(x = state.x77[, var], y = state.name, type = "bar",
orientation = "h", name = var) %>%
layout(showlegend = FALSE, hovermode = "y",
yaxis = list(showticklabels = FALSE))
})
s <- subplot(
subplot(barcharts, margin = 0.01), map,
nrows = 2, heights = c(0.3, 0.7)
)
l <- expect_traces(s, 9, "geo-cartesian")
geoDom <- l$layout[[grep("^geo", names(l$layout))]]$domain
expect_equivalent(geoDom$x, c(0, 1))
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)
)
expect_warning(
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"),
regexp = "No trace type|No scatter mode"
)
# 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
)
})
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.