diff --git a/DESCRIPTION b/DESCRIPTION index 3b046aa6..84e0c06e 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: animint Maintainer: Toby Dylan Hocking Author: Toby Dylan Hocking, Susan VanderPlas, Carson Sievert, Kevin Ferris, Tony Tsai -Version: 2016.05.07 +Version: 2016.05.08 License: GPL-3 Title: Interactive animations Description: An interactive animation can be defined using a list of diff --git a/NEWS b/NEWS index 1c42c466..3e7a4dac 100644 --- a/NEWS +++ b/NEWS @@ -180,6 +180,14 @@ 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.08 PR#146 + +GGPLOT: the compiler now stops with an informative error when stats +are used with showSelected. New warning when position is used with +showSelected. + +RENDER: aes(href) works when data_is_object (e.g. geom_polygon) + 2016.05.07 PR#151 BUGFIX: common chunk data were not computed correctly when some chunks diff --git a/R/animint.R b/R/animint.R index 6752e447..eab4599b 100644 --- a/R/animint.R +++ b/R/animint.R @@ -395,6 +395,7 @@ saveLayer <- function(l, d, meta){ ## plot.Selectors. s.aes <- selector.aes(g$aes) + meta$selector.aes[[g$classed]] <- s.aes ## Do not copy group unless it is specified in aes, and do not copy ## showSelected variables which are specified multiple times. @@ -486,19 +487,30 @@ saveLayer <- function(l, d, meta){ } } - ## Warn if stat_bin is used with animint aes. geom_bar + stat_bin - ## doesn't make sense with clickSelects/showSelected, since two + not.identity <- function(stat.or.position){ + x <- stat.or.position$objname + is.character(x) && length(x)==1 && x != "identity" + } + is.show <- grepl("showSelected", names(g$aes)) + has.show <- any(is.show) + ## Error if non-identity stat is used with showSelected, since + ## typically the stats will delete the showSelected column from the + ## built data set. For example geom_bar + stat_bin doesn't make + ## sense with clickSelects/showSelected, since two ## clickSelects/showSelected values may show up in the same bin. - stat <- l$stat - if(!is.null(stat)){ - is.bin <- stat$objname=="bin" - is.animint.aes <- grepl("clickSelects|showSelected", names(g$aes)) - if(is.bin & any(is.animint.aes)){ - warning(paste0("stat_bin is unpredictable ", - "when used with clickSelects/showSelected.\n", - "Use plyr::ddply() to do the binning ", - "or use make_bar if using geom_bar/geom_histogram.")) - } + if(has.show && not.identity(l$stat)){ + show.names <- names(g$aes)[is.show] + data.has.show <- show.names %in% names(g.data) + signal <- if(all(data.has.show))warning else stop + print(l) + signal("showSelected only works with stat=identity, problem: ", + g$classed) + } + ## Warn if non-identity position is used with animint aes. + if(has.show && not.identity(l$position)){ + print(l) + warning("showSelected only works with position=identity, problem: ", + g$classed) } ##print("before pre-processing") @@ -893,7 +905,8 @@ saveLayer <- function(l, d, meta){ } ## group should be the last thing in nest_order, if it is present. - if("group" %in% names(g$aes)){ + data.object.geoms <- c("line", "path", "ribbon", "polygon") + if("group" %in% names(g$aes) && g$geom %in% data.object.geoms){ g$nest_order <- c(g$nest_order, "group") } @@ -1405,6 +1418,24 @@ animint2dir <- function(plot.list, out.dir = tempfile(), as.list(unique(unlist(lapply(values.update, "[[", "update")))) } + ## Now that selectors are all defined, go back through geoms to + ## check if there are any warnings to issue. + for(g.name in names(meta$geoms)){ + g.info <- meta$geoms[[g.name]] + g.selectors <- meta$selector.aes[[g.name]] + show.vars <- g.info$aes[g.selectors$showSelected$one] + duration.vars <- names(meta$duration) + show.with.duration <- show.vars[show.vars %in% duration.vars] + no.key <- ! "key" %in% names(g.info$aes) + if(length(show.with.duration) && no.key){ + warning( + "to ensure that smooth transitions are interpretable, ", + "aes(key) should be specifed for geoms with aes(showSelected=", + show.with.duration[1], + "), problem: ", g.name) + } + } + ## For a static data viz with no interactive aes, no need to check ## for trivial showSelected variables with only 1 level. if(0 < length(meta$selectors)){ diff --git a/inst/examples/breakpoints.R b/inst/examples/breakpoints.R index 5f0f6fb8..085b8d57 100644 --- a/inst/examples/breakpoints.R +++ b/inst/examples/breakpoints.R @@ -29,5 +29,5 @@ breakpointError <- geom_line(aes(segments, error, group=bases.per.probe, clickSelects=bases.per.probe), data=only.error, lwd=4)) -gg2animint(breakpointError) +animint2dir(breakpointError) diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index ec639a73..957af64b 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1132,7 +1132,7 @@ var animint = function (to_select, json_file) { } } - var eActions, eAppend; + var eActions, eAppend, linkActions; var key_fun = null; var id_fun = function(d){ return d.id; @@ -1246,6 +1246,17 @@ var animint = function (to_select, json_file) { return one_row.id; }; elements = elements.data(kv, key_fun); + linkActions = function(a_elements){ + a_elements + .attr("xlink:href", function(group_info){ + var one_group = keyed_data[group_info.value]; + var one_row = one_group[0]; + return one_row.href; + }) + .attr("target", "_blank") + .attr("class", "geom") + ; + }; eActions = function (e) { e.attr("d", function (d) { var one_group = keyed_data[d.value]; @@ -1294,7 +1305,14 @@ var animint = function (to_select, json_file) { }); }; eAppend = "path"; - } else if (g_info.geom == "segment") { + }else{ + linkActions = function(a_elements){ + a_elements.attr("xlink:href", function(d){ return d.href; }) + .attr("target", "_blank") + .attr("class", "geom"); + }; + } + if (g_info.geom == "segment") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("x1", function (d) { @@ -1314,7 +1332,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "line"; - } else if (g_info.geom == "linerange") { + } + if (g_info.geom == "linerange") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("x1", function (d) { @@ -1334,7 +1353,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "line"; - } else if (g_info.geom == "vline") { + } + if (g_info.geom == "vline") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("x1", toXY("x", "xintercept")) @@ -1346,7 +1366,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "line"; - } else if (g_info.geom == "hline") { + } + if (g_info.geom == "hline") { // pretty much a copy of geom_vline with obvious modifications elements = elements.data(data, key_fun); eActions = function (e) { @@ -1359,7 +1380,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "line"; - } else if (g_info.geom == "text") { + } + if (g_info.geom == "text") { elements = elements.data(data, key_fun); // TODO: how to support vjust? firefox doensn't support // baseline-shift... use paths? @@ -1375,7 +1397,8 @@ var animint = function (to_select, json_file) { }); }; eAppend = "text"; - } else if (g_info.geom == "point") { + } + if (g_info.geom == "point") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("cx", toXY("x", "x")) @@ -1385,7 +1408,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "circle"; - } else if (g_info.geom == "jitter") { + } + if (g_info.geom == "jitter") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("cx", toXY("x", "x")) @@ -1395,7 +1419,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "circle"; - } else if (g_info.geom == "tallrect") { + } + if (g_info.geom == "tallrect") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("x", toXY("x", "xmin")) @@ -1410,7 +1435,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "rect"; - } else if (g_info.geom == "widerect") { + } + if (g_info.geom == "widerect") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("y", toXY("y", "ymax")) @@ -1425,7 +1451,8 @@ var animint = function (to_select, json_file) { .style("stroke", get_colour); }; eAppend = "rect"; - } else if (g_info.geom == "rect") { + } + if (g_info.geom == "rect") { elements = elements.data(data, key_fun); eActions = function (e) { e.attr("x", toXY("x", "xmin")) @@ -1444,7 +1471,8 @@ var animint = function (to_select, json_file) { } }; eAppend = "rect"; - } else if (g_info.geom == "boxplot") { + } + if (g_info.geom == "boxplot") { // TODO: currently boxplots are unsupported (we intentionally // stop with an error in the R code). The reason why is that @@ -1524,16 +1552,9 @@ var animint = function (to_select, json_file) { .style("stroke-width", get_size) .style("stroke", get_colour); }; - } else { - return "unsupported geom " + g_info.geom; } elements.exit().remove(); var enter = elements.enter(); - var linkActions = function(a_elements){ - a_elements.attr("xlink:href", function(d){ return d.href; }) - .attr("target", "_blank") - .attr("class", "geom"); - }; if(g_info.aes.hasOwnProperty("href")){ enter = enter.append("svg:a") .append("svg:"+eAppend); @@ -1960,7 +1981,7 @@ var animint = function (to_select, json_file) { // add a button to view the animation widgets var show_hide_animation_controls = element.append("button") .text(show_message) - .attr("id", "show_hide_animation_controls") + .attr("id", viz_id + "_show_hide_animation_controls") .on("click", function(){ if(this.textContent == show_message){ time_table.style("display", ""); @@ -2027,7 +2048,7 @@ var animint = function (to_select, json_file) { var duration_inputs = duration_tds .append("input") .attr("id", function(s_name){ - return "duration_ms_" + s_name; + return viz_id + "_duration_ms_" + s_name; }) .attr("type", "text") .on("change", function(s_name){ diff --git a/tests/testthat/test-compiler-errors.R b/tests/testthat/test-compiler-errors.R index c74ac857..88a5a4ce 100644 --- a/tests/testthat/test-compiler-errors.R +++ b/tests/testthat/test-compiler-errors.R @@ -54,3 +54,119 @@ test_that("no error for time option with color", { ) info <- animint2dir(viz, open.browser=FALSE) }) + +data("WorldBank", package="animint") +viz.no.duration <- list( + scatter=ggplot()+ + geom_point(aes(x=life.expectancy, y=fertility.rate, color=region, + key=country, + showSelected=year, + clickSelects=country), + data=WorldBank)+ + geom_text(aes(x=life.expectancy, y=fertility.rate, label=country, + showSelected=year, + showSelected2=country, + showSelected3=region, + clickSelects=country), + data=WorldBank), + first=list( + year=1970, + country=c("Canada", "India", "Pakistan", "Japan"), + region=c("North America", "South Asia")), + selector.types=list(country="multiple") +) + +test_that("no warning for no duration vars", { + expect_no_warning({ + info <- animint2dir(viz.no.duration, open.browser=FALSE) + }) +}) + +test_that("warn no key for geom_text with showSelected=duration var", { + viz.duration <- viz.no.duration + viz.duration$duration <- list(year=2000) + expect_warning({ + info <- animint2dir(viz.duration, open.browser=FALSE) + }, "to ensure that smooth transitions are interpretable, aes(key) should be specifed for geoms with aes(showSelected=year), problem: geom2_text_scatter", fixed=TRUE) +}) + +viz.key.duration <- list( + scatter=ggplot()+ + geom_point(aes(x=life.expectancy, y=fertility.rate, color=region, + key=country, + showSelected=year, + clickSelects=country), + data=WorldBank)+ + geom_text(aes(x=life.expectancy, y=fertility.rate, label=country, + showSelected=year, + showSelected2=country, + showSelected3=region, + key=country, + clickSelects=country), + data=WorldBank), + first=list( + year=1970, + country=c("Canada", "India", "Pakistan", "Japan"), + region=c("North America", "South Asia")), + selector.types=list(country="multiple"), + duration=list(year=2000) +) +test_that("no warning when key specified", { + expect_no_warning({ + info <- animint2dir(viz.key.duration, open.browser=FALSE) + }) +}) + +test_that("warning for position=stack and showSelected", { + set.seed(1) + df <- data.frame( + letter = c(replicate(4, LETTERS[1:5])), + count = c(replicate(4, rbinom(5, 50, 0.5))), + stack = rep(rep(1:2, each = 5), 2), + facet = rep(1:2, each = 10) + ) + gg <- ggplot() + + theme_bw()+ + theme(panel.margin=grid::unit(0, "lines"))+ + geom_bar( + aes(letter, count, fill = stack, showSelected=facet, + key=paste(stack, letter)), + data = df, + stat = "identity", + position="stack" + ) + complicated <- list( + plot = gg, + time = list(variable = "facet", ms = 1000), + duration = list(facet = 1000) + ) + expect_warning({ + animint2dir(complicated, open.browser=FALSE) + }, "showSelected only works with position=identity, problem: geom1_bar_plot") +}) + +test_that("no warning for position=stack without showSelected", { + set.seed(1) + df <- data.frame( + letter = c(replicate(4, LETTERS[1:5])), + count = c(replicate(4, rbinom(5, 50, 0.5))), + stack = rep(rep(1:2, each = 5), 2), + facet = rep(1:2, each = 10) + ) + gg <- ggplot() + + theme_bw()+ + theme(panel.margin=grid::unit(0, "lines"))+ + geom_bar( + aes(letter, count, fill = stack), + data = df, + stat = "identity", + position="stack" + ) + no.show <- list( + plot = gg + ) + expect_no_warning({ + animint2dir(no.show, open.browser=FALSE) + }) +}) + diff --git a/tests/testthat/test-renderer1-href.R b/tests/testthat/test-renderer1-href.R index 41250ae7..d650b446 100644 --- a/tests/testthat/test-renderer1-href.R +++ b/tests/testthat/test-renderer1-href.R @@ -52,3 +52,19 @@ test_that("clicking updates href (again)", { c("http://en.wikipedia.org/wiki/orange", "http://en.wikipedia.org/wiki/black")) }) + +test_that("aes(href) works with geom_polygon", { + USpolygons <- map_data("state") + USpolygons$href <- paste0("https://en.wikipedia.org/wiki/", USpolygons$region) + viz.href <- list( + map=ggplot()+ + ggtitle("click a state to read its Wikipedia page")+ + coord_equal()+ + geom_polygon( + aes(x=long, y=lat, group=group, href=href), + data=USpolygons, fill="black", colour="grey") + ) + info <- animint2HTML(viz.href) + (expected.vec <- unique(USpolygons$href)) + expect_links(info$html, expected.vec) +}) diff --git a/tests/testthat/test-renderer1-knit-print.R b/tests/testthat/test-renderer1-knit-print.R index 6f8998a5..dd8ef15f 100644 --- a/tests/testthat/test-renderer1-knit-print.R +++ b/tests/testthat/test-renderer1-knit-print.R @@ -40,6 +40,32 @@ test_that("svg id property is unique", { expect_true(all(id.counts==1)) }) +all.list <- getNodeSet(html, "//*") +id.na.vec <- sapply(all.list, function(e){ + attr.vec.or.null <- xmlAttrs(e) + if("id" %in% names(attr.vec.or.null)){ + attr.vec.or.null[["id"]] + }else{ + NA + } +}) +## In HTML, all values are case-insensitive +## http://www.w3schools.com/tags/att_global_id.asp +lower.id.vec <- tolower(id.na.vec) +id.counts <- table(lower.id.vec) +(not.unique <- id.counts[1 < id.counts]) +test_that("id property is unique over entire page", { + expect_equal(length(not.unique), 0) +}) + +test_that("id must contain at least one character", { + expect_true(all(0 < nchar(names(id.counts)))) +}) + +test_that("id must not contain any space characters", { + expect_false(any(grepl(" ", names(id.counts)))) +}) + ## function to extract all circles from an HTML page get_circles <- function(html=getHTML()) { plot.names <- c("plot1top", "plot1bottom") diff --git a/tests/testthat/test-renderer2-widerect.R b/tests/testthat/test-renderer2-widerect.R index 1d9799db..b2aaef8e 100644 --- a/tests/testthat/test-renderer2-widerect.R +++ b/tests/testthat/test-renderer2-widerect.R @@ -201,7 +201,7 @@ test_that("animation updates", { expect_true(old.year != new.year) }) -clickID("show_hide_animation_controls") +clickID("plot_show_hide_animation_controls") test_that("pause stops animation", { clickID("play_pause") @@ -400,7 +400,7 @@ test_that("middle of transition != after when duration=2000", { expect_true(during.width != after.width) }) -e <- remDr$findElement("id", "duration_ms_year") +e <- remDr$findElement("id", "plot_duration_ms_year") e$clickElement() e$clearElement() e$sendKeysToElement(list("0", key="enter")) diff --git a/tests/testthat/test-renderer3-stat-bin.R b/tests/testthat/test-renderer3-stat-bin.R new file mode 100644 index 00000000..7be660ab --- /dev/null +++ b/tests/testthat/test-renderer3-stat-bin.R @@ -0,0 +1,60 @@ +acontext("stat bin") + +set.seed(1) +make <- function(count, stack, facet){ + data.frame(count, row=1:count, stack, facet) +} +df <- rbind( + make(2, 1, 1), + make(5, 1, 1), + make(3, 2, 1), + make(4, 2, 1), + make(2, 2, 2), + make(5, 2, 2), + make(3, 1, 2), + make(4, 1, 2) +) + +test_that("error for stat=bin and showSelected", { + gg <- ggplot() + + theme_bw()+ + theme(panel.margin=grid::unit(0, "lines"))+ + geom_bar( + aes(count, group=stack, fill=stack, showSelected=facet), + binwidth=1, + data = df, + stat = "bin", + position="identity" + ) + gg+facet_grid(facet~.) + complicated <- list( + plot = gg + ) + expect_error({ + animint2HTML(complicated) + }, "showSelected only works with stat=identity, problem: geom1_bar_plot") +}) + +test_that("no warning for stat=bin without showSelected", { + gg <- ggplot() + + theme_bw()+ + theme(panel.margin=grid::unit(0, "lines"))+ + geom_bar( + aes(count, group=stack, fill=stack), + binwidth=1, + data = df, + stat = "bin", + position="identity" + )+ + facet_grid(facet~.) + complicated <- list(plot = gg) + expect_no_warning({ + info <- animint2HTML(complicated) + }) + for(panel in 1:2){ + xpath <- sprintf('//g[@class="PANEL%d"]//rect', panel) + style.vec <- getStyleValue(info$html, xpath, "fill") + fill.counts <- table(style.vec) + expect_equal(length(fill.counts), 2) + } +})