Merge pull request #151 from tdhock/fix-line-group

FunctionalPruning data test

.travis.yml

@@ -18,10 +18,11 @@ install:
   - $HOME/opt/pandoc/pandoc --version
   # install uninstalled packages which this pkg depends on/links to/suggests.
   - ./travis-tool.sh install_deps
-  - ./travis-tool.sh install_github tdhock/ggplot2 jimhester/covr
+  - Rscript -e 'devtools::install_github("tdhock/RSelenium@7a70f57ea4b4ac7a14cefa5d650265efe04ab209", upgrade_dependencies=FALSE, dependencies=TRUE)'
+  - Rscript -e 'devtools::install_github(c("hadley/scales@2c3edf45de56d617444dc38e47e0404173817886", "tdhock/ggplot2@a8b06ddb680acdcdbd927773b1011c562134e4d2"), upgrade_dependencies=FALSE, dependencies=FALSE)'
+  - Rscript -e "devtools::install(upgrade_dependencies=FALSE, dependencies=FALSE)"
 
 script:
-  - Rscript -e "devtools::install(dep=FALSE)"
   - Rscript -e "source('tests/testthat.R', chdir=TRUE)"
 
 after_success:

DESCRIPTION

@@ -1,7 +1,7 @@
 Package: animint
 Maintainer: Toby Dylan Hocking <[email protected]>
 Author: Toby Dylan Hocking, Susan VanderPlas, Carson Sievert, Kevin Ferris, Tony Tsai
-Version: 2016.03.23
+Version: 2016.05.07
 License: GPL-3
 Title: Interactive animations
 Description: An interactive animation can be defined using a list of
@@ -30,7 +30,4 @@ Suggests:
     devtools,
     httr,
     maps
-Remotes: tdhock/ggplot2,
-    ropensci/RSelenium,
-    hadley/scales@2c3edf45de56d617444dc38e47e0404173817886
 RoxygenNote: 5.0.1

NEWS

@@ -180,6 +180,11 @@ RENDER: multiple animints inside of a single shiny app? This is
 probably just a theoretical issue. (why not just make a single
 animint?)
 
+2016.05.07 PR#151
+
+BUGFIX: common chunk data were not computed correctly when some chunks
+did not have all groups.
+
 2016.03.23 PR#143
 
 DSL: informative error when time option but no interactive aes

R/animint.R

