diff --git a/.ci/atime/tests.R b/.ci/atime/tests.R index ef0b910b9..af47079f8 100644 --- a/.ci/atime/tests.R +++ b/.ci/atime/tests.R @@ -10,5 +10,21 @@ test.list <- atime::atime_test_list( }, seconds.limit=1, Slow="352f7e10040cb9de6ddd16416d342e9746c14c7a", # Parent of the first commit (https://github.com/animint/animint2/commit/121a11399e7d6ca6c822cd22472886c6d4d8cf10) of the PR (https://github.com/animint/animint2/pull/238/commits). - Fast="30950779702e6c8aeecd24aeb737c9fa5ce898e0") # Last commit in the PR (https://github.com/animint/animint2/pull/238/commits). + Fast="30950779702e6c8aeecd24aeb737c9fa5ce898e0"), # Last commit in the PR (https://github.com/animint/animint2/pull/238/commits). + ## Post-#242 workload with NA groups and multiple common columns (#258) + "getCommonChunk post-#242 NA workload"=atime::atime_test( + expr=animint2:::getCommonChunk(built, "showSelected", list(group="group")), + setup={ + N <- 2000 + built <- data.table( + x=rep(1:5, length.out=N), + y=rnorm(N), + colour="foo", + group=rep(seq_len(N/4), each=4), + showSelected=rep(1:2, each=N/2), + na_group=rep(c(0,0,1,0), length.out=N), + row_in_group=rep(1:4, length.out=N) + ) + }, + seconds.limit=2) ) diff --git a/.gitignore b/.gitignore index 80b74d00b..d6b5367fb 100644 --- a/.gitignore +++ b/.gitignore @@ -11,4 +11,13 @@ *pids.txt *~ .vscode/settings.json -/node_modules \ No newline at end of file +/node_modules +*.o +*.so +*.dll +src/*.o +src/*.so +src/*.dll +vignettes/*.html +vignettes/*.knit.md +vignettes/*.utf8.md \ No newline at end of file diff --git a/DESCRIPTION b/DESCRIPTION index 73aad0d6f..10ab38ab5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -89,7 +89,8 @@ Imports: stats, knitr (>= 1.5.33), data.table (>= 1.9.8), - methods + methods, + Rcpp Suggests: gert, gitcreds, gh, sp, @@ -117,9 +118,11 @@ Suggests: chromote, magick License: GPL-3 +LinkingTo: Rcpp Encoding: UTF-8 LazyData: true Collate: + 'RcppExports.R' 'gganimintproto.r' 'aaa-.r' 'aes-calculated.r' @@ -229,6 +232,7 @@ Collate: 'position-stack.r' 'quick-plot.r' 'range.r' + 'rcpp-dynlib.R' 'save.r' 'scale-.r' 'scale-alpha.r' diff --git a/NAMESPACE b/NAMESPACE index 8f94a3988..166e5c13d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -503,6 +503,7 @@ export(ylab) export(ylim) export(zeroGrob) import(RJSONIO) +import(Rcpp) import(data.table) import(grid) import(gtable) @@ -526,3 +527,4 @@ importFrom(utils,packageVersion) importFrom(utils,str) importFrom(utils,tail) importFrom(utils,write.table) +useDynLib(animint2, .registration = TRUE) diff --git a/NEWS.md b/NEWS.md index 7d3d8c548..929f68974 100644 --- a/NEWS.md +++ b/NEWS.md @@ -2,6 +2,13 @@ - `geom(showSelected=character())` means to opt-out of interactive legends. Thanks @ANAMASGARD. +# Changes in version TBD (issue #258) + +- `getCommonChunk()` uses `detect_common_value_dt()` with a C++ fast path and per-column R fallback instead of the old nested per-column scan. +- `common_value_for_group_subset_cpp()` in C++ accelerates the inner compare in `getCommonChunk()`; R handles grouping; R fallback when unavailable. +- New unit tests in `test-compiler-getCommonChunk.R`. +- New atime benchmark for post-#242 NA common-chunk workload. Thanks @nishita-shah1 + # Changes in version 2026.3.8 (PR#311) - `geom_dotplot()` has been removed. Use `geom_point()` instead for interactive visualizations. (Fixed #289) diff --git a/R/RcppExports.R b/R/RcppExports.R new file mode 100644 index 000000000..96b9e4b29 --- /dev/null +++ b/R/RcppExports.R @@ -0,0 +1,7 @@ +# Generated by using Rcpp::compileAttributes() -> do not edit by hand +# Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +common_value_for_group_subset_cpp <- function(value_lists) { + .Call(`_animint2_common_value_for_group_subset_cpp`, value_lists) +} + diff --git a/R/rcpp-dynlib.R b/R/rcpp-dynlib.R new file mode 100644 index 000000000..0e2c047d0 --- /dev/null +++ b/R/rcpp-dynlib.R @@ -0,0 +1,3 @@ +#' @useDynLib animint2, .registration = TRUE +#' @import Rcpp +NULL diff --git a/R/z_animintHelpers.R b/R/z_animintHelpers.R index 0fa7791ac..f8d51a5b3 100644 --- a/R/z_animintHelpers.R +++ b/R/z_animintHelpers.R @@ -761,6 +761,66 @@ getTextSize <- function(element.name, theme){ paste(input.size, "pt", sep="") } +##' Common values for one (column, group) across chunk.vars subsets. +##' @param value_lists list of atomic vectors, one per chunk.vars level. +##' @return list with common (list of length 1) and is.common (logical). +##' @keywords internal +common_value_for_group_subset <- function(value_lists){ + if(isTRUE(getOption("animint2.use.cpp", TRUE))){ + cpp_out <- tryCatch( + common_value_for_group_subset_cpp(value_lists), + error=function(e) NULL + ) + if(!is.null(cpp_out)) return(cpp_out) + } + lvec <- vapply(value_lists, length, integer(1)) + value.vec <- unlist(value_lists, use.names=FALSE) + if(length(lvec) > 0 && all(lvec[1] == lvec)){ + group.size <- lvec[1] + m <- matrix(value.vec, group.size) + min.na.vec <- apply(m, 1, function(x) x[!is.na(x)][1]) + if(length(unique(min.na.vec)) == 1){ + min.na.vec <- min.na.vec[1] + } + list( + common=list(min.na.vec), + is.common=all(m == min.na.vec, na.rm=TRUE) + ) + }else if(length(unique(value.vec)) == 1){ + list(common=list(value.vec[1]), is.common=TRUE) + }else{ + list(common=list(), is.common=FALSE) + } +} + +##' Detect common column values for each group. +##' Grouping stays in R; inner compare may use C++ via +##' common_value_for_group_subset(). +##' @param built data.table keyed by group and chunk.vars. +##' @param col.name.vec candidate column names. +##' @param chunk.vars chunk variable names. +##' @return data.table with col.name, group, common, is.common. +##' @keywords internal +detect_common_value_dt <- function(built, col.name.vec, chunk.vars){ + group <- col.name <- value <- common <- is.common <- NULL + if(length(col.name.vec) == 0){ + return(data.table( + col.name=character(), + group=integer(), + common=list(), + is.common=logical() + )) + } + chunk.cols <- chunk.vars + rbindlist(lapply(col.name.vec, function(cn) { + built[, { + group_dt <- .SD[, list(value_list = list(get(cn))), by = chunk.cols] + cv <- common_value_for_group_subset(group_dt$value_list) + list(common = cv$common, is.common = cv$is.common) + }, by = group][, col.name := cn] + })) +} + ##' Save the common columns for each tsv to one chunk ##' @param built data.frame of built data. ##' @param chunk.vars which variables to chunk on. @@ -771,7 +831,7 @@ getTextSize <- function(element.name, theme){ ##' @importFrom stats na.omit ##' @import data.table getCommonChunk <- function(built, chunk.vars, aes.list){ - group <- col.name <- group.size <- ok <- all.common <- size <- showSelected_values <- common <- NULL + group <- col.name <- group.size <- ok <- all.common <- size <- showSelected_values <- common <- is.common <- NULL ## Above to avoid CRAN NOTE. if(length(chunk.vars) == 0){ return(NULL) @@ -797,8 +857,6 @@ getCommonChunk <- function(built, chunk.vars, aes.list){ g_chunk <- c("group", chunk.vars) setkeyv(built, g_chunk) group_size_dt <- built[, .(size=.N), by=c("group",chunk.vars)] - ## first_ss_dt <- built[, .SD[1], by=group, .SDcols=chunk.vars] - ## setkeyv(first_ss_dt, g_chunk) ss_count_dt <- group_size_dt[, .( showSelected_values=.N, min_size=min(size), @@ -806,28 +864,8 @@ getCommonChunk <- function(built, chunk.vars, aes.list){ ), by=group] groups_in_several_ss <- ss_count_dt[showSelected_values>1] if(nrow(groups_in_several_ss)==0)return(NULL) - common_value_dt <- data.table(col.name=col.name.vec)[, { - built[, { - group_dt <- .SD[, list(value_list=list(get(col.name))), by=chunk.vars] - lvec <- sapply(group_dt$value_list, length) - value.vec <- unlist(group_dt$value_list) - if(all(lvec[1]==lvec)){ - group.size <- lvec[1] - m <- matrix(value.vec, group.size) - min.na.vec <- apply(m,1,function(x)x[!is.na(x)][1]) - if(length(unique(min.na.vec))==1){ - min.na.vec <- min.na.vec[1] - } - is.common <- all(m==min.na.vec,na.rm=TRUE) - ##if(anyNA(min.na.vec))is.common <- FALSE #TODO maybe could relax? - data.table(common=list(min.na.vec), is.common) - }else if(length(unique(value.vec))==1){ - data.table(common=list(value.vec[1]), is.common=TRUE) - }else{ - data.table(common=list(), is.common=FALSE) - } - }, by=group] - }, keyby=col.name] + common_value_dt <- detect_common_value_dt(built, col.name.vec, chunk.vars) + setkeyv(common_value_dt, "col.name") common_var_dt <- common_value_dt[, .( all.common=all(is.common) ), keyby=col.name] diff --git a/build.sh b/build.sh index ce573b3cb..74faa89bc 100644 --- a/build.sh +++ b/build.sh @@ -23,6 +23,7 @@ rm animint2-release/tests/testthat/helper-HTML.R rm animint2-release/tests/testthat/test-compiler-chunk-vars.R rm animint2-release/tests/testthat/test-compiler-ghpages.R rm animint2-release/vignettes/animint2.Rmd #to save disk space +rm animint2-release/vignettes/get-common-chunk-cpp.Rmd # CRAN release has no VignetteBuilder cat < animint2-release/tests/testthat.R library(testthat) data.table::setDTthreads(1) diff --git a/man/checkSelectorNames.Rd b/man/checkSelectorNames.Rd new file mode 100644 index 000000000..c8ffe6875 --- /dev/null +++ b/man/checkSelectorNames.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/z_animintHelpers.R +\name{checkSelectorNames} +\alias{checkSelectorNames} +\title{Validate selector names for CSS compatibility} +\usage{ +checkSelectorNames(selectors) +} +\arguments{ +\item{selectors}{selectors to validate} +} +\value{ +\code{NULL}. Throws error if invalid characters found. +} +\description{ +Validate selector names for CSS compatibility +} diff --git a/man/common_value_for_group_subset.Rd b/man/common_value_for_group_subset.Rd new file mode 100644 index 000000000..87d9e3554 --- /dev/null +++ b/man/common_value_for_group_subset.Rd @@ -0,0 +1,18 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/z_animintHelpers.R +\name{common_value_for_group_subset} +\alias{common_value_for_group_subset} +\title{Common values for one (column, group) across chunk.vars subsets.} +\usage{ +common_value_for_group_subset(value_lists) +} +\arguments{ +\item{value_lists}{list of atomic vectors, one per chunk.vars level.} +} +\value{ +list with common (list of length 1) and is.common (logical). +} +\description{ +Common values for one (column, group) across chunk.vars subsets. +} +\keyword{internal} diff --git a/man/detect_common_value_dt.Rd b/man/detect_common_value_dt.Rd new file mode 100644 index 000000000..c06787e3b --- /dev/null +++ b/man/detect_common_value_dt.Rd @@ -0,0 +1,26 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/z_animintHelpers.R +\name{detect_common_value_dt} +\alias{detect_common_value_dt} +\title{Detect common column values for each group. +Grouping stays in R; inner compare may use C++ via +common_value_for_group_subset().} +\usage{ +detect_common_value_dt(built, col.name.vec, chunk.vars) +} +\arguments{ +\item{built}{data.table keyed by group and chunk.vars.} + +\item{col.name.vec}{candidate column names.} + +\item{chunk.vars}{chunk variable names.} +} +\value{ +data.table with col.name, group, common, is.common. +} +\description{ +Detect common column values for each group. +Grouping stays in R; inner compare may use C++ via +common_value_for_group_subset(). +} +\keyword{internal} diff --git a/src/RcppExports.cpp b/src/RcppExports.cpp new file mode 100644 index 000000000..89d58e6fd --- /dev/null +++ b/src/RcppExports.cpp @@ -0,0 +1,33 @@ +// Generated by using Rcpp::compileAttributes() -> do not edit by hand +// Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393 + +#include + +using namespace Rcpp; + +#ifdef RCPP_USE_GLOBAL_ROSTREAM +Rcpp::Rostream& Rcpp::Rcout = Rcpp::Rcpp_cout_get(); +Rcpp::Rostream& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get(); +#endif + +// common_value_for_group_subset_cpp +List common_value_for_group_subset_cpp(List value_lists); +RcppExport SEXP _animint2_common_value_for_group_subset_cpp(SEXP value_listsSEXP) { +BEGIN_RCPP + Rcpp::RObject rcpp_result_gen; + Rcpp::RNGScope rcpp_rngScope_gen; + Rcpp::traits::input_parameter< List >::type value_lists(value_listsSEXP); + rcpp_result_gen = Rcpp::wrap(common_value_for_group_subset_cpp(value_lists)); + return rcpp_result_gen; +END_RCPP +} + +static const R_CallMethodDef CallEntries[] = { + {"_animint2_common_value_for_group_subset_cpp", (DL_FUNC) &_animint2_common_value_for_group_subset_cpp, 1}, + {NULL, NULL, 0} +}; + +RcppExport void R_init_animint2(DllInfo *dll) { + R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); + R_useDynamicSymbols(dll, FALSE); +} diff --git a/src/get_common_chunk.cpp b/src/get_common_chunk.cpp new file mode 100644 index 000000000..5dd483150 --- /dev/null +++ b/src/get_common_chunk.cpp @@ -0,0 +1,153 @@ +#include +#include +#include + +using namespace Rcpp; + +namespace { + +bool is_na_at(SEXP v, int i) { + switch (TYPEOF(v)) { + case REALSXP: return ISNA(REAL(v)[i]); + case INTSXP: return INTEGER(v)[i] == NA_INTEGER; + case LGLSXP: return LOGICAL(v)[i] == NA_LOGICAL; + case STRSXP: return STRING_ELT(v, i) == NA_STRING; + default: return false; + } +} + +bool eq_at(SEXP a, int ia, SEXP b, int ib) { + if (TYPEOF(a) != TYPEOF(b)) return false; + switch (TYPEOF(a)) { + case REALSXP: { + double da = REAL(a)[ia], db = REAL(b)[ib]; + return (ISNA(da) && ISNA(db)) || da == db; + } + case INTSXP: { + int da = INTEGER(a)[ia], db = INTEGER(b)[ib]; + return (da == NA_INTEGER && db == NA_INTEGER) || da == db; + } + case LGLSXP: { + int da = LOGICAL(a)[ia], db = LOGICAL(b)[ib]; + return (da == NA_LOGICAL && db == NA_LOGICAL) || da == db; + } + case STRSXP: + return STRING_ELT(a, ia) == STRING_ELT(b, ib); + default: + return false; + } +} + +SEXP scalar_at(SEXP v, int i) { + switch (TYPEOF(v)) { + case REALSXP: return Rf_ScalarReal(REAL(v)[i]); + case INTSXP: return Rf_ScalarInteger(INTEGER(v)[i]); + case LGLSXP: return Rf_ScalarLogical(LOGICAL(v)[i]); + case STRSXP: return Rf_ScalarString(STRING_ELT(v, i)); + default: return R_NilValue; + } +} + +bool all_same(const std::vector& xs) { + if (xs.empty()) return false; + for (size_t k = 1; k < xs.size(); ++k) { + if (!eq_at(xs[0], 0, xs[k], 0)) return false; + } + return true; +} + +SEXP scalars_to_vector(const std::vector& xs) { + if (xs.empty()) return R_NilValue; + const int n = static_cast(xs.size()); + switch (TYPEOF(xs[0])) { + case REALSXP: { + NumericVector out(n); + for (int i = 0; i < n; ++i) out[i] = REAL(xs[i])[0]; + return out; + } + case INTSXP: { + IntegerVector out(n); + for (int i = 0; i < n; ++i) out[i] = INTEGER(xs[i])[0]; + return out; + } + case LGLSXP: { + LogicalVector out(n); + for (int i = 0; i < n; ++i) out[i] = LOGICAL(xs[i])[0]; + return out; + } + case STRSXP: { + CharacterVector out(n); + for (int i = 0; i < n; ++i) out[i] = STRING_ELT(xs[i], 0); + return out; + } + default: + return xs[0]; + } +} + +List wrap_common(SEXP x) { + return List::create(x); +} + +} // namespace + +// [[Rcpp::export]] +List common_value_for_group_subset_cpp(List value_lists) { + const int nchunks = value_lists.size(); + if (nchunks == 0) { + return List::create(Named("common") = List(), Named("is.common") = false); + } + std::vector vecs(nchunks); + std::vector lvec(nchunks); + for (int c = 0; c < nchunks; ++c) { + vecs[c] = value_lists[c]; + lvec[c] = Rf_length(vecs[c]); + } + if (lvec[0] > 0 && std::equal(lvec.begin() + 1, lvec.end(), lvec.begin())) { + const int gs = lvec[0]; + std::vector min_na(gs, R_NilValue); + for (int r = 0; r < gs; ++r) { + for (int c = 0; c < nchunks; ++c) { + if (!is_na_at(vecs[c], r)) { + min_na[r] = scalar_at(vecs[c], r); + break; + } + } + if (min_na[r] == R_NilValue) min_na[r] = scalar_at(vecs[0], r); + } + const bool ref_scalar = all_same(min_na); + const SEXP ref0 = min_na[0]; + bool is_common = true; + for (int c = 0; c < nchunks && is_common; ++c) { + for (int r = 0; r < gs; ++r) { + if (is_na_at(vecs[c], r)) continue; + SEXP ref = ref_scalar ? ref0 : min_na[r]; + if (!eq_at(vecs[c], r, ref, 0)) { + is_common = false; + break; + } + } + } + if (ref_scalar) { + return List::create( + Named("common") = wrap_common(ref0), + Named("is.common") = is_common + ); + } + return List::create( + Named("common") = wrap_common(scalars_to_vector(min_na)), + Named("is.common") = is_common + ); + } + std::vector flat; + for (int c = 0; c < nchunks; ++c) { + for (int r = 0; r < lvec[c]; ++r) flat.push_back(scalar_at(vecs[c], r)); + } + if (!flat.empty() && all_same(flat)) { + return List::create( + Named("common") = wrap_common(flat[0]), + Named("is.common") = true + ); + } + return List::create(Named("common") = List(), Named("is.common") = false); +} diff --git a/tests/testthat/test-compiler-getCommonChunk.R b/tests/testthat/test-compiler-getCommonChunk.R new file mode 100644 index 000000000..b5d400c52 --- /dev/null +++ b/tests/testthat/test-compiler-getCommonChunk.R @@ -0,0 +1,158 @@ +context("getCommonChunk") +## Pure unit test: no tests_init(), servr (port 4848), or browser required. +library(data.table) + +expect_common_varied <- function(result, common_cols, varied_cols) { + expect_type(result, "list") + expect_named(result, c("common", "varied")) + expect_true(all(common_cols %in% names(result$common))) + expect_false(any(varied_cols %in% names(result$common))) +} + +test_that("NULL when chunk.vars empty", { + built <- data.table(x = 1:4, group = 1:4) + expect_null(animint2:::getCommonChunk(built, character(), list(group = "group"))) +}) + +test_that("NULL when only one chunk subset", { + built <- data.table( + x = 1:4, + y = 5:8, + group = 1:4, + showSelected = 1 + ) + expect_null(animint2:::getCommonChunk(built, "showSelected", list(group = "group"))) +}) + +test_that("NULL when no group appears in multiple subsets", { + built <- data.table( + x = 1:4, + y = 5:8, + group = 1:4, + showSelected = 1:4 + ) + expect_null(animint2:::getCommonChunk(built, "showSelected", list(group = "group"))) +}) + +test_that("polygon-like data splits x,y into common chunk", { + ## Each group appears in showSelected 1 and 2; x,y fixed per group; fill varies. + built <- data.table( + group = rep(1:2, each = 4), + showSelected = rep(c(1, 1, 2, 2), 2), + x = rep(c(10, 20), each = 4), + y = rep(c(1, 2), each = 4), + fill = c("a", "a", "b", "b", "c", "c", "d", "d") + ) + result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + expect_common_varied(result, c("x", "y", "group"), "fill") + expect_equal(nrow(result$common), 2) +}) + +test_that("colour common but xy varied", { + built <- data.table( + group = rep(c("left", "right"), each = 4), + showSelected = rep(c("A", "A", "B", "B"), 2), + x = 1:8, + y = c(6, 6, 7, 7, 8, 8, 9, 9), + colour = "foo", + constant = "bar" + ) + result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + expect_common_varied(result, c("colour", "constant", "group"), c("x", "y")) +}) + +test_that("xy common but colour varied", { + built <- data.table( + group = rep(c("left", "right"), each = 4), + showSelected = rep(c("A", "A", "B", "B"), 2), + x = rep(c(1, 2), each = 4), + y = rep(c(7, 8), each = 4), + colour = c("red", "red", "blue", "blue", "green", "gold", "green", "gold") + ) + result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + expect_common_varied(result, c("x", "y", "group"), "colour") +}) + +test_that("single common column with multi-row group is allowed (#255)", { + built <- data.table( + group = rep(1:2, each = 4), + showSelected = rep(c(1, 1, 2, 2), 2), + x = c(10, 20, 10, 20, 30, 40, 30, 40), + y = rnorm(8), + colour = rnorm(8) + ) + result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + expect_common_varied(result, c("x", "group"), c("y", "colour")) +}) + +test_that("single common column with one row per group returns NULL", { + built <- data.table( + x = 1:4, + y = rnorm(4), + group = 1:4, + colour = "red", + showSelected = rep(1:2, each = 2) + ) + expect_null(animint2:::getCommonChunk(built, "showSelected", list(group = "group"))) +}) + +test_that("NA paths keep na_group and row_in_group in varied data", { + built <- data.table( + group = rep(1:2, each = 4), + showSelected = rep(c(1, 1, 2, 2), 2), + x = c(NA, 2, NA, 2, NA, 5, NA, 5), + y = 1:8, + na_group = c(0, 0, 1, 0, 0, 0, 1, 0), + row_in_group = c(1, 2, 1, 2, 1, 2, 1, 2) + ) + result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + expect_type(result, "list") + chunk1 <- result$varied[["1"]] + expect_true(all(c("na_group", "row_in_group", "y") %in% names(chunk1))) + expect_false("x" %in% names(chunk1)) +}) + +test_that("factors are treated as character", { + built <- data.table( + group = rep(1:2, each = 4), + showSelected = factor(rep(c(1, 1, 2, 2), 2)), + x = rep(c(10, 20), each = 4), + y = rep(c(1, 2), each = 4), + fill = factor(c("a", "a", "b", "b", "c", "c", "d", "d")) + ) + result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + expect_common_varied(result, c("x", "y", "group"), "fill") +}) + +test_that("C++ and R detect_common_value_dt agree", { + built <- data.table( + group = rep(1:2, each = 4), + showSelected = rep(c(1, 1, 2, 2), 2), + x = rep(c(10, 20), each = 4), + y = rep(c(1, 2), each = 4), + colour = rep(c("r", "g"), each = 4), + na_group = 0, + row_in_group = 1:4 + ) + chunk.vars <- "showSelected" + col.name.vec <- c("x", "y", "colour") + setkeyv(built, c("group", chunk.vars)) + r_dt <- with( + options(animint2.use.cpp = FALSE), + animint2:::detect_common_value_dt(built, col.name.vec, chunk.vars) + ) + if(exists("common_value_for_group_subset_cpp", where = asNamespace("animint2"), mode = "function")){ + cpp_dt <- animint2:::detect_common_value_dt(built, col.name.vec, chunk.vars) + setorder(r_dt, col.name, group) + setorder(cpp_dt, col.name, group) + expect_equal(nrow(r_dt), nrow(cpp_dt)) + expect_equal(r_dt$col.name, cpp_dt$col.name) + expect_equal(r_dt$group, cpp_dt$group) + expect_equal(r_dt$is.common, cpp_dt$is.common) + for(i in seq_len(nrow(r_dt))){ + expect_equal(r_dt$common[[i]], cpp_dt$common[[i]]) + } + } else { + skip("C++ not compiled") + } +}) diff --git a/vignettes/get-common-chunk-cpp.Rmd b/vignettes/get-common-chunk-cpp.Rmd new file mode 100644 index 000000000..31486ed52 --- /dev/null +++ b/vignettes/get-common-chunk-cpp.Rmd @@ -0,0 +1,383 @@ +--- +title: "get_common_chunk.cpp: C++ common chunk detection" +author: "animint2 contributors" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{get_common_chunk.cpp: C++ common chunk detection} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set(collapse = TRUE, comment = "#>") +``` + +Guide to the issue [#258](https://github.com/animint/animint2/issues/258) C++ work for +`getCommonChunk()`: what each file does, how the code fits together, and how to test it. + +## Problem + +Interactive plots split geom data into multiple chunk TSV files (one per selector value). +Often `x`, `y`, and `group` are identical across chunks; only `fill` (or similar) changes. + +``` +geom1_polygon_chunk_common.tsv -> x, y, group (written once) +geom1_polygon_chunk1.tsv -> fill, group +geom1_polygon_chunk2.tsv -> fill, group +``` + +`getCommonChunk()` detects shared columns at compile time and splits output into a +common TSV plus smaller varied TSVs. The browser merges them with `copy_chunk()` in +`inst/htmljs/animint.js`. + +## Architecture (current) + +C++ handles **inner compare only** (~154 lines). R handles grouping, assembly, and file I/O. + +``` +geom-.r + └─ getCommonChunk() [R/z_animintHelpers.R] + └─ detect_common_value_dt() [R: per-column grouping loop] + └─ common_value_for_group_subset() + ├─ common_value_for_group_subset_cpp() [src/get_common_chunk.cpp] + └─ R fallback + └─ dcast, split_recursive, varied.chunk + └─ fwrite *_chunk_common.tsv [geom-.r] + └─ saveChunks() -> *_chunkN.tsv [R/z_animintHelpers.R] + +Browser: copy_chunk() in inst/htmljs/animint.js +``` + +## Files changed for issue #258 + +| File | Role | +|------|------| +| `src/get_common_chunk.cpp` | C++ inner compare (`common_value_for_group_subset_cpp`) | +| `src/RcppExports.cpp` | Auto-generated `.Call` registration | +| `R/RcppExports.R` | R wrapper calling C++ | +| `R/z_animintHelpers.R` | `common_value_for_group_subset()`, `detect_common_value_dt()`, `getCommonChunk()` | +| `R/geom-.r` | Calls `getCommonChunk()`; adds `na_group`, `row_in_group` (unchanged API) | +| `DESCRIPTION` | `Imports: Rcpp`, `LinkingTo: Rcpp` | +| `NAMESPACE` | `useDynLib(animint2, .registration = TRUE)` | +| `tests/testthat/test-compiler-getCommonChunk.R` | 11 unit tests | +| `.ci/atime/tests.R` | Performance benchmark for post-#242 NA workload | +| `NEWS.md` | Changelog entry | + + +--- + +## File: `src/get_common_chunk.cpp` + +**Exported function:** `common_value_for_group_subset_cpp(List value_lists)` + +**Input:** list of atomic vectors, one per chunk subset (e.g. each `showSelected` level) +for one `(column, group)`. + +**Output:** named list: + +```r +list(common = list(...), is.common = TRUE/FALSE) +``` + +Must match R shape: `common` is a list of length 1 whose element is an atomic vector +(or scalar). Use `wrap_common()` in C++ so data.table does not duplicate rows. + +### Internal helpers + +| Function | Lines (approx) | Role | +|----------|----------------|------| +| `is_na_at(v, i)` | 9-17 | NA test on vector element | +| `eq_at(a, ia, b, ib)` | 19-39 | Equal with NA = NA | +| `scalar_at(v, i)` | 41-49 | One cell as SEXP via `Rf_Scalar*` | +| `all_same(xs)` | 51-57 | All scalars equal | +| `scalars_to_vector(xs)` | 59-86 | Build atomic vector for R `common` | +| `wrap_common(x)` | 88-90 | `list(x)` wrapper | +| `common_value_for_group_subset_cpp` | 94-153 | Exported entry point | + +### Algorithm (mirrors R `common_value_for_group_subset()`) + +1. If all chunk vectors have equal length: build matrix, `min_na` per row, NA-tolerant + compare (PR #242). +2. Else if one unique value across all elements: scalar common. +3. Else: not common (`common = list()`, `is.common = FALSE`). + +### Design + +- R groups; C++ compares (small review surface). +- No file I/O in C++. +- `Rf_Scalar*` required on Windows / R 4.5+. +- SEXP types preserve mixed column types (numeric, character, etc.). + +--- + +## File: `R/z_animintHelpers.R` + +### `common_value_for_group_subset(value_lists)` + +~20 lines. Core R logic. Calls C++ when compiled: + +```r +if (isTRUE(getOption("animint2.use.cpp", TRUE))) { + cpp_out <- tryCatch( + common_value_for_group_subset_cpp(value_lists), + error = function(e) NULL + ) + if (!is.null(cpp_out)) return(cpp_out) +} +# R fallback: matrix + min.na.vec + all(..., na.rm = TRUE) +``` + +### `detect_common_value_dt(built, col.name.vec, chunk.vars)` + +Loops columns. For each column, groups by `group`, splits by `chunk.vars`, calls +`common_value_for_group_subset()` on each group's chunk vectors. + +Per-column loop (not `melt()`) keeps mixed column types correct. + +### `getCommonChunk(built, chunk.vars, aes.list)` + +Public entry used from `geom-.r`: + +1. Early exits (no chunk vars, one subset, no group in multiple subsets). +2. `detect_common_value_dt()` to find common columns. +3. If 2+ common columns (partial) or 1 common column with multi-row group (#255): + build `common` data.frame and `varied` nested list via `split_recursive()` / + `varied.chunk()`. +4. Return `list(common = ..., varied = ...)` or `NULL`. + +--- + +## File: `R/RcppExports.R` + +Auto-generated by `Rcpp::compileAttributes()`: + +```r +common_value_for_group_subset_cpp <- function(value_lists) { + .Call(`_animint2_common_value_for_group_subset_cpp`, value_lists) +} +``` + +--- + +## File: `R/geom-.r` + +Before `getCommonChunk()`: + +- Sets default `group = 1` when user omits `aes(group)` (#255). +- Adds `na_group` and `row_in_group` for NA path handling (#242). + +Then: + +```r +data.or.null <- getCommonChunk(g.data, chunk.cols, g$aes) +``` + +If non-NULL, writes `*_chunk_common.tsv` and passes `varied` to `saveChunks()`. + +--- + +## File: `inst/htmljs/animint.js` + +`copy_chunk(g_info, varied_chunk)` merges downloaded varied TSV rows with cached +common TSV rows. When NAs split paths, `row_in_group` picks the matching common row. + +--- + +## Why SEXP? + +**SEXP** = **S EXpression**, R's universal C type. Comparisons use R NA rules across +numeric, integer, logical, and character columns. + +| Name | Meaning | +|------|---------| +| `is_na_at(v, i)` | Is row `i` of vector `v` NA? | +| `eq_at(a, ia, b, ib)` | Equal with NA = NA? | +| `scalar_at(v, i)` | One cell as length-1 SEXP | + +--- + +## Worked example + +| row | group | showSelected | x | y | fill | +|-----|-------|--------------|---|---|------| +| 0 | 1 | 1 | 10 | 1 | a | +| 1 | 1 | 1 | 20 | 1 | a | +| 2 | 1 | 2 | 10 | 2 | b | +| 3 | 1 | 2 | 20 | 2 | b | +| 4 | 2 | 1 | 30 | 1 | c | +| 5 | 2 | 1 | 40 | 1 | c | +| 6 | 2 | 2 | 30 | 2 | d | +| 7 | 2 | 2 | 40 | 2 | d | + +For group 1, column `x`: chunks `[10, 20]` and `[10, 20]` -> common. +Column `fill`: `[a, a]` vs `[b, b]` -> not common. + +Result: common TSV has `x`, `y`, `group`; varied chunks have `fill` only. + +```{r quick-example, eval=FALSE} +library(animint2) +library(data.table) + +built <- data.table( + group = rep(1:2, each = 4), + showSelected = rep(c(1, 1, 2, 2), 2), + x = rep(c(10, 20), each = 4), + y = rep(c(1, 2), each = 4), + fill = c("a", "a", "b", "b", "c", "c", "d", "d") +) +setkeyv(built, c("group", "showSelected")) + +dt <- animint2:::detect_common_value_dt(built, c("x", "y", "fill"), "showSelected") +dt[, .(col.name, group, is.common)] + +result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) +names(result$common) +result$varied +``` + +During development use `devtools::load_all()` instead of `library(animint2)`. + +## NA example (PR #242) + +| group | showSelected | x | +|-------|--------------|---| +| 1 | 1 | NA | +| 1 | 1 | 2 | +| 1 | 2 | NA | +| 1 | 2 | 2 | + +Chunks `[NA, 2]` vs `[NA, 2]`: row 1 NA skipped, row 2 matches -> `x` is common. + +--- + +## Tests + +**File:** `tests/testthat/test-compiler-getCommonChunk.R` + +Pure unit tests: no browser, no `tests_init()`, no port 4848 server. + +| Test | What it checks | +|------|----------------| +| `NULL when chunk.vars empty` | Early exit | +| `NULL when only one chunk subset` | Early exit | +| `NULL when no group appears in multiple subsets` | Early exit | +| `polygon-like data splits x,y into common chunk` | Typical map/polygon case | +| `colour common but xy varied` | Partial common (2+ common cols) | +| `xy common but colour varied` | Partial common | +| `single common column with multi-row group is allowed (#255)` | One common col OK | +| `single common column with one row per group returns NULL` | One common col rejected | +| `NA paths keep na_group and row_in_group in varied data` | PR #242 sparse cols | +| `factors are treated as character` | Factor coercion | +| `C++ and R detect_common_value_dt agree` | C++ vs R fallback match | + +### Run tests (fast) + +From package root: + +```{r run-tests, eval=FALSE} +library(devtools) +load_all() +library(testthat) +library(data.table) + +testthat::test_file("tests/testthat/test-compiler-getCommonChunk.R") +``` + +Expected: `[ FAIL 0 | WARN 0 | SKIP 0 | PASS 38 ]` (11 tests, 38 expectations). + +Skip `tests_init()` and `helper-HTML.R` for this file; they are only for renderer tests. + +### Compare C++ vs R manually + +```{r compare-cpp-r, eval=FALSE} +options(animint2.use.cpp = FALSE) # R inner compare only +r_result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + +options(animint2.use.cpp = TRUE) # C++ inner compare (default) +cpp_result <- animint2:::getCommonChunk(built, "showSelected", list(group = "group")) + +identical(r_result, cpp_result) +``` + +### Existing integration tests (should still pass) + +After changing `getCommonChunk()` code, also run: + +```{r integration-tests, eval=FALSE} +files <- c( + "test-compiler-save-separate-chunks.R", + "test-renderer1-chunk-vars.R", + "test-renderer3-chunk-NA-separate-lines.R", + "test-renderer1-chunk-WorldBank-NA.R", + "test-renderer2-VariantModels.R" +) +for (f in files) { + testthat::test_file(file.path("tests/testthat", f)) +} +``` + +Integration tests need `tests_init()` (browser + servr on port 4848). + +### Performance benchmark + +```{r atime, eval=FALSE} +install.packages("atime") +source(".ci/atime/tests.R") +atime::atime(test.list = test.list) +``` + +Benchmarks: `getCommonChunk improved in #238` and `getCommonChunk post-#242 NA workload`. + +### Windows setup + +C++ requires Rtools matching your R version. If `devtools::load_all()` fails: + +```powershell +winget install RProject.Rtools --accept-package-agreements --accept-source-agreements +$env:Path = "C:\rtools45\usr\bin;C:\rtools45\mingw64\bin;" + $env:Path +``` + +--- + +## Debug options + +```{r debug, eval=FALSE} +options(animint2.use.cpp = FALSE) # force R inner compare +options(animint2.use.cpp = TRUE) # restore default + +# verify C++ compiled +"common_value_for_group_subset_cpp" %in% ls(asNamespace("animint2"), all = TRUE) +``` + +--- + +## Issue history (brief) + +| PR | Change | +|----|--------| +| [#238](https://github.com/animint/animint2/pull/238) | Vectorized R; faster but incomplete | +| [#242](https://github.com/animint/animint2/pull/242) | NA matrix logic, `na_group`, `row_in_group` | +| [#255](https://github.com/animint/animint2/pull/255) | `group = 1` default, single common column, points | +| [#258](https://github.com/animint/animint2/issues/258) | C++ inner compare; R grouping unchanged | + +--- + +## C++ to R mapping + +| C++ | R (`R/z_animintHelpers.R`) | +|-----|----------------------------| +| `common_value_for_group_subset_cpp` | `common_value_for_group_subset()` | +| matrix + NA loop | `all(m == min.na.vec, na.rm = TRUE)` | +| `is_na_at` / `eq_at` | `is.na` / `==` with `na.rm` | +| (grouping) | `detect_common_value_dt()` per-column loop | + +--- + +## References + +- [Issue #258](https://github.com/animint/animint2/issues/258) +- [PR #238](https://github.com/animint/animint2/pull/238) +- [PR #242](https://github.com/animint/animint2/pull/242) +- [PR #255](https://github.com/animint/animint2/pull/255) +- `tests/testthat/test-compiler-getCommonChunk.R`