expect_traces <- function(p, n.traces, name){ stopifnot(is.numeric(n.traces)) L <- expect_doppelganger_built(p, paste0("plotly-", name)) expect_equivalent(length(L$data), n.traces) L } # expect 2 plotly graphs to have the same traces expect_same_data <- function(p1, p2) { if (!is.plotly(p1) || !is.plotly(p2)) { stop("Both arguments must be plotly objects", call. = FALSE) } d1 <- plotly_build(p1)$x$data d2 <- plotly_build(p2)$x$data if (length(d1) != length(d2)) { stop("Number of traces is different.", call. = FALSE) } # for each trace, align the names (since ordering doesn't matter) d1 <- Map(function(x, y) structure(x[names(y)], class = oldClass(x)), d1, d2) expect_identical(d1, d2) } test_that("vector values with repeated values are returned verbatim", { p <- plot_ly(x = c(1, 2), y = c(1, 1)) l <- plotly_build(p)$x expect_equivalent(l$data[[1]]$x, c(1, 2)) expect_equivalent(l$data[[1]]$y, c(1, 1)) }) test_that("plot_ly defaults to scatterplot", { p1 <- plot_ly(mtcars, x = ~wt, y = ~mpg) p2 <- plot_ly(mtcars, x = ~wt, y = ~mpg) %>% add_markers() expect_same_data(p1, p2) }) test_that("Variable mappings return same result regardless of where they appear", { p1 <- plot_ly(mtcars, x = ~wt, y = ~mpg, size = ~disp) p2 <- plot_ly(mtcars, x = ~wt, y = ~mpg) %>% add_markers(size = ~disp) expect_same_data(p1, p2) p1 <- plot_ly(mtcars, x = ~wt, y = ~mpg, color = ~disp) p2 <- plot_ly(mtcars, x = ~wt, y = ~mpg) %>% add_markers(color = ~disp) expect_same_data(p1, p2) p1 <- plot_ly(mtcars, x = ~wt, y = ~mpg, symbol = ~factor(am)) p2 <- plot_ly(mtcars, x = ~wt, y = ~mpg) %>% add_markers(symbol = ~factor(am)) expect_same_data(p1, p2) p1 <- plot_ly(mtcars, x = ~wt, y = ~mpg, linetype = ~factor(am)) p2 <- plot_ly(mtcars, x = ~wt, y = ~mpg) %>% add_markers(linetype = ~factor(am)) expect_message(plotly_build(p1), "Adding lines to mode") expect_message(plotly_build(p2), "Adding lines to mode") expect_same_data(p1, p2) }) test_that("plot_ly() handles a simple scatterplot", { d <- palmerpenguins::penguins %>% filter(!is.na(bill_length_mm)) p <- plot_ly(data = d, x = ~bill_length_mm, y = ~bill_depth_mm, mode = "markers") l <- expect_traces(p, 1, "scatterplot") expect_equivalent(l$data[[1]]$mode, "markers") expect_equivalent(l$data[[1]]$x, na.omit(palmerpenguins::penguins$bill_length_mm)) expect_equivalent(l$data[[1]]$y, na.omit(palmerpenguins::penguins$bill_depth_mm)) expect_true(l$layout$xaxis$title == "bill_length_mm") expect_true(l$layout$yaxis$title == "bill_depth_mm") expect_true(l$layout$xaxis$automargin) expect_true(l$layout$yaxis$automargin) }) test_that("type inference + add_data + layering works as expected", { p <- plot_ly(palmerpenguins::penguins, x = ~species) %>% add_trace(opacity = 0.3) %>% add_data(palmerpenguins::penguins[sample(nrow(palmerpenguins::penguins), 10), ]) %>% add_trace() %>% layout(barmode = "overlay") l <- expect_traces(p, 2, "bar-inference") types <- unique(unlist(lapply(l$data, "[[", "type"))) expect_equivalent(types, "histogram") expect_equivalent(l$data[[1]]$opacity, 0.3) expect_equivalent(l$layout$barmode, "overlay") expect_true(length(l$data[[1]]$x) > length(l$data[[2]]$x)) }) test_that("x/y/z properties have a class of AsIs", { p <- plot_ly(x = 1, y = 1, z = 1, type = "scatter3d") l <- expect_traces(p, 1, "box-data-array") tr <- l$data[[1]] expect_true(inherits(tr$x, "AsIs")) expect_true(inherits(tr$y, "AsIs")) expect_true(inherits(tr$z, "AsIs")) }) test_that("grouping within multiples traces works", { g <- expand.grid(visit = 1:2, id = 1:3, cohort = c("A", "B")) g$response <- rnorm(nrow(g)) d <- group_by(g, id) p <- plot_ly(d, x = ~visit, y = ~response, color = ~cohort, colors = c("red", "blue")) l <- expect_traces(add_lines(p), 2, "group-within-trace") expect_equivalent(l$data[[1]]$x, c(1, 2, NA, 1, 2, NA, 1, 2)) expect_equivalent(l$data[[2]]$x, c(1, 2, NA, 1, 2, NA, 1, 2)) expect_true(l$data[[1]]$line$color == toRGB("red")) expect_true(l$data[[2]]$line$color == toRGB("blue")) }) test_that("Alpha can be applied to both constant and scaled colors", { p <- plot_ly(x = rnorm(100), y = rnorm(100), color = ~rnorm(100)) p <- add_markers(p, alpha = 0.05) p <- add_lines(p, x = -1:1, y = -1:1, color = I("red"), alpha = 0.4) # one trace for the colorbar l <- expect_traces(p, 3, "alpha-blending") # verify the correct alpha for the points rgbs <- l$data[[1]]$marker$colorscale[, 2] alphas <- unique(sub("\\)", "", sapply(strsplit(rgbs, ","), "[[", 4))) expect_equivalent("0.05", alphas) # verify the correct alpha for the lines rgb <- l$data[[2]]$line$color alpha <- sub("\\)", "", sapply(strsplit(rgb, ","), "[[", 4)) expect_equivalent("0.4", alpha) }) test_that("Alpha still applies when no color is applied", { p <- plot_ly(mtcars, x = ~mpg, y = ~disp, alpha = 0.5) l <- expect_traces(p, 1, "alpha-no-color") # verify the correct alpha for the points expect_true(l$data[[1]]$marker$color == "rgba(31,119,180,0.5)") }) test_that("Factors correctly mapped to a positional axis", { x <- factor(c(1, 2, 4, 8, 16, 32)) p <- plot_ly(x = x, y = c(1, 2, 3, 4, 5, 6)) %>% add_markers() l <- expect_traces(p, 1, "factor-axis") expect_equivalent(l$layout$xaxis$type, "category") expect_equivalent(l$layout$xaxis$categoryorder, "array") expect_equivalent(l$layout$xaxis$categoryarray, levels(x)) }) test_that("Character strings correctly mapped to a positional axis", { # scramble alphabet order letters <- LETTERS[as.numeric(sort(as.character(1:26)))] p <- plot_ly(x = letters, y = seq_along(letters)) %>% add_bars(color = rep(c("a1", "a2"), length.out = 26)) l <- expect_warning(expect_traces(p, 2, "character-axis"), regexp = "minimal value for n is 3") expect_equivalent(l$layout$xaxis$type, "category") expect_equivalent(l$layout$xaxis$categoryorder, "array") expect_equivalent(l$layout$xaxis$categoryarray, LETTERS) }) test_that("Histogram", { p <- plot_ly(x = rnorm(100)) l <- expect_traces(p, 1, "histogram") o <- unlist(lapply(l$data, "[[", "orientation")) types <- unlist(lapply(l$data, "[[", "type")) expect_null(o) expect_equivalent(unique(types), "histogram") }) test_that("Discrete variable mapped to x creates horizontal bar chart", { p <- plot_ly(y = rnorm(100)) l <- expect_traces(p, 1, "histogram-vert") o <- unlist(lapply(l$data, "[[", "orientation")) types <- unlist(lapply(l$data, "[[", "type")) expect_equivalent(unique(o), "h") expect_equivalent(unique(types), "histogram") }) test_that("Can avoid inheriting attributes", { p <- plot_ly(mtcars, x = ~wt, y = ~mpg, color = I("red")) %>% add_histogram(x = ~factor(vs), inherit = FALSE) l <- expect_traces(p, 1, "inherit-FALSE") expect_equivalent(l$data[[1]][["type"]], "histogram") expect_equivalent(l$data[[1]][["x"]], factor(mtcars[["vs"]])) expect_null(l$data[[1]][["y"]]) expect_true(l$data[[1]][["marker"]][["color"]] != toRGB("red")) }) test_that("Complex example works", { # note how median (the variable) doesn't exist in the second layer p <- txhousing %>% plot_ly(x = ~date, y = ~median) %>% group_by(city) %>% add_lines(alpha = 0.2, name = "Texan Cities", hoverinfo = "none") %>% group_by(date) %>% summarise( q1 = quantile(median, 0.25, na.rm = TRUE), m = median(median, na.rm = TRUE), q3 = quantile(median, 0.75, na.rm = TRUE) ) %>% add_lines(y = ~m, color = I("red"), name = "median") %>% add_ribbons(ymin = ~q1, ymax = ~q3, color = I("red"), name = "IQR") l <- expect_traces(p, 3, "time-series-summary") }) test_that("span/size controls errorbar thickness/width", { p <- plot_ly(x = 1:10, y = 1:10, error_x = list(value = 3), error_y = list(value = 2), span = I(5), size = I(10), stroke = I("black"), color = I("red")) %>% plotly_build() expect_doppelganger_built(p, "errorbar.width") d <- p$x$data expect_length(d, 1) expect_true(d[[1]]$error_x$value == 3) expect_true(d[[1]]$error_x$thickness == 5) expect_true(d[[1]]$error_x$width == 10) expect_true(d[[1]]$error_x$color == toRGB("red")) expect_true(d[[1]]$error_y$value == 2) expect_true(d[[1]]$error_y$thickness == 5) expect_true(d[[1]]$error_y$width == 10) expect_true(d[[1]]$error_y$color == toRGB("red")) }) test_that("Vector of redundant text is reduced to string when hoveron=fills", { # see https://github.com/ropensci/plotly/issues/1233 d <- data.frame( AA = c(2,3,3,2, NA, 6,7,7,6, NA), BB = c(2,2,3,2, NA, 6,6,7,6, NA), CC = c(rep('abc', 5), rep('xyz', 5)), LL = c(rep('A', 5), rep('B', 5)) ) p <- plot_ly(d) %>% add_trace(x = ~AA, y = ~BB, text = ~paste('
Example of custom hover text
', LL, '
', CC, '
.'), split = ~LL, mode = "lines", fill = "toself", hoveron = 'fills', type = "scatter", color = I(c(rep(toRGB("black", 1), 5), rep(toRGB("red", 1), 5))) ) b <- plotly_build(p) d <- b$x$data expect_length(d, 2) expect_true(d[[1]]$line$color == toRGB("black")) expect_true(d[[1]]$fillcolor == toRGB("black", 0.5)) expect_true(d[[2]]$line$color == toRGB("red")) expect_true(d[[2]]$fillcolor == toRGB("red", 0.5)) expect_true( d[[1]]$text == '
Example of custom hover text
A
abc
.' ) expect_true( d[[2]]$text == '
Example of custom hover text
B
xyz
.' ) }) test_that("Can map data to legendgroup", { d <- data.frame( x = 1:100, y = runif(100), group = letters[1:5] ) l <- plot_ly(data = d, x = ~x, y = ~y) %>% add_bars(color = ~group, legendgroup = ~group) %>% add_markers(color = ~group, legendgroup = ~group) %>% plotly_build() expect_length(l$x$data, 10) markers <- compact(lapply(l$x$data, function(tr) if (tr$type == "scatter") tr)) for (i in seq_along(markers)) { expect_length(markers[[i]]$legendgroup, 1) expect_true(markers[[i]]$legendgroup == letters[[i]]) } bars <- compact(lapply(l$x$data, function(tr) if (tr$type == "bar") tr)) for (i in seq_along(bars)) { expect_length(bars[[i]]$legendgroup, 1) expect_true(bars[[i]]$legendgroup == letters[[i]]) } }) test_that("Axis domains aren't supplied if layout.grid exists", { p <- plot_ly(type = 'scatter',mode = 'lines', y = c(5,1,3), xaxis = 'x', yaxis = 'y') %>% add_trace(y = c(2,1,5), xaxis = 'x2', yaxis = 'y2') %>% add_trace(y = c(2,1,5), xaxis = 'x3', yaxis = 'y3')%>% add_trace(y = c(2,1,5), xaxis = 'x4', yaxis = 'y4')%>% add_trace(y = c(2,1,5), xaxis = 'x5', yaxis = 'y5')%>% add_trace(y = c(2,1,5), xaxis = 'x6', yaxis = 'y6')%>% layout(grid = list(rows = 2, columns = 3, pattern ='independent')) l <- expect_doppelganger_built(p, "layout-grid") expect_null(l$layout$xaxis$domain) expect_null(l$layout$yaxis$domain) }) test_that("Informative deprecation message for titlefont", { expect_warning(config(plot_ly(), cloud = TRUE), "cloud") }) test_that("Informative warning for invalid config attr", { p <- config(plot_ly(), foobar = TRUE) expect_warning(plotly_build(p), "foobar") }) test_that("Informative deprecation message for titlefont", { p <- layout(plot_ly(), title = "A title", titlefont = list(size = 30)) expect_warning(plotly_build(p), "titlefont") }) test_that("toWebGL() shouldn't complain if it's already webgl", { p <- plot_ly(x = 1, y = 1) %>% add_trace(type = "scattergl", mode = "markers") %>% toWebGL() expect_silent(plotly_build(p)) }) test_that("Line breaks are properly translated (R -> HTML)", { # create target labels suffix <- "\n\n(third line)\n(fourth line)" d <- palmerpenguins::penguins %>% filter(!is.na(bill_length_mm)) target_labels <- d$species %>% unique() %>% sort() %>% paste0(suffix) %>% gsub(pattern = "\n", replacement = br(), x = ., fixed = TRUE) # test factor column levels(d$species) <- paste0(levels(d$species), suffix) p1 <- d %>% plot_ly(x = ~bill_length_mm, y = ~species) expect_equivalent(plotly_build(p1)[["x"]][["layout"]][["yaxis"]][["categoryarray"]], target_labels) # test character column p2 <- d %>% dplyr::mutate(species = as.character(species)) %>% plot_ly(x = ~bill_length_mm, y = ~species) expect_equivalent(plotly_build(p2)[["x"]][["layout"]][["yaxis"]][["categoryarray"]], target_labels) }) test_that("group_by() on a plotly object doesn't produce warning", { expect_warning(group_by(plot_ly(txhousing), city), NA) })