tests/testthat/test-renderer1-interactive-facets.R

In tdhock/animint2: Animated Interactive Grammar of Graphics

acontext("Interactive facets")

## Example: 4 plots, 2 selectors.
data(intreg, package = "animint2")
signal.colors <- c(estimate="#0adb0a", latent="#0098ef")
breakpoint.colors <- c("1breakpoint"="#ff7d7d", "0breakpoints"='#f6f4bf')
model.linetypes <- c(margin="dotted",limit="dashed",regression="solid")
intreg$annotations$logratio <- max(intreg$sig$log)

mmir.facets <- 
  list(signal=ggplot()+
       theme_animint(height=300, width=800)+       
       scale_x_continuous("position on chromosome (mega base pairs)",
                          breaks=c(100,200))+
       geom_tallrect(aes(xmin=first.base/1e6, xmax=last.base/1e6,
                         fill=annotation),
                     showSelected="signal",
                     data=intreg$annotations)+
       scale_fill_manual(values=breakpoint.colors,guide="none")+
       geom_text(aes((first.base+last.base)/2e6, logratio+1/8,
                     label=annotation),
                 showSelected="signal",
                 data=intreg$annotations)+
       geom_blank(aes(first.base/1e6, logratio+2/8),
                  data=intreg$annotations)+
       geom_point(aes(base/1e6, logratio),
                  showSelected="signal",
                  data=intreg$signals)+
       geom_segment(aes(first.base/1e6, mean, xend=last.base/1e6, yend=mean),
                    showSelected=c("signal", "segments"),
                    data=intreg$segments,
                    colour=signal.colors[["estimate"]])+
       geom_vline(aes(xintercept=base/1e6),
                  showSelected=c("signal", "segments"),
                  colour=signal.colors[["estimate"]],
                  linetype="dashed",
                  data=intreg$breaks),
       penalty=ggplot()+
       geom_tallrect(aes(xmin=min.L, xmax=max.L),
                     showSelected="signal",
                     clickSelects="segments",
                     data=data.frame(intreg$selection, what="segments"),
                     alpha=1/2)+
       ylab("")+
       theme_animint(height=500, width=800)+
       geom_segment(aes(min.L, feature, xend=max.L, yend=feature),
                    clickSelects="signal",
                    size=5,
                    data=data.frame(intreg$intervals, what="regression"))+
       geom_segment(aes(min.L, min.feature, xend=max.L, yend=max.feature,
                        linetype=line),
                    colour="red",
                    size=3,
                    data=data.frame(intreg$model, what="regression"))+
       scale_linetype_manual(values=model.linetypes)+
       geom_segment(aes(min.L, cost, xend=max.L, yend=cost),
                    showSelected="signal",
                    data=data.frame(intreg$selection, what="error"))+
       geom_segment(aes(min.L, segments, xend=max.L, yend=segments),
                    showSelected="signal",
                    data=data.frame(intreg$selection, what="segments"))+
       xlab("penalty value $L=f(x)$")+ # TODO: mathjax.
       facet_grid(what~.,scales="free"))

info <- animint2HTML(mmir.facets)

getTransform <- function(tick)xmlAttrs(tick)[["transform"]]

test_that("y axes align in facet_grid(variable~.)", {
  g.list <- getNodeSet(
    info$html, "//svg[@id='plot_penalty']//g[contains(@class, 'yaxis')]")
  expect_equal(length(g.list), 3)
  transform.txt <- sapply(g.list, getTransform)
  x.txt <- sub("translate[(](.*?),.*", "\\1", transform.txt)
  for(x.val in x.txt){
    expect_equal(x.val, x.txt[[1]])
  }
})

test_that("red lines are only drawn in panel 2", {
  panelPath <- function(panel.i){
    paste0("//svg[@id='plot_penalty']",
           "//g[@class='geom9_segment_penalty']",
           "//g[@class='PANEL", panel.i, "']",
           "//line")
  }
  PANEL1lines <- getNodeSet(info$html, panelPath(1))
  expect_equal(length(PANEL1lines), 0)
  PANEL2lines <- getNodeSet(info$html, panelPath(2))
  expect_equal(length(PANEL2lines), 6)
  PANEL3lines <- getNodeSet(info$html, panelPath(3))
  expect_equal(length(PANEL3lines), 0)
})