tests/testthat/test-renderer3-update-axes-multiple-ss.R

In animint2: Animated Interactive Grammar of Graphics

acontext("update_axes - multiple single selectors")

## Test for appropriate warnings
set.seed(123)

# Empty domains in axis updates -> generate warning
data_f1 <- data.frame(a=runif(30, 1, 30), b=sample(1:30))
data_f1$ss1 <- as.factor(1:3)
data_f1$ss2 <- as.factor(c("alpha", "beta"))
data_f1$ss3 <- as.factor(c("A", "A", "B"))
# factors "1" & "2" are never paired with factor "B"
# factor "3" is never paired with factor "A"
plot1 <- ggplot() + geom_point(aes(a,b),
                               showSelected=c("ss1","ss2","ss3"),
                               data = data_f1) +
  theme_animint(update_axes=c("x"))
viz <- list(p=plot1)

viz$selector.types <- list(ss1="single", ss2="single", ss3="single")
expect_warning(animint2HTML(viz),
               "some data subsets have no data to plot")

# Only a single unique value in domains for axis updates -> generate warning
data_f2 <- data.frame(a=runif(6, 1, 6), b=sample(1:6))
data_f2$ss1 <- as.factor(1:3)
data_f2$ss2 <- as.factor(c("alpha", "beta"))
# Each factor interaction only possesses a single value
plot2 <- ggplot() + geom_point(aes(a,b),
                               showSelected=c("ss1", "ss2"),
                               data = data_f2) +
  theme_animint(update_axes=c("x"))
viz <- list(p=plot2)

viz$selector.types <- list(ss1="single", ss2="single")
expect_warning(animint2HTML(viz),
               "some data subsets have only a single data value to plot")

# Axes updates for more than one single selectors -> no warnings
data_f3 <- data.frame(a=runif(60, 1, 60), b=sample(1:60))
data_f3$ss1 <- as.factor(1:3)
data_f3$ss2 <- as.factor(c("alpha", "beta"))
plot3 <- ggplot() + geom_point(aes(a,b, colour=ss1),
                               showSelected="ss2",
                               data = data_f3)
  
viz <- list(p=plot3 + theme_animint(update_axes=c("x")))

viz$selector.types <- list(ss1="single", ss2="single")
expect_no_warning(animint2HTML(viz))

## --------------------------------------------------------------------- ##
## Tests for axis updates for more than one showSelected vars

# Plots with axis updates
no_updates <- plot3

update_x <- no_updates+
  theme_animint(update_axes=c("x"))
update_y <- no_updates+
  theme_animint(update_axes=c("y"))
update_xy <- no_updates+
  theme_animint(update_axes=c("x","y"))

viz <- (list(neither=no_updates, 
             x=update_x, 
             y=update_y, 
             both=update_xy))

viz$selector.types <- list(ss1="single", ss2="single")
viz$time = list(variable="ss2", ms=5000)

info <- animint2HTML(viz)

# Update selection and get HTML
clickID(c("plot_neither_ss1_variable_3"))
Sys.sleep(1)
info$html_updated1 <- getHTML()

# Let the gear variable change and get HTML
# Also checks for automatic axis updates with animation
Sys.sleep(6)
info$html_updated2 <- getHTML()

## --------------------------------------------------------------------- ##
## Test for tick updates

rect_path <- "//svg[@id='plot_%s']//g[contains(@class, '%saxis')]"
all_rect_paths <- lapply(names(viz), sprintf, fmt=rect_path,
                         c("x","y"))[1:4]

# Take tick diffs for all 4 plots
rect_nodes1 <- sapply(all_rect_paths, getNodeSet, doc=info$html)
original_tick_diff_x <- sapply(rect_nodes1[1, ], getTickDiff, axis="x")
original_tick_diff_y <- sapply(rect_nodes1[2, ], getTickDiff, axis="y")

rect_nodes2 <- sapply(all_rect_paths, getNodeSet, doc=info$html_updated1)
updated_tick_diff_x1 <- sapply(rect_nodes2[1, ], getTickDiff, axis="x")
updated_tick_diff_y1 <- sapply(rect_nodes2[2, ], getTickDiff, axis="y")

rect_nodes3 <- sapply(all_rect_paths, getNodeSet, doc=info$html_updated2)
updated_tick_diff_x2 <- sapply(rect_nodes3[1, ], getTickDiff, axis="x")
updated_tick_diff_y2 <- sapply(rect_nodes3[2, ], getTickDiff, axis="y")