@@ -903,7 +903,7 @@ saveLayer <- function(l, d, meta){
   g.data.varied <- if(is.null(data.or.null)){
     split.x(g.data, chunk.cols)
   }else{
-    g$columns <- lapply(data.or.null, names)
+    g$columns$common <- as.list(names(data.or.null$common))
     tsv.name <- sprintf("%s_chunk_common.tsv", g$classed)
     tsv.path <- file.path(meta$out.dir, tsv.name)
     write.table(data.or.null$common, tsv.path,
@@ -977,31 +977,39 @@ getCommonChunk <- function(built, chunk.vars, aes.list){
   is.common.mat <-
     matrix(NA, length(values.by.group), length(col.name.vec),
            dimnames=list(group=names(values.by.group),
-             col.name=col.name.vec))
+                         col.name=col.name.vec))
+  group.info.list <- list()
   for(group.name in names(values.by.group)){
     values.by.chunk <- values.by.group[[group.name]]
     row.count.vec <- sapply(values.by.chunk, nrow)
     same.size.chunks <- all(row.count.vec[1] == row.count.vec)
+    ## For every group, save values for creating common tsv later.
+    one.group.info <- values.by.chunk[[1]]
     for(col.name in col.name.vec){
       value.list <- lapply(values.by.chunk, function(df)df[[col.name]])
       is.common.mat[group.name, col.name] <- if(same.size.chunks){
         value.mat <- do.call(cbind, value.list)
-        all(value.mat[, 1] == value.mat)
+        least.missing <- which.min(colSums(is.na(value.mat)))
+        value.vec <- value.mat[, least.missing]
+        one.group.info[[col.name]] <- value.vec
+        all(value.vec == value.mat)
       }else{
-        value.tab <- table(unlist(value.list))
+        value.vec <- unlist(value.list)
+        one.group.info[[col.name]] <- value.vec[[1]]
+        value.tab <- table(value.vec)
         length(value.tab) == 1
       }
     }
+    group.info.list[[group.name]] <- one.group.info
   }
   is.common <- apply(is.common.mat, 2, all, na.rm=TRUE)
   ## TODO: another criterion could be used to save disk space even if
   ## there is only 1 chunk.
   if(is.common[["group"]] && sum(is.common) >= 2){
     common.cols <- names(is.common)[is.common]
-    one.chunk <- built.by.chunk[[1]]
-    ## Should each chunk have the same info about each group? 
-    common.not.na <- na.omit(one.chunk[common.cols])
-    common.unique <- unique(common.not.na)
+    group.info <- do.call(rbind, group.info.list)
+    group.info.common <- group.info[, names(which(is.common))]
+    common.unique <- unique(group.info.common)
     ## For geom_polygon and geom_path we may have two rows that should
     ## both be kept (the start and the end of each group may be the
     ## same if the shape is closed), so we define common.data as all
@@ -1011,14 +1019,13 @@ getCommonChunk <- function(built, chunk.vars, aes.list){
     common.data <- if(all(data.per.group == 1)){
       common.unique
     }else{
-      common.not.na
+      group.info.common
     }
     built.group <- do.call(rbind, built.by.chunk)
-    built.has.common <- subset(built.group, group %in% common.data$group)
-    varied.df.list <- split.x(built.has.common, chunk.vars)
+    varied.df.list <- split.x(na.omit(built.group), chunk.vars)
     varied.cols <- c("group", names(is.common)[!is.common])
     varied.data <- varied.chunk(varied.df.list, varied.cols)
-    return(list(common=common.data,
+    return(list(common=na.omit(common.data),
                 varied=varied.data))
   }
 }

inst/htmljs/animint.js

@@ -1032,7 +1032,7 @@ var animint = function (to_select, json_file) {
         }
       });
       if(g_info.data_is_object){
-	if(isArray(some_data)){
+	if(isArray(some_data) && some_data.length){
 	  data["0"] = some_data;
 	}else{
 	  for(k in some_data){

man/FunctionalPruning.Rd

@@ -0,0 +1,17 @@
+\name{FunctionalPruning}
+\alias{FunctionalPruning}
+\docType{data}
+\title{
+  Functional Pruning Algorithm
+}
+\description{
+  Output of an algorithm for optimal change-point detection.
+}
+\usage{data("FunctionalPruning")}
+\format{
+  a named list of 4 data.frames
+}
+\source{
+https://github.com/tdhock/PeakSegFPOP-paper/blob/master/figure-constrained-PDPA-normal-real.R
+}
+\keyword{datasets}

tests/testthat/helper-functions.R

@@ -225,24 +225,8 @@ getStyleValue <- function(html, xpath, style.name) {
 }
 
 ## testthat there is no warning generated by a piece of code.
-gives_no_warning <- function(){
-  function(expr) {
-    warnings <- evaluate_promise(expr)$warnings
-    s <- ifelse(length(warnings)==1, "", "s")
-    expectation(
-      length(warnings) == 0,
-      paste0("created ", length(warnings),
-             " warning", s, ": ",
-             paste(warnings, collapse=", ")),
-      "no warnings given"
-    )
-  }
-}
-expect_no_warning <- function(object, ..., info=NULL, label=NULL){
-  if (is.null(label)) {
-    label <- testthat:::find_expr("object")
-  }
-  expect_that(object, gives_no_warning(), info=info, label=label)
+expect_no_warning <- function(object, regexp, ...){
+  expect_warning(object, NA)
 }
 
 getTransform <- function(tick)xmlAttrs(tick)[["transform"]]

tests/testthat/test-renderer3-FunctionalPruning.R

@@ -0,0 +1,61 @@
+context("FunctionalPruning")
+
+data(FunctionalPruning, package="animint")
+min.bug.viz <- list(
+  pruning=ggplot()+
+    geom_line(aes(mean, cost,
+                  showSelected=minimization),
+              color="grey",
+              size=5,
+              data=FunctionalPruning$envelope)+
+    geom_line(aes(mean, cost, color=data.i.fac,
+                  group=paste(piece.i, data.i),
+                  showSelected=minimization),
+              data=FunctionalPruning$cost.lines)+
+    geom_point(aes(min.cost.mean, min.cost,
+                   color=data.i.fac,
+                   showSelected=minimization),
+               size=5,
+               data=FunctionalPruning$minima),
+  data=ggplot()+
+    geom_tile(aes(timestep, total.segments,
+                  fill=optimal.cost,
+                  id=paste0("segs", total.segments, "time", timestep),
+                  clickSelects=minimization),
+              data=FunctionalPruning$grid),
+  first=list(minimization="2 segments up to data point 4")
+)
+info <- animint2HTML(min.bug.viz)
+
+some.lines <- subset(FunctionalPruning$cost.lines, timestep==4 & n.segments==2)
+with(some.lines, table(data.i, piece.i))
+test_that("one line rendered for min envelope", {
+  path.list <- getNodeSet(
+    info$html, 
+    '//g[@class="geom1_line_pruning"]//path')
+  expect_equal(length(path.list), 1)
+})
+
+test_that("four lines rendered for cost candidates", {
+  path.list <- getNodeSet(
+    info$html, 
+    '//g[@class="geom2_line_pruning"]//path')
+  expect_equal(length(path.list), 4)
+})
+
+html <- clickHTML(id="segs1time4")
+
+test_that("min envelope line disappears", {
+  path.list <- getNodeSet(
+    html, 
+    '//g[@class="geom1_line_pruning"]//path')
+  expect_equal(length(path.list), 0)
+})
+
+test_that("cost candidates lines disappear", {
+  path.list <- getNodeSet(
+    html, 
+    '//g[@class="geom2_line_pruning"]//path')
+  expect_equal(length(path.list), 0)
+})
+

wercker.yml

@@ -11,9 +11,21 @@ build:
           sudo ln -sf /usr/local/share/$PHANTOM_JS/bin/phantomjs /usr/local/bin
           phantomjs --version
     - script:
-      name: echo install animint dependencies
+      name: echo install_deps
       code: |
-        Rscript -e "devtools::install(upgrade_dependencies=FALSE, dependencies=TRUE)"
+        Rscript -e "devtools::install_deps(dependencies=TRUE)"
+    - script:
+      name: echo install RSelenium+dependencies
+      code: |
+        Rscript -e 'devtools::install_github("tdhock/RSelenium@7a70f57ea4b4ac7a14cefa5d650265efe04ab209", upgrade_dependencies=FALSE, dependencies=TRUE)'
+    - script:
+      name: echo install old dependencies
+      code: |
+        Rscript -e 'devtools::install_github(c("hadley/scales@2c3edf45de56d617444dc38e47e0404173817886", "tdhock/ggplot2@a8b06ddb680acdcdbd927773b1011c562134e4d2"), upgrade_dependencies=FALSE, dependencies=FALSE)'
+    - script:
+      name: echo install animint 
+      code: |
+        Rscript -e "devtools::install(upgrade_dependencies=FALSE, dependencies=FALSE)"
     - script:
       name: copy source to animint 
       code: |