test-renderer1-panels.R

acontext("Panel background")

p1 <- a_plot() +
  a_geom_point(a_aes(Sepal.Length, Sepal.Width,
                 colour = Species, size = Species), data = iris) +
  a_theme_grey() + 
  a_theme(panel.background = a_element_rect(fill = "lightblue"),
        panel.border = a_element_rect(fill = NA,
                                    color = "black",
                                    size = 2,
                                    linetype = "dashed"),
        panel.margin = grid::unit(0.1, "cm")) +
  a_facet_wrap(~Species, nrow = 2)
p2 <- a_plot() +
  a_geom_point(a_aes(Petal.Length, Petal.Width,
                 colour = Species, size = Species), data = iris) +
  ggtitle("Petal Data") +
  a_theme_bw()
p3 <- p2 + 
  a_theme(panel.background = a_element_blank(), 
        panel.grid.major = a_element_blank(), 
        panel.grid.minor = a_element_blank())
p4 <- p2 + 
  ## recreating a_theme_fivethirtyeight from gga_themes package
  a_theme(rect = a_element_rect(fill = "#F0F0F0", colour = NA,
                            size = 0.5, linetype = 0),
        line = a_element_line(colour = "#D2D2D2", size = 0.5, linetype = 1,
                            lineend = "butt"),
        text = a_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 = a_element_rect(), 
        panel.grid = a_element_line(), 
        panel.grid.major = a_element_line(), 
        panel.grid.minor = a_element_blank(), 
        complete = T)

info <- animint2HTML(list(sepal = p1, petal = p2, blank = p3, gg538 = p4))

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)

# minor grid lines
grid_minor_sepal <- getNodeSet(
  info$html, '//svg[@id="plot_sepal"]//g[@class="grid_minor"]//line')

grid_minor_petal <- getNodeSet(
  info$html, '//svg[@id="plot_petal"]//g[@class="grid_minor"]//line')

grid_minor_blank <- getNodeSet(
  info$html, '//svg[@id="plot_blank"]//g[@class="grid_minor"]//line')

# different patterns to access
fillPattern <- paste0("fill: ",
                      "(?<value>.*?)",
                      ";")
strokePattern <- paste0("stroke: ",
                        "(?<value>.*?)",
                        ";")
dasharrayPattern <- paste0("stroke-dasharray:",
                           "(?<value>.*?)",
                           ";")

# 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 a_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_minor_sepal), 27)
  expect_equal(length(grid_minor_petal), 9)
  expect_equal(length(grid_major_blank), 0)
  expect_equal(length(grid_minor_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 = a_plot() + a_theme(legend.a_position = "none") +
    a_geom_point(data = tips, a_position = "jitter", 
               a_aes(x = sex, y = smoker, colour = sex_smoker),
               clickSelects = "sex_smoker"), 
  p2 = a_plot() +
    a_geom_point(data = tips,
               a_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 + a_scale_y_log10()
  ))
  # extract grids
  grid_minor_hor <- getNodeSet(info$html, '//svg//g[@class="grid_minor"]//g[@class="hor"]//line')
  grid_minor_vert <- getNodeSet(info$html, '//svg//g[@class="grid_minor"]//g[@class="vert"]//line')
  expect_equal(length(grid_minor_hor), 1)
  expect_equal(length(grid_minor_vert), 4)
})

test_that("no minor grid lines is handed correctly", {
  data(geyser, package = "MASS")
  info <- animint2HTML(list(
    g = a_plot() +  
      a_geom_point(data = geyser, 
                 a_aes(x = duration, y = waiting)) + 
      a_geom_contour(data = geyser, 
                   a_aes(x = duration, y = waiting), 
                   colour = "blue", size = .5, a_stat = "density2d") + 
      xlim(0.5, 6) + a_scale_y_log10(limits = c(40,110)) +
      ggtitle("a_geom_contour 2d density")
  ))
  # extract grids
  grid_major_hor <- getNodeSet(info$html, '//svg//g[@class="grid_major"]//g[@class="hor"]//line')
  grid_minor_hor <- getNodeSet(info$html, '//svg//g[@class="grid_minor"]//g[@class="hor"]//line')
  expect_equal(length(grid_major_hor), 1)
  expect_equal(length(grid_minor_hor), 0)
})