test_that("axis ticks change when plots are updated",{
  #no_updates
  expect_equal(updated_tick_diff_x1[1], original_tick_diff_x[1])
  expect_equal(updated_tick_diff_y1[1], original_tick_diff_y[1])
  expect_equal(updated_tick_diff_x2[1], original_tick_diff_x[1])
  expect_equal(updated_tick_diff_y2[1], original_tick_diff_y[1])
  #update_x
  expect_true(unequal(updated_tick_diff_x1[2], original_tick_diff_x[2],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_x2[2], original_tick_diff_x[2],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_x2[2], updated_tick_diff_x1[2],
                      tolerance=0.01))
  expect_equal(updated_tick_diff_y1[2], original_tick_diff_y[2])
  expect_equal(updated_tick_diff_y2[2], original_tick_diff_y[2])
  #update_y
  expect_equal(updated_tick_diff_x1[3], original_tick_diff_x[3])
  expect_equal(updated_tick_diff_x2[3], original_tick_diff_x[3])
  expect_true(unequal(updated_tick_diff_y1[3], original_tick_diff_y[3],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_y2[3], original_tick_diff_y[3],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_y2[3], updated_tick_diff_y1[3],
                      tolerance=0.01))
  #update_xy
  expect_true(unequal(updated_tick_diff_x1[4], original_tick_diff_x[4],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_x2[4], original_tick_diff_x[4],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_x2[4], updated_tick_diff_x1[4],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_y1[4], original_tick_diff_y[4],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_y2[4], original_tick_diff_y[4],
                      tolerance=0.01))
  expect_true(unequal(updated_tick_diff_y2[4], updated_tick_diff_y1[4],
                      tolerance=0.01))
})


## ------------------------------------------------------------------- ##
## Test for grid updates

minor_grid_attr1 <- minor_grid_attr2 <- minor_grid_attr3 <- list()
major_grid_attr1 <- major_grid_attr2 <- major_grid_attr3 <- list()

p_names <- names(viz)[1:4]
for(p.name in p_names){
  major_grid_attr1[[p.name]] <- get_grid_lines(info$html, p.name, "major")
  major_grid_attr2[[p.name]] <- get_grid_lines(info$html_updated1,
                                               p.name, "major")
  major_grid_attr3[[p.name]] <- get_grid_lines(info$html_updated2,
                                               p.name, "major")
  
  minor_grid_attr1[[p.name]] <- get_grid_lines(info$html, p.name, "minor")
  minor_grid_attr2[[p.name]] <- get_grid_lines(info$html_updated1,
                                               p.name, "minor")
  minor_grid_attr3[[p.name]] <- get_grid_lines(info$html_updated2,
                                               p.name, "minor")
}

test_that("major grids are updated",{
  # initial grid updates
  expect_true(unequal(major_grid_attr1$x, major_grid_attr1$neither))
  expect_true(unequal(major_grid_attr1$y, major_grid_attr1$neither))
  expect_true(unequal(major_grid_attr1$both, major_grid_attr1$neither))
  expect_true(unequal(major_grid_attr1$x, major_grid_attr1$neither))
  expect_true(unequal(major_grid_attr1$y, major_grid_attr1$neither))
  expect_true(unequal(major_grid_attr1$both, major_grid_attr1$neither))
  
  #no_updates
  expect_identical(major_grid_attr2$neither, major_grid_attr1$neither)
  expect_identical(major_grid_attr3$neither, major_grid_attr1$neither)
  
  #update_x -> only vert grids are updated
  expect_identical(major_grid_attr2$x$hor, major_grid_attr1$x$hor)
  expect_identical(major_grid_attr3$x$hor, major_grid_attr1$x$hor)
  expect_true(unequal(major_grid_attr2$x$vert,
                      major_grid_attr1$x$vert, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$x$vert,
                      major_grid_attr1$x$vert, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$x$vert,
                      major_grid_attr2$x$vert, tolerance=0.01))
  
  #update_y -> only hor grids are updated
  expect_true(unequal(major_grid_attr2$y$hor,
                      major_grid_attr1$y$hor, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$y$hor,
                      major_grid_attr1$y$hor, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$y$hor,
                      major_grid_attr2$y$hor, tolerance=0.01))
  expect_identical(major_grid_attr2$y$vert, major_grid_attr1$y$vert)
  expect_identical(major_grid_attr3$y$vert, major_grid_attr1$y$vert)
  
  #update_xy -> both vert and hor grids updated
  expect_true(unequal(major_grid_attr2$both$hor,
                      major_grid_attr1$both$hor, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$both$hor,
                      major_grid_attr1$both$hor, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$both$hor,
                      major_grid_attr2$both$hor, tolerance=0.01))
  expect_true(unequal(major_grid_attr2$both$vert,
                      major_grid_attr1$both$vert, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$both$vert,
                      major_grid_attr1$both$vert, tolerance=0.01))
  expect_true(unequal(major_grid_attr3$both$vert,
                      major_grid_attr2$both$vert, tolerance=0.01))
})

