acontext("Panel background") p2 <- ggplot() + geom_point(aes(Petal.Length, Petal.Width, colour = Species), data = iris) + ggtitle("Petal Data") + theme_bw() viz <- list( sepal=ggplot() + geom_point(aes(Sepal.Length, Sepal.Width, colour = Species), data = iris) + theme_grey() + theme(panel.background = element_rect(fill = "lightblue"), panel.border = element_rect(fill = NA, color = "black", size = 2, linetype = "dashed"), panel.margin = grid::unit(0.1, "cm")) + facet_wrap(~Species, nrow = 2), petal=p2, blank=p2 + theme(panel.background = element_blank(), panel.grid.major = element_blank(), panel.grid.minor = element_blank()), gg538=p2 + ## recreating theme_fivethirtyeight from ggthemes package theme(rect = element_rect(fill = "#F0F0F0", colour = NA, size = 0.5, linetype = 0), line = element_line(colour = "#D2D2D2", size = 0.5, linetype = 1, lineend = "butt"), text = element_text(family = "sans", face = "plain", colour = "#3C3C3C", size = 12, hjust = 0.5, vjust = 0.5, angle = 0, lineheight = 0.9, margin = c(0, 0, 0, 0), debug = FALSE), panel.background = element_rect(), panel.grid = element_line(), panel.grid.major = element_line(), panel.grid.minor = element_blank(), complete = T)) info <- animint2HTML(viz) rect.list <- getNodeSet( info$html, '//svg[@id="plot_sepal"]//rect[@class="border_rect"]') expect_equal(length(rect.list), 3) at.mat <- sapply(rect.list, xmlAttrs) test_that("four unique border_rect x values (some horiz space)", { left.vec <- as.numeric(at.mat["x", ]) width.vec <- as.numeric(at.mat["width", ]) right.vec <- left.vec + width.vec x.values <- unique(c(left.vec, right.vec)) expect_equal(length(x.values), 4) }) # extracting html from plots -------------------------------------- # background rectangle for each panel background_sepal <- getNodeSet( info$html, '//svg[@id="plot_sepal"]//rect[@class="background_rect"]') attr_back_sepal <- sapply(background_sepal, xmlAttrs) background_petal <- getNodeSet( info$html, '//svg[@id="plot_petal"]//rect[@class="background_rect"]') attr_back_petal <- sapply(background_petal, xmlAttrs) blank_petal <- getNodeSet( info$html, '//svg[@id="plot_blank"]//rect[@class="background_rect"]') gg538 <- getNodeSet( info$html, '//svg[@id="plot_gg538"]//rect[@class="background_rect"]') attr_gg538 <- sapply(gg538, xmlAttrs) # border rectangle for each panel border_sepal <- getNodeSet( info$html, '//svg[@id="plot_sepal"]//rect[@class="border_rect"]') attr_border_sepal <- sapply(border_sepal, xmlAttrs) border_petal <- getNodeSet( info$html, '//svg[@id="plot_petal"]//rect[@class="border_rect"]') attr_border_petal <- sapply(border_petal, xmlAttrs) # major grid lines grid_major_sepal <- getNodeSet( info$html, '//svg[@id="plot_sepal"]//g[@class="grid_major"]//line') attr_major_sepal <- sapply(grid_major_sepal, xmlAttrs) grid_major_petal <- getNodeSet( info$html, '//svg[@id="plot_petal"]//g[@class="grid_major"]//line') attr_major_petal <- sapply(grid_major_petal, xmlAttrs) grid_major_blank <- getNodeSet( info$html, '//svg[@id="plot_blank"]//g[@class="grid_major"]//line') grid_major_gg538 <- getNodeSet( info$html, '//svg[@id="plot_gg538"]//g[@class="grid_major"]//line') attr_major_gg538 <- sapply(grid_major_gg538, xmlAttrs) # different patterns to access fillPattern <- paste0("fill: ", "(?.*?)", ";") strokePattern <- paste0("stroke: ", "(?.*?)", ";") dasharrayPattern <- paste0("stroke-dasharray:", "(?.*?)", ";") # Testing ----------------------------------- test_that("panel backgrounds render correctly", { # testing that there are the correct number of panels expect_equal(length(background_sepal), 3) expect_equal(length(background_petal), 1) expect_equal(length(blank_petal), 0) # no rectangle for element_blank() expect_equal(length(gg538), 1) # test background fills match_sepal <- str_match_perl(attr_back_sepal["style",], fillPattern) value_sepal <- match_sepal[, "value"] expect_color(value_sepal[1], "lightblue") match_petal <- str_match_perl(attr_back_petal["style",], fillPattern) value_petal <- match_petal[, "value"] expect_color(value_petal[1], "white") match_gg538 <- str_match_perl(attr_gg538["style",], fillPattern) value_gg538 <- match_gg538[, "value"] expect_color(value_gg538[1], "#F0F0F0") }) test_that("panel borders render correctly", { # testing that there are the correct number of panels expect_equal(length(border_sepal), 3) expect_equal(length(border_petal), 1) # test border colors match_sepal <- str_match_perl(attr_border_sepal["style",], strokePattern) value_sepal <- match_sepal[, "value"] expect_color(value_sepal[1], "black") match_petal <- str_match_perl(attr_border_petal["style",], strokePattern) value_petal <- match_petal[, "value"] expect_color(value_petal[1], "grey50") }) test_that("grid lines are drawn correctly", { # correct number of grid lines in both plots expect_equal(length(grid_major_sepal), 30) expect_equal(length(grid_major_petal), 9) expect_equal(length(grid_major_blank), 0) expect_equal(length(grid_major_gg538), 9) # correct color of grid lines match_sepal <- str_match_perl(attr_major_sepal["style",], strokePattern) value_sepal <- match_sepal[, "value"] expect_color(value_sepal[1], "white") match_petal <- str_match_perl(attr_major_petal["style",], strokePattern) value_petal <- match_petal[, "value"] expect_color(value_petal[1], "grey90") match_gg538 <- str_match_perl(attr_major_gg538["style",], strokePattern) value_gg538 <- match_gg538[, "value"] expect_color(value_gg538[1], "#D2D2D2") }) data(tips, package = "reshape2") tips$sex_smoker <- with(tips, interaction(sex, smoker)) ss.viz <- list( p1 = ggplot() + theme(legend.position = "none") + geom_point(data = tips, position = "jitter", aes(x = sex, y = smoker, colour = sex_smoker), clickSelects = "sex_smoker"), p2 = ggplot() + geom_point(data = tips, aes(x = total_bill, y = tip, colour = sex_smoker), showSelected = "sex_smoker") ) test_that("renderer can handle no grid lines", { info <- animint2HTML(ss.viz) # extract grids grid_major_p1 <- getNodeSet( info$html, '//svg[@id="plot_p1"]//g[@class="grid_major"]//line') grid_minor_p1 <- getNodeSet( info$html, '//svg[@id="plot_p1"]//g[@class="grid_minor"]//line') expect_equal(length(grid_major_p1), 4) expect_equal(length(grid_minor_p1), 0) }) test_that("multiple selection sex_smoker plot", { ss.viz$selector.types$sex_smoker <- "multiple" info <- animint2HTML(ss.viz) circle.list <- getNodeSet( info$html, '//svg[@id="plot_p2"]//circle') expect_equal(length(circle.list), nrow(tips)) }) test_that("renderer can handle only one grid line", { info <- animint2HTML(list( petal = p2 + theme( panel.grid.major = element_line(colour="black") )+ scale_y_log10(breaks=1)+ scale_x_log10(breaks=c(2, 4, 6)) )) # extract grids grid_major_hor <- getNodeSet( info$html, '//svg//g[@class="grid_major"]//g[@class="y"]//line') grid_major_vert <- getNodeSet( info$html, '//svg//g[@class="grid_major"]//g[@class="x"]//line') expect_equal(length(grid_major_hor), 1) expect_equal(length(grid_major_vert), 3) }) test_that("no minor grid lines is handed correctly", { data(geyser, package = "MASS") info <- animint2HTML(list( g = ggplot() + theme( panel.grid.minor = element_line(colour="black"))+ geom_point(data = geyser, aes(x = duration, y = waiting)) + geom_contour(data = geyser, aes(x = duration, y = waiting), colour = "blue", size = .5, stat = "density2d") + xlim(0.5, 6) + scale_y_log10(breaks=50) + ggtitle("geom_contour 2d density") )) # extract grids grid_major_hor <- getNodeSet(info$html, '//svg//g[@class="grid_major"]//g[@class="y"]//line') grid_minor_hor <- getNodeSet(info$html, '//svg//g[@class="grid_minor"]//g[@class="y"]//line') expect_equal(length(grid_major_hor), 1) expect_equal(length(grid_minor_hor), 0) })