diff --git a/R/geom-.r b/R/geom-.r index 92e2b8a3b..65075bf4b 100644 --- a/R/geom-.r +++ b/R/geom-.r @@ -580,6 +580,10 @@ Geom <- gganimintproto("Geom", if("group" %in% names(g$aes) && g$geom %in% data.object.geoms){ g$nest_order <- c(g$nest_order, "group") } + ## If subgroup is specified for polygon, flag it for JS renderer. + if("subgroup" %in% names(g$aes) && g$geom == "polygon"){ + g$data_has_subgroup <- TRUE + } ## If user did not specify aes(group), then use group=1. if(! "group" %in% names(g$aes)){ g.data$group <- 1 diff --git a/R/geom-polygon.r b/R/geom-polygon.r index 4fec1868e..4bcf0b337 100644 --- a/R/geom-polygon.r +++ b/R/geom-polygon.r @@ -101,7 +101,7 @@ GeomPolygon <- gganimintproto("GeomPolygon", Geom, }, default_aes = aes(colour = "NA", fill = "grey20", size = 0.5, linetype = 1, - alpha = NA), + alpha = NA, subgroup = NULL), handle_na = function(data, params) { data diff --git a/inst/htmljs/animint.js b/inst/htmljs/animint.js index bfcc4b07f..03f239dea 100644 --- a/inst/htmljs/animint.js +++ b/inst/htmljs/animint.js @@ -1370,11 +1370,34 @@ var animint = function (to_select, json_file) { fill = "none"; fill_off = "none"; } + // Create d3.geo.path with null projection once (no geographic + // reprojection; coordinates are already in pixel space after + // applying scales). Only needed for polygon subgroup holes. + var geoPath = g_info.data_has_subgroup ? d3.geo.path().projection(null) : null; data_to_bind = kv; eActions = function (e) { e.attr("d", function (d) { - return lineThing(keyed_data[d.value]); - }) + var group_data = keyed_data[d.value]; + if(g_info.data_has_subgroup){ + // Build a GeoJSON Polygon: first ring is exterior, + // subsequent rings are holes (as per GeoJSON spec). + var by_subgroup = d3.nest() + .key(function(r){ return r["subgroup"]; }) + .entries(group_data); + var rings = by_subgroup.map(function(sg){ + var coords = sg.values.map(function(pt){ + return [scales.x(pt.x), scales.y(pt.y)]; + }); + coords.push(coords[0].slice()); // close ring + return coords; + }); + return geoPath({ type: "Polygon", coordinates: rings }); + } + return lineThing(group_data); + }); + if(g_info.data_has_subgroup){ + e.style("fill-rule", "evenodd"); + } }; eAppend = "path"; }else{ diff --git a/tests/testthat/test-renderer-polygon-subgroup.R b/tests/testthat/test-renderer-polygon-subgroup.R new file mode 100644 index 000000000..246aaef6b --- /dev/null +++ b/tests/testthat/test-renderer-polygon-subgroup.R @@ -0,0 +1,160 @@ +acontext("polygon subgroup holes") +library(animint2) +library(isoband) +library(data.table) +library(jsonlite) + +make_viz <- function(m, subgroup = TRUE) { + res <- as.data.table( + isoband::isobands( + (1:ncol(m)) / (ncol(m) + 1), + (nrow(m):1) / (nrow(m) + 1), + m, 0.5, 1.5 + )[[1]] + ) + if (subgroup) { + list(poly = ggplot() + + geom_polygon(aes(x, y, group = 1, subgroup = id), data = res)) + } else { + list(poly = ggplot() + + geom_polygon(aes(x, y, group = id), data = res)) + } +} + +compile <- function(viz) { + out_dir <- tempfile() + animint2dir(viz, out.dir = out_dir, open.browser = FALSE) + list( + json = jsonlite::fromJSON(file.path(out_dir, "plot.json")), + tsv = read.table( + file.path(out_dir, "geom1_polygon_poly_chunk1.tsv"), + header = TRUE, sep = "\t" + ), + dir = out_dir + ) +} + +m_simple <- matrix( + c(0, 0, 0, 0, 0, 0, + 0, 1, 1, 1, 1, 0, + 0, 1, 0, 0, 1, 0, + 0, 1, 0, 0, 1, 0, + 0, 1, 1, 1, 1, 0, + 0, 0, 0, 0, 0, 0), + 6, 6, byrow = TRUE) + +m_no_hole <- rbind( + c(0, 0, 0, 0, 0, 0, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 0, 0, 0, 0, 0, 0)) + +m_hole_and_mid <- rbind( + c(0, 0, 0, 0, 0, 0, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 1, 0, 0, 0, 1, 0), + c(0, 1, 0, 1, 0, 1, 0), + c(0, 1, 0, 0, 0, 1, 0), + c(0, 1, 1, 1, 1, 1, 0), + c(0, 0, 0, 0, 0, 0, 0)) + +## --- compiler tests (no browser needed) --- + +test_that("subgroup flag and TSV column present when subgroup used", { + out <- compile(make_viz(m_simple, subgroup = TRUE)) + expect_true(out$json$geoms$geom1_polygon_poly$data_has_subgroup) + expect_true("subgroup" %in% names(out$tsv)) + expect_equal(length(unique(out$tsv$subgroup)), 2) +}) + +test_that("subgroup flag absent when subgroup not used", { + out <- compile(make_viz(m_simple, subgroup = FALSE)) + expect_false(isTRUE(out$json$geoms$geom1_polygon_poly$data_has_subgroup)) +}) + +test_that("no_hole case has 1 subgroup, hole_and_mid has 3", { + out_no <- compile(make_viz(m_no_hole, subgroup = TRUE)) + expect_equal(length(unique(out_no$tsv$subgroup)), 1) + out_mid <- compile(make_viz(m_hole_and_mid, subgroup = TRUE)) + expect_equal(length(unique(out_mid$tsv$subgroup)), 3) +}) + +test_that("multiple groups with subgroup both appear in TSV", { + res1 <- as.data.table(isoband::isobands( + (1:ncol(m_simple)) / (ncol(m_simple) + 1), + (nrow(m_simple):1) / (nrow(m_simple) + 1), + m_simple, 0.5, 1.5)[[1]])[, grp := "A"] + res2 <- as.data.table(isoband::isobands( + (1:ncol(m_no_hole)) / (ncol(m_no_hole) + 1), + (nrow(m_no_hole):1) / (nrow(m_no_hole) + 1), + m_no_hole, 0.5, 1.5)[[1]])[, grp := "B"] + combined <- rbind(res1, res2) + viz_multi <- list( + poly = ggplot() + + geom_polygon(aes(x, y, group = grp, subgroup = id), data = combined) + ) + out_dir <- tempfile() + animint2dir(viz_multi, out.dir = out_dir, open.browser = FALSE) + tsv <- read.table( + file.path(out_dir, "geom1_polygon_poly_chunk1.tsv"), + header = TRUE, sep = "\t" + ) + expect_true("subgroup" %in% names(tsv)) + expect_equal(length(unique(tsv$group)), 2) +}) + +## --- renderer tests (browser required) --- + +res_A <- as.data.table(isoband::isobands( + (1:ncol(m_simple)) / (ncol(m_simple) + 1), + (nrow(m_simple):1) / (nrow(m_simple) + 1), + m_simple, 0.5, 1.5)[[1]])[, grp := "A"] +res_B <- as.data.table(isoband::isobands( + (1:ncol(m_no_hole)) / (ncol(m_no_hole) + 1), + (nrow(m_no_hole):1) / (nrow(m_no_hole) + 1), + m_no_hole, 0.5, 1.5)[[1]])[, grp := "B"] +res_click <- rbind(res_A, res_B) + +viz_click <- list( + poly = ggplot() + + geom_polygon( + aes(x, y, group = grp, subgroup = id, fill = grp, + id = paste0("poly_", grp)), + clickSelects = "grp", + data = res_click + ) +) + +info <- animint2HTML(viz_click) + +test_that("one path per group with evenodd fill-rule and multiple subpaths", { + html <- getHTML() + path_nodes <- getNodeSet(html, "//path[@class='geom']") + ## 2 groups A and B => 2 path elements (not 4) + expect_equal(length(path_nodes), 2) + ## fill-rule must be evenodd + styles <- sapply(path_nodes, xmlGetAttr, "style") + expect_true(any(grepl("evenodd", styles))) + ## group A (with hole) must have multiple closed subpaths (M commands) + d_vals <- sapply(path_nodes, xmlGetAttr, "d") + m_counts <- sapply(d_vals, function(d) length(gregexpr("M", d)[[1]])) + expect_true(any(m_counts >= 2)) +}) + +test_that("clickSelects works with subgroup polygons", { + ## click group A to deselect + clickID("poly_A") + Sys.sleep(1) + html_after <- getHTML() + path_nodes <- getNodeSet(html_after, "//path[@class='geom']") + expect_gt(length(path_nodes), 0) + ## click again to reselect + clickID("poly_A") + Sys.sleep(1) + html_restored <- getHTML() + path_nodes_restored <- getNodeSet(html_restored, "//path[@class='geom']") + expect_gte(length(path_nodes_restored), 1) +}) \ No newline at end of file