test_that("minor grids are updated",{
  # initial grid updates
  expect_true(unequal(minor_grid_attr1$x, minor_grid_attr1$neither))
  expect_true(unequal(minor_grid_attr1$y, minor_grid_attr1$neither))
  expect_true(unequal(minor_grid_attr1$both, minor_grid_attr1$neither))
  expect_true(unequal(minor_grid_attr1$x, minor_grid_attr1$neither))
  expect_true(unequal(minor_grid_attr1$y, minor_grid_attr1$neither))
  expect_true(unequal(minor_grid_attr1$both, minor_grid_attr1$neither))
  
  #no_updates
  expect_identical(minor_grid_attr2$neither, minor_grid_attr1$neither)
  expect_identical(minor_grid_attr3$neither, minor_grid_attr1$neither)
  
  #update_x -> only vert grids are updated
  expect_identical(minor_grid_attr2$x$hor, minor_grid_attr1$x$hor)
  expect_identical(minor_grid_attr3$x$hor, minor_grid_attr1$x$hor)
  expect_true(unequal(minor_grid_attr2$x$vert,
                      minor_grid_attr1$x$vert, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$x$vert,
                      minor_grid_attr1$x$vert, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$x$vert,
                      minor_grid_attr2$x$vert, tolerance=0.01))
  
  #update_y -> only hor grids are updated
  expect_true(unequal(minor_grid_attr2$y$hor,
                      minor_grid_attr1$y$hor, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$y$hor,
                      minor_grid_attr1$y$hor, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$y$hor,
                      minor_grid_attr2$y$hor, tolerance=0.01))
  expect_identical(minor_grid_attr2$y$vert, minor_grid_attr1$y$vert)
  expect_identical(minor_grid_attr3$y$vert, minor_grid_attr1$y$vert)
  
  #update_xy -> both vert and hor grids updated
  expect_true(unequal(minor_grid_attr2$both$hor,
                      minor_grid_attr1$both$hor, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$both$hor,
                      minor_grid_attr1$both$hor, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$both$hor,
                      minor_grid_attr2$both$hor, tolerance=0.01))
  expect_true(unequal(minor_grid_attr2$both$vert,
                      minor_grid_attr1$both$vert, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$both$vert,
                      minor_grid_attr1$both$vert, tolerance=0.01))
  expect_true(unequal(minor_grid_attr3$both$vert,
                      minor_grid_attr2$both$vert, tolerance=0.01))
})

## -------------------------------------------------------------------- ##
## Test for zooming of geoms

## Get ranges of geoms
no_updates_ranges1 <- get_pixel_ranges(info$html_updated1,
                                       "geom1_point_neither")
no_updates_ranges2 <- get_pixel_ranges(info$html_updated2,
                                       "geom1_point_neither")

x_updates_ranges1 <- get_pixel_ranges(info$html_updated1,
                                      "geom2_point_x")
x_updates_ranges2 <- get_pixel_ranges(info$html_updated2,
                                      "geom2_point_x")

y_updates_ranges1 <- get_pixel_ranges(info$html_updated1,
                                      "geom3_point_y")
y_updates_ranges2 <- get_pixel_ranges(info$html_updated2,
                                      "geom3_point_y")

xy_updates_ranges1 <- get_pixel_ranges(info$html_updated1,
                                       "geom4_point_both")
xy_updates_ranges2 <- get_pixel_ranges(info$html_updated2,
                                       "geom4_point_both")

test_that("geoms get zoomed-in upon changing selection", {
  # no_updates
  expect_true(unequal(no_updates_ranges2$x, no_updates_ranges1$x,
                      tolerance=0.01))
  expect_true(unequal(no_updates_ranges2$y, no_updates_ranges1$y,
                      tolerance=0.01))
  
  # x_updates
  expect_equal(x_updates_ranges2$x, x_updates_ranges1$x, tolerance=0.0001)
  expect_true(unequal(x_updates_ranges2$y, x_updates_ranges1$y,
                      tolerance=0.01))
  
  # y_updates
  expect_true(unequal(y_updates_ranges2$x, y_updates_ranges1$x,
                      tolerance=0.01))
  expect_equal(y_updates_ranges2$y, y_updates_ranges1$y, tolerance=0.0001)
  
  # xy_updates
  expect_equal(xy_updates_ranges2$x, xy_updates_ranges1$x, tolerance=0.0001)
  expect_equal(xy_updates_ranges2$y, xy_updates_ranges1$y, tolerance=0.0001)
})