diff --git a/NAMESPACE b/NAMESPACE index ca77029a5..d2c0622f2 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -99,6 +99,12 @@ export(gintervals.union) export(gintervals.update) export(giterator.cartesian_grid) export(giterator.intervals) +export(glm_batch_quantiles) +export(glm_extract_features) +export(glm_pred.create) +export(glm_pred.info) +export(glm_pred.ls) +export(glm_pred.rm) export(glookup) export(gpartition) export(gquantiles) @@ -192,11 +198,15 @@ importFrom(utils,write.table) useDynLib(misha,C_gcis_decay) useDynLib(misha,C_gcompute_strands_autocorr) useDynLib(misha,C_gextract) +useDynLib(misha,C_glm_extract_features) useDynLib(misha,C_gpartition) useDynLib(misha,C_gquantiles) +useDynLib(misha,C_gquantiles_multi) useDynLib(misha,C_gsample) useDynLib(misha,C_gscreen) +useDynLib(misha,C_gscreen_multi) useDynLib(misha,C_gsegment) +useDynLib(misha,C_gsummary_multi) useDynLib(misha,C_gwilcox) useDynLib(misha,garrays_import) useDynLib(misha,gbins_quantiles) diff --git a/NEWS.md b/NEWS.md index e178fdb41..2c40e34c6 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,3 +1,12 @@ +# misha (development version) + +### New features + +* New `glm_pred` virtual track type: a fused per-position GLM predictor over an arbitrary number of motif tracks with multi-axis strata defined by `selector_tracks` + `selector_breaks`. `glm_pred.create()` writes the model, `glm_pred.ls/info/rm` manage it, and the track is consumed via the usual `gextract` / `gscreen` paths. Weights/bias/interaction weights are labeled multi-axis arrays (`dim = c(N, K_1, ..., K_M)`); single-selector still accepts a plain `matrix(N, K_1)`. +* Added `glm_extract_features()`: single C++ call that replaces the R training-side pipeline (chunked `gextract` -> scale -> pivot -> logistic transforms -> GC interactions) with one pass over motif + GC tracks, returning the full `n_peaks x n_features` matrix. Multithreaded with per-chromosome handle reuse. +* Added `glm_batch_quantiles()`: parallel exact genome-wide quantiles for a batch of motif tracks (e.g. p=0.9999 per-motif caps for `glm_extract_features`). Bypasses `gquantiles` / virtual tracks; ~1.7x faster per track. +* `gquantiles`, `gsummary`, `gscreen` accept a vector of expressions and return a `data.frame` for multi-track calls (single-expression matrix returns unchanged). An optimized C++ fast path runs automatically for bare-track / simple-vtrack shapes in `gsummary` / `gscreen`; `gquantiles` opts in via `fast = TRUE` (>=5x faster for extreme quantiles on a 10-motif benchmark). + # misha 5.10.2 * **Performance fix:** a single-function `lse` (or `sum`/`exists`/`size`) virtual track scanned over a sliding window (`gvtrack.iterator(sshift=, eshift=)`) genome-wide is fast again. Since 5.6.7 a single-function "fast path" recomputed the windowed reduction from scratch on every step, bypassing the incremental sliding-window path; the common motif-energy quantile workload (windowed `lse` + `gquantiles`/`gscreen`) was ~2.5x slower (worse with wider windows). Such single-function reducers now keep the sliding-window path. Output is unchanged. diff --git a/R/batch-dispatch.R b/R/batch-dispatch.R new file mode 100644 index 000000000..1422eef47 --- /dev/null +++ b/R/batch-dispatch.R @@ -0,0 +1,327 @@ +# Internal helpers for the batched fast-path dispatcher used by gsummary +# (Phase 3), gscreen (Phase 4), and gquantiles (Phase 6). +# +# Contract: detect_fast_path(exprs, iterator, intervals, band) returns +# either NULL (not fast-path eligible, caller should use slow path) or a +# list with fields: +# $tracks character vector of underlying track names +# $func "lse" | "avg" | "sum" | "max" | "min" +# $sshift integer +# $eshift integer +# +# Window semantics: the C++ scan computes +# window = [c + sshift, c + iterator_step + eshift] +# at each iterator step c, mirroring the slow-path +# Iterator_modifier1D::transform convention +# [interv.start + sshift, interv.end + eshift] +# where the iterator interval has width iterator_step. Bare tracks pass +# sshift = eshift = 0 so the window is exactly the iterator step. +# +# Preconditions for eligibility: +# 1. Each expr is a bare track name OR a vtrack wrapping a single +# source track with func in {avg, sum, max, min, lse}. +# 2. All exprs share the same (func, sshift, eshift) tuple. +# 3. iterator is a fixed integer step (not a track-based iterator). +# 4. band is NULL. +# 5. intervals is either NULL, ALLGENOME, or a 1D intervals data.frame. + +.describe_single_expr <- function(e) { + # Bare track? + if (gtrack.exists(e)) { + info <- tryCatch(gtrack.info(e), error = function(err) NULL) + if (is.null(info)) { + return(NULL) + } + if (!identical(info$type, "dense") && !identical(info$type, "sparse")) { + return(NULL) + } + # Bare track → window equals one iterator step (sshift=eshift=0). + # `default_iterator` is the natural step when the caller passes + # iterator=NULL: bin_size for a dense track (one bin per step). A + # sparse track has no bin grid and its implicit (iterator=NULL) + # iterator is the irregular sparse iterator (one position per stored + # interval), which the grid-based fast path does NOT reproduce. So a + # bare sparse track is only eligible with an EXPLICIT iterator; + # default_iterator = NA forces that (mirrors the vtrack rule). + if (identical(info$type, "sparse")) { + default_it <- NA_integer_ + } else { + bsz <- info$bin.size + if (is.null(bsz) || !is.numeric(bsz)) bsz <- 1L + default_it <- as.integer(bsz) + } + return(list( + track = e, func = "avg", sshift = 0L, eshift = 0L, + default_iterator = default_it + )) + } + # Virtual track? + if (exists("GVTRACKS", envir = misha:::.misha)) { + gwd <- get("GWD", envir = misha:::.misha) + vts <- get("GVTRACKS", envir = misha:::.misha)[[gwd]] + if (!is.null(vts) && e %in% names(vts)) { + v <- vts[[e]] + if (!is.character(v$src) || length(v$src) != 1) { + return(NULL) + } + if (!gtrack.exists(v$src)) { + return(NULL) + } + if (!is.character(v$func) || length(v$func) != 1) { + return(NULL) + } + if (!(v$func %in% c("avg", "sum", "max", "min", "lse"))) { + return(NULL) + } + if (is.null(v$itr) || !identical(v$itr$type, "1d")) { + return(NULL) + } + sshift <- as.integer(v$itr$sshift) + eshift <- as.integer(v$itr$eshift) + if (is.na(sshift) || is.na(eshift)) { + return(NULL) + } + return(list( + track = v$src, func = v$func, + sshift = sshift, eshift = eshift, + default_iterator = NA_integer_ + )) + } + } + NULL +} + +# TRUE iff every scope interval sits on the iterator grid (origin 0), so the +# fast path's global-grid + point-membership scan matches the slow path's +# clipped fixed-bin iterator. A non-aligned start or a non-aligned end that is +# NOT the chromosome end would shift or truncate a partial bin differently +# between the two paths, so such scopes must fall back to the slow path. An end +# equal to the chromosome size is allowed: both paths clip the final window to +# the chromosome boundary identically. +.scope_grid_aligned <- function(iv, it_int) { + allg <- get("ALLGENOME", envir = misha:::.misha)[[1]] + chrom_size <- stats::setNames(as.numeric(allg$end), as.character(allg$chrom)) + starts <- as.numeric(iv$start) + ends <- as.numeric(iv$end) + csz <- chrom_size[as.character(iv$chrom)] + all(starts %% it_int == 0) && + all((ends %% it_int == 0) | (!is.na(csz) & ends == csz)) +} + +.detect_fast_path <- function(exprs, iterator, intervals, band) { + if (!is.character(exprs) || length(exprs) == 0) { + return(NULL) + } + if (!is.null(band)) { + return(NULL) + } + # Cheap lexical gate: skip the gtrack.info / .gvtrack.get calls when + # any expression contains operators or whitespace. + if (!all(.looks_like_bare_name(exprs))) { + return(NULL) + } + + infos <- lapply(exprs, .describe_single_expr) + if (any(vapply(infos, is.null, logical(1)))) { + return(NULL) + } + + # iterator is optional when every expression is a bare track with a + # known bin size — default to the common bin size (all must match). + # Vtracks have default_iterator = NA, so any vtrack forces the user + # to specify iterator explicitly. + if (is.null(iterator)) { + defaults <- vapply(infos, `[[`, integer(1), "default_iterator") + if (any(is.na(defaults))) { + return(NULL) + } + if (length(unique(defaults)) != 1) { + return(NULL) + } + it_int <- defaults[1] + } else { + if (!is.numeric(iterator) || length(iterator) != 1) { + return(NULL) + } + it_int <- as.integer(iterator) + if (is.na(it_int) || it_int <= 0) { + return(NULL) + } + } + + funcs <- vapply(infos, `[[`, character(1), "func") + sshift <- vapply(infos, `[[`, integer(1), "sshift") + eshift <- vapply(infos, `[[`, integer(1), "eshift") + + if (length(unique(funcs)) != 1) { + return(NULL) + } + if (length(unique(sshift)) != 1) { + return(NULL) + } + if (length(unique(eshift)) != 1) { + return(NULL) + } + + # Intervals: accept 1D data.frame. ALLGENOME is a list of + # (1D_df, 2D_df); unwrap to the 1D part. Reject bigset handles + # (character strings) and anything 2D. + if (!is.null(intervals)) { + iv <- intervals + if (is.list(iv) && !is.data.frame(iv) && length(iv) == 2 && + is.data.frame(iv[[1]])) { + iv <- iv[[1]] + } + if (!is.data.frame(iv)) { + return(NULL) + } + if (!all(c("chrom", "start", "end") %in% colnames(iv))) { + return(NULL) + } + if ("chrom1" %in% colnames(iv)) { + return(NULL) + } + # Only grid-aligned scopes match the slow path (see .scope_grid_aligned). + if (!.scope_grid_aligned(iv, it_int)) { + return(NULL) + } + } + + list( + tracks = vapply(infos, `[[`, character(1), "track"), + func = funcs[1], + sshift = sshift[1], + eshift = eshift[1], + iterator = it_int + ) +} + + +# Screen-specific parser. Each expression must be a single comparison: +# " " where op in <, <=, ==, >=, > +# and must satisfy .describe_single_expr (bare track or simple +# vtrack). Returns either NULL or a list with tracks/func/sshift/eshift/ +# iterator/ops/thresholds fields. +.detect_screen_fast_path <- function(exprs, iterator, intervals, band) { + if (!is.character(exprs) || length(exprs) == 0) { + return(NULL) + } + if (!is.null(band)) { + return(NULL) + } + # Parse " " from each expr. + rx <- "^\\s*(.+?)\\s*(<=|>=|==|<|>)\\s*([-+0-9.eE]+)\\s*$" + m <- regmatches(exprs, regexec(rx, exprs)) + if (any(vapply(m, function(x) length(x) != 4, logical(1)))) { + return(NULL) + } + lhs <- vapply(m, `[`, character(1), 2) + ops <- vapply(m, `[`, character(1), 3) + thr <- suppressWarnings(as.numeric(vapply(m, `[`, character(1), 4))) + if (any(is.na(thr))) { + return(NULL) + } + + infos <- lapply(lhs, .describe_single_expr) + if (any(vapply(infos, is.null, logical(1)))) { + return(NULL) + } + + funcs <- vapply(infos, `[[`, character(1), "func") + sshifts <- vapply(infos, `[[`, integer(1), "sshift") + eshifts <- vapply(infos, `[[`, integer(1), "eshift") + + if (is.null(iterator)) { + defaults <- vapply(infos, `[[`, integer(1), "default_iterator") + if (any(is.na(defaults))) { + return(NULL) + } + if (length(unique(defaults)) != 1) { + return(NULL) + } + it_int <- defaults[1] + } else { + if (!is.numeric(iterator) || length(iterator) != 1) { + return(NULL) + } + it_int <- as.integer(iterator) + if (is.na(it_int) || it_int <= 0) { + return(NULL) + } + } + + if (length(unique(funcs)) != 1) { + return(NULL) + } + if (length(unique(sshifts)) != 1) { + return(NULL) + } + if (length(unique(eshifts)) != 1) { + return(NULL) + } + + if (!is.null(intervals)) { + iv <- intervals + if (is.list(iv) && !is.data.frame(iv) && length(iv) == 2 && + is.data.frame(iv[[1]])) { + iv <- iv[[1]] + } + if (!is.data.frame(iv)) { + return(NULL) + } + if (!all(c("chrom", "start", "end") %in% colnames(iv))) { + return(NULL) + } + if ("chrom1" %in% colnames(iv)) { + return(NULL) + } + # Only grid-aligned scopes match the slow path (see .scope_grid_aligned). + if (!.scope_grid_aligned(iv, it_int)) { + return(NULL) + } + } + + list( + tracks = vapply(infos, `[[`, character(1), "track"), + func = funcs[1], + sshift = sshifts[1], + eshift = eshifts[1], + iterator = it_int, + ops = ops, + thresholds = thr + ) +} + +# Map comparison operator strings to the C-side CmpOp enum integers +# (see ThresholdScreen::CmpOp in BatchScreen.cpp). +.screen_op_to_int <- function(op_chr) { + tbl <- c("<" = 0L, "<=" = 1L, "==" = 2L, ">=" = 3L, ">" = 4L) + out <- tbl[op_chr] + if (any(is.na(out))) stop("unknown comparison operator", call. = FALSE) + as.integer(out) +} + +# Cheap lexical pre-check: an expression that contains operators, +# whitespace-around-operators, or parentheses cannot be a bare track or +# vtrack name, so skip the expensive .describe_single_expr path entirely. +# Matches identifier-like strings (letters, digits, "." and "_"), optionally +# wrapped in outer whitespace. Anything else falls through immediately. +.looks_like_bare_name <- function(s) { + grepl("^\\s*[A-Za-z0-9._]+\\s*$", s) +} + +# Emit a one-time per-session informational message explaining which path +# was taken (or why the fast path was declined). Suppressed via +# options(misha.quiet_dispatch = TRUE). +.fast_dispatch_msg <- function(fn, reason) { + if (isTRUE(getOption("misha.quiet_dispatch"))) { + return(invisible()) + } + key <- paste0("misha.dispatch_msg.", fn) + if (isTRUE(getOption(key))) { + return(invisible()) + } + packageStartupMessage(sprintf("[%s] %s", fn, reason)) + args <- setNames(list(TRUE), key) + do.call(options, args) +} diff --git a/R/compute-core.R b/R/compute-core.R index 754451907..8b4c24cac 100644 --- a/R/compute-core.R +++ b/R/compute-core.R @@ -218,13 +218,49 @@ gextract <- function(..., intervals = NULL, colnames = NULL, iterator = NULL, ba #' want to achieve identical results on any machine. For more information #' regarding multitasking please refer "User Manual". #' -#' @param expr track expression +#' @param expr track expression. Character vectors of length > 1 are +#' supported when \code{fast = TRUE} and every element resolves to a +#' simple track or vtrack shape; the return value is then a data.frame +#' with a \code{track} column and one column per percentile. #' @param percentiles an array of percentiles of quantiles in [0, 1] range #' @param intervals genomic scope for which the function is applied #' @param iterator track expression iterator. If 'NULL' iterator is determined #' implicitly based on track expression. #' @param band track expression band. If 'NULL' no band is used. -#' @return An array that represent quantiles. +#' @param fast if \code{TRUE} and \code{expr} is a bare track or vtrack name +#' (or a character vector of such names), a direct-mmap C++ fast path is +#' used. Default \code{FALSE} to preserve numeric back-compat with +#' single-expression calls (see Details). For multi-expression calls +#' \code{fast = TRUE} is required. +#' @return For a single expression, a named numeric vector of quantile +#' values. For a character vector of expressions with \code{fast = TRUE}, +#' a data.frame with columns \code{track} and one per percentile. +#' @details +#' **Numerical differences between fast and slow paths.** The fast path +#' (\code{fast = TRUE}) computes *exact* quantiles via \code{nth_element} +#' on a top-K heap (or on a full value buffer in fallback mode), +#' equivalent to \code{quantile(x, p, type = 1)}. The slow path +#' (\code{fast = FALSE}, default) uses \code{StreamPercentiler}, which +#' draws a reservoir sample when scanned data exceeds +#' \code{options(gmax.data.size)} and can return approximate quantiles +#' at extreme percentiles. Observed differences on motif-energy tracks at +#' \code{p = 0.9999} are in the range 0.02–0.06. The fast path is the +#' more correct answer (no subsampling); the slow path matches +#' long-standing misha behavior. If you have workflows pinned to +#' existing \code{gquantiles} outputs, keep \code{fast = FALSE}; +#' otherwise \code{fast = TRUE} is faster and exact. In a future +#' release the default may flip to \code{fast = TRUE}; this will be +#' announced in NEWS. +#' +#' **Memory and speed near p = 0.5.** The fast path's speedup for +#' extreme quantiles comes from a top-K heap that keeps only the top +#' (or bottom) \code{ceil((1 - max(p)) * N * 1.2)} values. For \code{p} +#' near 0.5, \code{K} approaches \code{N/2}, exceeds the internal cap +#' (\code{K_MAX = 10M}), and the fast path falls back to storing all +#' values (same memory footprint as pre-refactor misha). A warning +#' names the affected tracks. For median-like queries on whole-genome +#' data the fast path provides no speedup from top-K but still benefits +#' from direct-mmap scan and \code{std::thread} parallelism. #' @seealso \code{\link{gbins.quantiles}}, \code{\link{gintervals.quantiles}}, #' \code{\link{gdist}} #' @keywords ~quantiles ~percentiles @@ -238,17 +274,127 @@ gextract <- function(..., intervals = NULL, colnames = NULL, iterator = NULL, ba #' #' @export gquantiles -gquantiles <- function(expr = NULL, percentiles = 0.5, intervals = get("ALLGENOME", envir = .misha), iterator = NULL, band = NULL) { +gquantiles <- function(expr = NULL, percentiles = 0.5, + intervals = get("ALLGENOME", envir = .misha), + iterator = NULL, band = NULL, fast = FALSE) { if (is.null(substitute(expr))) { - stop("Usage: gquantiles(expr, percentiles = 0.5, intervals = .misha$ALLGENOME, iterator = NULL, band = NULL)", call. = FALSE) + stop("Usage: gquantiles(expr, percentiles = 0.5, intervals = .misha$ALLGENOME, iterator = NULL, band = NULL, fast = FALSE)", + call. = FALSE + ) } .gcheckroot() intervals <- rescue_ALLGENOME(intervals, as.character(substitute(intervals))) + # Multi-expression path: requires fast=TRUE and dispatch-eligible inputs. + if (is.character(expr) && length(expr) > 1) { + if (!isTRUE(fast)) { + stop("gquantiles: multi-expression calls require fast=TRUE ", + "(the slow path for multi-expr is Phase 5 work, not yet ", + "implemented).", + call. = FALSE + ) + } + fp <- .detect_fast_path(as.character(expr), iterator, intervals, band) + if (is.null(fp)) { + stop("gquantiles: multi-expression fast-path not eligible ", + "(each expression must resolve to a bare track or simple ", + "vtrack with matching func/sshift/eshift).", + call. = FALSE + ) + } + iv <- intervals + if (is.list(iv) && !is.data.frame(iv) && length(iv) == 2 && + is.data.frame(iv[[1]])) { + iv <- iv[[1]] + } + allg <- get("ALLGENOME", envir = .misha) + is_allgenome <- identical(iv, allg[[1]]) + c_intervals <- if (is_allgenome) NULL else iv + + n_threads <- as.integer(getOption("gmax.processes", 1L)) + m <- .gcall( + "C_gquantiles_multi", + as.character(fp$tracks), + as.numeric(percentiles), + as.integer(fp$iterator), + as.integer(fp$sshift), + as.integer(fp$eshift), + n_threads, + as.character(fp$func), + c_intervals, + .misha_env() + ) + # C returns a named matrix (rows = tracks, cols = percentiles). + # Convert to long data.frame with a leading `track` column whose + # values are the original input expressions. + mat <- if (is.matrix(m)) m else matrix(m, nrow = length(fp$tracks)) + df <- data.frame( + track = as.character(expr), mat, + check.names = FALSE, stringsAsFactors = FALSE + ) + names(df)[-1] <- as.character(percentiles) + rownames(df) <- NULL + return(df) + } + exprstr <- do.call(.gexpr2str, list(substitute(expr)), envir = parent.frame()) .iterator <- do.call(.giterator, list(substitute(iterator)), envir = parent.frame()) + # Single-expression fast path: opt-in via fast=TRUE. If preconditions + # fail, emit a one-time informational message and fall back to the + # slow path. If preconditions pass, use the exact-nth_element path. + if (isTRUE(fast) && is.character(expr) && length(expr) == 1L) { + fp <- .detect_fast_path(as.character(expr), iterator, intervals, band) + if (!is.null(fp)) { + iv <- intervals + if (is.list(iv) && !is.data.frame(iv) && length(iv) == 2 && + is.data.frame(iv[[1]])) { + iv <- iv[[1]] + } + allg <- get("ALLGENOME", envir = .misha) + is_allgenome <- identical(iv, allg[[1]]) + c_intervals <- if (is_allgenome) NULL else iv + + n_threads <- as.integer(getOption("gmax.processes", 1L)) + m <- .gcall( + "C_gquantiles_multi", + as.character(fp$tracks), + as.numeric(percentiles), + as.integer(fp$iterator), + as.integer(fp$sshift), + as.integer(fp$eshift), + n_threads, + as.character(fp$func), + c_intervals, + .misha_env() + ) + # For a single track the C entry returns a numeric vector + # (n_pctiles=1) or a 1-row matrix. Flatten to the named-numeric + # return shape that legacy gquantiles produces. + out <- as.numeric(m) + names(out) <- as.character(percentiles) + return(out) + } + .fast_dispatch_msg( + "gquantiles", + "fast=TRUE not eligible for this expression; using slow path" + ) + } else if (!isTRUE(fast) && is.character(expr) && length(expr) == 1L) { + # Inform only when the user could have opted in and the fast path + # is eligible. Silent otherwise. + fp_test <- .detect_fast_path( + as.character(expr), iterator, + intervals, band + ) + if (!is.null(fp_test)) { + .fast_dispatch_msg( + "gquantiles", + "a faster exact-quantile path is available; pass fast = TRUE (see ?gquantiles)" + ) + } + } + if (.ggetOption("gmultitasking")) { res <- .gcall("gquantiles_multitask", intervals, exprstr, percentiles, .iterator, band, .misha_env()) } else { @@ -271,6 +417,11 @@ gquantiles <- function(expr = NULL, percentiles = 0.5, intervals = get("ALLGENOM #' @param iterator track expression iterator. If 'NULL' iterator is determined #' implicitly based on track expression. #' @param band track expression band. If 'NULL' no band is used. +#' @param fast if \code{TRUE} (default) and \code{expr} is a character vector +#' of length > 1 whose elements are bare track or vtrack names, a fast +#' direct-mmap C++ multi-track path is used and a data.frame with columns +#' \code{track, n, n_nan, min, max, sum, mean, sd} is returned. Single +#' expressions always take the legacy path for bit-exact back-compat. #' @return An array that represents summary statistics. #' @seealso \code{\link{gintervals.summary}}, \code{\link{gbins.summary}} #' @keywords ~summary ~statistics @@ -283,9 +434,12 @@ gquantiles <- function(expr = NULL, percentiles = 0.5, intervals = get("ALLGENOM #' gsummary("rects_track") #' #' @export gsummary -gsummary <- function(expr = NULL, intervals = NULL, iterator = NULL, band = NULL) { +gsummary <- function(expr = NULL, intervals = NULL, iterator = NULL, + band = NULL, fast = TRUE) { if (is.null(substitute(expr))) { - stop("Usage: gsummary(expr, intervals = .misha$ALLGENOME, iterator = NULL, band = NULL)", call. = FALSE) + stop("Usage: gsummary(expr, intervals = .misha$ALLGENOME, iterator = NULL, band = NULL, fast = TRUE)", + call. = FALSE + ) } .gcheckroot() @@ -295,6 +449,64 @@ gsummary <- function(expr = NULL, intervals = NULL, iterator = NULL, band = NULL intervals <- get("ALLGENOME", envir = .misha) } + # Fast path activates only for a character vector of length > 1. Single + # scalar inputs always take the legacy path to preserve bit-exact + # backward compatibility (existing regression tests rely on the legacy + # output shape and numerics). + if (isTRUE(fast) && is.character(expr) && length(expr) > 1) { + fp <- .detect_fast_path(as.character(expr), iterator, intervals, band) + if (!is.null(fp)) { + # Unwrap ALLGENOME-style list into a bare 1D data.frame (the + # batch C entry only consumes 1D intervals). + iv <- intervals + if (is.list(iv) && !is.data.frame(iv) && length(iv) == 2 && + is.data.frame(iv[[1]])) { + iv <- iv[[1]] + } + # ALLGENOME equivalent ⇒ pass NULL to the C entry to skip the + # interval-mask machinery entirely (faster, same result). + allg <- get("ALLGENOME", envir = .misha) + is_allgenome <- identical(iv, allg[[1]]) + c_intervals <- if (is_allgenome) NULL else iv + + n_threads <- as.integer(getOption("gmax.processes", 1L)) + m <- .gcall( + "C_gsummary_multi", + as.character(fp$tracks), + as.integer(fp$iterator), + as.integer(fp$sshift), + as.integer(fp$eshift), + n_threads, + as.character(fp$func), + c_intervals, + .misha_env() + ) + # Read by column name. The C side guarantees these names; if + # ever absent, the test-batch-summary.R contract test catches it. + df <- data.frame( + track = as.character(expr), + n = m[, "n"], n_nan = m[, "n_nan"], + min = m[, "min"], max = m[, "max"], sum = m[, "sum"], + mean = m[, "mean"], sd = m[, "sd"], + stringsAsFactors = FALSE + ) + rownames(df) <- NULL + return(df) + } + .fast_dispatch_msg( + "gsummary", + "multi-expr fast-path not eligible (expression not a bare track or simple vtrack); using slow path" + ) + } + + # Slow path (single expression, legacy behavior). + if (is.character(expr) && length(expr) > 1) { + stop("gsummary: multi-expression slow path not yet implemented ", + "(Phase 5 work); pass fast=TRUE with simple track or vtrack names, ", + "or call gsummary once per expression.", + call. = FALSE + ) + } exprstr <- do.call(.gexpr2str, list(substitute(expr)), envir = parent.frame()) .iterator <- do.call(.giterator, list(substitute(iterator)), envir = parent.frame()) diff --git a/R/compute-utils.R b/R/compute-utils.R index 1fc9c1851..5c6025f7f 100644 --- a/R/compute-utils.R +++ b/R/compute-utils.R @@ -198,6 +198,12 @@ gsample <- function(expr = NULL, n = NULL, intervals = NULL, iterator = NULL, ba #' @param band track expression band. If 'NULL' no band is used. #' @param intervals.set.out intervals set name where the function result is #' optionally outputted +#' @param fast if \code{TRUE} (default) and \code{expr} is a character vector +#' of length > 1 whose elements are simple \code{" "} +#' comparisons (with \code{op} one of \code{<, <=, ==, >=, >}), a fast +#' direct-mmap C++ multi-track path is used and a data.frame with columns +#' \code{chrom, start, end, track} is returned. Single expressions always +#' take the legacy path for bit-exact back-compat. #' @return If 'intervals.set.out' is 'NULL' a set of intervals that match track #' expression. #' @seealso \code{\link{gsegment}}, \code{\link{gextract}} @@ -213,9 +219,12 @@ gsample <- function(expr = NULL, n = NULL, intervals = NULL, iterator = NULL, ba #' ) #' #' @export gscreen -gscreen <- function(expr = NULL, intervals = NULL, iterator = NULL, band = NULL, intervals.set.out = NULL) { +gscreen <- function(expr = NULL, intervals = NULL, iterator = NULL, + band = NULL, intervals.set.out = NULL, fast = TRUE) { if (is.null(substitute(expr))) { - stop("Usage: gscreen(expr, intervals = .misha$ALLGENOME, iterator = NULL, band = NULL, intervals.set.out = NULL)", call. = FALSE) + stop("Usage: gscreen(expr, intervals = .misha$ALLGENOME, iterator = NULL, band = NULL, intervals.set.out = NULL, fast = TRUE)", + call. = FALSE + ) } .gcheckroot() @@ -225,6 +234,64 @@ gscreen <- function(expr = NULL, intervals = NULL, iterator = NULL, band = NULL, intervals <- get("ALLGENOME", envir = .misha) } + # Fast path: character vector of length > 1, each element a simple + # " " comparison. Single-expression calls continue to + # take the legacy path to preserve bit-exact back-compat with the + # existing gscreen regression tests and intervals-set-out semantics. + if (isTRUE(fast) && is.character(expr) && length(expr) > 1 && + is.null(intervals.set.out)) { + fp <- .detect_screen_fast_path( + as.character(expr), iterator, + intervals, band + ) + if (!is.null(fp)) { + iv <- intervals + if (is.list(iv) && !is.data.frame(iv) && length(iv) == 2 && + is.data.frame(iv[[1]])) { + iv <- iv[[1]] + } + allg <- get("ALLGENOME", envir = .misha) + is_allgenome <- identical(iv, allg[[1]]) + c_intervals <- if (is_allgenome) NULL else iv + + n_threads <- as.integer(getOption("gmax.processes", 1L)) + ops_int <- .screen_op_to_int(fp$ops) + # C_gscreen_multi returns columns (chrom, start, end, track_idx) + # where track_idx is the 0-based index into the input expression + # vector. Map to the user-facing `track` column with the original + # expression strings — unambiguous even for duplicate underlying + # tracks (e.g. two thresholds on the same source track). + res <- .gcall( + "C_gscreen_multi", + as.character(fp$tracks), + as.integer(fp$iterator), + as.integer(fp$sshift), + as.integer(fp$eshift), + n_threads, + as.character(fp$func), + as.integer(ops_int), + as.numeric(fp$thresholds), + c_intervals, + .misha_env() + ) + expr_str <- as.character(expr) + res$track <- expr_str[res$track_idx + 1L] + res$track_idx <- NULL + return(res) + } + .fast_dispatch_msg( + "gscreen", + "multi-expr fast-path not eligible; using slow path" + ) + } + if (is.character(expr) && length(expr) > 1) { + stop("gscreen: multi-expression slow path not yet implemented ", + "(Phase 5 work); pass fast=TRUE with simple ' ' ", + "comparisons, or call gscreen once per expression.", + call. = FALSE + ) + } + exprstr <- do.call(.gexpr2str, list(substitute(expr)), envir = parent.frame()) .iterator <- do.call(.giterator, list(substitute(iterator)), envir = parent.frame()) intervals.set.out <- do.call(.gexpr2str, list(substitute(intervals.set.out)), envir = parent.frame()) diff --git a/R/glm-features.R b/R/glm-features.R new file mode 100644 index 000000000..0ee24808b --- /dev/null +++ b/R/glm-features.R @@ -0,0 +1,306 @@ +# Resolve transform column-name suffixes from a `transforms` list. +# Uses element names when all elements are named; otherwise falls back to +# generic t1..tN. Partially-named lists fall back to generic to avoid +# silently mislabeling the unnamed entries. +.glm_features_transform_names <- function(transforms) { + n <- length(transforms) + nm <- names(transforms) + if (!is.null(nm) && all(nzchar(nm))) { + return(nm) + } + paste0("t", seq_len(n)) +} + +#' Extract GLM feature matrix from motif energy tracks +#' +#' Reads multiple motif energy tracks, applies scaling and logistic transforms, +#' and returns the complete feature matrix in a single C++ pass. This replaces +#' the R-side pipeline of gextract -> scale -> reshape -> logistic transform. +#' +#' @param track_names Character vector of motif track names +#' (e.g., \code{"th_epi.all_db_motifs.JASPAR_Zic2"}). +#' @param intervals Data frame with \code{chrom}, \code{start}, \code{end} columns. +#' All intervals must have the same width. +#' @param tile_size Tile width in bp (default 200). +#' @param flank_size Flanking region in bp added to each side of the peak (default 350). +#' @param max_cap Named numeric vector of per-motif maximum cap values +#' (genome-wide quantiles). Names must match \code{track_names}. +#' @param dis_from_cap Distance below cap for normalization (default 10). +#' @param scale_factor Output range scale factor (default 10). +#' @param transforms List of transform configurations. Each element is a list +#' with fields \code{L}, \code{k}, \code{x_0}, \code{pre_shift}, \code{post_shift}. +#' Defaults to the 4 standard logistic heads (low-energy, high-energy, sigmoid, +#' higher-energy). +#' @param gc_track GC content track name (default \code{"seq.G_or_C"}). +#' @param gc_scale_factor Scale factor for GC features (default 10). +#' @param n_threads Integer scalar: number of worker threads. Defaults to +#' \code{getOption("gmax.processes", 1L)} for consistency with the rest +#' of misha. Pass \code{n_threads = 0L} to auto-detect +#' (\code{min(n_peaks, hardware_concurrency, 40)}). Each thread holds +#' its own per-chromosome mmap of the motif and GC tracks; for the +#' typical 191-motif workload that's a few hundred MB resident per +#' thread (mmap, so most of it stays in the OS page cache). +#' +#' @return A numeric matrix with one row per interval and columns for: +#' \itemize{ +#' \item Motif features: \code{n_motifs * n_tiles * n_transforms} columns +#' \item GC features: \code{n_tiles} columns +#' \item GC interactions: \code{choose(n_tiles, 2)} columns +#' } +#' +#' @examples +#' \dontrun{ +#' gdb.init("/path/to/trackdb") +#' peaks <- data.frame(chrom = "chr1", start = c(1000, 2000), end = c(1300, 2300)) +#' motifs <- c("th_epi.all_db_motifs.JASPAR_Zic2") +#' caps <- c(JASPAR_Zic2 = 10.5) +#' names(caps) <- motifs +#' result <- glm_extract_features(motifs, peaks, max_cap = caps) +#' } +#' +#' @export +glm_extract_features <- function( + track_names, + intervals, + tile_size = 200L, + flank_size = 350L, + max_cap, + dis_from_cap = 10, + scale_factor = 10, + transforms = list( + "low-energy" = list(L = 2, k = 0.5, x_0 = 0, pre_shift = 0, post_shift = -1), + "high-energy" = list(L = 2, k = 0.5, x_0 = 10, pre_shift = 0, post_shift = 0), + "sigmoid" = list(L = 1, k = 1, x_0 = 0, pre_shift = -5, post_shift = 0), + "higher-energy" = list(L = 2, k = 1, x_0 = 10, pre_shift = 0, post_shift = 0) + ), + gc_track = "seq.G_or_C", + gc_scale_factor = 10, + n_threads = getOption("gmax.processes", 1L) +) { + # Validate inputs + stopifnot(is.character(track_names), length(track_names) > 0) + stopifnot(is.data.frame(intervals)) + stopifnot(all(c("chrom", "start", "end") %in% names(intervals))) + stopifnot(length(max_cap) == length(track_names)) + + n_peaks <- nrow(intervals) + n_motifs <- length(track_names) + n_transforms <- length(transforms) + if (n_peaks == 0L) { + stop("'intervals' must contain at least one row") + } + + # Check uniform peak size + peak_sizes <- intervals$end - intervals$start + if (length(unique(peak_sizes)) != 1) { + stop("All intervals must have the same width") + } + + # Pass chromosome names through to C++, which resolves them via misha's + # internal chromkey (chromkey.chrom2id). Earlier versions resolved to + # integer IDs in R using a positional match against + # gintervals.chrom_sizes(intervals) — but that only reflects the order + # of chromosomes present in the input subset, not the chromkey insertion + # order, so any missing chromosome (e.g., chrM/chrY excluded upstream) + # silently shifted all later chromids by one. + chrom_names <- as.character(intervals$chrom) + if (any(is.na(chrom_names))) { + stop("Some chromosome names are NA") + } + + # Order max_cap to match track_names + if (!is.null(names(max_cap))) { + max_cap_ordered <- max_cap[track_names] + if (any(is.na(max_cap_ordered))) { + stop("max_cap names do not match track_names") + } + } else { + max_cap_ordered <- max_cap + } + + # Build transform matrix (n_transforms x 5, column-major) + transform_mat <- matrix(0, nrow = n_transforms, ncol = 5) + for (i in seq_along(transforms)) { + t <- transforms[[i]] + transform_mat[i, 1] <- t$L + transform_mat[i, 2] <- t$k + transform_mat[i, 3] <- t$x_0 + transform_mat[i, 4] <- t$pre_shift + transform_mat[i, 5] <- t$post_shift + } + + # Call C++ + result <- .gcall( + "C_glm_extract_features", + as.character(track_names), + chrom_names, + as.numeric(intervals$start), + as.numeric(intervals$end), + as.integer(tile_size), + as.integer(flank_size), + as.numeric(max_cap_ordered), + as.numeric(dis_from_cap), + as.numeric(scale_factor), + transform_mat, + as.character(gc_track), + as.numeric(gc_scale_factor), + as.integer(n_threads), + .misha_env() + ) + + # Compute column names + peak_size <- peak_sizes[1] + extended <- peak_size + 2 * flank_size + n_tiles <- extended %/% tile_size + + # Tile distances relative to peak center + half <- peak_size %/% 2 + tile_starts <- (seq_len(n_tiles) - 1L) * tile_size - flank_size - half + tile_midpoints <- tile_starts + tile_size / 2 + dist_labels <- as.character(as.integer(tile_midpoints)) + + # Short motif names (last component of track path) + motif_short <- vapply( + strsplit(track_names, "\\."), + function(x) x[length(x)], + character(1) + ) + + # Transform suffixes from element names; fallback to t1..tN. + transform_names <- .glm_features_transform_names(transforms) + + # Motif columns: (tile * n_motifs + motif) * n_transforms + transform + motif_col_names <- character(n_motifs * n_tiles * n_transforms) + idx <- 1 + for (ti in seq_len(n_tiles)) { + for (mi in seq_len(n_motifs)) { + for (tr in seq_len(n_transforms)) { + motif_col_names[idx] <- paste0( + motif_short[mi], "_dist_", + gsub("-", "neg_", dist_labels[ti]), + "_", transform_names[tr] + ) + idx <- idx + 1 + } + } + } + + # GC columns + gc_col_names <- paste0( + "gc_content_tile_dist_", + gsub("-", "neg_", dist_labels) + ) + + # GC interaction columns (choose(n_tiles, 2) entries in row-major order) + n_gc_inter <- if (n_tiles >= 2L) n_tiles * (n_tiles - 1L) %/% 2L else 0L + gc_inter_names <- character(n_gc_inter) + if (n_gc_inter > 0L) { + idx <- 1L + for (a in seq_len(n_tiles - 1L)) { + for (b in seq.int(a + 1L, n_tiles)) { + gc_inter_names[idx] <- paste0( + "int_", gc_col_names[a], "_x_", gc_col_names[b] + ) + idx <- idx + 1L + } + } + } + + colnames(result) <- c(motif_col_names, gc_col_names, gc_inter_names) + result +} + + +#' Compute genome-wide quantiles for multiple tracks in parallel +#' +#' Efficiently computes genome-wide quantiles for many tracks using parallel +#' C++ threads. Each thread scans the genome for one track, computing LSE +#' aggregation over the specified window at each iterator position, then +#' computes exact quantiles using nth_element. +#' +#' @param track_names Character vector of track names. +#' @param percentiles Numeric vector of percentiles to compute (e.g., 0.9999). +#' @param iterator Integer scalar: iterator step size in bp (default 20L). +#' @param sshift Integer scalar: start shift for the LSE aggregation window +#' relative to iterator center (default -140L). +#' @param eshift Integer scalar: end shift for the LSE aggregation window +#' relative to iterator center (default 140L). +#' @param n_threads Integer scalar: number of parallel threads. Defaults to +#' \code{getOption("gmax.processes", 1L)} to match the rest of misha. +#' Set \code{options(gmax.processes = N)} or pass \code{n_threads = N} +#' to raise it. Pass \code{n_threads = 0L} to auto-detect +#' (\code{min(n_tracks, hardware_concurrency, 40)}). Each thread uses +#' ~540 MB for mouse genome at 20bp resolution. +#' @param func Window aggregation function. One of \code{"lse"} (default), +#' \code{"avg"}, \code{"sum"}, \code{"max"}, \code{"min"}. Matches the +#' vtrack \code{func} semantics. +#' @param intervals Optional 1D intervals data.frame (\code{chrom, start, end}) +#' restricting the scan to a subset of the genome. \code{NULL} (default) +#' scans the whole genome. +#' +#' @return If a single percentile is requested: a named numeric vector +#' (one value per track). If multiple percentiles: a matrix with +#' \code{n_tracks} rows and \code{n_percentiles} columns. +#' +#' @details +#' This function replaces the pattern of calling \code{gquantiles} once per +#' track in a loop. For 191 motif tracks, it reduces total runtime from +#' 5-10 minutes to ~1 minute by: +#' \itemize{ +#' \item Multi-threaded C++ execution (N tracks processed in parallel) +#' \item Avoiding R-to-C++ boundary overhead per track +#' \item No \code{doMC} fork overhead +#' \item Benefiting from OS page cache (mmap'd track files) +#' } +#' +#' The LSE aggregation uses the same float-precision \code{lse_accumulate} +#' as misha's \code{vtrack func="lse"}. +#' +#' The quantile algorithm uses exact \code{nth_element} (equivalent to +#' R's \code{quantile(x, p, type=1)}), which may differ slightly from +#' \code{gquantiles} which uses StreamPercentiler (approximate). +#' +#' @examples +#' \dontrun{ +#' gdb.init("/path/to/trackdb") +#' tracks <- paste0("th_epi.all_db_motifs.", c("JASPAR_Zic2", "HOMER_Unknown_ESC_element")) +#' q <- glm_batch_quantiles(tracks, percentiles = 0.9999) +#' # Returns: named vector with one value per track +#' +#' # Multiple percentiles: +#' q_mat <- glm_batch_quantiles(tracks, percentiles = c(0.99, 0.999, 0.9999)) +#' # Returns: matrix with tracks as rows, percentiles as columns +#' +#' # Control parallelism: +#' q <- glm_batch_quantiles(tracks, percentiles = 0.9999, n_threads = 10L) +#' } +#' +#' @export +glm_batch_quantiles <- function( + track_names, + percentiles, + iterator = 20L, + sshift = -140L, + eshift = 140L, + n_threads = getOption("gmax.processes", 1L), + func = "lse", + intervals = NULL +) { + stopifnot(is.character(track_names), length(track_names) > 0) + stopifnot(is.numeric(percentiles), length(percentiles) > 0) + stopifnot(all(percentiles >= 0 & percentiles <= 1)) + stopifnot(is.character(func), length(func) == 1) + + .gcall( + "C_gquantiles_multi", + as.character(track_names), + as.numeric(percentiles), + as.integer(iterator), + as.integer(sshift), + as.integer(eshift), + as.integer(n_threads), + as.character(func), + intervals, + .misha_env() + ) +} diff --git a/R/glm-pred.R b/R/glm-pred.R new file mode 100644 index 000000000..944bd29e2 --- /dev/null +++ b/R/glm-pred.R @@ -0,0 +1,629 @@ +# ============================================================================ +# GLM Predictor Virtual Track +# ============================================================================ +# Fused GLM linear prediction: per-position computation of +# bias + Σ(weight × transform(scale(smooth(track)))) + Σ(inter_weight × transform(product)) + +# Cut() labels for a break vector - same labels glm_pred uses for stratum binning +# (matches BinFinder::val2bin with include_lowest=true, right=true on the C++ side). +.glm_pred_cut_labels <- function(breaks) { + midpoints <- breaks[-length(breaks)] + diff(breaks) / 2 + levels(cut(midpoints, breaks = breaks, include.lowest = TRUE, right = TRUE)) +} + +# Validate / auto-derive dimnames for a stratified weights / bias / interaction array. +# x: numeric array. Plain numeric vector accepted only when M=1 and there is no leading axis (bias). +# K_per: integer vector of expected trailing-axis lengths (length M). +# selector_tracks: character vector of expected trailing-axis names (length M). +# selector_breaks: list of break vectors (length M) - labels are derived from these. +# leading_dim: integer expected leading-axis length, or NA when there is no leading axis. +# leading_name: character(1) name to assign to leading axis when present and unnamed. +# param: character(1) - parameter name used in error messages. +.glm_pred_normalize_strata_array <- function(x, K_per, selector_tracks, selector_breaks, + leading_dim, leading_name, param) { + M <- length(selector_tracks) + has_leading <- !is.na(leading_dim) + expected_dim <- if (has_leading) c(leading_dim, K_per) else K_per + + if (!is.numeric(x)) { + stop(sprintf("'%s' must be numeric", param), call. = FALSE) + } + + actual_dim <- dim(x) + if (is.null(actual_dim)) { + # Plain numeric vector. Allowed only for bias (no leading axis) at M=1. + if (has_leading) { + stop(sprintf( + "'%s' must be an array with dim = c(%s); got a length-%d numeric vector. To migrate from a flat matrix, use array(%s, dim = c(%s)) instead of matrix(%s, nrow = %d).", + param, paste(expected_dim, collapse = ", "), length(x), + param, paste(expected_dim, collapse = ", "), + param, expected_dim[1L] + ), call. = FALSE) + } + if (M != 1L) { + stop(sprintf( + "'%s' must be an array with dim = c(%s); got a length-%d numeric vector.", + param, paste(expected_dim, collapse = ", "), length(x) + ), call. = FALSE) + } + if (length(x) != K_per[1L]) { + stop(sprintf( + "'%s' must be numeric of length %d (or scalar); got length %d.", + param, K_per[1L], length(x) + ), call. = FALSE) + } + dim(x) <- K_per + } else if (length(actual_dim) != length(expected_dim) || any(actual_dim != expected_dim)) { + migration_hint <- if (M >= 2L && has_leading && length(actual_dim) == 2L) { + sprintf( + " To migrate from a flat matrix, use array(%s, dim = c(%s)) instead of matrix(%s, nrow = %d).", + param, paste(expected_dim, collapse = ", "), param, expected_dim[1L] + ) + } else { + "" + } + stop(sprintf( + "'%s' must be an array with dim = c(%s); got dim = c(%s).%s", + param, paste(expected_dim, collapse = ", "), + paste(actual_dim, collapse = ", "), migration_hint + ), call. = FALSE) + } + + dn <- dimnames(x) + if (is.null(dn)) dn <- vector("list", length(expected_dim)) + dn_names <- names(dn) + if (is.null(dn_names)) dn_names <- character(length(expected_dim)) + + for (m in seq_len(M)) { + ax <- if (has_leading) m + 1L else m + expected_labs <- .glm_pred_cut_labels(selector_breaks[[m]]) + if (is.null(dn[[ax]])) { + dn[[ax]] <- expected_labs + } else if (!identical(as.character(dn[[ax]]), expected_labs)) { + stop(sprintf( + "dimnames(%s)[[%d]] does not match cut() labels for selector_breaks[[%d]]; expected c(%s), got c(%s). Either omit dimnames (auto-derived) or match the cut() labels exactly.", + param, ax, m, + paste(sprintf('"%s"', expected_labs), collapse = ", "), + paste(sprintf('"%s"', dn[[ax]]), collapse = ", ") + ), call. = FALSE) + } + if (is.na(dn_names[ax]) || dn_names[ax] == "") { + dn_names[ax] <- selector_tracks[m] + } else if (dn_names[ax] != selector_tracks[m]) { + stop(sprintf( + "names(dimnames(%s))[%d] must be '%s'; got '%s'. Either omit dimnames (auto-derived) or match the selector_tracks name exactly.", + param, ax, selector_tracks[m], dn_names[ax] + ), call. = FALSE) + } + } + if (has_leading) { + if (is.na(dn_names[1L]) || dn_names[1L] == "") { + dn_names[1L] <- leading_name + } + } + + names(dn) <- dn_names + dimnames(x) <- dn + storage.mode(x) <- "double" + x +} + +#' Create a GLM predictor virtual track +#' +#' Creates a virtual track that computes a fused generalized linear model +#' prediction at each genome position. The pipeline for each entry is: +#' smooth → scale (cap + normalize) → transform (logistic) → weight. +#' Interactions are computed post-scaling, pre-transform. +#' +#' @param name character(1) Virtual track name +#' @param tracks character(N) Genomic track names (repeated OK) +#' @param inner_func character(N) \code{"sum"} or \code{"lse"} per entry +#' @param weights LM coefficients per entry. Shape depends on selectors: +#' \itemize{ +#' \item No selector: \code{numeric(N)}. +#' \item One selector (M=1): \code{matrix(N, K_1)}. +#' \item Two or more selectors (M>=2): array with +#' \code{dim = c(N, K_1, ..., K_M)}. Plain +#' \code{N x prod(K_m)} matrices are rejected to avoid flatten-order +#' ambiguity. Build with \code{array(coefs, dim = c(N, K_1, ..., K_M))}. +#' } +#' When a selector is specified, trailing-axis dimnames are auto-derived +#' from \code{selector_breaks} (\code{cut(include.lowest=TRUE, right=TRUE)} +#' labels) and trailing-axis names from \code{selector_tracks}. If you +#' supply your own dimnames they must match exactly; mismatches error +#' with the offending axis named. +#' @param bias Intercept term (default 0). Shape depends on selectors: +#' \itemize{ +#' \item No selector: \code{numeric(1)}. +#' \item One selector (M=1): scalar (recycled) or \code{numeric(K_1)}. +#' \item Two or more selectors (M>=2): scalar (recycled to all strata) +#' or array with \code{dim = c(K_1, ..., K_M)}. +#' } +#' Auto-derived dimnames mirror those of \code{weights} on the trailing +#' axes. +#' @param kernels list of numeric vectors (N or 1, recycled) Sub-bin kernel +#' weights, or NULL for direct aggregation +#' @param kernel_bins numeric(B) Offsets relative to shift window center, or NULL +#' @param shifts list of numeric(2) Per-entry \code{c(sshift, eshift)}, or NULL +#' @param trans_family character(N or 1 or NULL) \code{"logist"} or NA per entry +#' @param trans_params list of lists (N or NULL) Each element is a list with +#' fields \code{L}, \code{k}, \code{x_0}, and optionally \code{pre_shift}, +#' \code{post_shift} +#' @param max_cap numeric(N or NULL) Capping threshold per entry (NA to skip) +#' @param dis_from_cap numeric(N or NULL) Distance from cap per entry (NA to skip) +#' @param simple_cap logical(N or NULL) If TRUE, use simple cap-and-divide +#' scaling: \code{min(raw, max_cap) / dis_from_cap}. Default NULL (standard +#' cap-normalize scaling). +#' @param scale_factor numeric(1) Global scale factor (default 10) +#' @param interactions list of integer(2) (M or NULL) Pairs of entry indices (1-based) +#' @param interaction_weights Per-interaction LM coefficients. Shape mirrors +#' \code{weights} with the leading axis being the interaction index: +#' \itemize{ +#' \item No selector: \code{numeric(M_int)}. +#' \item One selector (M=1): \code{matrix(M_int, K_1)}. +#' \item Two or more selectors (M>=2): array with +#' \code{dim = c(M_int, K_1, ..., K_M)}. +#' } +#' Same dimnames rules as \code{weights}; leading axis name is +#' \code{"interaction"}. +#' @param interaction_trans_family character(M or 1 or NULL) Transform for interactions +#' @param inter_trans_params list of lists (M or NULL) Logistic params per interaction +#' @param selector_tracks character(M) or NULL Names of fixed-bin (dense) tracks +#' used for per-position model selection. With M selectors, strata are the +#' Cartesian product of per-selector bins (column-major: first selector varies +#' fastest). When NULL (default), K = 1 and a single set of weights is applied +#' everywhere. +#' @param selector_breaks list of M numeric vectors, or NULL. Each element is +#' the break vector (length K_m + 1, K_m >= 1) for the corresponding selector +#' track in \code{selector_tracks}. Break points use +#' \code{cut(include.lowest = TRUE, right = TRUE)} semantics. Required and +#' length-matched to \code{selector_tracks} when that is non-NULL. +#' +#' @return Invisibly returns \code{name}. +#' @export +glm_pred.create <- function(name, + tracks, + inner_func, + weights, + bias = 0, + kernels = NULL, + kernel_bins = NULL, + shifts = NULL, + trans_family = NULL, + trans_params = NULL, + max_cap = NULL, + dis_from_cap = NULL, + simple_cap = NULL, + scale_factor = 10, + interactions = NULL, + interaction_weights = NULL, + interaction_trans_family = NULL, + inter_trans_params = NULL, + selector_tracks = NULL, + selector_breaks = NULL) { + .gcheckroot() + + # --- Validate core vectors --- + if (!is.character(name) || length(name) != 1) { + stop("'name' must be a single character string", call. = FALSE) + } + if (!is.character(tracks) || length(tracks) == 0) { + stop("'tracks' must be a non-empty character vector", call. = FALSE) + } + N <- length(tracks) + + # Validate that all tracks exist + existing <- gtrack.ls() + missing_tracks <- setdiff(unique(tracks), existing) + if (length(missing_tracks) > 0) { + stop( + sprintf( + "Track(s) not found: %s", + paste0("'", missing_tracks, "'", collapse = ", ") + ), + call. = FALSE + ) + } + + if (!is.character(inner_func) || length(inner_func) != N) { + stop(sprintf("'inner_func' must be a character vector of length %d", N), call. = FALSE) + } + invalid_if <- setdiff(unique(inner_func), c("sum", "lse")) + if (length(invalid_if) > 0) { + stop( + sprintf( + "'inner_func' values must be 'sum' or 'lse' (got: %s)", + paste0("'", invalid_if, "'", collapse = ", ") + ), + call. = FALSE + ) + } + + # --- Validate selector tracks and determine K_total = prod K_m (Cartesian product) --- + K <- 1L + K_per <- integer(0) + if (!is.null(selector_tracks)) { + if (is.null(selector_breaks)) { + stop("'selector_breaks' required when 'selector_tracks' is specified", call. = FALSE) + } + if (!is.character(selector_tracks) || length(selector_tracks) < 1) { + stop("'selector_tracks' must be a character vector of length >= 1", call. = FALSE) + } + if (!is.list(selector_breaks) || length(selector_breaks) != length(selector_tracks)) { + stop(sprintf( + "'selector_breaks' must be a list of length %d (one per selector)", + length(selector_tracks) + ), call. = FALSE) + } + existing_tracks <- gtrack.ls() + K_per <- integer(length(selector_tracks)) + for (m in seq_along(selector_tracks)) { + tname <- selector_tracks[m] + br <- selector_breaks[[m]] + if (!is.numeric(br) || length(br) < 2) { + stop(sprintf( + "'selector_breaks[[%d]]' must be a numeric vector of length >= 2", + m + ), call. = FALSE) + } + if (is.unsorted(br, strictly = TRUE)) { + stop(sprintf("'selector_breaks[[%d]]' must be strictly increasing", m), call. = FALSE) + } + if (!(tname %in% existing_tracks)) { + stop(sprintf("Selector track '%s' not found", tname), call. = FALSE) + } + sel_info <- gtrack.info(tname) + if (sel_info$type != "dense") { + stop(sprintf( + "Selector track '%s' must be a fixed-bin (dense) track, got '%s'", + tname, sel_info$type + ), call. = FALSE) + } + K_per[m] <- length(br) - 1L + } + K <- as.integer(prod(K_per)) + } + + # --- Validate weights and bias --- + if (is.null(selector_tracks)) { + # No selector: weights = numeric(N), bias = numeric(1). + if (!is.numeric(weights) || !is.null(dim(weights)) || length(weights) != N) { + stop(sprintf( + "'weights' must be a numeric vector of length %d when no selector is specified", N + ), call. = FALSE) + } + if (!is.numeric(bias) || length(bias) != 1L) { + stop("'bias' must be a numeric scalar when no selector is specified", call. = FALSE) + } + weights <- as.numeric(weights) + bias <- as.numeric(bias) + } else { + weights <- .glm_pred_normalize_strata_array( + weights, + K_per = K_per, selector_tracks = selector_tracks, selector_breaks = selector_breaks, + leading_dim = N, leading_name = "entry", param = "weights" + ) + if (!is.numeric(bias)) { + stop("'bias' must be numeric", call. = FALSE) + } + if (length(bias) == 1L) { + bias <- array(rep(as.numeric(bias), prod(K_per)), dim = K_per) + } + bias <- .glm_pred_normalize_strata_array( + bias, + K_per = K_per, selector_tracks = selector_tracks, selector_breaks = selector_breaks, + leading_dim = NA_integer_, leading_name = NA_character_, param = "bias" + ) + } + + if (!is.numeric(scale_factor) || length(scale_factor) != 1 || scale_factor <= 0) { + stop("'scale_factor' must be a positive numeric scalar", call. = FALSE) + } + + # --- Validate and process shifts --- + sshifts <- rep(0, N) + eshifts <- rep(0, N) + if (!is.null(shifts)) { + if (!is.list(shifts) || length(shifts) != N) { + stop(sprintf("'shifts' must be a list of length %d", N), call. = FALSE) + } + for (i in seq_len(N)) { + s <- shifts[[i]] + if (!is.numeric(s) || length(s) != 2) { + stop(sprintf("shifts[[%d]] must be numeric(2)", i), call. = FALSE) + } + sshifts[i] <- s[1] + eshifts[i] <- s[2] + } + } + + # --- Validate kernel_bins and kernels --- + if (!is.null(kernel_bins)) { + if (!is.numeric(kernel_bins)) { + stop("'kernel_bins' must be a numeric vector", call. = FALSE) + } + if (is.null(kernels)) { + stop("'kernels' must be provided when 'kernel_bins' is specified", call. = FALSE) + } + } + if (!is.null(kernels)) { + if (!is.list(kernels)) { + stop("'kernels' must be a list of numeric vectors", call. = FALSE) + } + B <- if (!is.null(kernel_bins)) length(kernel_bins) else NA + kn_len <- length(kernels) + if (kn_len != 1 && kn_len != N) { + stop(sprintf("'kernels' must be length 1 or %d", N), call. = FALSE) + } + for (i in seq_along(kernels)) { + if (!is.numeric(kernels[[i]])) { + stop(sprintf("kernels[[%d]] must be numeric", i), call. = FALSE) + } + if (!is.na(B) && length(kernels[[i]]) != B) { + stop(sprintf("kernels[[%d]] must have length %d (matching kernel_bins)", i, B), + call. = FALSE + ) + } + } + # Recycle length-1 kernels + if (kn_len == 1 && N > 1) { + kernels <- rep(kernels, N) + } + } + + # --- Validate and recycle trans_family / trans_params --- + if (!is.null(trans_family)) { + if (length(trans_family) == 1) { + trans_family <- rep(trans_family, N) + } + if (length(trans_family) != N) { + stop(sprintf("'trans_family' must be length 1, %d, or NULL", N), call. = FALSE) + } + invalid_tf <- setdiff(unique(trans_family[!is.na(trans_family)]), "logist") + if (length(invalid_tf) > 0) { + stop( + sprintf( + "'trans_family' must be 'logist' or NA (got: %s)", + paste0("'", invalid_tf, "'", collapse = ", ") + ), + call. = FALSE + ) + } + } else { + trans_family <- rep(NA_character_, N) + } + + if (!is.null(trans_params)) { + if (length(trans_params) == 1) { + trans_params <- rep(trans_params, N) + } + if (length(trans_params) != N) { + stop(sprintf("'trans_params' must be length 1, %d, or NULL", N), call. = FALSE) + } + } else { + trans_params <- vector("list", N) + } + + # --- Validate max_cap / dis_from_cap --- + if (is.null(max_cap)) max_cap <- rep(NA_real_, N) + if (is.null(dis_from_cap)) dis_from_cap <- rep(NA_real_, N) + if (length(max_cap) != N) { + stop(sprintf("'max_cap' must be length %d or NULL", N), call. = FALSE) + } + if (length(dis_from_cap) != N) { + stop(sprintf("'dis_from_cap' must be length %d or NULL", N), call. = FALSE) + } + # --- Validate / recycle simple_cap --- + if (!is.null(simple_cap)) { + if (length(simple_cap) == 1) { + simple_cap <- rep(simple_cap, N) + } else if (length(simple_cap) != N) { + stop(sprintf("'simple_cap' must be length 1, %d, or NULL", N), + call. = FALSE + ) + } + } + # max_cap and dis_from_cap must be specified together per entry + cap_mismatch <- xor(is.na(max_cap), is.na(dis_from_cap)) + if (any(cap_mismatch)) { + bad <- which(cap_mismatch)[1] + stop( + sprintf( + "'max_cap' and 'dis_from_cap' must both be specified or both NA for each entry (mismatch at entry %d)", + bad + ), + call. = FALSE + ) + } + + # --- Flatten transform params into parallel vectors --- + trans_L <- vapply(seq_len(N), function(i) { + p <- trans_params[[i]] + if (is.null(p) || is.na(trans_family[i])) NA_real_ else p$L %||% 1 + }, numeric(1)) + trans_k <- vapply(seq_len(N), function(i) { + p <- trans_params[[i]] + if (is.null(p) || is.na(trans_family[i])) NA_real_ else p$k %||% 1 + }, numeric(1)) + trans_x0 <- vapply(seq_len(N), function(i) { + p <- trans_params[[i]] + if (is.null(p) || is.na(trans_family[i])) NA_real_ else p$x_0 %||% 0 + }, numeric(1)) + trans_pre <- vapply(seq_len(N), function(i) { + p <- trans_params[[i]] + if (is.null(p) || is.na(trans_family[i])) NA_real_ else p$pre_shift %||% 0 + }, numeric(1)) + trans_post <- vapply(seq_len(N), function(i) { + p <- trans_params[[i]] + if (is.null(p) || is.na(trans_family[i])) NA_real_ else p$post_shift %||% 0 + }, numeric(1)) + + # --- Build params list for C++ --- + # weights / bias / interaction_weights keep their array shape (with auto-derived + # dimnames) when a selector is specified. C++ reads via REAL(), which gives the + # column-major underlying buffer regardless of dim/dimnames attributes. + params <- list( + tracks = tracks, + inner_func = inner_func, + weights = weights, + bias = bias, + num_bins = as.integer(K), + scale_factor = as.numeric(scale_factor), + sshifts = as.numeric(sshifts), + eshifts = as.numeric(eshifts), + max_cap = as.numeric(max_cap), + dis_from_cap = as.numeric(dis_from_cap), + simple_cap = if (!is.null(simple_cap)) as.logical(simple_cap) else NULL, + trans_family = trans_family, + trans_L = as.numeric(trans_L), + trans_k = as.numeric(trans_k), + trans_x0 = as.numeric(trans_x0), + trans_pre = as.numeric(trans_pre), + trans_post = as.numeric(trans_post) + ) + + # Add selector params if present + if (!is.null(selector_tracks)) { + params$selector_tracks <- as.character(selector_tracks) + params$selector_breaks <- lapply(selector_breaks, as.numeric) + } + + # Add kernel params if present + if (!is.null(kernel_bins)) { + params$kernel_bins <- as.numeric(kernel_bins) + } + if (!is.null(kernels)) { + params$kernels <- kernels + } + + # --- Validate and flatten interactions --- + if (!is.null(interactions)) { + if (!is.list(interactions)) { + stop("'interactions' must be a list of integer(2) pairs", call. = FALSE) + } + M <- length(interactions) + if (is.null(selector_tracks)) { + if (!is.numeric(interaction_weights) || !is.null(dim(interaction_weights)) || + length(interaction_weights) != M) { + stop(sprintf( + "'interaction_weights' must be a numeric vector of length %d when no selector is specified", + M + ), call. = FALSE) + } + interaction_weights <- as.numeric(interaction_weights) + } else { + interaction_weights <- .glm_pred_normalize_strata_array( + interaction_weights, + K_per = K_per, + selector_tracks = selector_tracks, selector_breaks = selector_breaks, + leading_dim = M, leading_name = "interaction", + param = "interaction_weights" + ) + } + + inter_i <- vapply(interactions, `[`, integer(1), 1L) + inter_j <- vapply(interactions, `[`, integer(1), 2L) + + if (any(inter_i < 1 | inter_i > N | inter_j < 1 | inter_j > N)) { + stop(sprintf("Interaction indices must be in [1, %d]", N), call. = FALSE) + } + + params$inter_i <- as.integer(inter_i) + params$inter_j <- as.integer(inter_j) + params$inter_weights <- interaction_weights + + # Process interaction transforms + if (is.null(interaction_trans_family)) { + interaction_trans_family <- rep(NA_character_, M) + } else if (length(interaction_trans_family) == 1) { + interaction_trans_family <- rep(interaction_trans_family, M) + } else if (length(interaction_trans_family) != M) { + stop(sprintf( + "'interaction_trans_family' must be length 1, %d, or NULL", M + ), call. = FALSE) + } + + if (is.null(inter_trans_params)) { + inter_trans_params <- vector("list", M) + } else if (length(inter_trans_params) == 1) { + inter_trans_params <- rep(inter_trans_params, M) + } else if (length(inter_trans_params) != M) { + stop(sprintf( + "'inter_trans_params' must be length 1, %d, or NULL", M + ), call. = FALSE) + } + + params$inter_trans_family <- interaction_trans_family + params$inter_trans_L <- vapply(seq_len(M), function(m) { + p <- inter_trans_params[[m]] + if (is.null(p) || is.na(interaction_trans_family[m])) NA_real_ else p$L %||% 1 + }, numeric(1)) + params$inter_trans_k <- vapply(seq_len(M), function(m) { + p <- inter_trans_params[[m]] + if (is.null(p) || is.na(interaction_trans_family[m])) NA_real_ else p$k %||% 1 + }, numeric(1)) + params$inter_trans_x0 <- vapply(seq_len(M), function(m) { + p <- inter_trans_params[[m]] + if (is.null(p) || is.na(interaction_trans_family[m])) NA_real_ else p$x_0 %||% 0 + }, numeric(1)) + params$inter_trans_pre <- vapply(seq_len(M), function(m) { + p <- inter_trans_params[[m]] + if (is.null(p) || is.na(interaction_trans_family[m])) NA_real_ else p$pre_shift %||% 0 + }, numeric(1)) + params$inter_trans_post <- vapply(seq_len(M), function(m) { + p <- inter_trans_params[[m]] + if (is.null(p) || is.na(interaction_trans_family[m])) NA_real_ else p$post_shift %||% 0 + }, numeric(1)) + } + + # --- Register as vtrack --- + var <- list( + func = "glm.predict", + params = params + ) + + .gvtrack.set(name, var) + + invisible(name) +} + +#' Remove a GLM predictor virtual track +#' +#' @param name character(1) Virtual track name +#' @return None. +#' @export +glm_pred.rm <- function(name) { + gvtrack.rm(name) +} + +#' List GLM predictor virtual tracks +#' +#' @return Character vector of virtual track names that use glm.predict. +#' @export +glm_pred.ls <- function() { + all_vt <- gvtrack.ls() + if (length(all_vt) == 0) { + return(character(0)) + } + is_glm <- vapply(all_vt, function(vt) { + info <- gvtrack.info(vt) + identical(info$func, "glm.predict") + }, logical(1)) + all_vt[is_glm] +} + +#' Get info for a GLM predictor virtual track +#' +#' Returns the virtual track definition. When the track uses one or more +#' selectors, \code{weights}, \code{bias}, and \code{interaction_weights} +#' are returned as labeled arrays with \code{dim = c(N, K_1, ..., K_M)} +#' (or \code{c(K_1, ..., K_M)} for \code{bias}), with axis names taken +#' from \code{selector_tracks} and axis labels derived from +#' \code{selector_breaks} via \code{cut()} semantics. +#' +#' @param name character(1) Virtual track name +#' @return List with virtual track definition. +#' @export +glm_pred.info <- function(name) { + gvtrack.info(name) +} diff --git a/R/misha-package.R b/R/misha-package.R index 88766dd0a..633986e5d 100644 --- a/R/misha-package.R +++ b/R/misha-package.R @@ -41,7 +41,7 @@ #' @name misha-package #' @importFrom utils read.csv head read.table write.table #' @importFrom stats qnorm setNames -#' @useDynLib misha garrays_import gbins_quantiles gbins_summary gbintransform gchain2interv gcheck_iterator gcheck_vtrack C_gcis_decay C_gcompute_strands_autocorr gcreate_pwm_energy_multitask gcreate_pwm_energy gcreate_test_computer2d_track C_gextract gextract_multitask gfind_neighbors gfind_neighbors gfind_tracks_n_intervals gget_tracks_attrs gintervals_chrom_sizes gintervals_import_genes gintervals_quantiles gintervals_quantiles_multitask gintervals_stats gintervals_stats gintervals_summary gintervcanonic gintervdiff ginterv_intersectband gintervintersect gintervs_liftover gintervsort gintervunion giterator_intervals gmapply gmapply gmapply_multitask C_gpartition C_gquantiles gquantiles_multitask grbind C_gsample C_gscreen gscreen_multitask C_gsegment gseqimport gseqread gset_tracks_attrs gsmooth gtrack_2d_import gtrack_bintransform gtrackconvert gtrack_create_meta gtrackcreate_multitask gtrack_create_sparse gtrack_create_track2d gtrackcreate gtrackcor gtrackcor_multitask gtrackdist gtrackdist_multitask gtrack_import_contacts gtrackimport_mappedseq gtrackimportwig gtrackinfo gtrack_intervals_load gtrack_liftover gtrack_modify gtracksummary gtracksummary_multitask C_gwilcox +#' @useDynLib misha garrays_import gbins_quantiles gbins_summary gbintransform gchain2interv gcheck_iterator gcheck_vtrack C_gcis_decay C_gcompute_strands_autocorr gcreate_pwm_energy_multitask gcreate_pwm_energy gcreate_test_computer2d_track C_gextract C_glm_extract_features C_gquantiles_multi C_gscreen_multi C_gsummary_multi gextract_multitask gfind_neighbors gfind_neighbors gfind_tracks_n_intervals gget_tracks_attrs gintervals_chrom_sizes gintervals_import_genes gintervals_quantiles gintervals_quantiles_multitask gintervals_stats gintervals_stats gintervals_summary gintervcanonic gintervdiff ginterv_intersectband gintervintersect gintervs_liftover gintervsort gintervunion giterator_intervals gmapply gmapply gmapply_multitask C_gpartition C_gquantiles gquantiles_multitask grbind C_gsample C_gscreen gscreen_multitask C_gsegment gseqimport gseqread gset_tracks_attrs gsmooth gtrack_2d_import gtrack_bintransform gtrackconvert gtrack_create_meta gtrackcreate_multitask gtrack_create_sparse gtrack_create_track2d gtrackcreate gtrackcor gtrackcor_multitask gtrackdist gtrackdist_multitask gtrack_import_contacts gtrackimport_mappedseq gtrackimportwig gtrackinfo gtrack_intervals_load gtrack_liftover gtrack_modify gtracksummary gtracksummary_multitask C_gwilcox #' @aliases misha-package misha #' @keywords package "_PACKAGE" diff --git a/_pkgdown.yml b/_pkgdown.yml index 3eb252b16..215dd2ef1 100755 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -53,6 +53,18 @@ reference: - gvtrack.rm - gvtrack.clear - gvtrack.filter + - title: GLM predictor virtual tracks + desc: Fused generalized linear model prediction at each genome position + contents: + - glm_pred.create + - glm_pred.rm + - glm_pred.ls + - glm_pred.info + - title: GLM feature extraction + desc: Batch feature extraction for LASSO training from motif tracks + contents: + - glm_extract_features + - glm_batch_quantiles - title: Intervals functions desc: Functions to manipulate and create intervals contents: diff --git a/man/glm_batch_quantiles.Rd b/man/glm_batch_quantiles.Rd new file mode 100644 index 000000000..6473fc786 --- /dev/null +++ b/man/glm_batch_quantiles.Rd @@ -0,0 +1,90 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/glm-features.R +\name{glm_batch_quantiles} +\alias{glm_batch_quantiles} +\title{Compute genome-wide quantiles for multiple tracks in parallel} +\usage{ +glm_batch_quantiles( + track_names, + percentiles, + iterator = 20L, + sshift = -140L, + eshift = 140L, + n_threads = getOption("gmax.processes", 1L), + func = "lse", + intervals = NULL +) +} +\arguments{ +\item{track_names}{Character vector of track names.} + +\item{percentiles}{Numeric vector of percentiles to compute (e.g., 0.9999).} + +\item{iterator}{Integer scalar: iterator step size in bp (default 20L).} + +\item{sshift}{Integer scalar: start shift for the LSE aggregation window +relative to iterator center (default -140L).} + +\item{eshift}{Integer scalar: end shift for the LSE aggregation window +relative to iterator center (default 140L).} + +\item{n_threads}{Integer scalar: number of parallel threads. Defaults to +\code{getOption("gmax.processes", 1L)} to match the rest of misha. +Set \code{options(gmax.processes = N)} or pass \code{n_threads = N} +to raise it. Pass \code{n_threads = 0L} to auto-detect +(\code{min(n_tracks, hardware_concurrency, 40)}). Each thread uses +~540 MB for mouse genome at 20bp resolution.} + +\item{func}{Window aggregation function. One of \code{"lse"} (default), +\code{"avg"}, \code{"sum"}, \code{"max"}, \code{"min"}. Matches the +vtrack \code{func} semantics.} + +\item{intervals}{Optional 1D intervals data.frame (\code{chrom, start, end}) +restricting the scan to a subset of the genome. \code{NULL} (default) +scans the whole genome.} +} +\value{ +If a single percentile is requested: a named numeric vector + (one value per track). If multiple percentiles: a matrix with + \code{n_tracks} rows and \code{n_percentiles} columns. +} +\description{ +Efficiently computes genome-wide quantiles for many tracks using parallel +C++ threads. Each thread scans the genome for one track, computing LSE +aggregation over the specified window at each iterator position, then +computes exact quantiles using nth_element. +} +\details{ +This function replaces the pattern of calling \code{gquantiles} once per +track in a loop. For 191 motif tracks, it reduces total runtime from +5-10 minutes to ~1 minute by: +\itemize{ + \item Multi-threaded C++ execution (N tracks processed in parallel) + \item Avoiding R-to-C++ boundary overhead per track + \item No \code{doMC} fork overhead + \item Benefiting from OS page cache (mmap'd track files) +} + +The LSE aggregation uses the same float-precision \code{lse_accumulate} +as misha's \code{vtrack func="lse"}. + +The quantile algorithm uses exact \code{nth_element} (equivalent to +R's \code{quantile(x, p, type=1)}), which may differ slightly from +\code{gquantiles} which uses StreamPercentiler (approximate). +} +\examples{ +\dontrun{ +gdb.init("/path/to/trackdb") +tracks <- paste0("th_epi.all_db_motifs.", c("JASPAR_Zic2", "HOMER_Unknown_ESC_element")) +q <- glm_batch_quantiles(tracks, percentiles = 0.9999) +# Returns: named vector with one value per track + +# Multiple percentiles: +q_mat <- glm_batch_quantiles(tracks, percentiles = c(0.99, 0.999, 0.9999)) +# Returns: matrix with tracks as rows, percentiles as columns + +# Control parallelism: +q <- glm_batch_quantiles(tracks, percentiles = 0.9999, n_threads = 10L) +} + +} diff --git a/man/glm_extract_features.Rd b/man/glm_extract_features.Rd new file mode 100644 index 000000000..a779e4a1d --- /dev/null +++ b/man/glm_extract_features.Rd @@ -0,0 +1,82 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/glm-features.R +\name{glm_extract_features} +\alias{glm_extract_features} +\title{Extract GLM feature matrix from motif energy tracks} +\usage{ +glm_extract_features( + track_names, + intervals, + tile_size = 200L, + flank_size = 350L, + max_cap, + dis_from_cap = 10, + scale_factor = 10, + transforms = list(`low-energy` = list(L = 2, k = 0.5, x_0 = 0, pre_shift = 0, + post_shift = -1), `high-energy` = list(L = 2, k = 0.5, x_0 = 10, pre_shift = 0, + post_shift = 0), sigmoid = list(L = 1, k = 1, x_0 = 0, pre_shift = -5, post_shift = + 0), `higher-energy` = list(L = 2, k = 1, x_0 = 10, pre_shift = 0, post_shift = 0)), + gc_track = "seq.G_or_C", + gc_scale_factor = 10, + n_threads = getOption("gmax.processes", 1L) +) +} +\arguments{ +\item{track_names}{Character vector of motif track names +(e.g., \code{"th_epi.all_db_motifs.JASPAR_Zic2"}).} + +\item{intervals}{Data frame with \code{chrom}, \code{start}, \code{end} columns. +All intervals must have the same width.} + +\item{tile_size}{Tile width in bp (default 200).} + +\item{flank_size}{Flanking region in bp added to each side of the peak (default 350).} + +\item{max_cap}{Named numeric vector of per-motif maximum cap values +(genome-wide quantiles). Names must match \code{track_names}.} + +\item{dis_from_cap}{Distance below cap for normalization (default 10).} + +\item{scale_factor}{Output range scale factor (default 10).} + +\item{transforms}{List of transform configurations. Each element is a list +with fields \code{L}, \code{k}, \code{x_0}, \code{pre_shift}, \code{post_shift}. +Defaults to the 4 standard logistic heads (low-energy, high-energy, sigmoid, +higher-energy).} + +\item{gc_track}{GC content track name (default \code{"seq.G_or_C"}).} + +\item{gc_scale_factor}{Scale factor for GC features (default 10).} + +\item{n_threads}{Integer scalar: number of worker threads. Defaults to +\code{getOption("gmax.processes", 1L)} for consistency with the rest +of misha. Pass \code{n_threads = 0L} to auto-detect +(\code{min(n_peaks, hardware_concurrency, 40)}). Each thread holds +its own per-chromosome mmap of the motif and GC tracks; for the +typical 191-motif workload that's a few hundred MB resident per +thread (mmap, so most of it stays in the OS page cache).} +} +\value{ +A numeric matrix with one row per interval and columns for: + \itemize{ + \item Motif features: \code{n_motifs * n_tiles * n_transforms} columns + \item GC features: \code{n_tiles} columns + \item GC interactions: \code{choose(n_tiles, 2)} columns + } +} +\description{ +Reads multiple motif energy tracks, applies scaling and logistic transforms, +and returns the complete feature matrix in a single C++ pass. This replaces +the R-side pipeline of gextract -> scale -> reshape -> logistic transform. +} +\examples{ +\dontrun{ +gdb.init("/path/to/trackdb") +peaks <- data.frame(chrom = "chr1", start = c(1000, 2000), end = c(1300, 2300)) +motifs <- c("th_epi.all_db_motifs.JASPAR_Zic2") +caps <- c(JASPAR_Zic2 = 10.5) +names(caps) <- motifs +result <- glm_extract_features(motifs, peaks, max_cap = caps) +} + +} diff --git a/man/glm_pred.create.Rd b/man/glm_pred.create.Rd new file mode 100644 index 000000000..9d973d608 --- /dev/null +++ b/man/glm_pred.create.Rd @@ -0,0 +1,122 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/glm-pred.R +\name{glm_pred.create} +\alias{glm_pred.create} +\title{Create a GLM predictor virtual track} +\usage{ +glm_pred.create( + name, + tracks, + inner_func, + weights, + bias = 0, + kernels = NULL, + kernel_bins = NULL, + shifts = NULL, + trans_family = NULL, + trans_params = NULL, + max_cap = NULL, + dis_from_cap = NULL, + simple_cap = NULL, + scale_factor = 10, + interactions = NULL, + interaction_weights = NULL, + interaction_trans_family = NULL, + inter_trans_params = NULL, + selector_tracks = NULL, + selector_breaks = NULL +) +} +\arguments{ +\item{name}{character(1) Virtual track name} + +\item{tracks}{character(N) Genomic track names (repeated OK)} + +\item{inner_func}{character(N) \code{"sum"} or \code{"lse"} per entry} + +\item{weights}{LM coefficients per entry. Shape depends on selectors: +\itemize{ + \item No selector: \code{numeric(N)}. + \item One selector (M=1): \code{matrix(N, K_1)}. + \item Two or more selectors (M>=2): array with + \code{dim = c(N, K_1, ..., K_M)}. Plain + \code{N x prod(K_m)} matrices are rejected to avoid flatten-order + ambiguity. Build with \code{array(coefs, dim = c(N, K_1, ..., K_M))}. +} +When a selector is specified, trailing-axis dimnames are auto-derived +from \code{selector_breaks} (\code{cut(include.lowest=TRUE, right=TRUE)} +labels) and trailing-axis names from \code{selector_tracks}. If you +supply your own dimnames they must match exactly; mismatches error +with the offending axis named.} + +\item{bias}{Intercept term (default 0). Shape depends on selectors: +\itemize{ + \item No selector: \code{numeric(1)}. + \item One selector (M=1): scalar (recycled) or \code{numeric(K_1)}. + \item Two or more selectors (M>=2): scalar (recycled to all strata) + or array with \code{dim = c(K_1, ..., K_M)}. +} +Auto-derived dimnames mirror those of \code{weights} on the trailing +axes.} + +\item{kernels}{list of numeric vectors (N or 1, recycled) Sub-bin kernel +weights, or NULL for direct aggregation} + +\item{kernel_bins}{numeric(B) Offsets relative to shift window center, or NULL} + +\item{shifts}{list of numeric(2) Per-entry \code{c(sshift, eshift)}, or NULL} + +\item{trans_family}{character(N or 1 or NULL) \code{"logist"} or NA per entry} + +\item{trans_params}{list of lists (N or NULL) Each element is a list with +fields \code{L}, \code{k}, \code{x_0}, and optionally \code{pre_shift}, +\code{post_shift}} + +\item{max_cap}{numeric(N or NULL) Capping threshold per entry (NA to skip)} + +\item{dis_from_cap}{numeric(N or NULL) Distance from cap per entry (NA to skip)} + +\item{simple_cap}{logical(N or NULL) If TRUE, use simple cap-and-divide +scaling: \code{min(raw, max_cap) / dis_from_cap}. Default NULL (standard +cap-normalize scaling).} + +\item{scale_factor}{numeric(1) Global scale factor (default 10)} + +\item{interactions}{list of integer(2) (M or NULL) Pairs of entry indices (1-based)} + +\item{interaction_weights}{Per-interaction LM coefficients. Shape mirrors +\code{weights} with the leading axis being the interaction index: +\itemize{ + \item No selector: \code{numeric(M_int)}. + \item One selector (M=1): \code{matrix(M_int, K_1)}. + \item Two or more selectors (M>=2): array with + \code{dim = c(M_int, K_1, ..., K_M)}. +} +Same dimnames rules as \code{weights}; leading axis name is +\code{"interaction"}.} + +\item{interaction_trans_family}{character(M or 1 or NULL) Transform for interactions} + +\item{inter_trans_params}{list of lists (M or NULL) Logistic params per interaction} + +\item{selector_tracks}{character(M) or NULL Names of fixed-bin (dense) tracks +used for per-position model selection. With M selectors, strata are the +Cartesian product of per-selector bins (column-major: first selector varies +fastest). When NULL (default), K = 1 and a single set of weights is applied +everywhere.} + +\item{selector_breaks}{list of M numeric vectors, or NULL. Each element is +the break vector (length K_m + 1, K_m >= 1) for the corresponding selector +track in \code{selector_tracks}. Break points use +\code{cut(include.lowest = TRUE, right = TRUE)} semantics. Required and +length-matched to \code{selector_tracks} when that is non-NULL.} +} +\value{ +Invisibly returns \code{name}. +} +\description{ +Creates a virtual track that computes a fused generalized linear model +prediction at each genome position. The pipeline for each entry is: +smooth → scale (cap + normalize) → transform (logistic) → weight. +Interactions are computed post-scaling, pre-transform. +} diff --git a/man/glm_pred.info.Rd b/man/glm_pred.info.Rd new file mode 100644 index 000000000..38a2d88c9 --- /dev/null +++ b/man/glm_pred.info.Rd @@ -0,0 +1,22 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/glm-pred.R +\name{glm_pred.info} +\alias{glm_pred.info} +\title{Get info for a GLM predictor virtual track} +\usage{ +glm_pred.info(name) +} +\arguments{ +\item{name}{character(1) Virtual track name} +} +\value{ +List with virtual track definition. +} +\description{ +Returns the virtual track definition. When the track uses one or more +selectors, \code{weights}, \code{bias}, and \code{interaction_weights} +are returned as labeled arrays with \code{dim = c(N, K_1, ..., K_M)} +(or \code{c(K_1, ..., K_M)} for \code{bias}), with axis names taken +from \code{selector_tracks} and axis labels derived from +\code{selector_breaks} via \code{cut()} semantics. +} diff --git a/man/glm_pred.ls.Rd b/man/glm_pred.ls.Rd new file mode 100644 index 000000000..9c2ad9c80 --- /dev/null +++ b/man/glm_pred.ls.Rd @@ -0,0 +1,14 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/glm-pred.R +\name{glm_pred.ls} +\alias{glm_pred.ls} +\title{List GLM predictor virtual tracks} +\usage{ +glm_pred.ls() +} +\value{ +Character vector of virtual track names that use glm.predict. +} +\description{ +List GLM predictor virtual tracks +} diff --git a/man/glm_pred.rm.Rd b/man/glm_pred.rm.Rd new file mode 100644 index 000000000..e24db6f3f --- /dev/null +++ b/man/glm_pred.rm.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/glm-pred.R +\name{glm_pred.rm} +\alias{glm_pred.rm} +\title{Remove a GLM predictor virtual track} +\usage{ +glm_pred.rm(name) +} +\arguments{ +\item{name}{character(1) Virtual track name} +} +\value{ +None. +} +\description{ +Remove a GLM predictor virtual track +} diff --git a/man/gquantiles.Rd b/man/gquantiles.Rd index 5b5105102..be3293c12 100644 --- a/man/gquantiles.Rd +++ b/man/gquantiles.Rd @@ -9,11 +9,15 @@ gquantiles( percentiles = 0.5, intervals = get("ALLGENOME", envir = .misha), iterator = NULL, - band = NULL + band = NULL, + fast = FALSE ) } \arguments{ -\item{expr}{track expression} +\item{expr}{track expression. Character vectors of length > 1 are +supported when \code{fast = TRUE} and every element resolves to a +simple track or vtrack shape; the return value is then a data.frame +with a \code{track} column and one column per percentile.} \item{percentiles}{an array of percentiles of quantiles in [0, 1] range} @@ -23,9 +27,17 @@ gquantiles( implicitly based on track expression.} \item{band}{track expression band. If 'NULL' no band is used.} + +\item{fast}{if \code{TRUE} and \code{expr} is a bare track or vtrack name +(or a character vector of such names), a direct-mmap C++ fast path is +used. Default \code{FALSE} to preserve numeric back-compat with +single-expression calls (see Details). For multi-expression calls +\code{fast = TRUE} is required.} } \value{ -An array that represent quantiles. +For a single expression, a named numeric vector of quantile + values. For a character vector of expressions with \code{fast = TRUE}, + a data.frame with columns \code{track} and one per percentile. } \description{ Calculates the quantiles of a track expression for the given percentiles. @@ -44,6 +56,33 @@ the number of available CPU cores, running the function on two different machines might give different results. Please switch off multitasking if you want to achieve identical results on any machine. For more information regarding multitasking please refer "User Manual". + + +**Numerical differences between fast and slow paths.** The fast path +(\code{fast = TRUE}) computes *exact* quantiles via \code{nth_element} +on a top-K heap (or on a full value buffer in fallback mode), +equivalent to \code{quantile(x, p, type = 1)}. The slow path +(\code{fast = FALSE}, default) uses \code{StreamPercentiler}, which +draws a reservoir sample when scanned data exceeds +\code{options(gmax.data.size)} and can return approximate quantiles +at extreme percentiles. Observed differences on motif-energy tracks at +\code{p = 0.9999} are in the range 0.02–0.06. The fast path is the +more correct answer (no subsampling); the slow path matches +long-standing misha behavior. If you have workflows pinned to +existing \code{gquantiles} outputs, keep \code{fast = FALSE}; +otherwise \code{fast = TRUE} is faster and exact. In a future +release the default may flip to \code{fast = TRUE}; this will be +announced in NEWS. + +**Memory and speed near p = 0.5.** The fast path's speedup for +extreme quantiles comes from a top-K heap that keeps only the top +(or bottom) \code{ceil((1 - max(p)) * N * 1.2)} values. For \code{p} +near 0.5, \code{K} approaches \code{N/2}, exceeds the internal cap +(\code{K_MAX = 10M}), and the fast path falls back to storing all +values (same memory footprint as pre-refactor misha). A warning +names the affected tracks. For median-like queries on whole-genome +data the fast path provides no speedup from top-K but still benefits +from direct-mmap scan and \code{std::thread} parallelism. } \examples{ \dontshow{ diff --git a/man/gscreen.Rd b/man/gscreen.Rd index 1c09106b0..64d2e6a6a 100644 --- a/man/gscreen.Rd +++ b/man/gscreen.Rd @@ -9,7 +9,8 @@ gscreen( intervals = NULL, iterator = NULL, band = NULL, - intervals.set.out = NULL + intervals.set.out = NULL, + fast = TRUE ) } \arguments{ @@ -24,6 +25,13 @@ implicitly based on track expression.} \item{intervals.set.out}{intervals set name where the function result is optionally outputted} + +\item{fast}{if \code{TRUE} (default) and \code{expr} is a character vector +of length > 1 whose elements are simple \code{" "} +comparisons (with \code{op} one of \code{<, <=, ==, >=, >}), a fast +direct-mmap C++ multi-track path is used and a data.frame with columns +\code{chrom, start, end, track} is returned. Single expressions always +take the legacy path for bit-exact back-compat.} } \value{ If 'intervals.set.out' is 'NULL' a set of intervals that match track diff --git a/man/gsummary.Rd b/man/gsummary.Rd index 69a123fa2..1dc4aa218 100644 --- a/man/gsummary.Rd +++ b/man/gsummary.Rd @@ -4,7 +4,13 @@ \alias{gsummary} \title{Calculates summary statistics of track expression} \usage{ -gsummary(expr = NULL, intervals = NULL, iterator = NULL, band = NULL) +gsummary( + expr = NULL, + intervals = NULL, + iterator = NULL, + band = NULL, + fast = TRUE +) } \arguments{ \item{expr}{track expression} @@ -15,6 +21,12 @@ gsummary(expr = NULL, intervals = NULL, iterator = NULL, band = NULL) implicitly based on track expression.} \item{band}{track expression band. If 'NULL' no band is used.} + +\item{fast}{if \code{TRUE} (default) and \code{expr} is a character vector +of length > 1 whose elements are bare track or vtrack names, a fast +direct-mmap C++ multi-track path is used and a data.frame with columns +\code{track, n, n_nan, min, max, sum, mean, sd} is returned. Single +expressions always take the legacy path for bit-exact back-compat.} } \value{ An array that represents summary statistics. diff --git a/src/BatchQuantiles.cpp b/src/BatchQuantiles.cpp new file mode 100644 index 000000000..1ae9fb9ba --- /dev/null +++ b/src/BatchQuantiles.cpp @@ -0,0 +1,463 @@ +// BatchQuantiles.cpp — batched multi-track genome-wide quantile scan. +// +// Phase 2: TopKQuantile reducer with top-K / bottom-K heap-backed vector +// plus full-vector fallback, sliding-max upper-bound pruning, and +// per-aggregator (`lse`/`avg`/`sum`/`max`/`min`) templating. Supports +// whole-genome scans and caller-provided intervals. + +#include "BatchTrackScan.h" +#include "rdbinterval.h" +#include "rdbutils.h" +#include "GenomeTrack.h" + +#include + +#include +#include +#include +#include +#include +#include +#include +#include +#include + +using namespace rdb; +using namespace batchscan; + +// --------------------------------------------------------------------------- +// TopKQuantile reducer. +// +// Mode (set at Config build time): +// use_fallback = true -> State::buf holds every accepted value; final +// nth_element runs over the full buffer. +// use_fallback = false -> State::buf is a heap-backed vector of size K. +// top_side = true -> min-heap of largest K so far +// top_side = false -> max-heap of smallest K so far +// +// Heap build is lazy: we append until buf.size() == K, then make_heap once, +// and thereafter swap-replace the extremum. This avoids heap overhead while +// the buffer is filling and amortizes the log(K) cost across pushes. +// --------------------------------------------------------------------------- +struct TopKQuantile { + struct Config { + std::vector percentiles; + uint32_t K = 0; + bool use_fallback = true; + bool top_side = true; + }; + + struct State { + const Config *cfg = nullptr; + uint64_t n_total = 0; + std::vector buf; + bool heap_built = false; + + void init(const Config &c, int /*chromid*/, int /*iterator_step*/) { + cfg = &c; + buf.reserve(c.use_fallback ? 1024 + : std::min(c.K, 1u << 20)); + } + + // Called by the scan driver for every non-NaN position, whether it + // gets pushed into the heap or not. This keeps n_total consistent + // between fallback and heap modes — without it, heap-mode would + // undercount pruned-but-valid positions, shifting the rank + // calculation in topk_finalize. + void count_pruned() { ++n_total; } + + // NaN-aggregate positions have no rank. Ignored for quantile math; + // they neither contribute to n_total nor the heap. + void nan_seen() {} + + void accept(float v, int64_t /*pos*/) { + ++n_total; + if (!cfg || cfg->use_fallback) { + buf.push_back(v); + return; + } + uint32_t K = cfg->K; + if (!heap_built) { + buf.push_back(v); + // Use >= K so that a merged accumulator (which may already + // hold K elements before the first accept) heapifies on its + // very first accept rather than silently growing past K. + if (buf.size() >= (size_t)K) { + if (cfg->top_side) + std::make_heap(buf.begin(), buf.end(), + std::greater{}); + else + std::make_heap(buf.begin(), buf.end(), + std::less{}); + heap_built = true; + } + return; + } + // Heap full; swap-replace if v improves on the extremum. + if (cfg->top_side) { + if (v > buf.front()) { + std::pop_heap(buf.begin(), buf.end(), + std::greater{}); + buf.back() = v; + std::push_heap(buf.begin(), buf.end(), + std::greater{}); + } + } else { + if (v < buf.front()) { + std::pop_heap(buf.begin(), buf.end(), + std::less{}); + buf.back() = v; + std::push_heap(buf.begin(), buf.end(), + std::less{}); + } + } + } + + void boundary() {} + + // Runtime hint to the driver: is pruning ever possible for this + // State? Returning false lets the driver skip sliding-deque + // maintenance entirely (each position saves 1-2 deque pushes + + // advance_front calls — measurable on large fallback-mode scans). + // For TopKQuantile, fallback mode never prunes, so maintaining + // the max/min deques is pure overhead. + bool pruning_active() const { + return cfg && !cfg->use_fallback; + } + + // Pruning: only meaningful in heap mode, and only once the heap is + // full. For top-K (all percentiles >= 0.5), skip positions whose + // upper bound is below the current K-th largest. For bottom-K, + // skip positions whose lower bound is above the current K-th smallest. + bool prune(float upper, float lower) const { + if (!cfg || cfg->use_fallback || !heap_built) return false; + return cfg->top_side ? (upper < buf.front()) + : (lower > buf.front()); + } + + // Merge: concat, then if in heap mode and over capacity, trim to K + // via nth_element (cheaper than N·K heap pushes). + void merge(const State &o) { + n_total += o.n_total; + if (!cfg && o.cfg) cfg = o.cfg; // pick up Config on first merge + + if (cfg && !cfg->use_fallback) { + buf.insert(buf.end(), o.buf.begin(), o.buf.end()); + if (buf.size() > (size_t)cfg->K) { + uint32_t K = cfg->K; + if (cfg->top_side) { + // Keep largest K: order buf so that the largest K + // occupy positions [N-K, N); then discard prefix. + std::nth_element(buf.begin(), buf.begin() + (buf.size() - K), + buf.end()); + buf.erase(buf.begin(), buf.begin() + (buf.size() - K)); + } else { + std::nth_element(buf.begin(), buf.begin() + K - 1, + buf.end()); + buf.resize(K); + } + } + heap_built = false; // re-heapify lazily on next accept + } else { + buf.insert(buf.end(), o.buf.begin(), o.buf.end()); + } + } + }; + + struct Result { std::vector quantile_vals; }; + + // Pruning is meaningful only in heap mode; setting needs_pruning=true + // unconditionally is safe (State::prune returns false in fallback mode + // because `heap_built` stays false and the early-return fires). In + // fallback mode the scan driver still maintains the sliding deques — + // measurable overhead flagged as future work (addendum, Phase 2 review). + static constexpr bool needs_pruning = true; + // needs_lower_bound = true is required for bottom-K pruning + // (top_side=false, all percentiles < 0.5), which consults `lower` in + // State::prune. Spec originally had false; implementation flipped to + // true to make bottom-K pruning actually fire. See addendum D-phase-2. + static constexpr bool needs_lower_bound = true; + // Quantiles need the actual value, not just a pass-flag, so the + // certain-pass shortcut doesn't apply. + static constexpr bool supports_certain_pass = false; +}; + +// --------------------------------------------------------------------------- +// finalize: compute the quantile value for each requested percentile, using +// the merged State::buf. In fallback mode buf holds all N values; in heap +// mode buf holds the K extreme values. +// --------------------------------------------------------------------------- +static std::vector topk_finalize(TopKQuantile::State &s) +{ + const auto &pctiles = s.cfg->percentiles; + std::vector out(pctiles.size(), + std::numeric_limits::quiet_NaN()); + int64_t N_total = (int64_t)s.n_total; // all accepted (non-NaN) values + int64_t N_buf = (int64_t)s.buf.size(); + if (N_buf == 0) return out; + for (size_t i = 0; i < pctiles.size(); ++i) { + double p = pctiles[i]; + int64_t rank = (int64_t)std::floor(p * (double)(N_total - 1)); + if (rank < 0) rank = 0; + if (rank >= N_total) rank = N_total - 1; + + int64_t buf_rank; + if (s.cfg->use_fallback) { + buf_rank = rank; + } else { + // Heap mode: buf holds K extreme values. + // top_side = true -> buf holds the largest K values; + // rank r among all N maps to buf index + // r - (N - K). + // top_side = false -> buf holds the smallest K values; + // rank r maps to buf index r. + if (s.cfg->top_side) + buf_rank = rank - (N_total - N_buf); + else + buf_rank = rank; + } + if (buf_rank < 0) buf_rank = 0; + if (buf_rank >= N_buf) buf_rank = N_buf - 1; + std::nth_element(s.buf.begin(), s.buf.begin() + buf_rank, + s.buf.end()); + out[i] = (double)s.buf[buf_rank]; + } + return out; +} + +// --------------------------------------------------------------------------- +// Parse `_func` SEXP into WindowAggFunc. +// --------------------------------------------------------------------------- +static WindowAggFunc parse_func(SEXP _func) +{ + if (!Rf_isString(_func) || Rf_length(_func) != 1) + verror("func must be a character scalar"); + const char *s = CHAR(STRING_ELT(_func, 0)); + if (!std::strcmp(s, "lse")) return WindowAggFunc::LSE; + if (!std::strcmp(s, "avg")) return WindowAggFunc::AVG; + if (!std::strcmp(s, "sum")) return WindowAggFunc::SUM; + if (!std::strcmp(s, "max")) return WindowAggFunc::MAX; + if (!std::strcmp(s, "min")) return WindowAggFunc::MIN; + verror("func must be one of: lse, avg, sum, max, min"); + return WindowAggFunc::LSE; // unreachable +} + +// --------------------------------------------------------------------------- +// .Call entry: C_gquantiles_multi +// +// Args (9): +// 1. _track_names character vector +// 2. _percentiles numeric vector +// 3. _iterator integer scalar (bp step) +// 4. _sshift integer scalar +// 5. _eshift integer scalar +// 6. _n_threads integer scalar (0 = auto) +// 7. _func character scalar: "lse"|"avg"|"sum"|"max"|"min" +// 8. _intervals data.frame (or NULL for whole-genome) +// 9. _envir R environment +// --------------------------------------------------------------------------- +extern "C" SEXP C_gquantiles_multi( + SEXP _track_names, + SEXP _percentiles, + SEXP _iterator, + SEXP _sshift, + SEXP _eshift, + SEXP _n_threads, + SEXP _func, + SEXP _intervals, + SEXP _envir) +{ + try { + RdbInitializer rdb_init; + IntervUtils iu(_envir); + + int n_tracks = Rf_length(_track_names); + std::vector track_names(n_tracks); + for (int i = 0; i < n_tracks; ++i) + track_names[i] = CHAR(STRING_ELT(_track_names, i)); + + int n_pctiles = Rf_length(_percentiles); + std::vector pctiles(REAL(_percentiles), + REAL(_percentiles) + n_pctiles); + for (double p : pctiles) + if (p < 0.0 || p > 1.0) verror("percentile %g not in [0, 1]", p); + + int iterator_step = INTEGER(_iterator)[0]; + int sshift = INTEGER(_sshift)[0]; + int eshift = INTEGER(_eshift)[0]; + int n_threads_req = INTEGER(_n_threads)[0]; + if (iterator_step <= 0) + verror("iterator must be a positive integer"); + + WindowAggFunc func = parse_func(_func); + + const GenomeChromKey &chromkey = iu.get_chromkey(); + SEXP envir = iu.get_env(); + + // Main-thread resolution of track paths and types. + std::vector track_dirs(n_tracks); + std::vector track_types(n_tracks); + for (int m = 0; m < n_tracks; ++m) { + track_dirs[m] = track2path(envir, track_names[m]); + track_types[m] = GenomeTrack::get_type( + track_dirs[m].c_str(), chromkey, false); + } + + // Build per-chrom intervals list (optional restriction). + const int n_chroms = (int)chromkey.get_num_chroms(); + std::vector> per_chrom(n_chroms); + bool use_intervals = !Rf_isNull(_intervals); + if (use_intervals) { + GIntervalsFetcher1D *i1d = nullptr; + GIntervalsFetcher2D *i2d = nullptr; + iu.convert_rintervs(_intervals, &i1d, &i2d); + std::unique_ptr g1(i1d); + std::unique_ptr g2(i2d); + if (i2d && i2d->size() > 0) + verror("intervals must be 1D"); + i1d->sort(); + i1d->unify_overlaps(); + for (int c = 0; c < n_chroms; ++c) { + if (i1d->size(c) == 0) continue; + i1d->begin_chrom_iter(c); + for (auto it = i1d->get_chrom_begin(); + it != i1d->get_chrom_end(); ++it) { + per_chrom[c].push_back(*it); + } + } + } + + // Estimate N (positions per track) for adaptive K. + uint64_t total_bp = 0; + if (use_intervals) { + for (auto &v : per_chrom) + for (auto &g : v) + total_bp += (uint64_t)(g.end - g.start); + } else { + for (int c = 0; c < n_chroms; ++c) + total_bp += chromkey.get_chrom_size(c); + } + uint64_t N_est = total_bp / (uint64_t)iterator_step; + if (N_est == 0) N_est = 1; + + constexpr uint32_t K_MAX = 10'000'000u; + + double min_p = *std::min_element(pctiles.begin(), pctiles.end()); + double max_p = *std::max_element(pctiles.begin(), pctiles.end()); + bool all_top = (min_p >= 0.5); + bool all_bot = (max_p < 0.5); + bool mixed_tail = !(all_top || all_bot); + + double tail = 0.0; + if (all_top) tail = 1.0 - min_p; + else if (all_bot) tail = max_p; + double K_needed_f = std::ceil(tail * (double)N_est * 1.2); + if (K_needed_f < 1.0) K_needed_f = 1.0; + bool clamp = K_needed_f > (double)K_MAX; + uint32_t K = clamp ? K_MAX + : (uint32_t)K_needed_f; + + bool use_fallback = mixed_tail || clamp; + + std::vector configs(n_tracks); + for (int m = 0; m < n_tracks; ++m) { + configs[m].percentiles = pctiles; + configs[m].K = K; + configs[m].use_fallback = use_fallback; + configs[m].top_side = all_top; + } + + if (mixed_tail) + Rf_warning("percentiles span both tails (<0.5 and >=0.5); " + "top-K pruning disabled, falling back to full storage"); + if (clamp) + Rf_warning("quantile K=%g exceeds K_MAX=%u; " + "falling back to full storage " + "(memory ~= 4 B * N_positions * n_tracks)", + K_needed_f, K_MAX); + + unsigned hw = std::thread::hardware_concurrency(); + if (hw == 0) hw = 4; + int n_threads; + if (n_threads_req > 0) { + n_threads = std::min(n_threads_req, n_tracks); + } else { + n_threads = (int)std::min((unsigned)n_tracks, std::min(hw, 40u)); + } + if (n_threads < 1) n_threads = 1; + + ScanConfig scan; + scan.func = func; + scan.iterator_step = iterator_step; + scan.sshift = sshift; + scan.eshift = eshift; + scan.per_chrom_intervals = use_intervals ? &per_chrom : nullptr; + scan.n_threads = n_threads; + + BatchTrackScanResult scan_result; + run_batch_scan(track_names, track_dirs, track_types, + configs, scan, chromkey, scan_result); + + for (int m = 0; m < n_tracks; ++m) { + if (!scan_result.error_messages[m].empty()) + verror("Error processing track %s: %s", + track_names[m].c_str(), + scan_result.error_messages[m].c_str()); + } + auto &per_track = scan_result.per_track_states; + + SEXP result; + if (n_pctiles == 1) + rprotect(result = Rf_allocVector(REALSXP, n_tracks)); + else + rprotect(result = Rf_allocMatrix(REALSXP, n_tracks, n_pctiles)); + double *out = REAL(result); + + for (int m = 0; m < n_tracks; ++m) { + auto qs = topk_finalize(per_track[m]); + for (int p = 0; p < n_pctiles; ++p) { + if (n_pctiles == 1) + out[m] = qs[p]; + else + out[m + (int64_t)p * n_tracks] = qs[p]; + } + } + + if (n_pctiles == 1) { + SEXP names; + rprotect(names = Rf_allocVector(STRSXP, n_tracks)); + for (int i = 0; i < n_tracks; ++i) + SET_STRING_ELT(names, i, STRING_ELT(_track_names, i)); + Rf_setAttrib(result, R_NamesSymbol, names); + } else { + SEXP rownames; + rprotect(rownames = Rf_allocVector(STRSXP, n_tracks)); + for (int i = 0; i < n_tracks; ++i) + SET_STRING_ELT(rownames, i, STRING_ELT(_track_names, i)); + + SEXP colnames; + rprotect(colnames = Rf_allocVector(STRSXP, n_pctiles)); + for (int i = 0; i < n_pctiles; ++i) { + char buf[64]; + snprintf(buf, sizeof(buf), "%.6g", pctiles[i]); + SET_STRING_ELT(colnames, i, Rf_mkChar(buf)); + } + + SEXP dimnames; + rprotect(dimnames = Rf_allocVector(VECSXP, 2)); + SET_VECTOR_ELT(dimnames, 0, rownames); + SET_VECTOR_ELT(dimnames, 1, colnames); + Rf_setAttrib(result, R_DimNamesSymbol, dimnames); + } + + return result; + + } catch (TGLException &e) { + rerror("%s", e.msg()); + } catch (const std::bad_alloc &) { + rerror("Out of memory"); + } catch (const std::exception &e) { + rerror("%s", e.what()); + } + return R_NilValue; +} diff --git a/src/BatchScreen.cpp b/src/BatchScreen.cpp new file mode 100644 index 000000000..6a07a39ea --- /dev/null +++ b/src/BatchScreen.cpp @@ -0,0 +1,371 @@ +// BatchScreen.cpp — batched multi-track threshold-screen scan. +// +// For each track, emits intervals where the windowed-aggregated value +// satisfies `value threshold`. Consecutive passing scan positions +// within iterator-step distance merge into a single interval (same +// semantics as single-track gscreen). The main thread flattens all +// per-track intervals into a long data.frame with columns +// {chrom, start, end, track}. + +#include "BatchTrackScan.h" +#include "rdbinterval.h" +#include "rdbutils.h" +#include "GenomeTrack.h" + +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +using namespace rdb; +using namespace batchscan; + +// --------------------------------------------------------------------------- +// ThresholdScreen reducer. needs_pruning=true with bound-based skip for +// all operators except EQ; needs_lower_bound=true because LT/LE require +// window-min bounds. +// --------------------------------------------------------------------------- +struct ThresholdScreen { + enum class CmpOp { LT = 0, LE = 1, EQ = 2, GE = 3, GT = 4 }; + + struct Config { CmpOp op; float threshold; }; + + struct State { + const Config *cfg = nullptr; + int chromid = -1; + int iterator_step = 1; + std::vector passing; // flushed runs for this chrom + int64_t cur_start = -1, cur_end = -1; + + void init(const Config &c, int cid, int it) { + cfg = &c; + chromid = cid; + iterator_step = it; + cur_start = cur_end = -1; + } + + static bool compare(float v, float t, CmpOp op) { + switch (op) { + case CmpOp::LT: return v < t; + case CmpOp::LE: return v <= t; + case CmpOp::EQ: return v == t; + case CmpOp::GE: return v >= t; + case CmpOp::GT: return v > t; + } + return false; + } + + void flush_cur() { + if (cur_start >= 0) { + // Each scan position represents a bin of width + // iterator_step (matching the legacy gscreen bin semantics + // where a passing position at pos emits an interval + // [pos, pos + bin_size)). A run flushes as + // [cur_start, cur_end + iterator_step) so consecutive + // passing bins merge into contiguous intervals. + passing.emplace_back(chromid, cur_start, + cur_end + (int64_t)iterator_step, + /*strand=*/(char)0); + cur_start = cur_end = -1; + } + } + + void accept(float v, int64_t pos) { + bool pass = compare(v, cfg->threshold, cfg->op); + if (pass) { + if (cur_start < 0 || pos > cur_end + iterator_step) { + flush_cur(); + cur_start = pos; + } + cur_end = pos; + } else { + flush_cur(); + } + } + + // Called by driver on interval-mask gap / chrom end. Critical for + // correctness with fragmented intervals — without it, two passing + // runs separated by a masked-out region would fuse into one + // interval spanning positions that were never evaluated. + void boundary() { flush_cur(); } + + // NaN aggregate → no value to compare against threshold; in legacy + // gscreen semantics the comparison `NaN threshold` is false + // for every operator, which breaks any passing run. + void nan_seen() { flush_cur(); } + + // EQ never prunes; GT/GE/LT/LE do. Returning false on EQ lets the + // driver skip sliding-deque maintenance entirely for EQ predicates. + bool pruning_active() const { + return cfg && cfg->op != CmpOp::EQ; + } + + bool prune(float upper, float lower) const { + switch (cfg->op) { + case CmpOp::GT: case CmpOp::GE: return upper < cfg->threshold; + case CmpOp::LT: case CmpOp::LE: return lower > cfg->threshold; + case CmpOp::EQ: return false; + } + return false; + } + + // Symmetric to prune(): returns true when the aggregator bound + // already guarantees the predicate passes, so the driver can skip + // aggregate_window entirely. For GT/GE the lower bound > threshold + // guarantees the actual value > threshold; for LT/LE the upper + // bound < threshold guarantees value < threshold. EQ has no + // bound-based pass-guarantee. + bool certain_pass(float upper, float lower) const { + switch (cfg->op) { + case CmpOp::GT: return lower > cfg->threshold; + case CmpOp::GE: return lower >= cfg->threshold; + case CmpOp::LT: return upper < cfg->threshold; + case CmpOp::LE: return upper <= cfg->threshold; + case CmpOp::EQ: return false; + } + return false; + } + + // Called by the driver when certain_pass() returns true. Semantics + // identical to accept() with pass=true — extends or starts a run. + // We don't know the real aggregated value here, so we can't call + // compare(); that's fine because ThresholdScreen only emits + // intervals, not values. + void accept_certain_pass(int64_t pos) { + if (cur_start < 0 || pos > cur_end + iterator_step) { + flush_cur(); + cur_start = pos; + } + cur_end = pos; + } + + // Pruned-but-valid positions must be counted in a reducer that + // needs n_total for rank math; ThresholdScreen doesn't. No-op. + void count_pruned() {} + + void merge(const State &o) { + passing.insert(passing.end(), o.passing.begin(), o.passing.end()); + } + }; + + struct Result { std::vector intervals; }; + + static constexpr bool needs_pruning = true; + static constexpr bool needs_lower_bound = true; + // Trait: driver should consult state.certain_pass() and, when true, + // call state.accept_certain_pass() instead of aggregate_window + + // accept. Reducers that don't benefit (summary, quantiles — they + // need the actual value) omit the trait. + static constexpr bool supports_certain_pass = true; +}; + +static WindowAggFunc parse_func(SEXP _func) +{ + if (!Rf_isString(_func) || Rf_length(_func) != 1) + verror("func must be a character scalar"); + const char *s = CHAR(STRING_ELT(_func, 0)); + if (!std::strcmp(s, "lse")) return WindowAggFunc::LSE; + if (!std::strcmp(s, "avg")) return WindowAggFunc::AVG; + if (!std::strcmp(s, "sum")) return WindowAggFunc::SUM; + if (!std::strcmp(s, "max")) return WindowAggFunc::MAX; + if (!std::strcmp(s, "min")) return WindowAggFunc::MIN; + verror("func must be one of: lse, avg, sum, max, min"); + return WindowAggFunc::LSE; +} + +// --------------------------------------------------------------------------- +// .Call entry: C_gscreen_multi +// +// Args (10): +// 1. _track_names character vector (length N) +// 2. _iterator integer scalar (bp step) +// 3. _sshift integer scalar +// 4. _eshift integer scalar +// 5. _n_threads integer scalar (0 = auto) +// 6. _func character scalar +// 7. _ops integer vector of length N (CmpOp enum ints 0..4) +// 8. _thresholds numeric vector of length N +// 9. _intervals data.frame or NULL +// 10. _envir R environment +// +// Returns: data.frame with columns chrom, start, end, track (long form). +// --------------------------------------------------------------------------- +extern "C" SEXP C_gscreen_multi( + SEXP _track_names, SEXP _iterator, SEXP _sshift, SEXP _eshift, + SEXP _n_threads, SEXP _func, SEXP _ops, SEXP _thresholds, + SEXP _intervals, SEXP _envir) +{ + try { + RdbInitializer rdb_init; + IntervUtils iu(_envir); + + int n_tracks = Rf_length(_track_names); + if (Rf_length(_ops) != n_tracks) + verror("ops must have the same length as track_names"); + if (Rf_length(_thresholds) != n_tracks) + verror("thresholds must have the same length as track_names"); + + std::vector track_names(n_tracks); + for (int i = 0; i < n_tracks; ++i) + track_names[i] = CHAR(STRING_ELT(_track_names, i)); + + int iterator_step = INTEGER(_iterator)[0]; + int sshift = INTEGER(_sshift)[0]; + int eshift = INTEGER(_eshift)[0]; + int n_threads_req = INTEGER(_n_threads)[0]; + if (iterator_step <= 0) + verror("iterator must be a positive integer"); + + WindowAggFunc func = parse_func(_func); + + std::vector configs(n_tracks); + for (int m = 0; m < n_tracks; ++m) { + int op_i = INTEGER(_ops)[m]; + if (op_i < 0 || op_i > 4) + verror("ops[%d] = %d not in 0..4", m + 1, op_i); + configs[m].op = (ThresholdScreen::CmpOp)op_i; + configs[m].threshold = (float)REAL(_thresholds)[m]; + } + + const GenomeChromKey &chromkey = iu.get_chromkey(); + SEXP envir = iu.get_env(); + + std::vector track_dirs(n_tracks); + std::vector track_types(n_tracks); + for (int m = 0; m < n_tracks; ++m) { + track_dirs[m] = track2path(envir, track_names[m]); + track_types[m] = GenomeTrack::get_type( + track_dirs[m].c_str(), chromkey, false); + } + + const int n_chroms = (int)chromkey.get_num_chroms(); + std::vector> per_chrom(n_chroms); + bool use_intervals = !Rf_isNull(_intervals); + if (use_intervals) { + GIntervalsFetcher1D *i1d = nullptr; + GIntervalsFetcher2D *i2d = nullptr; + iu.convert_rintervs(_intervals, &i1d, &i2d); + std::unique_ptr g1(i1d); + std::unique_ptr g2(i2d); + if (i2d && i2d->size() > 0) + verror("intervals must be 1D"); + i1d->sort(); + i1d->unify_overlaps(); + for (int c = 0; c < n_chroms; ++c) { + if (i1d->size(c) == 0) continue; + i1d->begin_chrom_iter(c); + for (auto it = i1d->get_chrom_begin(); + it != i1d->get_chrom_end(); ++it) { + per_chrom[c].push_back(*it); + } + } + } + + unsigned hw = std::thread::hardware_concurrency(); + if (hw == 0) hw = 4; + int n_threads; + if (n_threads_req > 0) { + n_threads = std::min(n_threads_req, n_tracks); + } else { + n_threads = (int)std::min((unsigned)n_tracks, std::min(hw, 40u)); + } + if (n_threads < 1) n_threads = 1; + + ScanConfig scan; + scan.func = func; + scan.iterator_step = iterator_step; + scan.sshift = sshift; + scan.eshift = eshift; + scan.per_chrom_intervals = use_intervals ? &per_chrom : nullptr; + scan.n_threads = n_threads; + + BatchTrackScanResult scan_result; + run_batch_scan(track_names, track_dirs, track_types, + configs, scan, chromkey, scan_result); + + for (int m = 0; m < n_tracks; ++m) { + if (!scan_result.error_messages[m].empty()) + verror("Error processing track %s: %s", + track_names[m].c_str(), + scan_result.error_messages[m].c_str()); + } + + // Flatten per-track intervals into a long vector. + int64_t total_intervals = 0; + for (auto &st : scan_result.per_track_states) + total_intervals += (int64_t)st.passing.size(); + + // Return a track_idx column (0-based into the input vector) instead + // of a track-name column. The R wrapper uses this to map each row + // back to the caller's original expression string — unambiguous even + // when multiple expressions share the same underlying source track. + SEXP chrom_col, start_col, end_col, track_idx_col; + rprotect(chrom_col = Rf_allocVector(STRSXP, total_intervals)); + rprotect(start_col = Rf_allocVector(REALSXP, total_intervals)); + rprotect(end_col = Rf_allocVector(REALSXP, total_intervals)); + rprotect(track_idx_col = Rf_allocVector(INTSXP, total_intervals)); + + int64_t row = 0; + for (int m = 0; m < n_tracks; ++m) { + auto &ivs = scan_result.per_track_states[m].passing; + for (auto &g : ivs) { + SET_STRING_ELT(chrom_col, row, + Rf_mkChar(iu.id2chrom(g.chromid).c_str())); + REAL(start_col)[row] = (double)g.start; + // A run flushes as [cur_start, cur_end + iterator_step); the + // last passing position on a chrom whose size is not a multiple + // of the iterator step would otherwise emit an end past the + // chromosome. Clamp to chrom size, matching the slow path, + // which clips the final iterator interval to the chrom end. + REAL(end_col)[row] = std::min( + (double)g.end, (double)chromkey.get_chrom_size(g.chromid)); + INTEGER(track_idx_col)[row] = m; + ++row; + } + } + + // Build data.frame (list of 4 columns with class "data.frame" and + // row.names attribute). + SEXP df; + rprotect(df = Rf_allocVector(VECSXP, 4)); + SET_VECTOR_ELT(df, 0, chrom_col); + SET_VECTOR_ELT(df, 1, start_col); + SET_VECTOR_ELT(df, 2, end_col); + SET_VECTOR_ELT(df, 3, track_idx_col); + + SEXP names; + rprotect(names = Rf_allocVector(STRSXP, 4)); + SET_STRING_ELT(names, 0, Rf_mkChar("chrom")); + SET_STRING_ELT(names, 1, Rf_mkChar("start")); + SET_STRING_ELT(names, 2, Rf_mkChar("end")); + SET_STRING_ELT(names, 3, Rf_mkChar("track_idx")); + Rf_setAttrib(df, R_NamesSymbol, names); + + SEXP rownames; + rprotect(rownames = Rf_allocVector(INTSXP, 2)); + INTEGER(rownames)[0] = NA_INTEGER; + INTEGER(rownames)[1] = -(int)total_intervals; + Rf_setAttrib(df, R_RowNamesSymbol, rownames); + + SEXP cls; + rprotect(cls = Rf_allocVector(STRSXP, 1)); + SET_STRING_ELT(cls, 0, Rf_mkChar("data.frame")); + Rf_setAttrib(df, R_ClassSymbol, cls); + + return df; + + } catch (TGLException &e) { + rerror("%s", e.msg()); + } catch (const std::bad_alloc &) { + rerror("Out of memory"); + } catch (const std::exception &e) { + rerror("%s", e.what()); + } + return R_NilValue; +} diff --git a/src/BatchSummary.cpp b/src/BatchSummary.cpp new file mode 100644 index 000000000..a09178219 --- /dev/null +++ b/src/BatchSummary.cpp @@ -0,0 +1,278 @@ +// BatchSummary.cpp — batched multi-track genome-wide summary statistics. +// +// Uses BatchTrackScan. Each (track, chrom) worker accumulates +// per-position counts/sums/min/max; per-track merging combines them; +// the main thread emits one row per track with columns +// {n, n_nan, min, max, sum, mean, sd}. + +#include "BatchTrackScan.h" +#include "rdbinterval.h" +#include "rdbutils.h" +#include "GenomeTrack.h" + +#include + +#include +#include +#include +#include +#include +#include +#include +#include + +using namespace rdb; +using namespace batchscan; + +// --------------------------------------------------------------------------- +// Summary reducer. needs_pruning = false → driver skips sliding-deque +// maintenance (Summary needs every value). +// --------------------------------------------------------------------------- +struct Summary { + struct Config {}; + + struct State { + uint64_t n = 0, n_nan = 0; + double sum = 0.0, sum_sq = 0.0; + double min_val = std::numeric_limits::infinity(); + double max_val = -std::numeric_limits::infinity(); + + void init(const Config &, int, int) {} + + // Called only for non-NaN aggregate values (driver filters NaN + // before calling accept). Bumps total count and updates aggregates. + void accept(float v, int64_t) { + ++n; + double d = (double)v; + sum += d; + sum_sq += d * d; + if (d < min_val) min_val = d; + if (d > max_val) max_val = d; + } + + // Called by the driver when the aggregate is NaN (all-NaN window). + // Matches legacy gsummary semantics: every evaluated scan position + // contributes to num_bins, and NaN-aggregate positions also + // contribute to num_nan. + void nan_seen() { ++n; ++n_nan; } + + // Count a pruned valid position — required interface (no-op here + // because needs_pruning is false, this never gets called). + void count_pruned() {} + + void boundary() {} + + bool prune(float, float) const { return false; } + + void merge(const State &o) { + n += o.n; + n_nan += o.n_nan; + sum += o.sum; + sum_sq += o.sum_sq; + if (o.min_val < min_val) min_val = o.min_val; + if (o.max_val > max_val) max_val = o.max_val; + } + }; + + struct Result { + double n, n_nan, min, max, sum, mean, sd; + }; + + static constexpr bool needs_pruning = false; + static constexpr bool needs_lower_bound = false; + static constexpr bool supports_certain_pass = false; +}; + +static Summary::Result summary_finalize(const Summary::State &s) +{ + Summary::Result r; + r.n = (double)s.n; + r.n_nan = (double)s.n_nan; + uint64_t n_valid = s.n - s.n_nan; + if (n_valid == 0) { + r.min = r.max = r.sum = r.mean = r.sd = + std::numeric_limits::quiet_NaN(); + return r; + } + r.min = s.min_val; + r.max = s.max_val; + r.sum = s.sum; + double mean = s.sum / (double)n_valid; + r.mean = mean; + if (n_valid > 1) { + // Bessel-corrected stdev, matching IntervalSummary::get_stdev(). + double var = + (s.sum_sq - (double)n_valid * mean * mean) / (double)(n_valid - 1); + if (var < 0) var = 0; // float-precision guard + r.sd = std::sqrt(var); + } else { + r.sd = std::numeric_limits::quiet_NaN(); + } + return r; +} + +static WindowAggFunc parse_func(SEXP _func) +{ + if (!Rf_isString(_func) || Rf_length(_func) != 1) + verror("func must be a character scalar"); + const char *s = CHAR(STRING_ELT(_func, 0)); + if (!std::strcmp(s, "lse")) return WindowAggFunc::LSE; + if (!std::strcmp(s, "avg")) return WindowAggFunc::AVG; + if (!std::strcmp(s, "sum")) return WindowAggFunc::SUM; + if (!std::strcmp(s, "max")) return WindowAggFunc::MAX; + if (!std::strcmp(s, "min")) return WindowAggFunc::MIN; + verror("func must be one of: lse, avg, sum, max, min"); + return WindowAggFunc::LSE; // unreachable +} + +// --------------------------------------------------------------------------- +// .Call entry: C_gsummary_multi +// +// Args (8): +// 1. _track_names character vector +// 2. _iterator integer scalar (bp step) +// 3. _sshift integer scalar +// 4. _eshift integer scalar +// 5. _n_threads integer scalar (0 = auto) +// 6. _func character scalar: "lse"|"avg"|"sum"|"max"|"min" +// 7. _intervals data.frame or NULL (whole-genome) +// 8. _envir R environment +// +// Returns: REALSXP matrix with dimensions n_tracks x 7, rownames = track +// names, colnames = {"n","n_nan","min","max","sum","mean","sd"}. +// --------------------------------------------------------------------------- +extern "C" SEXP C_gsummary_multi( + SEXP _track_names, + SEXP _iterator, + SEXP _sshift, + SEXP _eshift, + SEXP _n_threads, + SEXP _func, + SEXP _intervals, + SEXP _envir) +{ + try { + RdbInitializer rdb_init; + IntervUtils iu(_envir); + + int n_tracks = Rf_length(_track_names); + std::vector track_names(n_tracks); + for (int i = 0; i < n_tracks; ++i) + track_names[i] = CHAR(STRING_ELT(_track_names, i)); + + int iterator_step = INTEGER(_iterator)[0]; + int sshift = INTEGER(_sshift)[0]; + int eshift = INTEGER(_eshift)[0]; + int n_threads_req = INTEGER(_n_threads)[0]; + if (iterator_step <= 0) + verror("iterator must be a positive integer"); + + WindowAggFunc func = parse_func(_func); + + const GenomeChromKey &chromkey = iu.get_chromkey(); + SEXP envir = iu.get_env(); + + std::vector track_dirs(n_tracks); + std::vector track_types(n_tracks); + for (int m = 0; m < n_tracks; ++m) { + track_dirs[m] = track2path(envir, track_names[m]); + track_types[m] = GenomeTrack::get_type( + track_dirs[m].c_str(), chromkey, false); + } + + const int n_chroms = (int)chromkey.get_num_chroms(); + std::vector> per_chrom(n_chroms); + bool use_intervals = !Rf_isNull(_intervals); + if (use_intervals) { + GIntervalsFetcher1D *i1d = nullptr; + GIntervalsFetcher2D *i2d = nullptr; + iu.convert_rintervs(_intervals, &i1d, &i2d); + std::unique_ptr g1(i1d); + std::unique_ptr g2(i2d); + if (i2d && i2d->size() > 0) + verror("intervals must be 1D"); + i1d->sort(); + i1d->unify_overlaps(); + for (int c = 0; c < n_chroms; ++c) { + if (i1d->size(c) == 0) continue; + i1d->begin_chrom_iter(c); + for (auto it = i1d->get_chrom_begin(); + it != i1d->get_chrom_end(); ++it) { + per_chrom[c].push_back(*it); + } + } + } + + std::vector configs(n_tracks); + + unsigned hw = std::thread::hardware_concurrency(); + if (hw == 0) hw = 4; + int n_threads; + if (n_threads_req > 0) { + n_threads = std::min(n_threads_req, n_tracks); + } else { + n_threads = (int)std::min((unsigned)n_tracks, std::min(hw, 40u)); + } + if (n_threads < 1) n_threads = 1; + + ScanConfig scan; + scan.func = func; + scan.iterator_step = iterator_step; + scan.sshift = sshift; + scan.eshift = eshift; + scan.per_chrom_intervals = use_intervals ? &per_chrom : nullptr; + scan.n_threads = n_threads; + + BatchTrackScanResult scan_result; + run_batch_scan(track_names, track_dirs, track_types, + configs, scan, chromkey, scan_result); + + for (int m = 0; m < n_tracks; ++m) { + if (!scan_result.error_messages[m].empty()) + verror("Error processing track %s: %s", + track_names[m].c_str(), + scan_result.error_messages[m].c_str()); + } + + // n_tracks x 7 matrix with columns n, n_nan, min, max, sum, mean, sd. + SEXP result; + rprotect(result = Rf_allocMatrix(REALSXP, n_tracks, 7)); + double *out = REAL(result); + for (int m = 0; m < n_tracks; ++m) { + auto r = summary_finalize(scan_result.per_track_states[m]); + out[m + 0 * n_tracks] = r.n; + out[m + 1 * n_tracks] = r.n_nan; + out[m + 2 * n_tracks] = r.min; + out[m + 3 * n_tracks] = r.max; + out[m + 4 * n_tracks] = r.sum; + out[m + 5 * n_tracks] = r.mean; + out[m + 6 * n_tracks] = r.sd; + } + + SEXP rownames; + rprotect(rownames = Rf_allocVector(STRSXP, n_tracks)); + for (int i = 0; i < n_tracks; ++i) + SET_STRING_ELT(rownames, i, STRING_ELT(_track_names, i)); + + SEXP colnames; + rprotect(colnames = Rf_allocVector(STRSXP, 7)); + const char *cn[] = {"n", "n_nan", "min", "max", "sum", "mean", "sd"}; + for (int i = 0; i < 7; ++i) SET_STRING_ELT(colnames, i, Rf_mkChar(cn[i])); + + SEXP dimnames; + rprotect(dimnames = Rf_allocVector(VECSXP, 2)); + SET_VECTOR_ELT(dimnames, 0, rownames); + SET_VECTOR_ELT(dimnames, 1, colnames); + Rf_setAttrib(result, R_DimNamesSymbol, dimnames); + + return result; + + } catch (TGLException &e) { + rerror("%s", e.msg()); + } catch (const std::bad_alloc &) { + rerror("Out of memory"); + } catch (const std::exception &e) { + rerror("%s", e.what()); + } + return R_NilValue; +} diff --git a/src/BatchTrackScan.cpp b/src/BatchTrackScan.cpp new file mode 100644 index 000000000..e3a2be23a --- /dev/null +++ b/src/BatchTrackScan.cpp @@ -0,0 +1,115 @@ +#include "BatchTrackScan.h" +#include "GenomeTrack1D.h" // lse_accumulate + +#include +#include + +namespace batchscan { + +float aggregate_window(WindowAggFunc func, const float *bins, int64_t sbin, + int64_t ebin) +{ + // The legacy read path (GenomeTrackFixedBin::read_next_bin) converts + // +/-inf bins to NaN, so a non-finite bin is "missing" and excluded from + // every reducer. We read raw mmap bins here, so apply the same rule via + // std::isfinite (false for NaN and inf) to stay bit-identical to the slow + // path on tracks that contain inf bins. + switch (func) { + case WindowAggFunc::LSE: { + float lse = -std::numeric_limits::infinity(); + uint64_t n = 0; + for (int64_t b = sbin; b < ebin; ++b) { + if (std::isfinite(bins[b])) { lse_accumulate(lse, bins[b]); ++n; } + } + return n ? lse : std::numeric_limits::quiet_NaN(); + } + case WindowAggFunc::AVG: { + double s = 0; uint64_t n = 0; + for (int64_t b = sbin; b < ebin; ++b) + if (std::isfinite(bins[b])) { s += bins[b]; ++n; } + return n ? (float)(s / (double)n) + : std::numeric_limits::quiet_NaN(); + } + case WindowAggFunc::SUM: { + double s = 0; uint64_t n = 0; + for (int64_t b = sbin; b < ebin; ++b) + if (std::isfinite(bins[b])) { s += bins[b]; ++n; } + return n ? (float)s : std::numeric_limits::quiet_NaN(); + } + case WindowAggFunc::MAX: { + float m = -std::numeric_limits::infinity(); + uint64_t n = 0; + for (int64_t b = sbin; b < ebin; ++b) + if (std::isfinite(bins[b])) { if (bins[b] > m) m = bins[b]; ++n; } + return n ? m : std::numeric_limits::quiet_NaN(); + } + case WindowAggFunc::MIN: { + float m = std::numeric_limits::infinity(); + uint64_t n = 0; + for (int64_t b = sbin; b < ebin; ++b) + if (std::isfinite(bins[b])) { if (bins[b] < m) m = bins[b]; ++n; } + return n ? m : std::numeric_limits::quiet_NaN(); + } + } + return std::numeric_limits::quiet_NaN(); +} + +float aggregate_precomputed_const(WindowAggFunc func, int n_bins) +{ + switch (func) { + case WindowAggFunc::LSE: return std::log((float)n_bins); + case WindowAggFunc::SUM: return (float)n_bins; + default: return 0.0f; + } +} + +// Per-aggregator upper bound derived from the window max. +// Used by reducers that prune extreme quantiles/threshold checks; tight but +// cheap. For MIN we return +inf because max-based bound is uninformative. +float aggregate_upper_bound(WindowAggFunc func, float window_max, + float precomputed_const) +{ + switch (func) { + case WindowAggFunc::LSE: return window_max + precomputed_const; + // SUM upper bound. precomputed_const is an OVER-estimate of the bin + // count (ceil(W/B)+1, and the true non-NaN count can be lower still + // for partial/NaN bins). window_max * count is only a valid upper + // bound when window_max >= 0 (more bins -> larger sum); when + // window_max < 0 the largest possible sum is achieved with the FEWEST + // bins, so sum <= 0. The universally valid bound is + // max(window_max, 0) * count. (Was window_max * count, which is not a + // bound for negative-valued tracks.) + case WindowAggFunc::SUM: + return (window_max > 0.0f ? window_max : 0.0f) * precomputed_const; + case WindowAggFunc::AVG: return window_max; + case WindowAggFunc::MAX: return window_max; + case WindowAggFunc::MIN: return std::numeric_limits::infinity(); + } + return std::numeric_limits::infinity(); +} + +// Per-aggregator lower bound derived from the window min. +// Used for bottom-percentile / LT / LE pruning. For LSE, window_min is a +// valid lower bound because LSE >= max >= min of the non-NaN bins. For MAX +// we return -inf (max-based aggregator has no useful min lower bound). +float aggregate_lower_bound(WindowAggFunc func, float window_min, + float precomputed_const) +{ + switch (func) { + case WindowAggFunc::LSE: return window_min; + // SUM lower bound. Mirror of the upper bound: window_min * count is a + // valid lower bound only when window_min <= 0; when window_min > 0 the + // smallest possible sum uses the FEWEST bins (0) -> sum >= 0. The + // universally valid bound is min(window_min, 0) * count. (Was + // window_min * count, which over-bounds even an all-positive track + // whenever the count is over-estimated, wrongly pruning LT/LE passes.) + case WindowAggFunc::SUM: + return (window_min < 0.0f ? window_min : 0.0f) * precomputed_const; + case WindowAggFunc::AVG: return window_min; + case WindowAggFunc::MIN: return window_min; + case WindowAggFunc::MAX: return -std::numeric_limits::infinity(); + } + return -std::numeric_limits::infinity(); +} + +} // namespace batchscan diff --git a/src/BatchTrackScan.h b/src/BatchTrackScan.h new file mode 100644 index 000000000..7d37b3b32 --- /dev/null +++ b/src/BatchTrackScan.h @@ -0,0 +1,108 @@ +#ifndef BATCHTRACKSCAN_H_ +#define BATCHTRACKSCAN_H_ + +// Shared skeleton for batched multi-track scans used by: +// - BatchQuantiles.cpp (TopKQuantile reducer) +// - BatchSummary.cpp (Summary reducer, Phase 3) +// - BatchScreen.cpp (ThresholdScreen reducer, Phase 4) +// +// The scan driver is templated over a Reducer concept. Reducers must expose: +// - struct Config, State, Result +// - static constexpr bool needs_pruning (enables sliding-max + prune()) +// - static constexpr bool needs_lower_bound (also enables sliding-min) +// - static constexpr bool supports_certain_pass +// (when true, State must also expose certain_pass(upper, lower) and +// accept_certain_pass(pos); driver uses them to skip aggregate_window +// for positions whose bound already guarantees the predicate passes) +// - State::init(const Config&, int chromid, int iterator_step) +// - State::accept(float val, int64_t pos) (called for non-NaN aggregate) +// - State::nan_seen() (called for NaN aggregate) +// - State::count_pruned() (called for pruned-but-valid positions) +// - State::boundary() (flush at mask gap / chrom end) +// - State::prune(float upper, float lower) (true => skip position) +// - State::merge(const State& other) +// +// Thread-safety: workers MUST NOT call into the R C API. Everything that +// touches R (track name resolution, intervals conversion, SEXP allocation) +// happens on the main thread before/after run_batch_scan. + +#include +#include +#include +#include + +#include "GenomeChromKey.h" +#include "GenomeTrack.h" +#include "GInterval.h" + +namespace batchscan { + +enum class WindowAggFunc { LSE, AVG, SUM, MAX, MIN }; + +struct ScanConfig { + WindowAggFunc func; + int iterator_step; + int sshift; + int eshift; + // nullptr => whole genome. Otherwise indexed by chromid; each inner vector + // is the sorted, non-overlapping intervals restricting the scan on that + // chromosome. Positions whose scan center falls outside all intervals are + // skipped (and reducer.boundary() is called at the gap). + const std::vector> *per_chrom_intervals; + int n_threads; +}; + +// One task per (track, chrom). Each worker scans its task, merges its +// state into the per-track accumulator (in BatchTrackScanResult), and +// frees the task's state buffers. Not exposed to callers. +template +struct BatchTrackScanTask { + std::string track_name; + std::string track_dir; + GenomeTrack::Type track_type; + int track_idx; // index into the original track_names vector + int chromid; + typename Reducer::State state; + std::string error_msg; // set by worker on exception +}; + +// Output of run_batch_scan: merged per-track states + per-track error +// messages. Caller iterates per_track_states[m] to build the R result; +// error_messages[m] is non-empty if any chrom-task for track m failed. +template +struct BatchTrackScanResult; // defined in BatchTrackScan_impl.h + +// Aggregator math helpers — safe to call from any thread (pure, no R). +float aggregate_window(WindowAggFunc func, const float *bins, int64_t sbin, + int64_t ebin); + +float aggregate_upper_bound(WindowAggFunc func, float window_max, + float precomputed_const); + +float aggregate_lower_bound(WindowAggFunc func, float window_min, + float precomputed_const); + +// log(n_bins) for LSE, (float)n_bins for SUM, 0 otherwise. +float aggregate_precomputed_const(WindowAggFunc func, int n_bins); + +// Top-level driver. `track_dirs` and `track_types` must be resolved on the +// main thread before calling; workers never touch R to resolve names. +// After the call, out.per_track_states[m] is the fully-merged state for +// track m, and out.error_messages[m] is non-empty if any of its chrom-tasks +// failed. See run_batch_scan body in BatchTrackScan_impl.h for memory +// discipline notes. +template +void run_batch_scan( + const std::vector &track_names, + const std::vector &track_dirs, + const std::vector &track_types, + const std::vector &per_track_configs, + const ScanConfig &scan, + const GenomeChromKey &chromkey, + BatchTrackScanResult &out); + +} // namespace batchscan + +#include "BatchTrackScan_impl.h" + +#endif // BATCHTRACKSCAN_H_ diff --git a/src/BatchTrackScan_impl.h b/src/BatchTrackScan_impl.h new file mode 100644 index 000000000..0519a0f90 --- /dev/null +++ b/src/BatchTrackScan_impl.h @@ -0,0 +1,512 @@ +#ifndef BATCHTRACKSCAN_IMPL_H_ +#define BATCHTRACKSCAN_IMPL_H_ + +// Included from BatchTrackScan.h. Contains templated scan driver and +// per-track inner loops. Reducer methods are called via task.state.*. + +#include +#include +#include +#include +#include +#include +#include + +#include "GenomeTrack1D.h" +#include "GenomeTrackFixedBin.h" +#include "GenomeTrackSparse.h" + +namespace batchscan { + +// Array-backed monotonic deque. CAP must be >= number of bins in the window. +// Entries are indexed by "bin index"; caller is responsible for pushing bins +// in increasing index order and advancing the front as the window slides. +template +struct SlidingExtremum { + int idx[CAP]; + float val[CAP]; + int head = 0; + int tail = 0; + + void reset() { head = tail = 0; } + + void advance_front(int front_bin) { + while (head < tail && idx[head % CAP] < front_bin) ++head; + } + + void push_bin(int b, float v) { + // Evict worse entries from the back: for max-deque, anything <= v is + // dominated; for min-deque, anything >= v. + while (head < tail) { + float back = val[(tail - 1) % CAP]; + bool dominated = IsMax ? (back <= v) : (back >= v); + if (!dominated) break; + --tail; + } + // Caller is required to hold the live window to <= CAP bins (enforced + // by the scan_fixedbin_inner guard at window setup time). + // assert((size_t)(tail - head) < (size_t)CAP); + idx[tail % CAP] = b; + val[tail % CAP] = v; + ++tail; + } + + float current_extremum() const { + if (head >= tail) { + return IsMax ? -std::numeric_limits::infinity() + : std::numeric_limits::infinity(); + } + return val[head % CAP]; + } +}; + +// Window capacity: supports windows up to 256 bins (e.g. 256*20bp = 5120bp). +// No realistic vtrack call exceeds this. +static constexpr int WINDOW_CAP = 256; + +using SlidingMax = SlidingExtremum; +using SlidingMin = SlidingExtremum; + +// Open per-chrom handle. Called from worker thread — the main thread has +// already resolved track_dir and track_type (which are R-env operations). +inline void open_chrom_track(const std::string &track_dir, + GenomeTrack::Type type, int chromid, + const GenomeChromKey &chromkey, + std::shared_ptr &out_owner, + GenomeTrackFixedBin **out_fb, + GenomeTrackSparse **out_sp) +{ + std::string resolved = + GenomeTrack::find_existing_1d_filename(chromkey, track_dir, chromid); + std::string filename = track_dir + "/" + resolved; + *out_fb = nullptr; + *out_sp = nullptr; + if (type == GenomeTrack::FIXED_BIN) { + auto t = std::make_shared(); + t->init_read(filename.c_str(), chromid); + out_owner = t; + *out_fb = t.get(); + } else if (type == GenomeTrack::SPARSE) { + auto t = std::make_shared(); + t->init_read(filename.c_str(), chromid); + out_owner = t; + *out_sp = t.get(); + } else { + throw std::runtime_error(std::string("track ") + track_dir + + " has unsupported type (expected dense or sparse)"); + } +} + +// ----------------------------------------------------------------------------- +// FixedBin inner scan — sliding max/min + pruning gated on Reducer traits. +// ----------------------------------------------------------------------------- +template +void scan_fixedbin_inner(GenomeTrackFixedBin *fb, unsigned bin_size, + int64_t chrom_size, int iterator_step, + int sshift, int eshift, + const std::vector *allowed_intervals, + typename Reducer::State &state) +{ + int64_t total_bins = (int64_t)((chrom_size + bin_size - 1) / bin_size); + if (total_bins <= 0) return; + + int64_t out_count = 0; + const float *all_bins = fb->get_mmap_bins_ptr(0, total_bins, out_count); + if (!all_bins || out_count <= 0) return; + + // Window for one iterator step at position c is + // [c + sshift, c + iterator_step + eshift] -- mirrors the slow-path + // convention in TrackExpressionVars::Iterator_modifier1D::transform + // (interv.start + sshift, interv.end + eshift) where the iterator + // interval has width iterator_step. + // + // n_bins_per_window must be a safe upper bound on the number of bins + // a window of width W = iterator_step + eshift - sshift can overlap. + // For arbitrary alignment that's ceil(W/bin_size) + 1: an unaligned + // window of width W can clip into at most one extra bin beyond the + // aligned count. This is used both as the deque capacity check and + // as the precomputed_const for upper-bound pruning (LSE: log(n); + // SUM: n) -- overestimates loosen the bound (safe), underestimates + // would falsely prune valid passes (missed hits in gscreen, etc.). + const int W_window = iterator_step + eshift - sshift; + const int n_bins_per_window = std::max( + 1, (int)(((W_window + (int)bin_size - 1) / (int)bin_size) + 1)); + if (n_bins_per_window > WINDOW_CAP) { + throw std::runtime_error( + "BatchTrackScan: window exceeds WINDOW_CAP bins"); + } + const float pre_const = aggregate_precomputed_const(F, n_bins_per_window); + + SlidingMax smax; + SlidingMin smin; + int next_bin_to_push = 0; // next bin index to enter the deque(s) + + // Hoist the runtime "is pruning possible for this scan?" check out + // of the inner loop. For Reducer::needs_pruning==false the value is + // unused (the if constexpr below elides the branch entirely). For + // TopKQuantile fallback mode or ThresholdScreen EQ, this is false + // and we skip all sliding-deque maintenance per position. + const bool pruning_enabled = [&]() { + if constexpr (Reducer::needs_pruning) return state.pruning_active(); + else return false; + }(); + + size_t interval_cursor = 0; + bool prev_in_mask = false; + + for (int64_t c = 0; c < chrom_size; c += iterator_step) { + // Interval-mask check with monotonic cursor. + if (allowed_intervals) { + while (interval_cursor < allowed_intervals->size() && + (*allowed_intervals)[interval_cursor].end <= c) + ++interval_cursor; + bool in = (interval_cursor < allowed_intervals->size() && + c >= (*allowed_intervals)[interval_cursor].start); + if (!in) { + if (prev_in_mask) state.boundary(); + prev_in_mask = false; + if (Reducer::needs_pruning) { + smax.reset(); + smin.reset(); + next_bin_to_push = 0; // rebuild on next in-mask position + } + continue; + } + prev_in_mask = true; + } + + int64_t win_s = c + sshift; + int64_t win_e = c + iterator_step + eshift; + if (win_s < 0) win_s = 0; + if (win_e <= win_s) continue; + int64_t sbin = win_s / (int64_t)bin_size; + int64_t ebin = (win_e + (int64_t)bin_size - 1) / (int64_t)bin_size; + if (sbin < 0) sbin = 0; + if (ebin > out_count) ebin = out_count; + if (sbin >= ebin) continue; + + // Sliding-deque + pruning block. Gated by the compile-time + // Reducer::needs_pruning and the runtime pruning_enabled flag + // (hoisted above the loop from State::pruning_active()). For + // example, TopKQuantile fallback mode sets pruning_enabled=false, + // letting us skip the per-position deque push/advance entirely — + // a meaningful win on fallback-mode scans. + if constexpr (Reducer::needs_pruning) { + if (pruning_enabled) { + // Forward-jump past bins in a mask gap: after the deque reset + // on a gap, next_bin_to_push is 0, and we don't want to walk + // through the skipped region — skip directly to sbin. + if (next_bin_to_push < (int)sbin) next_bin_to_push = (int)sbin; + // Drop bins that have left the window BEFORE pushing the new ones. + // Pushing first could momentarily hold ~2x the window's bins across + // a step transition (old front not yet dropped + new bins), which + // can alias past WINDOW_CAP for large iterators. Advancing first + // bounds the live deque span to n_bins_per_window (<= WINDOW_CAP). + // The final deque state is identical (advance only touches the + // front, push only the back; all pushed indices are >= sbin). + smax.advance_front((int)sbin); + if constexpr (Reducer::needs_lower_bound) { + smin.advance_front((int)sbin); + } + // Push all bins up to ebin that we haven't seen yet. A non-finite + // bin (NaN or +/-inf) is "missing" (same rule as aggregate_window + // and the legacy read path), pushed as the dominated sentinel so it + // never becomes the window extremum. + while (next_bin_to_push < (int)ebin) { + int b = next_bin_to_push; + float v = all_bins[b]; + bool miss = !std::isfinite(v); + smax.push_bin(b, miss ? -std::numeric_limits::infinity() : v); + if constexpr (Reducer::needs_lower_bound) { + smin.push_bin(b, miss ? std::numeric_limits::infinity() : v); + } + ++next_bin_to_push; + } + + float wmax = smax.current_extremum(); + // An empty / all-missing window has wmax == -inf and a NaN + // aggregate; its bounds are meaningless. Skip prune/certain-pass + // and fall through to aggregate_window -> nan_seen, so a threshold + // screen flushes the run (matching the slow path) rather than + // pruning (which would fuse runs across the gap) or certain-passing + // (which would emit a phantom interval: the MIN>t / MAX -std::numeric_limits::infinity()) { + float wmin = Reducer::needs_lower_bound + ? smin.current_extremum() + : std::numeric_limits::quiet_NaN(); + float upper = aggregate_upper_bound(F, wmax, pre_const); + float lower = Reducer::needs_lower_bound + ? aggregate_lower_bound(F, wmin, pre_const) + : std::numeric_limits::quiet_NaN(); + if (state.prune(upper, lower)) { + // wmax > -inf, so this window has a valid (non-NaN) sample. + state.count_pruned(); + continue; + } + // Symmetric to prune: when the bound already guarantees the + // predicate passes (e.g. `lower > threshold` for GT), skip + // aggregate_window entirely. Only applies to reducers that + // don't need the actual value (ThresholdScreen). + if constexpr (Reducer::supports_certain_pass) { + if (state.certain_pass(upper, lower)) { + state.accept_certain_pass(c); + continue; + } + } + } + } + } + + float val = aggregate_window(F, all_bins, sbin, ebin); + if (std::isnan(val)) state.nan_seen(); + else state.accept(val, c); + } +} + +// ----------------------------------------------------------------------------- +// Sparse inner scan — no sliding-window optimization (irregular positions). +// Pruning is never triggered (bounds reported as +/-inf). +// Pattern mirrors bq_aggregate_lse_sparse from the original GlmBatchQuantiles. +// ----------------------------------------------------------------------------- +template +void scan_sparse_inner(GenomeTrackSparse *sp, int64_t chrom_size, + int iterator_step, int sshift, int eshift, + const std::vector *allowed_intervals, + typename Reducer::State &state) +{ + const GIntervals &intervals = sp->get_intervals(); + const std::vector &vals = sp->get_vals(); + + size_t interval_cursor = 0; + bool prev_in_mask = false; + + // Monotonic cursor over `intervals`: because c increases by iterator_step + // each step, win_s is also monotonically non-decreasing, so the first + // sparse interval whose end > win_s can only move forward. Replaces the + // per-position binary search with amortized O(1) advance. + size_t sparse_cursor = 0; + + for (int64_t c = 0; c < chrom_size; c += iterator_step) { + if (allowed_intervals) { + while (interval_cursor < allowed_intervals->size() && + (*allowed_intervals)[interval_cursor].end <= c) + ++interval_cursor; + bool in = (interval_cursor < allowed_intervals->size() && + c >= (*allowed_intervals)[interval_cursor].start); + if (!in) { + if (prev_in_mask) state.boundary(); + prev_in_mask = false; + continue; + } + prev_in_mask = true; + } + + int64_t win_s = c + sshift; + int64_t win_e = c + iterator_step + eshift; + if (win_s < 0) win_s = 0; + if (win_e <= win_s) continue; + + // Advance sparse_cursor past intervals that end at/before win_s. + while (sparse_cursor < intervals.size() && + (int64_t)intervals[sparse_cursor].end <= win_s) + ++sparse_cursor; + size_t lo = sparse_cursor; + + // Scan overlapping sparse intervals and compute the aggregator inline. + // We don't build a dense bins array here (sparse positions are + // irregular); aggregate state is kept directly. SUM/AVG accumulate + // in double for numerical stability, mirroring aggregate_window's + // fixedbin path. No pruning on sparse — we always call accept(). + float acc_lse = -std::numeric_limits::infinity(); + double acc_sum = 0.0; + float acc_max = -std::numeric_limits::infinity(); + float acc_min = std::numeric_limits::infinity(); + uint64_t n = 0; + for (size_t i = lo; i < intervals.size(); ++i) { + if ((int64_t)intervals[i].start >= win_e) break; + float v = vals[i]; + if (!std::isfinite(v)) continue; // NaN or +/-inf -> missing (legacy parity) + ++n; + if constexpr (F == WindowAggFunc::LSE) lse_accumulate(acc_lse, v); + else if constexpr (F == WindowAggFunc::SUM) acc_sum += v; + else if constexpr (F == WindowAggFunc::AVG) acc_sum += v; + else if constexpr (F == WindowAggFunc::MAX) { if (v > acc_max) acc_max = v; } + else if constexpr (F == WindowAggFunc::MIN) { if (v < acc_min) acc_min = v; } + } + if (n == 0) { + // Zero non-NaN bins in window → NaN aggregate. Still a valid + // scan position; reducers that count bins (Summary) need to + // see it via nan_seen(). Reducers that only care about + // non-NaN values (TopKQuantile, ThresholdScreen behavior on + // gap) ignore. + state.nan_seen(); + continue; + } + + float val; + if constexpr (F == WindowAggFunc::LSE) val = acc_lse; + else if constexpr (F == WindowAggFunc::SUM) val = (float)acc_sum; + else if constexpr (F == WindowAggFunc::AVG) val = (float)(acc_sum / (double)n); + else if constexpr (F == WindowAggFunc::MAX) val = acc_max; + else if constexpr (F == WindowAggFunc::MIN) val = acc_min; + + // No pruning for sparse path. + if (std::isnan(val)) state.nan_seen(); + else state.accept(val, c); + } +} + +// ----------------------------------------------------------------------------- +// Dispatcher: picks the right aggregator F template based on ScanConfig.func. +// ----------------------------------------------------------------------------- +template +void scan_task_dispatch(BatchTrackScanTask &task, + const ScanConfig &scan, + const GenomeChromKey &chromkey, + const std::vector *allowed_intervals) +{ + std::shared_ptr owner; + GenomeTrackFixedBin *fb = nullptr; + GenomeTrackSparse *sp = nullptr; + open_chrom_track(task.track_dir, task.track_type, task.chromid, + chromkey, owner, &fb, &sp); + int64_t chrom_size = chromkey.get_chrom_size(task.chromid); + +#define DISPATCH_F(FENUM) \ + case WindowAggFunc::FENUM: \ + if (fb) scan_fixedbin_inner( \ + fb, fb->get_bin_size(), chrom_size, scan.iterator_step, \ + scan.sshift, scan.eshift, allowed_intervals, task.state); \ + else if (sp) scan_sparse_inner( \ + sp, chrom_size, scan.iterator_step, scan.sshift, \ + scan.eshift, allowed_intervals, task.state); \ + break; + + switch (scan.func) { + DISPATCH_F(LSE) + DISPATCH_F(AVG) + DISPATCH_F(SUM) + DISPATCH_F(MAX) + DISPATCH_F(MIN) + } +#undef DISPATCH_F + + task.state.boundary(); // flush any pending run at chrom end +} + +// ----------------------------------------------------------------------------- +// Top-level driver. Tasks = all (track, chrom) pairs with non-zero chrom_size. +// Work queue via std::atomic. Workers catch all exceptions locally. +// +// Memory discipline: each worker, after completing a (track, chrom) task, +// merges its state into the corresponding per-track accumulator (under a +// per-track mutex) and frees the task's state. This keeps peak memory +// bounded by (per_track_accumulator * n_tracks + concurrent_task_buffers * +// n_threads), not by (all_task_buffers summed). Critical for the +// Phase 1 fallback mode where task state holds the full value vector. +// ----------------------------------------------------------------------------- +template +struct BatchTrackScanResult { + std::vector per_track_states; // length n_tracks + std::vector error_messages; // one per track, empty => OK +}; + +template +void run_batch_scan( + const std::vector &track_names, + const std::vector &track_dirs, + const std::vector &track_types, + const std::vector &per_track_configs, + const ScanConfig &scan, + const GenomeChromKey &chromkey, + BatchTrackScanResult &out) +{ + const int n_tracks = (int)track_names.size(); + const int n_chroms = (int)chromkey.get_num_chroms(); + + // Per-track accumulators + per-track mutexes. Accumulators are + // initialized with the track's Config so their cfg pointer outlives + // any merge call. + out.per_track_states.clear(); + out.per_track_states.resize(n_tracks); + out.error_messages.assign(n_tracks, std::string()); + for (int t = 0; t < n_tracks; ++t) + out.per_track_states[t].init(per_track_configs[t], /*chromid=*/0, + scan.iterator_step); + std::vector per_track_mutex(n_tracks); + + // Build (track, chrom) task list. + std::vector> tasks; + tasks.reserve((size_t)n_tracks * n_chroms); + for (int t = 0; t < n_tracks; ++t) { + for (int c = 0; c < n_chroms; ++c) { + if (chromkey.get_chrom_size(c) == 0) continue; + std::string resolved; + try { + resolved = GenomeTrack::find_existing_1d_filename( + chromkey, track_dirs[t], c); + } catch (...) { + continue; // no file for this (track, chrom) → skip task + } + if (resolved.empty()) continue; + + BatchTrackScanTask task; + task.track_name = track_names[t]; + task.track_dir = track_dirs[t]; + task.track_type = track_types[t]; + task.track_idx = t; + task.chromid = c; + task.state.init(per_track_configs[t], c, scan.iterator_step); + tasks.push_back(std::move(task)); + } + } + + std::atomic next_task{0}; + const size_t n_tasks = tasks.size(); + + auto worker = [&]() { + for (;;) { + size_t i = next_task.fetch_add(1); + if (i >= n_tasks) return; + auto &task = tasks[i]; + try { + const std::vector *allowed = + scan.per_chrom_intervals + ? &(*scan.per_chrom_intervals)[task.chromid] + : nullptr; + scan_task_dispatch(task, scan, chromkey, allowed); + // Merge into the per-track accumulator and release task state. + { + std::lock_guard lk(per_track_mutex[task.track_idx]); + out.per_track_states[task.track_idx].merge(task.state); + } + task.state = typename Reducer::State{}; // free buffers + } catch (const std::exception &e) { + task.error_msg = e.what(); + } catch (...) { + task.error_msg = "unknown error in worker thread"; + } + } + }; + + int n_threads = scan.n_threads; + if (n_threads < 1) n_threads = 1; + if ((size_t)n_threads > n_tasks) n_threads = (int)n_tasks; + if (n_threads > 0) { + std::vector threads; + threads.reserve(n_threads); + for (int i = 0; i < n_threads; ++i) threads.emplace_back(worker); + for (auto &t : threads) t.join(); + } + + // Surface the first error per track (if any). + for (auto &task : tasks) { + if (!task.error_msg.empty() && out.error_messages[task.track_idx].empty()) + out.error_messages[task.track_idx] = task.error_msg; + } +} + +} // namespace batchscan + +#endif // BATCHTRACKSCAN_IMPL_H_ diff --git a/src/GenomeTrackFixedBin.h b/src/GenomeTrackFixedBin.h index 20d29ff9e..3ca70e161 100644 --- a/src/GenomeTrackFixedBin.h +++ b/src/GenomeTrackFixedBin.h @@ -46,6 +46,22 @@ class GenomeTrackFixedBin : public GenomeTrack1D { unsigned get_bin_size() const { return m_bin_size; } int64_t get_num_samples() const { return m_num_samples; } + bool is_mmap() const { return m_mmap_data != nullptr; } + + // Direct pointer access into mmap region (zero-copy). + // Returns pointer to start_bin, sets out_count to number of bins available. + // Caller must handle isinf→NaN conversion. Returns nullptr if not mmap-backed. + const float *get_mmap_bins_ptr(int64_t start_bin, int64_t num_bins, int64_t &out_count) const { + if (!m_mmap_data || num_bins <= 0) + return nullptr; + int64_t available = m_mmap_num_bins - start_bin; + if (available <= 0) { + out_count = 0; + return nullptr; + } + out_count = std::min(num_bins, available); + return m_mmap_data + start_bin; + } // Serialize the bytes that init_write() would write as the per-chrom // file header. Used by the streaming indexed writer to produce a diff --git a/src/GlmFeatureExtractor.cpp b/src/GlmFeatureExtractor.cpp new file mode 100644 index 000000000..572037cec --- /dev/null +++ b/src/GlmFeatureExtractor.cpp @@ -0,0 +1,563 @@ +#include "GlmFeatureExtractor.h" +#include "GenomeTrack1D.h" // for lse_accumulate +#include "rdbutils.h" +#include "GenomeTrack.h" +#include "GenomeTrackFixedBin.h" + +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +using namespace rdb; +using namespace std; + +// --------------------------------------------------------------------------- +// Track opening — handles both FixedBin and Sparse tracks +// --------------------------------------------------------------------------- +void GlmFeatureExtractor::open_track_static(TrackHandle &handle, int chromid, + const GenomeChromKey &chromkey) +{ + string resolved = GenomeTrack::find_existing_1d_filename(chromkey, handle.track_dir, chromid); + string filename = handle.track_dir + "/" + resolved; + + handle.fixedbin = nullptr; + handle.sparse = nullptr; + handle.bin_size = 0; + + if (handle.type == GenomeTrack::FIXED_BIN) { + auto t = make_shared(); + t->init_read(filename.c_str(), chromid); + handle.track = t; + handle.fixedbin = t.get(); + handle.bin_size = t->get_bin_size(); + } else if (handle.type == GenomeTrack::SPARSE) { + auto t = make_shared(); + t->init_read(filename.c_str(), chromid); + handle.track = t; + handle.sparse = t.get(); + } else { + // Worker context: throw a plain runtime_error so we don't longjmp + // out of a non-main thread via verror(). + throw std::runtime_error( + std::string("Track ") + handle.track_dir + + " has unsupported type (expected dense or sparse)"); + } +} + +void GlmFeatureExtractor::open_track(TrackHandle &handle, int chromid) +{ + open_track_static(handle, chromid, m_iu.get_chromkey()); +} + +// --------------------------------------------------------------------------- +// Aggregation: log-sum-exp over a window +// Uses the same float-precision lse_accumulate as misha's vtrack func="lse" +// (GenomeTrack1D.h) to produce bit-identical results. +// --------------------------------------------------------------------------- +double GlmFeatureExtractor::aggregate_lse(const TrackHandle &handle, + int64_t start, int64_t end) +{ + if (start < 0) start = 0; + if (start >= end) return numeric_limits::quiet_NaN(); + + if (handle.fixedbin) { + unsigned bin_size = handle.bin_size; + if (bin_size == 0) return numeric_limits::quiet_NaN(); + + int64_t sbin = start / (int64_t)bin_size; + int64_t ebin = (int64_t)ceil(end / (double)bin_size); + int64_t num_bins = ebin - sbin; + if (num_bins <= 0) return numeric_limits::quiet_NaN(); + + int64_t out_count = 0; + const float *ptr = handle.fixedbin->get_mmap_bins_ptr(sbin, num_bins, out_count); + if (!ptr || out_count <= 0) return numeric_limits::quiet_NaN(); + + // Match misha's vtrack LSE: sequential float-precision accumulation + // (GenomeTrackFixedBin.cpp line 497-506, uses lse_accumulate(float&, float)) + float lse = -numeric_limits::infinity(); + uint64_t num_vs = 0; + for (int64_t i = 0; i < out_count; i++) { + if (!isnan(ptr[i])) { + lse_accumulate(lse, ptr[i]); + num_vs++; + } + } + if (num_vs == 0) return numeric_limits::quiet_NaN(); + return (double)lse; + } + + if (handle.sparse) { + const GIntervals &intervals = handle.sparse->get_intervals(); + const vector &vals = handle.sparse->get_vals(); + + size_t idx = sparse_lower_bound(intervals, start); + + float lse = -numeric_limits::infinity(); + uint64_t num_vs = 0; + for (size_t i = idx; i < intervals.size(); i++) { + if (intervals[i].start >= end) break; + if (!isnan(vals[i])) { + lse_accumulate(lse, vals[i]); + num_vs++; + } + } + if (num_vs == 0) return numeric_limits::quiet_NaN(); + return (double)lse; + } + + return numeric_limits::quiet_NaN(); +} + +// --------------------------------------------------------------------------- +// Aggregation: sum over a window (supports both FixedBin and Sparse) +// --------------------------------------------------------------------------- +double GlmFeatureExtractor::aggregate_sum(const TrackHandle &handle, + int64_t start, int64_t end) +{ + if (start < 0) start = 0; + if (start >= end) return numeric_limits::quiet_NaN(); + + if (handle.fixedbin) { + unsigned bin_size = handle.bin_size; + if (bin_size == 0) return numeric_limits::quiet_NaN(); + + int64_t sbin = start / (int64_t)bin_size; + int64_t ebin = (int64_t)ceil(end / (double)bin_size); + int64_t num_bins = ebin - sbin; + if (num_bins <= 0) return numeric_limits::quiet_NaN(); + + int64_t out_count = 0; + const float *ptr = handle.fixedbin->get_mmap_bins_ptr(sbin, num_bins, out_count); + if (!ptr || out_count <= 0) return numeric_limits::quiet_NaN(); + + double acc = 0.0; + bool has_val = false; + for (int64_t i = 0; i < out_count; i++) { + float v = ptr[i]; + if (!isnan(v) && !isinf(v)) { + acc += (double)v; + has_val = true; + } + } + return has_val ? acc : numeric_limits::quiet_NaN(); + } + + if (handle.sparse) { + const GIntervals &intervals = handle.sparse->get_intervals(); + const vector &vals = handle.sparse->get_vals(); + + size_t idx = sparse_lower_bound(intervals, start); + + double acc = 0.0; + bool has_val = false; + for (size_t i = idx; i < intervals.size(); i++) { + if (intervals[i].start >= end) break; + float v = vals[i]; + if (!isnan(v) && !isinf(v)) { + int64_t overlap_start = max((int64_t)intervals[i].start, start); + int64_t overlap_end = min((int64_t)intervals[i].end, end); + int64_t overlap_len = overlap_end - overlap_start; + acc += (double)v * overlap_len; + has_val = true; + } + } + return has_val ? acc : numeric_limits::quiet_NaN(); + } + + return numeric_limits::quiet_NaN(); +} + +// --------------------------------------------------------------------------- +// Binary search: find first interval where intervals[i].end > pos +// (i.e., the first interval that could overlap a query starting at pos) +// --------------------------------------------------------------------------- +size_t GlmFeatureExtractor::sparse_lower_bound(const GIntervals &intervals, int64_t pos) +{ + size_t lo = 0, hi = intervals.size(); + while (lo < hi) { + size_t mid = lo + (hi - lo) / 2; + if (intervals[mid].end <= pos) + lo = mid + 1; + else + hi = mid; + } + return lo; +} + +// --------------------------------------------------------------------------- +// Main extraction +// --------------------------------------------------------------------------- +void GlmFeatureExtractor::extract( + const vector &track_names, + const int *peak_chromids, + const int64_t *peak_starts, + const int64_t *peak_ends, + int n_peaks, + int tile_size, + int flank_size, + const vector &scaling, + const vector &transforms, + const string &gc_track_name, + double gc_scale_factor, + double *output, + int n_cols, + int n_threads) +{ + int n_motifs = (int)track_names.size(); + int n_transforms = (int)transforms.size(); + + // Tile geometry: peaks of uniform width get n_tiles symmetric tiles of + // tile_size, with flank_size of outer flank on each side. + int first_peak_size = (int)(peak_ends[0] - peak_starts[0]); + int extended = first_peak_size + 2 * flank_size; + int n_tiles = extended / tile_size; + + int n_gc_inter = n_tiles * (n_tiles - 1) / 2; + int expected_cols = n_motifs * n_tiles * n_transforms + n_tiles + n_gc_inter; + if (n_cols != expected_cols) { + verror("Column count mismatch: expected %d, got %d", expected_cols, n_cols); + } + + // Resolve all track paths up-front on the main thread (R-env access is + // not safe to call from worker threads — track2path / get_type touch the + // R interpreter via the misha environment). + SEXP envir = m_iu.get_env(); + const GenomeChromKey &chromkey = m_iu.get_chromkey(); + + vector motif_dirs(n_motifs); + vector motif_types(n_motifs); + for (int m = 0; m < n_motifs; m++) { + motif_dirs[m] = track2path(envir, track_names[m]); + motif_types[m] = GenomeTrack::get_type(motif_dirs[m].c_str(), chromkey, false); + } + string gc_dir = track2path(envir, gc_track_name); + GenomeTrack::Type gc_type = + GenomeTrack::get_type(gc_dir.c_str(), chromkey, false); + + // Sort peaks by (chrom, start). Each contiguous chromosome run lets a + // worker open all motif/GC tracks once and process many peaks before + // re-opening for the next chromosome. The atomic counter below also + // hands out chunks of consecutive sorted indices, so within a chunk a + // worker typically stays on a single chromosome. + vector peak_order(n_peaks); + iota(peak_order.begin(), peak_order.end(), 0); + sort(peak_order.begin(), peak_order.end(), [&](int a, int b) { + if (peak_chromids[a] != peak_chromids[b]) + return peak_chromids[a] < peak_chromids[b]; + return peak_starts[a] < peak_starts[b]; + }); + + memset(output, 0, sizeof(double) * (int64_t)n_peaks * n_cols); + + int motif_block_size = n_motifs * n_tiles * n_transforms; + int gc_block_start = motif_block_size; + int gc_inter_start = gc_block_start + n_tiles; + + if (n_threads < 1) n_threads = 1; + if (n_threads > n_peaks) n_threads = n_peaks; + + // Group peak_order indices by chromosome run. peak_order is already + // sorted by (chromid, start), so each chromosome is a contiguous slice. + struct ChromRun { int chromid; int oi_lo; int oi_hi; }; + std::vector chrom_runs; + { + int run_lo = 0; + while (run_lo < n_peaks) { + int chromid = peak_chromids[peak_order[run_lo]]; + int run_hi = run_lo + 1; + while (run_hi < n_peaks && + peak_chromids[peak_order[run_hi]] == chromid) + ++run_hi; + chrom_runs.push_back({chromid, run_lo, run_hi}); + run_lo = run_hi; + } + } + + std::mutex err_mtx; + std::string first_error; + + // Per-chromosome processing: open all motif + GC handles ONCE (single + // thread), pre-materialize sparse tracks, then fan out the peak loop + // across worker threads that share the read-only handles. This avoids + // the previous per-thread re-open cost (191 mmap setups × N_threads × + // N_chroms) which made >4-thread runs scale negatively. + // + // Thread safety: + // - GenomeTrackFixedBin::get_mmap_bins_ptr is `const` and only reads + // the mmap region — safe for concurrent calls. + // - GenomeTrackSparse::get_intervals/get_vals are lazy on first call; + // we trigger them from the main thread before fan-out so the + // workers see fully-loaded vectors. + // - Output rows are disjoint per peak (no write contention). + // + // Per-chromosome handle release: shared_ptr goes out of + // scope at the end of each iteration, freeing the previous chrom's + // mmap mappings before the next chrom is opened. + constexpr int CHUNK = 256; + + for (const auto &run : chrom_runs) { + int chromid = run.chromid; + + std::vector motif_handles(n_motifs); + TrackHandle gc_handle; + try { + for (int m = 0; m < n_motifs; m++) { + motif_handles[m].track_dir = motif_dirs[m]; + motif_handles[m].type = motif_types[m]; + open_track_static(motif_handles[m], chromid, chromkey); + if (motif_handles[m].sparse) { + motif_handles[m].sparse->get_intervals(); + motif_handles[m].sparse->get_vals(); + } + } + gc_handle.track_dir = gc_dir; + gc_handle.type = gc_type; + open_track_static(gc_handle, chromid, chromkey); + if (gc_handle.sparse) { + gc_handle.sparse->get_intervals(); + gc_handle.sparse->get_vals(); + } + } catch (TGLException &e) { + verror("%s", e.msg()); + } catch (const std::exception &e) { + verror("%s", e.what()); + } + + std::atomic next_chunk{0}; + const int n_run_peaks = run.oi_hi - run.oi_lo; + + auto worker = [&]() { + try { + std::vector gc_vals(n_tiles, 0.0); + while (true) { + int chunk_idx = next_chunk.fetch_add(1, std::memory_order_relaxed); + int rel_lo = chunk_idx * CHUNK; + if (rel_lo >= n_run_peaks) break; + int rel_hi = std::min(rel_lo + CHUNK, n_run_peaks); + + for (int rel = rel_lo; rel < rel_hi; rel++) { + int pi = peak_order[run.oi_lo + rel]; + + int64_t peak_center = (peak_starts[pi] + peak_ends[pi]) / 2; + int peak_size = (int)(peak_ends[pi] - peak_starts[pi]); + int half = peak_size / 2; + + for (int ti = 0; ti < n_tiles; ti++) { + int64_t tile_start = peak_center - half - flank_size + + (int64_t)ti * tile_size; + int64_t tile_end = tile_start + tile_size; + + double gc_raw = aggregate_sum(gc_handle, tile_start, tile_end); + double gc_scaled = isnan(gc_raw) ? 0.0 + : (gc_raw / tile_size) * gc_scale_factor; + gc_vals[ti] = gc_scaled; + + int gc_col = gc_block_start + ti; + output[pi + (int64_t)gc_col * n_peaks] = gc_scaled; + + for (int m = 0; m < n_motifs; m++) { + double raw = aggregate_lse(motif_handles[m], tile_start, tile_end); + double scaled = (isnan(raw) || !isfinite(raw)) + ? 0.0 : apply_scaling(raw, scaling[m]); + + for (int t = 0; t < n_transforms; t++) { + double transformed = apply_transform(scaled, transforms[t]); + if (!isfinite(transformed)) transformed = 0.0; + int col = (ti * n_motifs + m) * n_transforms + t; + output[pi + (int64_t)col * n_peaks] = transformed; + } + } + } + + int inter_idx = 0; + for (int a = 0; a < n_tiles; a++) { + for (int b = a + 1; b < n_tiles; b++) { + int col = gc_inter_start + inter_idx; + output[pi + (int64_t)col * n_peaks] = + gc_vals[a] * gc_vals[b] / gc_scale_factor; + inter_idx++; + } + } + } + } + } catch (TGLException &e) { + std::lock_guard lk(err_mtx); + if (first_error.empty()) first_error = e.msg(); + } catch (const std::exception &e) { + std::lock_guard lk(err_mtx); + if (first_error.empty()) first_error = e.what(); + } catch (...) { + std::lock_guard lk(err_mtx); + if (first_error.empty()) first_error = "unknown error in worker thread"; + } + }; + + int run_threads = std::min(n_threads, n_run_peaks); + if (run_threads <= 1) { + worker(); + } else { + std::vector threads; + threads.reserve(run_threads); + for (int i = 0; i < run_threads; i++) threads.emplace_back(worker); + for (auto &t : threads) t.join(); + } + if (!first_error.empty()) break; + } + + if (!first_error.empty()) verror("%s", first_error.c_str()); +} + +// --------------------------------------------------------------------------- +// .Call entry point +// --------------------------------------------------------------------------- +extern "C" SEXP C_glm_extract_features( + SEXP _track_names, // character vector + SEXP _chroms, // character vector (chromosome names) + SEXP _starts, // numeric vector (int64 as double) + SEXP _ends, // numeric vector (int64 as double) + SEXP _tile_size, // integer scalar + SEXP _flank_size, // integer scalar + SEXP _max_caps, // numeric vector (per-motif, same order as track_names) + SEXP _dis_from_cap, // numeric scalar + SEXP _scale_factor, // numeric scalar + SEXP _transforms, // numeric matrix: n_transforms x 5 (L, k, x_0, pre_shift, post_shift) + SEXP _gc_track, // character scalar + SEXP _gc_scale_factor, // numeric scalar + SEXP _n_threads, // integer scalar (0 = auto) + SEXP _envir) // R environment +{ + try { + RdbInitializer rdb_init; + IntervUtils iu(_envir); + + // Parse track names + int n_motifs = Rf_length(_track_names); + vector track_names(n_motifs); + for (int i = 0; i < n_motifs; i++) { + track_names[i] = CHAR(STRING_ELT(_track_names, i)); + } + + // Parse intervals: resolve chromosome names to chromkey IDs here so + // callers don't have to know misha's internal chromid layout (which + // is the chromkey insertion order, not any subset ordering). + if (TYPEOF(_chroms) != STRSXP) { + verror("'chroms' must be a character vector of chromosome names"); + } + int n_peaks = Rf_length(_chroms); + const GenomeChromKey &chromkey_for_ids = iu.get_chromkey(); + vector chromids(n_peaks); + for (int i = 0; i < n_peaks; i++) { + SEXP s = STRING_ELT(_chroms, i); + if (s == NA_STRING) { + verror("chroms[%d] is NA", i + 1); + } + chromids[i] = chromkey_for_ids.chrom2id(CHAR(s)); + } + const double *starts_d = REAL(_starts); + const double *ends_d = REAL(_ends); + + // Convert doubles to int64 + vector starts(n_peaks), ends(n_peaks); + for (int i = 0; i < n_peaks; i++) { + starts[i] = (int64_t)starts_d[i]; + ends[i] = (int64_t)ends_d[i]; + } + + int tile_size = INTEGER(_tile_size)[0]; + int flank_size = INTEGER(_flank_size)[0]; + + // Parse scaling config + const double *max_caps = REAL(_max_caps); + double dis_from_cap = REAL(_dis_from_cap)[0]; + double scale_factor = REAL(_scale_factor)[0]; + + vector scaling(n_motifs); + for (int i = 0; i < n_motifs; i++) { + scaling[i].max_cap = max_caps[i]; + scaling[i].dis_from_cap = dis_from_cap; + scaling[i].scale_factor = scale_factor; + } + + // Parse transforms (matrix: n_transforms x 5, column-major) + int n_transforms = Rf_nrows(_transforms); + const double *tdata = REAL(_transforms); + vector transforms(n_transforms); + for (int i = 0; i < n_transforms; i++) { + transforms[i].L = tdata[i + 0 * n_transforms]; + transforms[i].k = tdata[i + 1 * n_transforms]; + transforms[i].x_0 = tdata[i + 2 * n_transforms]; + transforms[i].pre_shift = tdata[i + 3 * n_transforms]; + transforms[i].post_shift = tdata[i + 4 * n_transforms]; + } + + string gc_track = CHAR(STRING_ELT(_gc_track, 0)); + double gc_scale_factor = REAL(_gc_scale_factor)[0]; + + // Thread count. 0 = auto: min(n_peaks, hardware_concurrency, 40). + // Negative or NA values fall back to 1 (silent, matching glm_batch_quantiles). + int n_threads_req = INTEGER(_n_threads)[0]; + int n_threads; + if (n_threads_req == NA_INTEGER || n_threads_req < 0) { + n_threads = 1; + } else if (n_threads_req == 0) { + unsigned hw = std::thread::hardware_concurrency(); + if (hw == 0) hw = 4; + n_threads = (int)std::min((unsigned)n_peaks, std::min(hw, 40u)); + if (n_threads < 1) n_threads = 1; + } else { + n_threads = std::min(n_threads_req, n_peaks); + if (n_threads < 1) n_threads = 1; + } + + // Compute output dimensions + int first_peak_size = (int)(ends[0] - starts[0]); + int extended = first_peak_size + 2 * flank_size; + int n_tiles = extended / tile_size; + int n_gc_inter = n_tiles * (n_tiles - 1) / 2; + int n_cols = n_motifs * n_tiles * n_transforms + n_tiles + n_gc_inter; + + // Allocate output matrix + SEXP result; + rprotect(result = Rf_allocMatrix(REALSXP, n_peaks, n_cols)); + double *output = REAL(result); + + // Run extraction + GlmFeatureExtractor extractor(iu); + extractor.extract( + track_names, + chromids.data(), + starts.data(), + ends.data(), + n_peaks, + tile_size, + flank_size, + scaling, + transforms, + gc_track, + gc_scale_factor, + output, + n_cols, + n_threads + ); + + return result; + + } catch (TGLException &e) { + rerror("%s", e.msg()); + } catch (const bad_alloc &e) { + rerror("Out of memory"); + } catch (const exception &e) { + rerror("%s", e.what()); + } + return R_NilValue; +} diff --git a/src/GlmFeatureExtractor.h b/src/GlmFeatureExtractor.h new file mode 100644 index 000000000..3312bce9d --- /dev/null +++ b/src/GlmFeatureExtractor.h @@ -0,0 +1,89 @@ +#ifndef GLMFEATUREEXTRACTOR_H_ +#define GLMFEATUREEXTRACTOR_H_ + +#include "rdbutils.h" +#include "GenomeTrackFixedBin.h" +#include "GenomeTrackSparse.h" +#include "GenomeTrack.h" + +#include +#include +#include +#include +#include +#include + +struct LmTransformConfig { + double L; + double k; + double x_0; + double pre_shift; + double post_shift; +}; + +struct LmScalingConfig { + double max_cap; + double dis_from_cap; + double scale_factor; +}; + +class GlmFeatureExtractor { +public: + GlmFeatureExtractor(rdb::IntervUtils &iu) : m_iu(iu) {} + + void extract( + const std::vector &track_names, + const int *peak_chromids, + const int64_t *peak_starts, + const int64_t *peak_ends, + int n_peaks, + int tile_size, + int flank_size, + const std::vector &scaling, + const std::vector &transforms, + const std::string &gc_track_name, + double gc_scale_factor, + double *output, + int n_cols, + int n_threads = 1 + ); + +private: + rdb::IntervUtils &m_iu; + + struct TrackHandle { + std::string track_dir; + GenomeTrack::Type type; + std::shared_ptr track; + GenomeTrackFixedBin *fixedbin = nullptr; + GenomeTrackSparse *sparse = nullptr; + unsigned bin_size = 0; + }; + + void open_track(TrackHandle &handle, int chromid); + // Worker-callable version: takes the chromkey directly so multiple + // threads don't race on m_iu.get_chromkey() (which is itself harmless + // but keeps the worker free of any shared mutable state). + static void open_track_static(TrackHandle &handle, int chromid, + const GenomeChromKey &chromkey); + + static double aggregate_lse(const TrackHandle &handle, int64_t start, int64_t end); + static double aggregate_sum(const TrackHandle &handle, int64_t start, int64_t end); + + // Binary search: find first interval index where intervals[i].end > pos + static size_t sparse_lower_bound(const GIntervals &intervals, int64_t pos); + + static inline double apply_scaling(double raw, const LmScalingConfig &s) { + double ceiled = std::min(raw - s.max_cap, 0.0); + double floored = std::max(ceiled, -s.dis_from_cap); + double scaled = s.scale_factor * (floored + s.dis_from_cap) / s.dis_from_cap; + return std::isfinite(scaled) ? scaled : 0.0; + } + + static inline double apply_transform(double x, const LmTransformConfig &t) { + double input = x + t.pre_shift; + return t.L / (1.0 + std::exp(-t.k * (input - t.x_0))) + t.post_shift; + } +}; + +#endif /* GLMFEATUREEXTRACTOR_H_ */ diff --git a/src/GlmVarProcessor.cpp b/src/GlmVarProcessor.cpp new file mode 100644 index 000000000..53772047b --- /dev/null +++ b/src/GlmVarProcessor.cpp @@ -0,0 +1,517 @@ +#include +#include +#include +#include +#include + +#include "GlmVarProcessor.h" +#include "TrackExpressionVars.h" +#include "GenomeTrack1D.h" +#include "GenomeTrackFixedBin.h" +#include "GenomeTrackSparse.h" +#include "rdbutils.h" + +using namespace rdb; +using namespace std; + +void GlmVarProcessor::prepare_batch(TrackExpressionVars::Track_vars &track_vars) +{ + m_glm_vars.clear(); + for (auto &var : track_vars) { + if (var.val_func == TrackExpressionVars::Track_var::GLM_PREDICT) { + m_glm_vars.push_back(&var); + } + } +} + +void GlmVarProcessor::process_glm_vars( + TrackExpressionVars::Track_vars &track_vars, + const GInterval &interval, + unsigned idx) +{ + for (auto *var : m_glm_vars) { + process_single_glm_var(*var, interval, idx); + } +} + +void GlmVarProcessor::process_single_glm_var( + TrackExpressionVars::Track_var &var, + const GInterval &interval, + unsigned idx) +{ + using GlmEntry = TrackExpressionVars::Track_var::GlmEntry; + using GlmScalingGroup = TrackExpressionVars::Track_var::GlmScalingGroup; + + int64_t center = (interval.start + interval.end) / 2; + + // ---- Multi-selector: compound bin = sum_m b_m * stride_m, NaN propagation ---- + int b = 0; + const int nsel = (int)var.glm_selector_fixedbins.size(); + bool selector_failed = false; + for (int m_sel = 0; m_sel < nsel; ++m_sel) { + GenomeTrackFixedBin *sel = var.glm_selector_fixedbins[m_sel]; + unsigned bs = var.glm_selector_bin_sizes[m_sel]; + if (!sel || bs == 0) { selector_failed = true; break; } + int64_t sel_bin = center / (int64_t)bs; + int64_t raw_count; + const float *ptr = sel->get_mmap_bins_ptr(sel_bin, 1, raw_count); + if (!ptr || raw_count <= 0 || !std::isfinite(ptr[0])) { selector_failed = true; break; } + int bm = var.glm_selector_binfinders[m_sel].val2bin((double)ptr[0]); + if (bm < 0) { selector_failed = true; break; } + b += bm * (int)var.glm_selector_strides[m_sel]; + } + if (selector_failed) { + var.var[idx] = NAN; + return; + } + // For nsel == 0 (no selector), b stays 0 — valid since glm_num_bins == 1. + + double result = var.glm_bias[b]; + bool has_interactions = !var.glm_interactions.empty(); + bool has_kernel_bins = !var.glm_kernel_bins.empty(); + int N = (int)var.glm_entries.size(); + int M = (int)var.glm_interactions.size(); + + // Bin-major layout: stride-1 access across entries within the same bin + const double *bin_weights = var.glm_all_weights.data() + (int64_t)b * N; + const double *bin_inter_weights = M > 0 ? var.glm_all_inter_weights.data() + (int64_t)b * M : nullptr; + + // ---- Pre-compute interaction-referenced entries (once per var, reuse across positions) ---- + const void *var_interactions_id = &var.glm_interactions; + if (has_interactions && (m_inter_referenced.size() != (size_t)N || m_inter_referenced_owner != var_interactions_id)) { + m_inter_referenced.assign(N, false); + for (const auto &inter : var.glm_interactions) { + m_inter_referenced[inter.entry_i] = true; + m_inter_referenced[inter.entry_j] = true; + } + m_inter_referenced_owner = var_interactions_id; + } + + // ---- Main effects ---- + // Track groups provide cache-friendly ordering: read one track's super-window, + // then process all its scaling groups. Each scaling group aggregates+scales once. + if (!var.glm_track_groups.empty()) { + using GlmTrackGroup = TrackExpressionVars::Track_var::GlmTrackGroup; + + for (const GlmTrackGroup &tg : var.glm_track_groups) { + + // Per-bin skip: if all entries in this track group have zero weight + // and none are interaction-referenced, skip the track read entirely. + if (var.glm_num_bins > 1) { + bool tg_needed = false; + for (int sg_idx : tg.scaling_group_indices) { + for (int eidx : var.glm_scaling_groups[sg_idx].entry_indices) { + if (bin_weights[var.glm_entries[eidx].weight_offset] != 0.0 || + (has_interactions && m_inter_referenced[eidx])) { + tg_needed = true; + goto tg_check_done; + } + } + } + tg_check_done: + if (!tg_needed) continue; + } + + const GlmEntry &track_rep = var.glm_entries[tg.track_entry_idx]; + + // Pre-read the super-window for this track (touches the cache once) + const float *super_ptr = nullptr; + int64_t super_sbin = 0; + int64_t super_count = 0; + unsigned bin_size = track_rep.cached_bin_size; + + if (track_rep.cached_fixedbin && bin_size > 0) { + int64_t sw_start = center + tg.min_sshift; + int64_t sw_end = center + tg.max_eshift; + super_sbin = sw_start / (int64_t)bin_size; + int64_t super_ebin = (int64_t)std::ceil(sw_end / (double)bin_size); + super_ptr = track_rep.cached_fixedbin->get_mmap_bins_ptr( + super_sbin, super_ebin - super_sbin, super_count); + } + + for (int sg_idx : tg.scaling_group_indices) { + const GlmScalingGroup &group = var.glm_scaling_groups[sg_idx]; + const GlmEntry &rep = var.glm_entries[group.representative_idx]; + + // Per-bin skip at scaling group level + if (var.glm_num_bins > 1) { + bool sg_needed = false; + for (int eidx : group.entry_indices) { + if (bin_weights[var.glm_entries[eidx].weight_offset] != 0.0 || + (has_interactions && m_inter_referenced[eidx])) { + sg_needed = true; + break; + } + } + if (!sg_needed) continue; + } + + double raw; + + // Try to aggregate from the pre-read super-window buffer + if (super_ptr && rep.cached_fixedbin && bin_size > 0) { + int64_t win_start = center + rep.sshift; + int64_t win_end = center + rep.eshift; + int64_t sbin = win_start / (int64_t)bin_size; + int64_t ebin = (int64_t)std::ceil(win_end / (double)bin_size); + + // Compute offsets into the super-window buffer + int64_t buf_off = sbin - super_sbin; + int64_t buf_end = ebin - super_sbin; + if (buf_off < 0) buf_off = 0; + if (buf_end > super_count) buf_end = super_count; + int64_t num_bins = buf_end - buf_off; + + if (num_bins > 0) { + const float *bins = super_ptr + buf_off; + if (rep.inner_is_lse) { + double max_val = -numeric_limits::infinity(); + for (int64_t i = 0; i < num_bins; i++) { + float v = bins[i]; + if (!std::isnan(v) && !std::isinf(v)) { + if ((double)v > max_val) max_val = (double)v; + } + } + if (!std::isfinite(max_val)) { + raw = numeric_limits::quiet_NaN(); + } else { + double exp_sum = 0.0; + for (int64_t i = 0; i < num_bins; i++) { + float v = bins[i]; + if (!std::isnan(v) && !std::isinf(v)) { + exp_sum += std::exp((double)v - max_val); + } + } + raw = max_val + std::log(exp_sum); + } + } else { + double acc = 0.0; + bool has_val = false; + for (int64_t i = 0; i < num_bins; i++) { + float v = bins[i]; + if (!std::isnan(v) && !std::isinf(v)) { + acc += (double)v; + has_val = true; + } + } + raw = has_val ? acc : numeric_limits::quiet_NaN(); + } + } else { + raw = numeric_limits::quiet_NaN(); + } + } else { + // Fallback: sparse track or no mmap + int64_t win_start = center + rep.sshift; + int64_t win_end = center + rep.eshift; + raw = aggregate_window(rep, win_start, win_end, rep.inner_is_lse); + } + + // All-NaN window → entire position is NaN + if (std::isnan(raw)) { + var.var[idx] = NAN; + return; + } + if (!std::isfinite(raw)) raw = 0.0; + double scaled = apply_scaling(raw, rep.scaling, var.glm_scale_factor); + + if (has_interactions) { + for (int idx : group.entry_indices) { + var.glm_scaled_cache[idx] = scaled; + } + } + + for (int idx : group.entry_indices) { + const GlmEntry &entry = var.glm_entries[idx]; + double transformed = scaled; + if (entry.transform.enabled) { + transformed = apply_transform(scaled, entry.transform); + } + if (!std::isfinite(transformed)) transformed = 0.0; + result += bin_weights[entry.weight_offset] * transformed; + } + } + } + } else if (!var.glm_scaling_groups.empty()) { + // Scaling groups without track groups + for (const GlmScalingGroup &group : var.glm_scaling_groups) { + // Per-bin skip + if (var.glm_num_bins > 1) { + bool sg_needed = false; + for (int eidx : group.entry_indices) { + if (bin_weights[var.glm_entries[eidx].weight_offset] != 0.0 || + (has_interactions && m_inter_referenced[eidx])) { + sg_needed = true; + break; + } + } + if (!sg_needed) continue; + } + const GlmEntry &rep = var.glm_entries[group.representative_idx]; + int64_t win_start = center + rep.sshift; + int64_t win_end = center + rep.eshift; + double raw = aggregate_window(rep, win_start, win_end, rep.inner_is_lse); + if (std::isnan(raw)) { + var.var[idx] = NAN; + return; + } + if (!std::isfinite(raw)) raw = 0.0; + double scaled = apply_scaling(raw, rep.scaling, var.glm_scale_factor); + if (has_interactions) { + for (int idx : group.entry_indices) { + var.glm_scaled_cache[idx] = scaled; + } + } + for (int idx : group.entry_indices) { + const GlmEntry &entry = var.glm_entries[idx]; + double transformed = scaled; + if (entry.transform.enabled) { + transformed = apply_transform(scaled, entry.transform); + } + if (!std::isfinite(transformed)) transformed = 0.0; + result += bin_weights[entry.weight_offset] * transformed; + } + } + } else { + // Fallback: per-entry loop (kernel_bins case or no groups built) + for (int i = 0; i < N; i++) { + // Per-bin skip + if (var.glm_num_bins > 1 && bin_weights[i] == 0.0 && + !(has_interactions && m_inter_referenced[i])) continue; + + const GlmEntry &entry = var.glm_entries[i]; + + double raw; + if (!has_kernel_bins) { + int64_t win_start = center + entry.sshift; + int64_t win_end = center + entry.eshift; + raw = aggregate_window(entry, win_start, win_end, entry.inner_is_lse); + } else { + // Kernel sub-bin smoothing + int64_t win_center = center + (entry.sshift + entry.eshift) / 2; + int B = (int)var.glm_kernel_bins.size(); + + if (entry.inner_is_lse) { + double acc = -numeric_limits::infinity(); + for (int kb = 0; kb < B; kb++) { + double bin_val = read_single_bin(entry, win_center + (int64_t)var.glm_kernel_bins[kb]); + if (std::isfinite(bin_val) && entry.kernel_weights[kb] > 0) { + lse_accumulate(acc, std::log(entry.kernel_weights[kb]) + bin_val); + } + } + raw = std::isfinite(acc) ? acc : numeric_limits::quiet_NaN(); + } else { + raw = 0.0; + bool has_val = false; + for (int kb = 0; kb < B; kb++) { + double bin_val = read_single_bin(entry, win_center + (int64_t)var.glm_kernel_bins[kb]); + if (std::isfinite(bin_val)) { + raw += entry.kernel_weights[kb] * bin_val; + has_val = true; + } + } + if (!has_val) raw = numeric_limits::quiet_NaN(); + } + } + + if (std::isnan(raw)) { + var.var[idx] = NAN; + return; + } + if (!std::isfinite(raw)) raw = 0.0; + double scaled = apply_scaling(raw, entry.scaling, var.glm_scale_factor); + + if (has_interactions) { + var.glm_scaled_cache[i] = scaled; + } + + double transformed = scaled; + if (entry.transform.enabled) { + transformed = apply_transform(scaled, entry.transform); + } + if (!std::isfinite(transformed)) transformed = 0.0; + result += bin_weights[entry.weight_offset] * transformed; + } + } + + // ---- Interactions ---- + for (const auto &inter : var.glm_interactions) { + double product; + + if (!has_kernel_bins) { + // Product of cached scaled values, re-normalized by scale_factor + product = var.glm_scaled_cache[inter.entry_i] + * var.glm_scaled_cache[inter.entry_j] + / var.glm_scale_factor; + } else { + // Per-bin product, kernel-weighted (design doc §3.3): + // product = Σ_b kernel[b] × scaled_i_at_b × scaled_j_at_b / scale_factor + // Uses entry_i's kernel weights as the shared kernel[b]. + const GlmEntry &ei = var.glm_entries[inter.entry_i]; + const GlmEntry &ej = var.glm_entries[inter.entry_j]; + int64_t win_center_i = center + (ei.sshift + ei.eshift) / 2; + int64_t win_center_j = center + (ej.sshift + ej.eshift) / 2; + int B = (int)var.glm_kernel_bins.size(); + + product = 0.0; + bool inter_has_val = false; + for (int kb = 0; kb < B; kb++) { + double vi = read_single_bin(ei, win_center_i + (int64_t)var.glm_kernel_bins[kb]); + double vj = read_single_bin(ej, win_center_j + (int64_t)var.glm_kernel_bins[kb]); + if (!std::isfinite(vi) || !std::isfinite(vj)) continue; + double si = apply_scaling(vi, ei.scaling, var.glm_scale_factor); + double sj = apply_scaling(vj, ej.scaling, var.glm_scale_factor); + + product += ei.kernel_weights[kb] * si * sj / var.glm_scale_factor; + inter_has_val = true; + } + if (!inter_has_val) { + var.var[idx] = NAN; + return; + } + } + + // Apply interaction-specific transform + if (inter.transform.enabled) { + product = apply_transform(product, inter.transform); + } + + // NaN/Inf → 0 + if (!std::isfinite(product)) product = 0.0; + + result += bin_inter_weights[inter.weight_offset] * product; + } + + var.var[idx] = result; +} + +double GlmVarProcessor::aggregate_window( + const TrackExpressionVars::Track_var::GlmEntry &entry, + int64_t start, int64_t end, + bool is_lse) +{ + // Clamp window to valid coordinate range (mirrors iterator modifier clipping) + if (start < 0) start = 0; + if (start >= end) return 0.0; + + if (entry.cached_fixedbin) { + unsigned bin_size = entry.cached_bin_size; + if (bin_size == 0) return 0.0; + + int64_t sbin = start / bin_size; + int64_t ebin = (int64_t)std::ceil(end / (double)bin_size); + int64_t num_bins = ebin - sbin; + if (num_bins <= 0) return 0.0; + + int64_t raw_count; + const float *raw = entry.cached_fixedbin->get_mmap_bins_ptr(sbin, num_bins, raw_count); + if (!raw) { + raw_count = entry.cached_fixedbin->read_bins_bulk(sbin, num_bins, const_cast&>(m_raw_bins)); + raw = m_raw_bins.data(); + } + + if (raw_count <= 0) return 0.0; + + if (is_lse) { + // Two-pass numerically stable LSE + double max_val = -numeric_limits::infinity(); + for (int64_t i = 0; i < raw_count; i++) { + float v = raw[i]; + if (!std::isnan(v) && !std::isinf(v)) { + if ((double)v > max_val) max_val = (double)v; + } + } + if (!std::isfinite(max_val)) return numeric_limits::quiet_NaN(); + + double exp_sum = 0.0; + for (int64_t i = 0; i < raw_count; i++) { + float v = raw[i]; + if (!std::isnan(v) && !std::isinf(v)) { + exp_sum += std::exp((double)v - max_val); + } + } + return max_val + std::log(exp_sum); + } else { + // Sum + double acc = 0.0; + bool has_val = false; + for (int64_t i = 0; i < raw_count; i++) { + float v = raw[i]; + if (!std::isnan(v) && !std::isinf(v)) { + acc += (double)v; + has_val = true; + } + } + return has_val ? acc : numeric_limits::quiet_NaN(); + } + } + + if (entry.cached_sparse) { + const GIntervals &intervals = entry.cached_sparse->get_intervals(); + const vector &vals = entry.cached_sparse->get_vals(); + + if (is_lse) { + double acc = -numeric_limits::infinity(); + for (size_t i = 0; i < intervals.size(); i++) { + if (intervals[i].start >= end) break; + if (intervals[i].end <= start) continue; + float v = vals[i]; + if (!std::isnan(v) && !std::isinf(v)) { + lse_accumulate(acc, (double)v); + } + } + return std::isfinite(acc) ? acc : numeric_limits::quiet_NaN(); + } else { + double acc = 0.0; + bool has_val = false; + for (size_t i = 0; i < intervals.size(); i++) { + if (intervals[i].start >= end) break; + if (intervals[i].end <= start) continue; + float v = vals[i]; + if (!std::isnan(v) && !std::isinf(v)) { + acc += (double)v; + has_val = true; + } + } + return has_val ? acc : numeric_limits::quiet_NaN(); + } + } + + // Track not available for this chromosome + return numeric_limits::quiet_NaN(); +} + +double GlmVarProcessor::read_single_bin( + const TrackExpressionVars::Track_var::GlmEntry &entry, + int64_t pos) +{ + if (entry.cached_fixedbin) { + unsigned bin_size = entry.cached_bin_size; + if (bin_size == 0) return numeric_limits::quiet_NaN(); + + int64_t bin_idx = pos / bin_size; + int64_t raw_count; + const float *raw = entry.cached_fixedbin->get_mmap_bins_ptr(bin_idx, 1, raw_count); + if (!raw || raw_count <= 0) + return numeric_limits::quiet_NaN(); + float v = raw[0]; + if (std::isnan(v) || std::isinf(v)) + return numeric_limits::quiet_NaN(); + return (double)v; + } + + if (entry.cached_sparse) { + // For sparse tracks, read a single-bin-width window + const GIntervals &intervals = entry.cached_sparse->get_intervals(); + const vector &vals = entry.cached_sparse->get_vals(); + for (size_t i = 0; i < intervals.size(); i++) { + if (intervals[i].start > pos) break; + if (intervals[i].end <= pos) continue; + float v = vals[i]; + if (!std::isnan(v) && !std::isinf(v)) + return (double)v; + } + return numeric_limits::quiet_NaN(); + } + + return numeric_limits::quiet_NaN(); +} diff --git a/src/GlmVarProcessor.h b/src/GlmVarProcessor.h new file mode 100644 index 000000000..3c40cc61e --- /dev/null +++ b/src/GlmVarProcessor.h @@ -0,0 +1,102 @@ +#ifndef GLMVARPROCESSOR_H_ +#define GLMVARPROCESSOR_H_ + +#include "TrackExpressionVars.h" +#include "GenomeTrack1D.h" +#include "GenomeTrackFixedBin.h" +#include "GenomeTrackSparse.h" +#include +#include +#include + +class GlmVarProcessor { +public: + GlmVarProcessor(rdb::IntervUtils &iu) : m_iu(iu) {} + ~GlmVarProcessor() = default; + + // Pre-build filtered GLM var list (call once at start_chrom) + void prepare_batch(TrackExpressionVars::Track_vars &track_vars); + + void process_glm_vars( + TrackExpressionVars::Track_vars &track_vars, + const GInterval &interval, + unsigned idx + ); + +private: + rdb::IntervUtils &m_iu; + std::vector m_glm_vars; + + // Scratch buffers + std::vector m_raw_bins; + std::vector m_inter_referenced; // per-entry: true if used by any interaction + const void *m_inter_referenced_owner{nullptr}; // tracks which var's interactions built the bitmap + + void process_single_glm_var( + TrackExpressionVars::Track_var &var, + const GInterval &interval, + unsigned idx + ); + + // Aggregate a track window [start, end) using sum or lse + double aggregate_window( + const TrackExpressionVars::Track_var::GlmEntry &entry, + int64_t start, int64_t end, + bool is_lse + ); + + // Read a single bin value at a genome position + double read_single_bin( + const TrackExpressionVars::Track_var::GlmEntry &entry, + int64_t pos + ); + + // Inline helpers + static inline double apply_scaling( + double raw, + const TrackExpressionVars::Track_var::GlmScaling &s, + double scale_factor) + { + if (!s.enabled) return raw; + if (s.simple_cap) { + // Simple cap-and-divide: min(raw, max_cap) / dis_from_cap + double capped = std::min(raw, s.max_cap); + double scaled = capped / s.dis_from_cap; + return std::isfinite(scaled) ? scaled : 0.0; + } + double ceiled = std::min(raw - s.max_cap, 0.0); + double floored = std::max(ceiled, -s.dis_from_cap); + double scaled = scale_factor * (floored + s.dis_from_cap) / s.dis_from_cap; + return std::isfinite(scaled) ? scaled : 0.0; + } + + // Fast exp approximation for bounded inputs (GLM logistic range ~[-20, 20]). + // Splits x = n*ln2 + r (r in [0, ln2)), uses ldexp(2^n) and a degree-5 + // Taylor series for exp(r). Max relative error < 0.01% in [-20, 20]. + static inline double fast_exp(double x) + { + if (x < -20.0) return 0.0; + if (x > 20.0) return std::exp(x); + + const double LN2 = 0.6931471805599453; + const double LOG2E = 1.4426950408889634; + double y = x * LOG2E; + double n = std::floor(y); + double r = x - n * LN2; // r in [0, ln2) + + // Taylor exp(r) for r in [0, 0.693]: 1 + r + r²/2 + r³/6 + r⁴/24 + r⁵/120 + // Horner form: 1 + r*(1 + r*(1/2 + r*(1/6 + r*(1/24 + r/120)))) + double p = 1.0 + r * (1.0 + r * (0.5 + r * (1.0/6.0 + r * (1.0/24.0 + r * (1.0/120.0))))); + return std::ldexp(p, (int)n); + } + + static inline double apply_transform( + double x, + const TrackExpressionVars::Track_var::GlmTransform &t) + { + double input = x + t.pre_shift; + return t.L / (1.0 + fast_exp(-t.k * (input - t.x_0))) + t.post_shift; + } +}; + +#endif /* GLMVARPROCESSOR_H_ */ diff --git a/src/TrackExpressionScanner.cpp b/src/TrackExpressionScanner.cpp index 2f8ec8081..0ad7896d3 100644 --- a/src/TrackExpressionScanner.cpp +++ b/src/TrackExpressionScanner.cpp @@ -575,8 +575,8 @@ TrackExpressionIteratorBase *TrackExprScanner::create_expr_iterator(SEXP giterat vector track_types; for (unsigned ivar = 0; ivar < vars.get_num_track_vars(); ++ivar) { - // Skip sequence-based variables since they don't have associated tracks - if (vars.is_seq_variable(ivar)) { + // Skip sourceless variables (sequence-based, glm.predict) + if (vars.is_seq_variable(ivar) || !vars.has_track(ivar)) { continue; } track_names.push_back(vars.get_track_name(ivar)); @@ -846,6 +846,7 @@ for (unsigned ivar = 0; ivar < vars.get_num_track_vars(); ++ivar) { num_tracks > 1) { for (unsigned ivar = 1; ivar < vars.get_num_track_vars(); ++ivar) { + if (!vars.has_track(ivar) || !vars.has_track(ivar - 1)) continue; if (vars.get_track_name(ivar) != vars.get_track_name(ivar - 1)) { if (track_exprs.size() == 1) verror("Cannot implicitly determine iterator policy: track expression \"%s\" contains more than one %s track.\n", diff --git a/src/TrackExpressionVars.cpp b/src/TrackExpressionVars.cpp index 22666add6..2fafac24d 100644 --- a/src/TrackExpressionVars.cpp +++ b/src/TrackExpressionVars.cpp @@ -1,5 +1,6 @@ #include #include +#include #include #include #include @@ -25,6 +26,7 @@ #include "IntervVarProcessor.h" #include "ValueVarProcessor.h" #include "SequenceVarProcessor.h" +#include "GlmVarProcessor.h" namespace { // Parse direction parameter from R params list. Returns ABOVE or BELOW. @@ -65,7 +67,8 @@ const char *TrackExpressionVars::Track_var::FUNC_NAMES[TrackExpressionVars::Trac "first", "first.pos.abs", "first.pos.relative", "last", "last.pos.abs", "last.pos.relative", "pwm.edit_distance", "pwm.edit_distance.pos", "pwm.max.edit_distance", "pwm.edit_distance.lse", "pwm.edit_distance.lse.pos", - "pwm.n_mutations"}; + "pwm.n_mutations", + "glm.predict"}; const char *TrackExpressionVars::Interv_var::FUNC_NAMES[TrackExpressionVars::Interv_var::NUM_FUNCS] = { "distance", "distance.center", "distance.edge", "coverage", "neighbor.count" }; @@ -158,6 +161,7 @@ TrackExpressionVars::TrackExpressionVars(rdb::IntervUtils &iu) : m_interv_processor = std::make_unique(iu); m_value_processor = std::make_unique(iu); m_sequence_processor = std::make_unique(iu, m_shared_seqfetch); + m_glm_processor = std::make_unique(iu); } TrackExpressionVars::~TrackExpressionVars() @@ -875,6 +879,385 @@ void TrackExpressionVars::add_vtrack_var(const string &vtrack, SEXP rvtrack) // Attach filter if present attach_filter_to_var(rvtrack, vtrack, var); return; + } else if (func == "glm.predict") { + // Fused GLM predictor virtual track (sourceless) + m_track_vars.push_back(Track_var()); + Track_var &var = m_track_vars.back(); + var.var_name = vtrack; + var.val_func = Track_var::GLM_PREDICT; + var.track_n_imdf = nullptr; + + SEXP rparams = get_rvector_col(rvtrack, "params", vtrack.c_str(), false); + if (Rf_isNull(rparams) || !Rf_isNewList(rparams)) + verror("Virtual track %s: glm.predict requires params list", vtrack.c_str()); + + // --- tracks (character vector, N entries) --- + int t_idx = findListElementIndex(rparams, "tracks"); + if (t_idx < 0) + verror("Virtual track %s: 'tracks' parameter is required", vtrack.c_str()); + SEXP rtracks = VECTOR_ELT(rparams, t_idx); + if (!Rf_isString(rtracks) || Rf_length(rtracks) < 1) + verror("Virtual track %s: 'tracks' must be a non-empty character vector", vtrack.c_str()); + int N = Rf_length(rtracks); + + // --- inner_func (character vector, N) --- + int if_idx = findListElementIndex(rparams, "inner_func"); + if (if_idx < 0) + verror("Virtual track %s: 'inner_func' parameter is required", vtrack.c_str()); + SEXP rif = VECTOR_ELT(rparams, if_idx); + if (!Rf_isString(rif) || Rf_length(rif) != N) + verror("Virtual track %s: 'inner_func' must be a character vector of length %d", vtrack.c_str(), N); + + // --- weights (numeric vector N, or matrix N×K flattened column-major) --- + int w_idx = findListElementIndex(rparams, "weights"); + if (w_idx < 0) + verror("Virtual track %s: 'weights' parameter is required", vtrack.c_str()); + SEXP rweights = VECTOR_ELT(rparams, w_idx); + if (!Rf_isReal(rweights)) + verror("Virtual track %s: 'weights' must be numeric", vtrack.c_str()); + + // Detect K from num_bins parameter (default 1) + int K = 1; + int nb_idx = findListElementIndex(rparams, "num_bins"); + if (nb_idx >= 0) { + SEXP rnb = VECTOR_ELT(rparams, nb_idx); + if (!Rf_isNull(rnb)) { + if (Rf_isInteger(rnb)) K = INTEGER(rnb)[0]; + else K = (int)Rf_asReal(rnb); + } + } + var.glm_num_bins = K; + + if (Rf_length(rweights) != N * K) + verror("Virtual track %s: 'weights' length must be %d (N=%d x K=%d)", + vtrack.c_str(), N * K, N, K); + + // --- bias (numeric scalar or vector of length K) --- + var.glm_bias.assign(K, 0.0); + int b_idx = findListElementIndex(rparams, "bias"); + if (b_idx >= 0) { + SEXP rbias = VECTOR_ELT(rparams, b_idx); + if (!Rf_isNull(rbias) && Rf_isReal(rbias)) { + double *bp = REAL(rbias); + int blen = Rf_length(rbias); + for (int i = 0; i < K && i < blen; i++) + var.glm_bias[i] = bp[i]; + } + } + + // --- scale_factor (numeric scalar) --- + var.glm_scale_factor = 10.0; + int sf_idx = findListElementIndex(rparams, "scale_factor"); + if (sf_idx >= 0) { + SEXP rsf = VECTOR_ELT(rparams, sf_idx); + if (!Rf_isNull(rsf)) + var.glm_scale_factor = Rf_asReal(rsf); + } + + // --- sshifts / eshifts (numeric vectors, N) --- + SEXP rsshifts = R_NilValue, reshifts = R_NilValue; + int ss_idx = findListElementIndex(rparams, "sshifts"); + int es_idx = findListElementIndex(rparams, "eshifts"); + if (ss_idx >= 0) rsshifts = VECTOR_ELT(rparams, ss_idx); + if (es_idx >= 0) reshifts = VECTOR_ELT(rparams, es_idx); + + // --- max_cap / dis_from_cap (numeric vectors, N, may contain NA) --- + SEXP rmaxcap = R_NilValue, rdiscap = R_NilValue; + int mc_idx = findListElementIndex(rparams, "max_cap"); + int dc_idx = findListElementIndex(rparams, "dis_from_cap"); + if (mc_idx >= 0) rmaxcap = VECTOR_ELT(rparams, mc_idx); + if (dc_idx >= 0) rdiscap = VECTOR_ELT(rparams, dc_idx); + + // --- trans_family (character vector, N, may contain NA) --- + SEXP rtfam = R_NilValue; + int tf_idx = findListElementIndex(rparams, "trans_family"); + if (tf_idx >= 0) rtfam = VECTOR_ELT(rparams, tf_idx); + + // --- trans param vectors (5 parallel numeric vectors, N each) --- + SEXP rtL = R_NilValue, rtk = R_NilValue, rtx0 = R_NilValue; + SEXP rtpre = R_NilValue, rtpost = R_NilValue; + int tL_idx = findListElementIndex(rparams, "trans_L"); + int tk_idx = findListElementIndex(rparams, "trans_k"); + int tx0_idx = findListElementIndex(rparams, "trans_x0"); + int tpre_idx = findListElementIndex(rparams, "trans_pre"); + int tpost_idx = findListElementIndex(rparams, "trans_post"); + if (tL_idx >= 0) rtL = VECTOR_ELT(rparams, tL_idx); + if (tk_idx >= 0) rtk = VECTOR_ELT(rparams, tk_idx); + if (tx0_idx >= 0) rtx0 = VECTOR_ELT(rparams, tx0_idx); + if (tpre_idx >= 0) rtpre = VECTOR_ELT(rparams, tpre_idx); + if (tpost_idx >= 0) rtpost = VECTOR_ELT(rparams, tpost_idx); + + // --- kernel_bins (optional numeric vector, B) --- + SEXP rkbins = R_NilValue; + int kb_idx = findListElementIndex(rparams, "kernel_bins"); + if (kb_idx >= 0) rkbins = VECTOR_ELT(rparams, kb_idx); + if (!Rf_isNull(rkbins) && Rf_isReal(rkbins)) { + int B = Rf_length(rkbins); + var.glm_kernel_bins.resize(B); + double *kbp = REAL(rkbins); + for (int b = 0; b < B; b++) + var.glm_kernel_bins[b] = kbp[b]; + } + + // --- kernels (optional list of numeric vectors, N or recycled from length 1) --- + SEXP rkernels = R_NilValue; + int kn_idx = findListElementIndex(rparams, "kernels"); + if (kn_idx >= 0) rkernels = VECTOR_ELT(rparams, kn_idx); + + // --- Build GlmEntry vector --- + var.glm_entries.resize(N); + // Copy weights directly — R's column-major layout is already bin-major: wp[b*N + i] + var.glm_all_weights.assign(REAL(rweights), REAL(rweights) + N * K); + double *ssp = (!Rf_isNull(rsshifts) && Rf_isReal(rsshifts)) ? REAL(rsshifts) : nullptr; + double *esp = (!Rf_isNull(reshifts) && Rf_isReal(reshifts)) ? REAL(reshifts) : nullptr; + double *mcp = (!Rf_isNull(rmaxcap) && Rf_isReal(rmaxcap)) ? REAL(rmaxcap) : nullptr; + double *dcp = (!Rf_isNull(rdiscap) && Rf_isReal(rdiscap)) ? REAL(rdiscap) : nullptr; + double *tLp = (!Rf_isNull(rtL) && Rf_isReal(rtL)) ? REAL(rtL) : nullptr; + double *tkp = (!Rf_isNull(rtk) && Rf_isReal(rtk)) ? REAL(rtk) : nullptr; + double *tx0p = (!Rf_isNull(rtx0) && Rf_isReal(rtx0)) ? REAL(rtx0) : nullptr; + double *tprep = (!Rf_isNull(rtpre) && Rf_isReal(rtpre)) ? REAL(rtpre) : nullptr; + double *tpostp = (!Rf_isNull(rtpost) && Rf_isReal(rtpost)) ? REAL(rtpost) : nullptr; + + for (int i = 0; i < N; i++) { + auto &entry = var.glm_entries[i]; + entry.track_name = CHAR(STRING_ELT(rtracks, i)); + + // inner_func + string ifunc = CHAR(STRING_ELT(rif, i)); + entry.inner_is_lse = (ifunc == "lse"); + + // weight(s) — bin-major layout matches R column-major: wp[b*N + i] + entry.weight_offset = i; + + // shifts + entry.sshift = ssp ? (int64_t)ssp[i] : 0; + entry.eshift = esp ? (int64_t)esp[i] : 0; + + // scaling + if (mcp && !ISNA(mcp[i]) && dcp && !ISNA(dcp[i])) { + entry.scaling.enabled = true; + entry.scaling.max_cap = mcp[i]; + entry.scaling.dis_from_cap = dcp[i]; + } + + // simple_cap flag (optional logical vector) + int sc_idx = findListElementIndex(rparams, "simple_cap"); + if (sc_idx >= 0) { + SEXP rsc = VECTOR_ELT(rparams, sc_idx); + if (!Rf_isNull(rsc) && Rf_isLogical(rsc) && i < Rf_length(rsc)) { + entry.scaling.simple_cap = (LOGICAL(rsc)[i] == TRUE); + } + } + + // transform + if (rtfam != R_NilValue && Rf_isString(rtfam) && Rf_length(rtfam) > i) { + SEXP tfam_elt = STRING_ELT(rtfam, i); + if (tfam_elt != NA_STRING) { + string tfam = CHAR(tfam_elt); + if (tfam == "logist") { + entry.transform.enabled = true; + if (tLp && !ISNA(tLp[i])) entry.transform.L = tLp[i]; + if (tkp && !ISNA(tkp[i])) entry.transform.k = tkp[i]; + if (tx0p && !ISNA(tx0p[i])) entry.transform.x_0 = tx0p[i]; + if (tprep && !ISNA(tprep[i])) entry.transform.pre_shift = tprep[i]; + if (tpostp && !ISNA(tpostp[i])) entry.transform.post_shift = tpostp[i]; + } + } + } + + // kernel weights per entry (optional) + if (!Rf_isNull(rkernels) && Rf_isNewList(rkernels)) { + int kn_len = Rf_length(rkernels); + int ki = (kn_len == 1) ? 0 : i; // recycle if length 1 + SEXP rk = VECTOR_ELT(rkernels, ki); + if (Rf_isReal(rk)) { + int B = Rf_length(rk); + entry.kernel_weights.resize(B); + double *kp = REAL(rk); + for (int b = 0; b < B; b++) + entry.kernel_weights[b] = kp[b]; + } + } + } + + // --- Interactions (optional) --- + int ii_idx = findListElementIndex(rparams, "inter_i"); + int ij_idx = findListElementIndex(rparams, "inter_j"); + int iw_idx = findListElementIndex(rparams, "inter_weights"); + if (ii_idx >= 0 && ij_idx >= 0 && iw_idx >= 0) { + SEXP rii = VECTOR_ELT(rparams, ii_idx); + SEXP rij = VECTOR_ELT(rparams, ij_idx); + SEXP riw = VECTOR_ELT(rparams, iw_idx); + if (!Rf_isNull(rii) && !Rf_isNull(rij) && !Rf_isNull(riw)) { + int M = Rf_length(rii); // inter_i always has exactly M elements + int iw_len = Rf_length(riw); + if (iw_len != M * K) + verror("Virtual track %s: 'inter_weights' length must be %d (M=%d x K=%d)", + vtrack.c_str(), M * K, M, K); + // inter_i/inter_j can be integer or real + var.glm_interactions.resize(M); + // Copy interaction weights directly — R column-major = bin-major: iwp[b*M + m] + var.glm_all_inter_weights.assign(REAL(riw), REAL(riw) + M * K); + + // Get interaction transform params + SEXP ritfam = R_NilValue; + SEXP ritL = R_NilValue, ritk = R_NilValue, ritx0 = R_NilValue; + SEXP ritpre = R_NilValue, ritpost = R_NilValue; + int itf_idx = findListElementIndex(rparams, "inter_trans_family"); + if (itf_idx >= 0) ritfam = VECTOR_ELT(rparams, itf_idx); + int itL_idx = findListElementIndex(rparams, "inter_trans_L"); + int itk_idx = findListElementIndex(rparams, "inter_trans_k"); + int itx0_idx = findListElementIndex(rparams, "inter_trans_x0"); + int itpre_idx = findListElementIndex(rparams, "inter_trans_pre"); + int itpost_idx = findListElementIndex(rparams, "inter_trans_post"); + if (itL_idx >= 0) ritL = VECTOR_ELT(rparams, itL_idx); + if (itk_idx >= 0) ritk = VECTOR_ELT(rparams, itk_idx); + if (itx0_idx >= 0) ritx0 = VECTOR_ELT(rparams, itx0_idx); + if (itpre_idx >= 0) ritpre = VECTOR_ELT(rparams, itpre_idx); + if (itpost_idx >= 0) ritpost = VECTOR_ELT(rparams, itpost_idx); + + double *iip = Rf_isInteger(rii) ? nullptr : REAL(rii); + int *iipi = Rf_isInteger(rii) ? INTEGER(rii) : nullptr; + double *ijp = Rf_isInteger(rij) ? nullptr : REAL(rij); + int *ijpi = Rf_isInteger(rij) ? INTEGER(rij) : nullptr; + double *itLp = (!Rf_isNull(ritL) && Rf_isReal(ritL)) ? REAL(ritL) : nullptr; + double *itkp = (!Rf_isNull(ritk) && Rf_isReal(ritk)) ? REAL(ritk) : nullptr; + double *itx0p = (!Rf_isNull(ritx0) && Rf_isReal(ritx0)) ? REAL(ritx0) : nullptr; + double *itprep = (!Rf_isNull(ritpre) && Rf_isReal(ritpre)) ? REAL(ritpre) : nullptr; + double *itpostp = (!Rf_isNull(ritpost) && Rf_isReal(ritpost)) ? REAL(ritpost) : nullptr; + + for (int m = 0; m < M; m++) { + auto &inter = var.glm_interactions[m]; + // 1-based R index to 0-based C++ index + inter.entry_i = (iipi ? iipi[m] : (int)iip[m]) - 1; + inter.entry_j = (ijpi ? ijpi[m] : (int)ijp[m]) - 1; + inter.weight_offset = m; // bin-major: access as [b*M + m] + + if (inter.entry_i < 0 || inter.entry_i >= N || + inter.entry_j < 0 || inter.entry_j >= N) + verror("Virtual track %s: interaction index out of range [1, %d]", + vtrack.c_str(), N); + + // Interaction transform + if (ritfam != R_NilValue && Rf_isString(ritfam) && Rf_length(ritfam) > m) { + SEXP itfam_elt = STRING_ELT(ritfam, m); + if (itfam_elt != NA_STRING) { + string itfam = CHAR(itfam_elt); + if (itfam == "logist") { + inter.transform.enabled = true; + if (itLp && !ISNA(itLp[m])) inter.transform.L = itLp[m]; + if (itkp && !ISNA(itkp[m])) inter.transform.k = itkp[m]; + if (itx0p && !ISNA(itx0p[m])) inter.transform.x_0 = itx0p[m]; + if (itprep && !ISNA(itprep[m])) inter.transform.pre_shift = itprep[m]; + if (itpostp && !ISNA(itpostp[m])) inter.transform.post_shift = itpostp[m]; + } + } + } + } + } + } + + // --- selector_tracks (CHARACTER vector len M) and selector_breaks (LIST of REAL vectors len M) --- + int st_idx = findListElementIndex(rparams, "selector_tracks"); + int sb_idx = findListElementIndex(rparams, "selector_breaks"); + if (st_idx >= 0) { + SEXP rst = VECTOR_ELT(rparams, st_idx); + if (!Rf_isNull(rst)) { + if (!Rf_isString(rst)) + verror("'selector_tracks' must be a character vector"); + int M = Rf_length(rst); + if (M < 1) + verror("'selector_tracks' must have length >= 1 when present"); + if (sb_idx < 0) + verror("'selector_breaks' is required when 'selector_tracks' is present"); + SEXP rsb = VECTOR_ELT(rparams, sb_idx); + if (!Rf_isVectorList(rsb) || Rf_length(rsb) != M) + verror("'selector_breaks' must be a list of length %d (one per selector)", M); + + var.glm_selector_track_names.resize(M); + var.glm_selector_binfinders.resize(M); + var.glm_selector_strides.assign(M, 0); + + int64_t K_total = 1; + for (int m = 0; m < M; ++m) { + var.glm_selector_track_names[m] = CHAR(STRING_ELT(rst, m)); + SEXP rbm = VECTOR_ELT(rsb, m); + if (!Rf_isReal(rbm) || Rf_length(rbm) < 2) + verror("'selector_breaks[[%d]]' must be a numeric vector of length >= 2", m + 1); + int nbr = Rf_length(rbm); + std::vector breaks(REAL(rbm), REAL(rbm) + nbr); + var.glm_selector_binfinders[m].init(breaks, true, true); + int K_m = nbr - 1; + var.glm_selector_strides[m] = (size_t)K_total; + K_total *= K_m; + } + if (K_total != var.glm_num_bins) + verror("Compound bin count from selectors (%lld) does not match weights/bias (%d)", + (long long)K_total, var.glm_num_bins); + } + } + + // Allocate scaled cache if interactions exist + if (!var.glm_interactions.empty()) { + var.glm_scaled_cache.resize(N, 0.0); + } + + // Build scaling groups: entries with identical + // (track_name, sshift, eshift, inner_is_lse, scaling) share one + // aggregate+scale computation. Only the transform+weight differ. + if (var.glm_kernel_bins.empty()) { + // Group key: (track_name, sshift, eshift, inner_is_lse, scaling_enabled, max_cap, dis_from_cap) + // Use a map with string key for simplicity at parse time (runs once). + map> group_map; + for (int i = 0; i < N; i++) { + auto &e = var.glm_entries[i]; + // Build a string key from the grouping fields + char keybuf[256]; + snprintf(keybuf, sizeof(keybuf), + "%s|%lld|%lld|%d|%d|%.17g|%.17g|%d", + e.track_name.c_str(), + (long long)e.sshift, (long long)e.eshift, + (int)e.inner_is_lse, + (int)e.scaling.enabled, + e.scaling.enabled ? e.scaling.max_cap : 0.0, + e.scaling.enabled ? e.scaling.dis_from_cap : 0.0, + (int)e.scaling.simple_cap); + group_map[string(keybuf)].push_back(i); + } + var.glm_scaling_groups.reserve(group_map.size()); + for (auto &kv : group_map) { + Track_var::GlmScalingGroup g; + g.representative_idx = kv.second[0]; + g.entry_indices = std::move(kv.second); + var.glm_scaling_groups.push_back(std::move(g)); + } + + // Build track-level groups: cluster scaling groups by track name + // for cache-friendly traversal (read one track's data, process all groups). + map> tg_map; + for (int sg = 0; sg < (int)var.glm_scaling_groups.size(); sg++) { + auto &rep = var.glm_entries[var.glm_scaling_groups[sg].representative_idx]; + tg_map[rep.track_name].push_back(sg); + } + var.glm_track_groups.reserve(tg_map.size()); + for (auto &kv : tg_map) { + Track_var::GlmTrackGroup tg; + tg.track_entry_idx = var.glm_scaling_groups[kv.second[0]].representative_idx; + tg.min_sshift = numeric_limits::max(); + tg.max_eshift = numeric_limits::min(); + for (int sg_idx : kv.second) { + auto &rep = var.glm_entries[var.glm_scaling_groups[sg_idx].representative_idx]; + tg.min_sshift = min(tg.min_sshift, rep.sshift); + tg.max_eshift = max(tg.max_eshift, rep.eshift); + } + tg.scaling_group_indices = std::move(kv.second); + var.glm_track_groups.push_back(std::move(tg)); + } + } + + var.percentile = numeric_limits::quiet_NaN(); + var.requires_pv = false; + return; } } @@ -1536,6 +1919,10 @@ void TrackExpressionVars::register_track_functions() if (TrackExpressionVars::is_sequence_based_function(ivar->val_func)) { continue; } + // Skip GLM predict variables - they manage their own track reads + if (TrackExpressionVars::is_glm_function(ivar->val_func)) { + continue; + } GenomeTrack1D *track1d = GenomeTrack::is_1d(ivar->track_n_imdf->type) ? (GenomeTrack1D *)ivar->track_n_imdf->track.get() : NULL; GenomeTrack2D *track2d = GenomeTrack::is_2d(ivar->track_n_imdf->type) ? (GenomeTrack2D *)ivar->track_n_imdf->track.get() : NULL; @@ -1639,7 +2026,7 @@ void TrackExpressionVars::register_track_functions() verror("vtrack functions 'last.pos.abs' and 'last.pos.relative' can only be used on 1D tracks"); track1d->register_function(GenomeTrack1D::LAST_POS); break; - // Sequence-based functions work directly on sequences, no need to register track functions + // Sequence-based functions bypass normal track function registration default: if (!TrackExpressionVars::is_sequence_based_function((Track_var::Val_func)ivar->val_func)) verror("Unrecognized virtual track function"); @@ -1662,10 +2049,19 @@ void TrackExpressionVars::init(const TrackExpressionIteratorBase &expr_itr) // First validate iterator compatibility for (Track_vars::const_iterator itrack_var = m_track_vars.begin(); itrack_var != m_track_vars.end(); ++itrack_var) { - // Skip iterator validation for sequence-based variables since they don't have tracks or imdf + // Skip iterator validation for sourceless variables (sequence-based, glm.predict) if (TrackExpressionVars::is_sequence_based_function(itrack_var->val_func)) { continue; } + // GLM predict is 1D-only: it reads source tracks directly without dimension projection + if (TrackExpressionVars::is_glm_function(itrack_var->val_func)) { + if (expr_itr.is_2d()) + verror("Virtual track %s: glm.predict does not support 2D iterators", itrack_var->var_name.c_str()); + continue; + } + if (!itrack_var->track_n_imdf) { + continue; + } if (expr_itr.is_1d()) { @@ -1700,11 +2096,14 @@ void TrackExpressionVars::init(const TrackExpressionIteratorBase &expr_itr) for (Track_vars::const_iterator ivar = m_track_vars.begin(); ivar != m_track_vars.end(); ++ivar) { - // Skip sequence-based tracks + // Skip sourceless tracks (sequence-based, glm.predict) if (TrackExpressionVars::is_sequence_based_function(ivar->val_func)) { continue; } + if (!ivar->track_n_imdf) { + continue; + } track_names.push_back(ivar->track_n_imdf->name); track_types.push_back(ivar->track_n_imdf->type); } @@ -1886,9 +2285,10 @@ void TrackExpressionVars::start_chrom(const GInterval &interval) { reset_shared_1d_track_masters(); - // Precompute sequence-only flags (avoids O(N*M) scan in set_vars hot loop) - for (Track_n_imdfs::iterator itn = m_track_n_imdfs.begin(); itn != m_track_n_imdfs.end(); ++itn) + // Precompute sequence-only flag (avoids O(N*M) scan in set_vars hot loop) + for (Track_n_imdfs::iterator itn = m_track_n_imdfs.begin(); itn != m_track_n_imdfs.end(); ++itn) { itn->has_only_sequence_functions = is_sequence_track_n_imdf(*itn); + } for (Track_n_imdfs::iterator itrack_n_imdf = m_track_n_imdfs.begin(); itrack_n_imdf != m_track_n_imdfs.end(); ++itrack_n_imdf) { @@ -1954,6 +2354,109 @@ void TrackExpressionVars::start_chrom(const GInterval &interval) ivar->pwm_scorer->invalidate_cache(); } } + + // Open track handles for GLM predict multi-track vtracks. + // Many entries reference the same underlying track (e.g. 2430 entries + // from 190 unique motifs). Cache handles by track_name so we open each + // file only once, avoiding FD exhaustion under heavy parallelism. + { + struct GlmTrackCache { + shared_ptr handle; + GenomeTrackFixedBin *fixedbin; + GenomeTrackSparse *sparse; + unsigned bin_size; + }; + unordered_map glm_track_cache; + + for (auto &var : m_track_vars) { + if (var.val_func != Track_var::GLM_PREDICT) continue; + for (auto &entry : var.glm_entries) { + try { + auto it = glm_track_cache.find(entry.track_name); + if (it != glm_track_cache.end()) { + entry.track_handle = it->second.handle; + entry.cached_fixedbin = it->second.fixedbin; + entry.cached_sparse = it->second.sparse; + entry.cached_bin_size = it->second.bin_size; + continue; + } + + string track_dir = track2path(m_iu.get_env(), entry.track_name); + GenomeTrack::Type ttype = GenomeTrack::get_type(track_dir.c_str(), m_iu.get_chromkey(), false); + string resolved = GenomeTrack::find_existing_1d_filename(m_iu.get_chromkey(), track_dir, interval.chromid); + string filename(track_dir + "/" + resolved); + // GLM reads bin_size/mmap directly without read_interval(), + // so shared-backend dependents (which defer init) would be uninitialized. + entry.track_handle = create_and_init_1d_track(filename, interval.chromid, ttype); + if (entry.track_handle) { + GenomeTrack *raw = entry.track_handle.get(); + entry.cached_fixedbin = dynamic_cast(raw); + entry.cached_sparse = entry.cached_fixedbin ? nullptr + : dynamic_cast(raw); + if (entry.cached_fixedbin) { + entry.cached_bin_size = entry.cached_fixedbin->get_bin_size(); + } else { + entry.cached_bin_size = 0; + } + } else { + entry.cached_fixedbin = nullptr; + entry.cached_sparse = nullptr; + entry.cached_bin_size = 0; + } + glm_track_cache.emplace(entry.track_name, + GlmTrackCache{entry.track_handle, entry.cached_fixedbin, + entry.cached_sparse, entry.cached_bin_size}); + } catch (TGLException &e) { + // Surface real errors (bad track name, corrupted file) + // instead of silently NaN'ing the affected positions. + // Legitimate "no data on this chrom" returns nullptr from + // create_and_init_1d_track without throwing and is handled + // in the else-branch above. + const string &chrom_str = m_iu.get_chromkey().id2chrom(interval.chromid); + verror("GLM entry track '%s' failed to open for chrom %s: %s", + entry.track_name.c_str(), chrom_str.c_str(), e.msg()); + } + } + } + } + + // Open selector tracks for GLM predict vars (M >= 0) + for (auto &var : m_track_vars) { + if (var.val_func != Track_var::GLM_PREDICT) continue; + const int M = (int)var.glm_selector_track_names.size(); + if (M == 0) continue; + + var.glm_selector_handles.assign(M, nullptr); + var.glm_selector_fixedbins.assign(M, nullptr); + var.glm_selector_bin_sizes.assign(M, 0u); + + const string &chrom_str = m_iu.get_chromkey().id2chrom(interval.chromid); + for (int m = 0; m < M; ++m) { + const string &tname = var.glm_selector_track_names[m]; + try { + string track_dir = track2path(m_iu.get_env(), tname); + GenomeTrack::Type ttype = GenomeTrack::get_type(track_dir.c_str(), m_iu.get_chromkey(), false); + string resolved = GenomeTrack::find_existing_1d_filename(m_iu.get_chromkey(), track_dir, interval.chromid); + string filename(track_dir + "/" + resolved); + var.glm_selector_handles[m] = init_1d_track_with_shared_backend(filename, interval.chromid, ttype); + if (!var.glm_selector_handles[m]) + verror("GLM selector track '%s' returned null handle for chrom %s", + tname.c_str(), chrom_str.c_str()); + GenomeTrack *raw = var.glm_selector_handles[m].get(); + var.glm_selector_fixedbins[m] = dynamic_cast(raw); + if (!var.glm_selector_fixedbins[m]) + verror("GLM selector track '%s' is not a fixed-bin track for chrom %s", + tname.c_str(), chrom_str.c_str()); + var.glm_selector_bin_sizes[m] = var.glm_selector_fixedbins[m]->get_bin_size(); + } catch (TGLException &e) { + verror("GLM selector track '%s' failed to open for chrom %s: %s", + tname.c_str(), chrom_str.c_str(), e.msg()); + } + } + } + + // Pre-build GLM var batch list for the processor + m_glm_processor->prepare_batch(m_track_vars); } void TrackExpressionVars::start_chrom(const GInterval2D &interval) @@ -2112,7 +2615,7 @@ void TrackExpressionVars::set_vars(const GInterval2D &interval, const DiagonalBa void TrackExpressionVars::set_vars(unsigned idx) { - // Setup tracks (read intervals for non-sequence-based tracks) + // Setup tracks (read intervals for non-sequence tracks) for (Track_n_imdfs::iterator itrack_n_imdf = m_track_n_imdfs.begin(); itrack_n_imdf != m_track_n_imdfs.end(); ++itrack_n_imdf) { if (itrack_n_imdf->has_only_sequence_functions) @@ -2147,4 +2650,7 @@ void TrackExpressionVars::set_vars(unsigned idx) // Process value variables m_value_processor->process_value_vars(m_value_vars, m_interval1d, idx); + + // Process GLM predict variables + m_glm_processor->process_glm_vars(m_track_vars, m_interval1d, idx); } diff --git a/src/TrackExpressionVars.h b/src/TrackExpressionVars.h index 55e6d2e07..0b0f6701c 100644 --- a/src/TrackExpressionVars.h +++ b/src/TrackExpressionVars.h @@ -56,6 +56,9 @@ class TrackVarProcessor; class IntervVarProcessor; class ValueVarProcessor; class SequenceVarProcessor; +class GlmVarProcessor; +class GenomeTrackFixedBin; +class GenomeTrackSparse; using namespace std; @@ -159,6 +162,7 @@ class TrackExpressionVars { PWM_EDIT_DISTANCE_LSE, PWM_EDIT_DISTANCE_LSE_POS, PWM_N_MUTATIONS, + GLM_PREDICT, NUM_FUNCS }; @@ -183,6 +187,78 @@ class TrackExpressionVars { Iterator_modifier1D *seq_imdf1d{NULL}; // Filter for masking genomic regions (applied after iterator modifiers) std::shared_ptr filter; + // GLM predictor structs and fields + struct GlmScaling { + bool enabled{false}; + double max_cap{0.0}; + double dis_from_cap{10.0}; + bool simple_cap{false}; // true: min(raw, max_cap) / dis_from_cap (no floor remapping) + }; + + struct GlmTransform { + bool enabled{false}; + double L{1.0}; + double k{1.0}; + double x_0{0.0}; + double pre_shift{0.0}; + double post_shift{0.0}; + }; + + struct GlmEntry { + std::string track_name; + bool inner_is_lse{false}; + int weight_offset{0}; // entry index into Track_var::glm_all_weights (bin-major: [b*N + offset]) + int64_t sshift{0}; + int64_t eshift{0}; + GlmScaling scaling; + GlmTransform transform; + std::vector kernel_weights; // length B (same as glm_kernel_bins) + GenomeTrackFixedBin *cached_fixedbin{nullptr}; + GenomeTrackSparse *cached_sparse{nullptr}; + std::shared_ptr track_handle; + unsigned cached_bin_size{0}; + }; + + struct GlmInteraction { + int entry_i{-1}; + int entry_j{-1}; + int weight_offset{0}; // entry index into Track_var::glm_all_inter_weights (bin-major: [b*M + offset]) + GlmTransform transform; + }; + + // Entries sharing (track_name, sshift, eshift, inner_is_lse, scaling) + // compute aggregate+scale once; each member entry applies its own transform+weight. + struct GlmScalingGroup { + int representative_idx; // first entry (for raw read + scale) + std::vector entry_indices; // all member entries + }; + + // Groups scaling groups by unique track name for cache-friendly traversal. + // At each position: read one track's super-window, process all its groups. + struct GlmTrackGroup { + int track_entry_idx; // any entry for track pointer access + int64_t min_sshift; // super-window: min shift across groups + int64_t max_eshift; // super-window: max shift across groups + std::vector scaling_group_indices; // indices into glm_scaling_groups + }; + + std::vector glm_entries; + std::vector glm_interactions; + std::vector glm_all_weights; // flat N*K, bin-major layout: [b*N + i] + std::vector glm_all_inter_weights; // flat M*K, bin-major layout: [b*M + m] + std::vector glm_kernel_bins; + std::vector glm_scaling_groups; // built at parse time + std::vector glm_track_groups; // built at parse time + std::vector glm_bias; // length K (1 for no selector) + int glm_num_bins{1}; // K (1 = no selector) + std::vector glm_selector_track_names; // length M (M >= 0) + std::vector glm_selector_fixedbins; // length M, set in start_chrom + std::vector> glm_selector_handles; // length M, set in start_chrom + std::vector glm_selector_bin_sizes; // length M, set in start_chrom + std::vector glm_selector_binfinders; // length M, set at parse time + std::vector glm_selector_strides; // length M, computed at parse time + double glm_scale_factor{10.0}; + std::vector glm_scaled_cache; // scratch: post-scaling values for interactions }; typedef vector Track_vars; @@ -257,6 +333,7 @@ class TrackExpressionVars { const string &get_track_name(unsigned ivar) const { return m_track_vars[ivar].track_n_imdf->name; } GenomeTrack::Type get_track_type(unsigned ivar) const { return m_track_vars[ivar].track_n_imdf->type; } + bool has_track(unsigned ivar) const { return m_track_vars[ivar].track_n_imdf != nullptr; } void parse_exprs(const vector &track_exprs); void init(const TrackExpressionIteratorBase &expr_itr); @@ -270,6 +347,7 @@ class TrackExpressionVars { static bool is_pwm_function(Track_var::Val_func func); static bool is_kmer_function(Track_var::Val_func func); static bool is_masked_function(Track_var::Val_func func); + static bool is_glm_function(Track_var::Val_func func); static bool is_pwm_edit_distance_function(Track_var::Val_func func); static bool is_pwm_lse_edit_distance_function(Track_var::Val_func func); @@ -343,6 +421,7 @@ class TrackExpressionVars { std::unique_ptr m_interv_processor; std::unique_ptr m_value_processor; std::unique_ptr m_sequence_processor; + std::unique_ptr m_glm_processor; void parse_imdf(SEXP rvtrack, const string &vtrack, Iterator_modifier1D *imdf1d, Iterator_modifier2D *imdf2d); Iterator_modifier1D *add_imdf(const Iterator_modifier1D &imdf1d); @@ -490,4 +569,8 @@ inline bool TrackExpressionVars::is_masked_function(Track_var::Val_func func) { return func == Track_var::MASKED_COUNT || func == Track_var::MASKED_FRAC; } +inline bool TrackExpressionVars::is_glm_function(Track_var::Val_func func) { + return func == Track_var::GLM_PREDICT; +} + #endif /* TRACKEXPRESSIONVARS_H_ */ diff --git a/src/TrackVarProcessor.cpp b/src/TrackVarProcessor.cpp index 4fd43dca4..a51557567 100644 --- a/src/TrackVarProcessor.cpp +++ b/src/TrackVarProcessor.cpp @@ -33,6 +33,10 @@ void TrackVarProcessor::process_track_vars( if (TrackExpressionVars::is_sequence_based_function(ivar->val_func)) { continue; } + // Skip GLM predict vtracks (processed by GlmVarProcessor) + if (TrackExpressionVars::is_glm_function(ivar->val_func)) { + continue; + } if (GenomeTrack::is_1d(ivar->track_n_imdf->type)) { process_single_track_var_1d(*ivar, interval, idx); diff --git a/src/misha-init.cpp b/src/misha-init.cpp index 99b45a3f3..1ab286b96 100644 --- a/src/misha-init.cpp +++ b/src/misha-init.cpp @@ -116,6 +116,10 @@ extern "C" { extern SEXP C_gseq_kmer_dist(SEXP, SEXP, SEXP, SEXP); extern SEXP C_ggenome_implant(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); extern SEXP C_intervals_coord_strings(SEXP, SEXP, SEXP); + extern SEXP C_glm_extract_features(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); + extern SEXP C_gquantiles_multi(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); + extern SEXP C_gsummary_multi(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); + extern SEXP C_gscreen_multi(SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP, SEXP); } static const R_CallMethodDef CallEntries[] = { @@ -227,6 +231,10 @@ static const R_CallMethodDef CallEntries[] = { {"C_gseq_kmer_dist", (DL_FUNC)&C_gseq_kmer_dist, 4}, {"C_ggenome_implant", (DL_FUNC)&C_ggenome_implant, 7}, {"C_intervals_coord_strings", (DL_FUNC)&C_intervals_coord_strings, 3}, + {"C_glm_extract_features", (DL_FUNC)&C_glm_extract_features, 14}, + {"C_gquantiles_multi", (DL_FUNC)&C_gquantiles_multi, 9}, + {"C_gsummary_multi", (DL_FUNC)&C_gsummary_multi, 8}, + {"C_gscreen_multi", (DL_FUNC)&C_gscreen_multi, 10}, {NULL, NULL, 0} }; diff --git a/tests/testthat/test-batch-fast-parity.R b/tests/testthat/test-batch-fast-parity.R new file mode 100644 index 000000000..31d4ae1d0 --- /dev/null +++ b/tests/testthat/test-batch-fast-parity.R @@ -0,0 +1,156 @@ +# Parity tests for the batched fast path (gscreen/gsummary/gquantiles +# fast=TRUE) against the legacy slow path, on controlled tracks that exercise +# the cases the example DB doesn't: negative values, NaN gaps, and chromosome +# sizes that aren't a multiple of the iterator. These guard the fixes for: +# #1 SUM aggregate bounds (window_max/min * over-estimated count was not a +# valid bound -> missed/spurious gscreen intervals, wrong gquantiles) +# #2 all-NaN MIN/MAX certain-pass (an all-NaN window certain-passed instead +# of breaking the run -> fused intervals / phantom hits) +# #5 gscreen run end past chrom size when chrom size % iterator != 0 +# #3 bare sparse track is not fast-path eligible without an explicit iterator +# #4 only grid-aligned scopes are fast-path eligible + +# Build a controlled genome with a signed track containing NaN gaps and a +# fully-covered positive track. +.setup_parity_db <- function(chrom_size = 600L, binsize = 10L) { + root <- tempfile("batchparity_") + dir.create(root) + dir.create(file.path(root, "tracks")) + dir.create(file.path(root, "seq")) + writeLines(sprintf("chr1\t%d", chrom_size), file.path(root, "chrom_sizes.txt")) + file.create(file.path(root, "seq", "chr1.seq")) + gsetroot(root) + + nbins <- chrom_size %/% binsize + # Signed track "t": data in bins 1:20 and 31:50, NaN gaps elsewhere. + vals <- rep(NA_real_, nbins) + vals[1:20] <- rep(c(2, -2, 1, -1), length.out = 20) + vals[31:50] <- rep(c(3, -3), length.out = 20) + idx <- which(!is.na(vals)) + gtrack.create_dense( + "t", "signed w/ NaN gaps", + intervals = data.frame(chrom = "chr1", start = (idx - 1) * binsize, end = idx * binsize), + values = vals[idx], binsize = binsize, defval = NaN, func = "weighted.mean" + ) + + # Fully-covered positive track "tfull": every bin = 0.5. + gtrack.create_dense( + "tfull", "all 0.5", + intervals = data.frame(chrom = "chr1", start = (seq_len(nbins) - 1) * binsize, end = seq_len(nbins) * binsize), + values = rep(0.5, nbins), binsize = binsize, defval = NaN, func = "weighted.mean" + ) + invisible(root) +} + +# Normalize a gscreen result for comparison (chrom -> character, sort). +.norm_iv <- function(d) { + if (is.null(d) || nrow(d) == 0) { + return(data.frame(chrom = character(0), start = numeric(0), end = numeric(0))) + } + out <- data.frame( + chrom = as.character(d$chrom), + start = as.numeric(d$start), + end = as.numeric(d$end), + stringsAsFactors = FALSE + ) + out <- out[order(out$chrom, out$start, out$end), ] + rownames(out) <- NULL + out +} + +# Compare a single screen expression: legacy (single-expr) vs fast (multi-expr, +# filtered back to that expression). The filler expression reuses the SAME lhs +# (track/vtrack) so the multi-expr set shares one (func, sshift, eshift) tuple +# and stays fast-path eligible. +.screen_parity <- function(expr, iterator) { + lhs <- sub("\\s*(<=|>=|==|<|>).*$", "", expr) + extra <- paste0(lhs, " < 1e12") + leg <- gscreen(expr, iterator = iterator) + fast <- gscreen(c(expr, extra), iterator = iterator, fast = TRUE) + f1 <- fast[fast$track == expr, , drop = FALSE] + list(leg = .norm_iv(leg), fast = .norm_iv(f1)) +} + +test_that("SUM screen fast path matches legacy on a signed track (#1)", { + old <- options(gmultitasking = FALSE, misha.quiet_dispatch = TRUE) + on.exit(options(old), add = TRUE) + .setup_parity_db() + remove_all_vtracks() + gvtrack.create("vsum", "t", "sum") + gvtrack.iterator("vsum", sshift = 0, eshift = 0) + + # The old SUM bounds (window_min*count) over-pruned LT and mis-handled GT + # on negative data. Sweep both sides and several thresholds. + for (thr in c(-5, -3, -1, 0, 1, 3)) { + for (op in c("<", ">")) { + expr <- sprintf("vsum %s %g", op, thr) + r <- .screen_parity(expr, iterator = 10) + expect_equal(r$fast, r$leg, info = expr) + } + } +}) + +test_that("MIN/MAX screen fast path does not fuse runs across NaN gaps (#2)", { + old <- options(gmultitasking = FALSE, misha.quiet_dispatch = TRUE) + on.exit(options(old), add = TRUE) + .setup_parity_db() + remove_all_vtracks() + gvtrack.create("vmin", "t", "min") + gvtrack.iterator("vmin", sshift = 0, eshift = 0) + gvtrack.create("vmax", "t", "max") + gvtrack.iterator("vmax", sshift = 0, eshift = 0) + + # vmin > t : the non-informative MIN upper bound (+inf) used to certain-pass + # an all-NaN window, fusing the two data runs into one. Must stay split. + r <- .screen_parity("vmin > -10", iterator = 10) + expect_equal(r$fast, r$leg) + expect_equal(nrow(r$fast), 2L) # two data regions, NaN gap between them + + # Symmetric MAX < t (MAX lower bound is -inf). + r2 <- .screen_parity("vmax < 10", iterator = 10) + expect_equal(r2$fast, r2$leg) + expect_equal(nrow(r2$fast), 2L) +}) + +test_that("gscreen fast path clamps run end to chrom size (#5)", { + old <- options(gmultitasking = FALSE, misha.quiet_dispatch = TRUE) + on.exit(options(old), add = TRUE) + .setup_parity_db(chrom_size = 600L) # 600 is not a multiple of iterator 70 + remove_all_vtracks() + + r <- .screen_parity("tfull > 0", iterator = 70L) + expect_equal(r$fast, r$leg) + # No emitted interval may exceed the chromosome size. + expect_true(all(r$fast$end <= 600)) +}) + +test_that("fast-path eligibility declines sparse-without-iterator and non-aligned scopes (#3,#4)", { + old <- options(gmultitasking = FALSE, misha.quiet_dispatch = TRUE) + on.exit(options(old), add = TRUE) + root <- .setup_parity_db() + # A sparse track. + gtrack.create_sparse( + "sp", "sparse", + intervals = data.frame(chrom = "chr1", start = c(50L, 150L, 350L), end = c(60L, 160L, 360L)), + values = c(1, 2, 3) + ) + + # #3: bare sparse track with iterator = NULL is NOT eligible (its implicit + # iterator is the irregular sparse iterator, not a grid). + expect_null(misha:::.detect_fast_path("sp", NULL, NULL, NULL)) + # ... but eligible with an explicit iterator. + expect_false(is.null(misha:::.detect_fast_path("sp", 10L, NULL, NULL))) + + # Dense bare track with iterator = NULL stays eligible (bin grid). + expect_false(is.null(misha:::.detect_fast_path("t", NULL, NULL, NULL))) + + # #4: a non-grid-aligned explicit scope is NOT eligible. + aligned <- data.frame(chrom = "chr1", start = 100L, end = 200L) # multiples of 10 + nonaligned <- data.frame(chrom = "chr1", start = 25L, end = 125L) # not multiples of 10 + expect_false(is.null(misha:::.detect_fast_path("t", 10L, aligned, NULL))) + expect_null(misha:::.detect_fast_path("t", 10L, nonaligned, NULL)) + + # A scope ending exactly at chrom size is allowed even if not a multiple. + full_chrom <- data.frame(chrom = "chr1", start = 0L, end = 600L) + expect_false(is.null(misha:::.detect_fast_path("t", 70L, full_chrom, NULL))) +}) diff --git a/tests/testthat/test-batch-quantiles-phase2.R b/tests/testthat/test-batch-quantiles-phase2.R new file mode 100644 index 000000000..2beb1552a --- /dev/null +++ b/tests/testthat/test-batch-quantiles-phase2.R @@ -0,0 +1,207 @@ +# Phase 2 tests: top-K pruning, aggregator templating, intervals support. +# Runs on gdb.init_examples() so no external db required. + +test_that("top-K path returns EXACTLY the same quantile value as fallback for the same extreme p", { + # Forces the fallback path by passing a mixed-tail percentile vector + # (triggers use_fallback=true in the C++ entry). Extracts the p=0.95 + # column and compares against a top-K-only call at p=0.95. + # Both share the identical scan and the identical downstream + # nth_element rank formula; any divergence is a real bug. + gdb.init_examples() + args <- list( + track_names = "dense_track", + iterator = 20L, sshift = -50L, eshift = 50L, + n_threads = 1L, func = "avg" + ) + # Mixed-tail → fallback. + suppressWarnings({ + q_fallback_mat <- do.call( + glm_batch_quantiles, + c(args, list(percentiles = c(0.2, 0.95))) + ) + }) + q_fallback_at_95 <- q_fallback_mat[1, 2] # p=0.95 column + + # Top-K only (all percentiles >= 0.5; no clamp on example db). + q_topk <- do.call( + glm_batch_quantiles, + c(args, list(percentiles = 0.95)) + ) + + expect_equal(unname(q_topk), unname(q_fallback_at_95), + tolerance = 0, + info = sprintf( + "topk=%g fallback=%g", + unname(q_topk), unname(q_fallback_at_95) + ) + ) +}) + +test_that("bottom-K path returns same value as fallback for p < 0.5", { + gdb.init_examples() + args <- list( + track_names = "dense_track", + iterator = 20L, sshift = -50L, eshift = 50L, + n_threads = 1L, func = "avg" + ) + suppressWarnings({ + q_fb <- do.call( + glm_batch_quantiles, + c(args, list(percentiles = c(0.05, 0.95))) + ) + }) + q_fb_at_5 <- q_fb[1, 1] + q_bot <- do.call( + glm_batch_quantiles, + c(args, list(percentiles = 0.05)) + ) + expect_equal(unname(q_bot), unname(q_fb_at_5), + tolerance = 0, + info = sprintf( + "bot=%g fb=%g", + unname(q_bot), unname(q_fb_at_5) + ) + ) +}) + +test_that("glm_batch_quantiles top-K path matches gquantiles on vtrack-max (sanity)", { + gdb.init_examples() + # Extreme p triggers top-K mode (heap-backed). Compare against the + # fallback path by forcing K large enough to not trip the pruning + # (impossible via public API — instead, cross-check top-K with + # func='max' where the definition is unambiguous). + q_top <- glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.99, + iterator = 10L, sshift = -30L, eshift = 30L, n_threads = 1L, + func = "max" + ) + # Compute reference via gquantiles on a max vtrack. + gvtrack.create("vt_ref", "dense_track", func = "max") + gvtrack.iterator("vt_ref", sshift = -30, eshift = 30) + ref <- gquantiles("vt_ref", percentiles = 0.99, iterator = 10L) + gvtrack.rm("vt_ref") + # gquantiles uses StreamPercentiler but max is an order statistic; + # for a small stream (example db) no subsampling occurs and results + # should match closely. Tolerance is loose because gquantiles may + # return a different quantile definition at the boundary. + expect_true(abs(unname(q_top) - unname(ref)) < 0.1, + info = sprintf("q_top=%g, ref=%g", unname(q_top), unname(ref)) + ) +}) + +test_that("func='avg' produces different values than func='max' (sanity)", { + gdb.init_examples() + args <- list( + track_names = "dense_track", percentiles = 0.5, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L + ) + q_avg <- do.call(glm_batch_quantiles, c(args, list(func = "avg"))) + q_max <- do.call(glm_batch_quantiles, c(args, list(func = "max"))) + q_sum <- do.call(glm_batch_quantiles, c(args, list(func = "sum"))) + q_min <- do.call(glm_batch_quantiles, c(args, list(func = "min"))) + # Invariants: + expect_true(q_min <= q_avg) + expect_true(q_avg <= q_max) + # sum with window 2 bins ~ avg * 2. + expect_true(q_sum >= q_max) + expect_true(all(is.finite(c(q_avg, q_max, q_sum, q_min)))) +}) + +test_that("func='lse' matches vtrack lse", { + gdb.init_examples() + # Use a dense track; results should match the legacy LSE path closely + # (same lse_accumulate, identical aggregation). + gvtrack.create("vt_lse", "dense_track", func = "lse") + gvtrack.iterator("vt_lse", sshift = -50, eshift = 50) + ref <- gquantiles("vt_lse", percentiles = 0.9, iterator = 50L) + gvtrack.rm("vt_lse") + q <- glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.9, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L, + func = "lse" + ) + # Example db is tiny; tolerance is loose to absorb StreamPercentiler + # vs exact-nth_element divergence on a small stream. + expect_true(abs(unname(q) - unname(ref)) < 1.0, + info = sprintf("q=%g ref=%g", unname(q), unname(ref)) + ) +}) + +test_that("intervals restriction narrows the scan", { + gdb.init_examples() + allg <- get("ALLGENOME", envir = .misha) + # Whole-genome scan. + q_all <- glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.5, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L, + func = "avg" + ) + # Restricted scan (a single interval on chrom 1). + small <- data.frame(chrom = "1", start = 0, end = 2000) + q_small <- glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.5, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L, + func = "avg", intervals = small + ) + # Both should be finite and not necessarily equal. Sanity only — + # the restricted scan covers ~40 positions (2000 bp / 50 bp) which + # is enough for a finite median. + expect_true(is.finite(q_all) && is.finite(q_small)) +}) + +test_that("intervals with multiple chroms and interval-mask boundary", { + gdb.init_examples() + # Two disjoint intervals on the same chrom — exercises the boundary() + # hook in the driver at the gap. The TopKQuantile reducer's boundary() + # is a no-op, so this is a smoke test that the driver doesn't crash + # when the mask has gaps. + ivs <- data.frame( + chrom = c("1", "1"), + start = c(0, 5000), + end = c(2000, 7000) + ) + q <- glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.5, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 2L, + func = "avg", intervals = ivs + ) + expect_true(is.finite(q)) +}) + +test_that("no fallback warning when K stays under K_MAX (example db at p=0.5)", { + gdb.init_examples() + # p=0.5 on the tiny example db gives K ≈ (few K positions) / 2, + # well under K_MAX=10M, so NO warning should fire. On real genomes + # the same call would trigger the K>K_MAX fallback warning; this + # test only documents the small-N branch. + expect_silent( + glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.5, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L, + func = "avg" + ) + ) +}) + +test_that("mixed-tail percentiles warn and fall back", { + gdb.init_examples() + expect_warning( + glm_batch_quantiles( + track_names = "dense_track", percentiles = c(0.1, 0.9), + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L, + func = "avg" + ), + regexp = "span both tails" + ) +}) + +test_that("intervals=NULL (default) yields the whole-genome scan", { + gdb.init_examples() + q_null <- glm_batch_quantiles( + track_names = "dense_track", percentiles = 0.9, + iterator = 50L, sshift = -50L, eshift = 50L, n_threads = 1L, + func = "avg" + ) + expect_true(is.finite(q_null)) + expect_named(q_null, "dense_track") +}) diff --git a/tests/testthat/test-batch-quantiles-smoke.R b/tests/testthat/test-batch-quantiles-smoke.R new file mode 100644 index 000000000..f941331c2 --- /dev/null +++ b/tests/testthat/test-batch-quantiles-smoke.R @@ -0,0 +1,93 @@ +# Synthetic smoke tests for the BatchTrackScan code path via glm_batch_quantiles. +# These run against gdb.init_examples() and don't require the mm10 motif db. +# They exercise the templated scan driver, per-(track, chrom) task queue, +# and TopKQuantile reducer in fallback mode (Phase 1) for both dense and +# sparse tracks. + +test_that("glm_batch_quantiles works on a single dense example track", { + gdb.init_examples() + q <- glm_batch_quantiles( + track_names = "dense_track", + percentiles = 0.5, + iterator = 50L, + sshift = -50L, + eshift = 50L, + n_threads = 1L + ) + expect_type(q, "double") + expect_equal(length(q), 1) + expect_true(is.finite(q)) + expect_named(q, "dense_track") +}) + +test_that("glm_batch_quantiles handles multiple percentiles (returns matrix)", { + gdb.init_examples() + q <- glm_batch_quantiles( + track_names = "dense_track", + percentiles = c(0.1, 0.5, 0.9), + iterator = 50L, + sshift = -50L, + eshift = 50L, + n_threads = 1L + ) + expect_true(is.matrix(q)) + expect_equal(dim(q), c(1, 3)) + expect_equal(rownames(q), "dense_track") + expect_true(all(is.finite(q))) + # Quantiles must be monotone nondecreasing. + expect_true(q[1, 1] <= q[1, 2]) + expect_true(q[1, 2] <= q[1, 3]) +}) + +test_that("glm_batch_quantiles is deterministic across thread counts", { + gdb.init_examples() + tracks <- c("dense_track", "subdir.dense_track2") + args <- list( + track_names = tracks, percentiles = 0.75, + iterator = 50L, sshift = -50L, eshift = 50L + ) + q1 <- do.call(glm_batch_quantiles, c(args, list(n_threads = 1L))) + q2 <- do.call(glm_batch_quantiles, c(args, list(n_threads = 2L))) + expect_equal(q1, q2, tolerance = 0) +}) + +test_that("glm_batch_quantiles vs gquantiles(vtrack, LSE) — same ballpark", { + # Note: on the tiny example db (~2K positions), StreamPercentiler vs + # exact nth_element can differ substantially more than on full genomes + # (the approximate tail estimator is noisy at small N). Use a loose + # tolerance: this test confirms the batched path produces a value in + # the same order of magnitude, not that it matches the legacy + # approximate path. Tight correctness is covered by the motif-db test + # (skipped without MISHA_MM10_MOTIF_DB) and by Phase 2 synthetic + # fast-vs-slow parity tests. + gdb.init_examples() + track <- "dense_track" + + gvtrack.create("vt_ref", track, func = "lse") + gvtrack.iterator("vt_ref", sshift = -100, eshift = 100) + ref <- gquantiles("vt_ref", percentiles = 0.5, iterator = 50L) + gvtrack.rm("vt_ref") + + fast <- glm_batch_quantiles( + track_names = track, percentiles = 0.5, + iterator = 50L, sshift = -100L, eshift = 100L, n_threads = 1L + ) + + expect_true(is.finite(ref) && is.finite(fast)) + expect_true(abs(unname(fast) - unname(ref)) < 1.0) +}) + +test_that("glm_batch_quantiles processes a sparse track", { + gdb.init_examples() + # sparse_track: quantile computation should succeed and return finite. + q <- glm_batch_quantiles( + track_names = "sparse_track", + percentiles = 0.5, + iterator = 100L, + sshift = -50L, + eshift = 50L, + n_threads = 1L + ) + expect_type(q, "double") + expect_true(is.finite(q)) +}) diff --git a/tests/testthat/test-batch-screen.R b/tests/testthat/test-batch-screen.R new file mode 100644 index 000000000..23075de34 --- /dev/null +++ b/tests/testthat/test-batch-screen.R @@ -0,0 +1,158 @@ +# Tests for gscreen fast path (Phase 4) on gdb.init_examples(). + +test_that("gscreen single-expr legacy behavior preserved", { + gdb.init_examples() + r <- gscreen("dense_track > 0.15") + expect_s3_class(r, "data.frame") + expect_true(all(c("chrom", "start", "end") %in% colnames(r))) +}) + +test_that("gscreen with character vector returns long data.frame", { + gdb.init_examples() + res <- gscreen(c("dense_track > 0.15", "dense_track < 0.05"), + fast = TRUE + ) + expect_s3_class(res, "data.frame") + expect_equal(colnames(res), c("chrom", "start", "end", "track")) + expect_true(all(res$track %in% c( + "dense_track > 0.15", + "dense_track < 0.05" + ))) +}) + +test_that("gscreen multi-track fast path matches per-track legacy calls", { + gdb.init_examples() + exprs <- c("dense_track > 0.15", "subdir.dense_track2 > 0.3") + fast <- gscreen(exprs, fast = TRUE) + + ref <- do.call(rbind, lapply(exprs, function(e) { + iv <- gscreen(e) + if (nrow(iv) == 0) { + data.frame( + chrom = character(0), start = numeric(0), + end = numeric(0), track = character(0), + stringsAsFactors = FALSE + ) + } else { + iv$track <- e + iv[, c("chrom", "start", "end", "track")] + } + })) + + # Sort both the same way (fast path returns per-track, then per-chrom; + # legacy returns per-chrom). + fast$chrom <- as.character(fast$chrom) + ref$chrom <- as.character(ref$chrom) + ord <- function(df) df[order(df$track, df$chrom, df$start, df$end), ] + fast_s <- ord(fast) + rownames(fast_s) <- NULL + ref_s <- ord(ref) + rownames(ref_s) <- NULL + expect_equal(nrow(fast_s), nrow(ref_s)) + expect_equal(fast_s$chrom, ref_s$chrom) + expect_equal(fast_s$start, ref_s$start, tolerance = 0) + expect_equal(fast_s$end, ref_s$end, tolerance = 0) + expect_equal(fast_s$track, ref_s$track) +}) + +test_that("gscreen supports all five comparison operators", { + gdb.init_examples() + for (op in c("<", "<=", "==", ">=", ">")) { + # Use a threshold that's likely to pass or not trivially, and a + # second expression so the fast path is exercised. + exprs <- c( + paste("dense_track", op, "0.1"), + paste("subdir.dense_track2", op, "0.2") + ) + df <- tryCatch(gscreen(exprs, fast = TRUE), + error = function(e) NULL + ) + expect_false(is.null(df), info = op) + expect_s3_class(df, "data.frame") + expect_equal(colnames(df), c("chrom", "start", "end", "track")) + } +}) + +test_that("gscreen flushes at interval-mask boundary (no spurious fusion)", { + gdb.init_examples() + # Two non-adjacent intervals on chrom 1. The boundary() hook must + # prevent a passing run on the first from fusing with a passing run + # on the second. + ivs <- data.frame( + chrom = c("1", "1"), + start = c(0, 200000), + end = c(100000, 300000), + stringsAsFactors = FALSE + ) + res <- gscreen(c("dense_track > 0.15", "subdir.dense_track2 > 0.3"), + intervals = ivs, fast = TRUE + ) + # No returned interval may straddle [100000, 200000). + bad <- with(res, as.character(chrom) == "1" & + start < 100000 & end > 200000) + expect_false(any(bad)) +}) + +test_that("gscreen handles multiple predicates on the SAME underlying track", { + # Regression for Phase 4 review C1: when two or more expressions share + # the same underlying source track, the R-side track-column rewrite + # previously collapsed the per-row mapping because it relied on + # the underlying-track name string and the rows were indistinguishable. + gdb.init_examples() + exprs <- c("dense_track > 0.05", "dense_track > 0.15") + fast <- gscreen(exprs, fast = TRUE) + # Both input expressions must appear in the track column. + expect_true(all(c("dense_track > 0.05", "dense_track > 0.15") %in% + unique(as.character(fast$track)))) + # The stricter threshold produces a subset of the looser one; every + # row tagged as the stricter predicate must also satisfy the looser. + ref_looser <- gscreen("dense_track > 0.05") + ref_stricter <- gscreen("dense_track > 0.15") + expect_equal(sum(fast$track == "dense_track > 0.05"), nrow(ref_looser)) + expect_equal(sum(fast$track == "dense_track > 0.15"), nrow(ref_stricter)) +}) + +test_that("gscreen multi-expr with fast=FALSE errors cleanly (Phase 5 scope)", { + gdb.init_examples() + expect_error( + gscreen(c("dense_track > 0.15", "dense_track < 0.05"), fast = FALSE), + regexp = "multi-expression slow path not yet implemented" + ) +}) + +test_that("gscreen with intervals.set.out + multi-expr rejects fast path", { + gdb.init_examples() + # intervals.set.out is incompatible with multi-expr fast path; must + # fall through (and then error from the slow-path stub). + expect_error( + gscreen(c("dense_track > 0.15", "dense_track < 0.05"), + intervals.set.out = "foo", fast = TRUE + ), + regexp = "multi-expression slow path not yet implemented" + ) +}) + +# Regression: vtrack with sshift=eshift=0 and iterator != bin_size produces +# windows unaligned to the bin grid (a 20bp window over 50bp bins can span +# 1-2 bins). The fast path must use the same window semantics as the slow +# path -- [iter_start + sshift, iter_end + eshift] -- and the LSE pruning +# upper bound must account for the unaligned bin count, otherwise valid +# passing positions get falsely pruned. +test_that("gscreen fast path with vtrack(sshift=eshift=0) matches slow path", { + gdb.init_examples() + gvtrack.create("vt_a", src = "dense_track", func = "lse") + gvtrack.create("vt_b", src = "subdir.dense_track2", func = "lse") + gvtrack.iterator("vt_a", sshift = 0, eshift = 0) + gvtrack.iterator("vt_b", sshift = 0, eshift = 0) + on.exit({ + gvtrack.rm("vt_a") + gvtrack.rm("vt_b") + }) + + fast <- gscreen(c("vt_a > 0.5", "vt_b > 0.5"), + iterator = 20L, fast = TRUE + ) + n_fast_a <- sum(fast$track == "vt_a > 0.5") + n_slow_a <- nrow(gscreen("vt_a > 0.5", iterator = 20L, fast = FALSE)) + expect_equal(n_fast_a, n_slow_a) +}) diff --git a/tests/testthat/test-batch-summary.R b/tests/testthat/test-batch-summary.R new file mode 100644 index 000000000..5d570b0e5 --- /dev/null +++ b/tests/testthat/test-batch-summary.R @@ -0,0 +1,143 @@ +# Tests for gsummary fast path (Phase 3) on gdb.init_examples(). + +test_that("gsummary single-expr legacy path is unchanged when fast=FALSE", { + gdb.init_examples() + r <- gsummary("dense_track", fast = FALSE) + expect_type(r, "double") + expect_named(r) + expect_true(all(c( + "Total intervals", "NaN intervals", + "Min", "Max", "Sum", "Mean", "Std dev" + ) %in% names(r))) +}) + +test_that("gsummary single-expr with fast=TRUE still returns legacy-shaped row", { + gdb.init_examples() + # Single-expression calls always take the legacy path (even with + # fast=TRUE), preserving bit-exact back-compat with pre-refactor + # output. Multi-track is where the fast path activates. + r <- gsummary("dense_track", fast = TRUE) + expect_type(r, "double") + expect_true(all(c( + "Total intervals", "NaN intervals", + "Min", "Max", "Sum", "Mean", "Std dev" + ) %in% names(r))) +}) + +test_that("gsummary with vector of tracks returns a data.frame", { + gdb.init_examples() + tracks <- c("dense_track", "subdir.dense_track2") + df <- gsummary(tracks, iterator = 20L, fast = TRUE) + expect_s3_class(df, "data.frame") + expect_equal( + colnames(df), + c("track", "n", "n_nan", "min", "max", "sum", "mean", "sd") + ) + expect_equal(nrow(df), 2) + expect_equal(df$track, tracks) + expect_true(all(is.finite(df$mean))) + expect_true(all(df$min <= df$mean)) + expect_true(all(df$mean <= df$max)) +}) + +test_that("C_gsummary_multi returns matrix with named columns (C/R contract)", { + # Regression: R compute-core must read summary stats by column name, + # not position - if C-side reorders the seven stat columns, R must + # not silently swap their meanings. The C side names the columns; + # this test pins that contract. + gdb.init_examples() + tracks <- c("dense_track", "subdir.dense_track2") + n_threads <- as.integer(getOption("gmax.processes", 1L)) + m <- misha:::.gcall( + "C_gsummary_multi", + as.character(tracks), + 50L, 0L, 0L, + n_threads, + "avg", + NULL, + misha:::.misha_env() + ) + expect_equal( + colnames(m), + c("n", "n_nan", "min", "max", "sum", "mean", "sd") + ) + expect_equal(rownames(m), tracks) +}) + +test_that("gsummary multi-track fast path matches per-track single calls", { + gdb.init_examples() + tracks <- c("dense_track", "subdir.dense_track2") + # Omit iterator — fast path uses the tracks' native bin size (50bp + # here), matching the slow path's implicit per-bin iteration. + fast <- gsummary(tracks, fast = TRUE) + # Compute reference per-track using the legacy slow path. + ref <- do.call(rbind, lapply(tracks, function(t) { + r <- gsummary(t, fast = FALSE) + data.frame( + track = t, + n = r["Total intervals"], + n_nan = r["NaN intervals"], + min = r["Min"], max = r["Max"], sum = r["Sum"], + mean = r["Mean"], sd = r["Std dev"], + row.names = NULL, stringsAsFactors = FALSE + ) + })) + # Both paths iterate bin-by-bin for these dense tracks. + # n = total scan positions (NaN + non-NaN); n_nan = NaN-aggregate + # positions. Must match legacy exactly. + expect_equal(fast$n, ref$n, tolerance = 0) + expect_equal(fast$n_nan, ref$n_nan, tolerance = 0) + expect_equal(fast$min, ref$min, tolerance = 1e-5) + expect_equal(fast$max, ref$max, tolerance = 1e-5) + expect_equal(fast$mean, ref$mean, tolerance = 1e-5) + expect_equal(fast$sd, ref$sd, tolerance = 1e-5) +}) + +test_that("gsummary fast path accepts intervals restriction", { + gdb.init_examples() + allg <- get("ALLGENOME", envir = .misha) + small <- data.frame( + chrom = "1", start = 0, end = 2000, + stringsAsFactors = FALSE + ) + # Intervals as a data.frame must work. + df <- gsummary(c("dense_track", "subdir.dense_track2"), + iterator = 20L, intervals = small, fast = TRUE + ) + expect_s3_class(df, "data.frame") + expect_equal(nrow(df), 2) + expect_true(all(is.finite(df$mean))) +}) + +test_that("gsummary falls through to slow path on complex expression", { + gdb.init_examples() + # A complex expression (arithmetic) — not fast-path eligible. + # Suppress the one-time dispatch message. + options(misha.quiet_dispatch = TRUE) + r <- gsummary("dense_track + 1", fast = TRUE) + expect_type(r, "double") + expect_named(r) + options(misha.quiet_dispatch = NULL) +}) + +test_that("gsummary multi-expr with fast=FALSE errors cleanly (Phase 5 scope)", { + gdb.init_examples() + expect_error( + gsummary(c("dense_track", "subdir.dense_track2"), fast = FALSE), + regexp = "multi-expression slow path not yet implemented" + ) +}) + +test_that("gsummary with vtrack (LSE window) — multi-expr fast path", { + gdb.init_examples() + gvtrack.create(vtrack = "vt_smry1", src = "dense_track", func = "lse") + gvtrack.create(vtrack = "vt_smry2", src = "subdir.dense_track2", func = "lse") + gvtrack.iterator("vt_smry1", sshift = -50, eshift = 50) + gvtrack.iterator("vt_smry2", sshift = -50, eshift = 50) + df <- gsummary(c("vt_smry1", "vt_smry2"), iterator = 20L, fast = TRUE) + gvtrack.rm("vt_smry1") + gvtrack.rm("vt_smry2") + expect_s3_class(df, "data.frame") + expect_equal(nrow(df), 2) + expect_true(all(is.finite(df$mean))) +}) diff --git a/tests/testthat/test-glm-batch-quantiles.R b/tests/testthat/test-glm-batch-quantiles.R new file mode 100644 index 000000000..29a9f7bd1 --- /dev/null +++ b/tests/testthat/test-glm-batch-quantiles.R @@ -0,0 +1,153 @@ +local_mm10_db <- Sys.getenv("MISHA_MM10_MOTIF_DB", "") +mm10_trackdb <- Sys.getenv("MISHA_MM10_TRACKDB", "") + +test_that("glm_batch_quantiles matches gquantiles for multiple tracks", { + # Requires local mm10 database with motif energy tracks + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9, gmultitasking = FALSE) + + # Pick 3 motifs for testing + motifs <- c("JASPAR_Zic2", "HOMER_Unknown_ESC_element", "JOLMA_ZIC3_mono_full") + track_dir <- "th_epi.all_db_motifs" + track_names <- paste0(track_dir, ".", motifs) + + # Test with single percentile (returns named vector) + percentile <- 0.9999 + sshift <- -140L + eshift <- 140L + iterator <- 20L + + # ---- R reference: gquantiles with virtual tracks ---- + ref_q <- sapply(seq_along(motifs), function(i) { + vt_name <- paste0("bq", i) + gvtrack.create(vtrack = vt_name, src = paste0(track_dir, ".", motifs[i]), func = "lse") + gvtrack.iterator(vt_name, sshift = sshift, eshift = eshift) + q <- gquantiles(vt_name, percentiles = percentile, iterator = iterator) + gvtrack.rm(vt_name) + q + }) + names(ref_q) <- track_names + + # ---- C++ batch quantiles ---- + batch_q <- glm_batch_quantiles( + track_names = track_names, + percentiles = percentile, + iterator = iterator, + sshift = sshift, + eshift = eshift, + n_threads = 3L + ) + + cat("Reference quantiles (gquantiles w/ StreamPercentiler):\n") + print(ref_q) + cat("Batch quantiles (exact nth_element):\n") + print(batch_q) + + # Results should be close but not bit-identical because gquantiles uses + # StreamPercentiler (approximate) while glm_batch_quantiles uses exact + # nth_element. Tolerance of 0.1 is generous; typical differences are ~0.02. + expect_equal(length(batch_q), length(ref_q)) + expect_equal(names(batch_q), names(ref_q)) + + for (i in seq_along(track_names)) { + diff <- abs(batch_q[i] - ref_q[i]) + cat(sprintf( + " %s: ref=%.6f, batch=%.6f, diff=%.4e\n", + track_names[i], ref_q[i], batch_q[i], diff + )) + expect_lt(diff, 0.1, + label = paste("quantile difference for", track_names[i]) + ) + } + + cat("Single-percentile comparison PASSED\n") +}) + + +test_that("glm_batch_quantiles works with multiple percentiles", { + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9, gmultitasking = FALSE) + + track_names <- c( + "th_epi.all_db_motifs.JASPAR_Zic2", + "th_epi.all_db_motifs.HOMER_Unknown_ESC_element" + ) + percentiles <- c(0.5, 0.99, 0.9999) + + result <- glm_batch_quantiles( + track_names = track_names, + percentiles = percentiles, + iterator = 20L, + sshift = -140L, + eshift = 140L, + n_threads = 2L + ) + + # Should return a matrix + expect_true(is.matrix(result)) + expect_equal(nrow(result), length(track_names)) + expect_equal(ncol(result), length(percentiles)) + expect_equal(rownames(result), track_names) + + # Values should be monotonically increasing across percentiles for each track + for (i in seq_len(nrow(result))) { + expect_true(all(diff(result[i, ]) >= 0), + label = paste("monotonicity for", track_names[i]) + ) + } + + cat("Multiple-percentile test PASSED\n") + cat("Result matrix:\n") + print(result) +}) + + +test_that("glm_batch_quantiles handles single track", { + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9, gmultitasking = FALSE) + + result <- glm_batch_quantiles( + track_names = "th_epi.all_db_motifs.JASPAR_Zic2", + percentiles = 0.9999, + iterator = 20L, + sshift = -140L, + eshift = 140L, + n_threads = 1L + ) + expect_true(is.numeric(result)) + expect_equal(length(result), 1) + expect_true(is.finite(result[1])) + + cat("Single track test PASSED, value:", result[1], "\n") +}) + + +test_that("glm_batch_quantiles is self-consistent across thread counts", { + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9, gmultitasking = FALSE) + + tracks <- c( + "th_epi.all_db_motifs.JASPAR_Zic2", + "th_epi.all_db_motifs.HOMER_Unknown_ESC_element", + "th_epi.all_db_motifs.JOLMA_ZIC3_mono_full" + ) + + # Run with 1 thread (sequential) + q1 <- glm_batch_quantiles(tracks, 0.9999, n_threads = 1L) + + # Run with 3 threads (parallel) + q3 <- glm_batch_quantiles(tracks, 0.9999, n_threads = 3L) + + # Should be identical (same code path, just concurrent) + expect_equal(q1, q3, tolerance = 0) + + cat("Thread consistency test PASSED\n") +}) diff --git a/tests/testthat/test-glm-features.R b/tests/testthat/test-glm-features.R new file mode 100644 index 000000000..5b590ad08 --- /dev/null +++ b/tests/testthat/test-glm-features.R @@ -0,0 +1,415 @@ +local_mm10_db <- Sys.getenv("MISHA_MM10_MOTIF_DB", "") +mm10_trackdb <- Sys.getenv("MISHA_MM10_TRACKDB", "") + +# ---- Unit tests for column-name derivation (no DB required) ---- + +test_that(".glm_features_transform_names uses element names when all named", { + transforms <- list( + low = list(L = 2, k = 0.5, x_0 = 0), + high = list(L = 1, k = 1, x_0 = 10) + ) + expect_identical( + misha:::.glm_features_transform_names(transforms), + c("low", "high") + ) +}) + +test_that(".glm_features_transform_names falls back to t1..tN for unnamed", { + transforms <- list(list(L = 2), list(L = 1), list(L = 2)) + expect_identical( + misha:::.glm_features_transform_names(transforms), + c("t1", "t2", "t3") + ) +}) + +test_that(".glm_features_transform_names falls back when partially named", { + # Partially named -> generic, since silent labeling on partial names + # would mislabel the unnamed entries. + transforms <- list(low = list(L = 2), list(L = 1)) + expect_identical( + misha:::.glm_features_transform_names(transforms), + c("t1", "t2") + ) +}) + +test_that(".glm_features_transform_names does not match by L-value fingerprint", { + # Regression for prior magic fingerprint that keyed on L == c(2,2,1,2): + # an unnamed length-4 transforms list with that exact L-pattern must + # NOT silently get the canonical labels - those labels are only + # correct when the user actually supplies the canonical pipeline by + # name. + transforms <- list( + list(L = 2, k = 0.5, x_0 = 0, pre_shift = 0, post_shift = -1), + list(L = 2, k = 0.5, x_0 = 10, pre_shift = 0, post_shift = 0), + list(L = 1, k = 1, x_0 = 0, pre_shift = -5, post_shift = 0), + list(L = 2, k = 1, x_0 = 10, pre_shift = 0, post_shift = 0) + ) + expect_identical( + misha:::.glm_features_transform_names(transforms), + c("t1", "t2", "t3", "t4") + ) +}) + +# ---- Integration tests (require local mm10 motif DB) ---- + +test_that("glm_extract_features matches R reference pipeline", { + # Requires local mm10 database with motif energy tracks + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9) + + # Pick 3 motifs and 50 peaks for a fast comparison + motifs <- c("JASPAR_Zic2", "HOMER_Unknown_ESC_element", "JOLMA_ZIC3_mono_full") + track_dir <- "th_epi.all_db_motifs" + track_names <- paste0(track_dir, ".", motifs) + + # Create 50 peaks on chr1 at known positions (300bp each) + set.seed(42) + peak_starts <- sort(sample(seq(5e6, 50e6, by = 1000), 50)) + peaks <- data.frame( + chrom = "chr1", + start = peak_starts, + end = peak_starts + 300L + ) + n_peaks <- nrow(peaks) + + # Config matching the LASSO training pipeline + tile_size <- 200L + flank_size <- 350L + scale_factor <- 10 + dist_from_max <- 10 + top_percentile <- 0.9999 + + # ---- R reference pipeline ---- + + # 1. Create virtual tracks (LSE aggregation) + for (motif in motifs) { + gvtrack.create(vtrack = motif, src = paste0(track_dir, ".", motif), func = "lse") + } + + # 2. Compute genome-wide quantiles + shift <- (300 - 20) / 2 # (peak_size - 20) / 2 + gw_max_q <- sapply(motifs, function(motif) { + gvtrack.iterator(motif, sshift = -shift, eshift = shift) + gquantiles(motif, percentiles = top_percentile, iterator = 20) + }) + names(gw_max_q) <- motifs + + # 3. Tile peaks + tile_peaks_r <- function(peaks, tile_size, flank_size) { + peaks_ext <- peaks + peaks_ext$start <- peaks$start - flank_size + peaks_ext$end <- peaks$end + flank_size + peaks_ext <- gintervals.force_range(peaks_ext) + + do.call(rbind, lapply(seq_len(nrow(peaks_ext)), function(i) { + starts <- seq(peaks_ext$start[i], peaks_ext$end[i] - 1, by = tile_size) + ends <- pmin(starts + tile_size, peaks_ext$end[i]) + peak_mid <- (peaks$start[i] + peaks$end[i]) / 2 + tile_mid <- starts + tile_size / 2 + data.frame( + chrom = peaks_ext$chrom[i], + start = starts, + end = ends, + peak_id = i, + dist = tile_mid - peak_mid + ) + })) + } + + tiled <- tile_peaks_r(peaks, tile_size, flank_size) + n_tiles <- length(unique(tiled$dist)) + + # 4. Extract motif energies (R pipeline) + # Reset virtual track iterators to no-shift for tile-level extraction + for (motif in motifs) { + gvtrack.iterator(motif, sshift = 0, eshift = 0) + } + + motif_energy <- gextract(motifs, intervals = tiled, iterator = tiled) %>% + dplyr::arrange(intervalID) + e_mat <- as.matrix(motif_energy[, motifs]) + + # 5. Scale + m_names <- rep(motifs, each = 1) # motifs already match column order + ceiled <- pmin(sweep(e_mat, 2, gw_max_q[motifs], "-"), 0) + floored <- pmax(ceiled, -dist_from_max) + scaled_r <- scale_factor * (floored + dist_from_max) / dist_from_max + scaled_r[!is.finite(scaled_r)] <- 0 + + # 6. Logistic transforms + logist <- function(x, x0, L, k) L / (1 + exp(-k * (x - x0))) + + f1 <- logist(scaled_r, x0 = 0, L = 2, k = 0.5) - 1 + f2 <- logist(scaled_r, x0 = 10, L = 2, k = 0.50) + f3 <- logist(scaled_r - 5, x0 = 0, L = 1, k = 1) + f4 <- logist(scaled_r, x0 = 10, L = 2, k = 1) + + # 7. GC features + gvtrack.create("gc_sum", src = "seq.G_or_C", func = "sum") + gc_raw <- gextract("gc_sum", + intervals = tiled, iterator = tiled, + colnames = "gc" + ) %>% + dplyr::arrange(intervalID) %>% + dplyr::pull(gc) + gc_raw[is.na(gc_raw)] <- 0 + gc_scaled_r <- (gc_raw / tile_size) * scale_factor + + # 8. Reshape to wide format (direct matrix indexing) + dist_vals <- sort(unique(tiled$dist)) + n_motifs <- length(motifs) + + # For each transform, create wide matrix + ref_motif_block <- matrix(NA_real_, nrow = n_peaks, ncol = n_motifs * n_tiles * 4) + ref_gc <- matrix(NA_real_, nrow = n_peaks, ncol = n_tiles) + + for (ti in seq_len(n_tiles)) { + row_idx <- seq(ti, nrow(tiled), by = n_tiles) + + for (mi in seq_len(n_motifs)) { + # Column in C++ output: (tile * n_motifs + motif) * n_transforms + transform + # (0-based in C++, 1-based here) + base_col <- ((ti - 1) * n_motifs + (mi - 1)) * 4 + + ref_motif_block[, base_col + 1] <- f1[row_idx, mi] + ref_motif_block[, base_col + 2] <- f2[row_idx, mi] + ref_motif_block[, base_col + 3] <- f3[row_idx, mi] + ref_motif_block[, base_col + 4] <- f4[row_idx, mi] + } + + ref_gc[, ti] <- gc_scaled_r[row_idx] + } + + # GC interactions + n_gc_inter <- n_tiles * (n_tiles - 1) / 2 + ref_gc_inter <- matrix(NA_real_, nrow = n_peaks, ncol = n_gc_inter) + idx <- 1 + for (a in seq_len(n_tiles - 1)) { + for (b in (a + 1):n_tiles) { + ref_gc_inter[, idx] <- ref_gc[, a] * ref_gc[, b] / scale_factor + idx <- idx + 1 + } + } + + ref_full <- cbind(ref_motif_block, ref_gc, ref_gc_inter) + + # ---- C++ pipeline ---- + max_cap <- gw_max_q + names(max_cap) <- track_names + + cpp_result <- glm_extract_features( + track_names = track_names, + intervals = peaks, + tile_size = tile_size, + flank_size = flank_size, + max_cap = max_cap, + dis_from_cap = dist_from_max, + scale_factor = scale_factor, + gc_track = "seq.G_or_C", + gc_scale_factor = scale_factor + ) + + # ---- Compare ---- + expect_equal(nrow(cpp_result), n_peaks) + expect_equal(ncol(cpp_result), ncol(ref_full)) + + # Compare values — should be bit-identical since we match misha's + # float-precision lse_accumulate and use std::exp for transforms + max_diff <- max(abs(cpp_result - ref_full), na.rm = TRUE) + cat("Max absolute difference:", max_diff, "\n") + expect_equal(max_diff, 0) + + # Check motif block specifically + motif_cols <- seq_len(n_motifs * n_tiles * 4) + max_motif_diff <- max(abs(cpp_result[, motif_cols] - ref_full[, motif_cols]), na.rm = TRUE) + cat("Max motif block diff:", max_motif_diff, "\n") + expect_equal(max_motif_diff, 0) + + # Check GC block + gc_cols <- n_motifs * n_tiles * 4 + seq_len(n_tiles) + max_gc_diff <- max(abs(cpp_result[, gc_cols] - ref_full[, gc_cols]), na.rm = TRUE) + cat("Max GC diff:", max_gc_diff, "\n") + expect_equal(max_gc_diff, 0) + + # Check GC interactions + inter_cols <- n_motifs * n_tiles * 4 + n_tiles + seq_len(n_gc_inter) + max_inter_diff <- max(abs(cpp_result[, inter_cols] - ref_full[, inter_cols]), na.rm = TRUE) + cat("Max GC interaction diff:", max_inter_diff, "\n") + expect_equal(max_inter_diff, 0) + + cat("All comparisons PASSED\n") +}) + +test_that("glm_extract_features resolves chromids via misha chromkey, not input subset order", { + # Regression test for the chrom-subset chromid bug: + # before the fix, chromids were computed positionally from + # gintervals.chrom_sizes(intervals). When the input intervals lacked one + # of the chromosomes that comes earlier in the chromkey (e.g. chrM in mm10 + # ordering), every chromosome after the missing one was mapped to the + # wrong file, producing all-zero features. Specifically chrX (chromkey id + # 20 in mm10) silently became id 19 = chrM, returning empty data because + # chrM is far shorter than chrX peak coordinates. + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9) + + motifs <- c("JASPAR_Zic2", "HOMER_Unknown_ESC_element") + track_dir <- "th_epi.all_db_motifs" + track_names <- paste0(track_dir, ".", motifs) + + # 5 peaks on chr1 + 5 peaks on chrX. Intentionally skip chrM/chrY so the + # input subset's positional ordering disagrees with the chromkey. + set.seed(1) + peaks <- rbind( + data.frame( + chrom = "chr1", + start = sort(sample(seq(5e6, 50e6, by = 1000), 5)), + end = NA_integer_ + ), + data.frame( + chrom = "chrX", + start = sort(sample(seq(5e6, 50e6, by = 1000), 5)), + end = NA_integer_ + ) + ) + peaks$end <- peaks$start + 300L + + # Compute caps via the existing R reference path (single-chrom is fine for + # quantiles since they're genome-wide). + for (motif in motifs) { + gvtrack.create( + vtrack = motif, src = paste0(track_dir, ".", motif), + func = "lse" + ) + } + shift <- (300 - 20) / 2 + gw_max_q <- sapply(motifs, function(motif) { + gvtrack.iterator(motif, sshift = -shift, eshift = shift) + gquantiles(motif, percentiles = 0.9999, iterator = 20) + }) + names(gw_max_q) <- motifs + max_cap <- gw_max_q + names(max_cap) <- track_names + + # Reset iterators to no-shift for tile-level extraction + for (motif in motifs) { + gvtrack.iterator(motif, sshift = 0, eshift = 0) + } + + # Run C++ feature extraction on the full multi-chrom set + cpp_full <- glm_extract_features( + track_names = track_names, + intervals = peaks, + tile_size = 200L, + flank_size = 350L, + max_cap = max_cap, + dis_from_cap = 10, + scale_factor = 10, + gc_track = "seq.G_or_C", + gc_scale_factor = 10 + ) + + # And on each chromosome separately — when only a single chrom is present + # in the input, the buggy positional ID always lined up with chromkey ID + # for that chrom, so per-chrom calls were unaffected by the bug. The + # rows for chr1 and chrX in cpp_full must therefore equal cpp_chr1 and + # cpp_chrX respectively. + cpp_chr1 <- glm_extract_features( + track_names = track_names, + intervals = peaks[peaks$chrom == "chr1", ], + tile_size = 200L, flank_size = 350L, + max_cap = max_cap, dis_from_cap = 10, scale_factor = 10, + gc_track = "seq.G_or_C", gc_scale_factor = 10 + ) + cpp_chrX <- glm_extract_features( + track_names = track_names, + intervals = peaks[peaks$chrom == "chrX", ], + tile_size = 200L, flank_size = 350L, + max_cap = max_cap, dis_from_cap = 10, scale_factor = 10, + gc_track = "seq.G_or_C", gc_scale_factor = 10 + ) + + chr1_rows <- which(peaks$chrom == "chr1") + chrX_rows <- which(peaks$chrom == "chrX") + + expect_equal( + unname(cpp_full[chr1_rows, , drop = FALSE]), + unname(cpp_chr1) + ) + expect_equal( + unname(cpp_full[chrX_rows, , drop = FALSE]), + unname(cpp_chrX) + ) + + # Sanity: chrX rows must contain non-zero motif energies (a regression + # to the old bug would zero them all out because we'd be reading chrM). + expect_gt(sum(abs(cpp_full[chrX_rows, ])), 0) +}) + +test_that("glm_extract_features is bit-identical across thread counts", { + skip_if(!dir.exists(local_mm10_db), "Local mm10 misha db not available") + gdb.init(local_mm10_db) + gdataset.load(mm10_trackdb) + options(gmax.data.size = 1e9) + + motifs <- c("JASPAR_Zic2", "HOMER_Unknown_ESC_element", "JOLMA_ZIC3_mono_full") + track_dir <- "th_epi.all_db_motifs" + track_names <- paste0(track_dir, ".", motifs) + + # Enough peaks across enough chroms to actually engage > 1 worker + set.seed(7) + chr1_peaks <- data.frame( + chrom = "chr1", + start = sort(sample(seq(5e6, 50e6, by = 1000), 200)) + ) + chr2_peaks <- data.frame( + chrom = "chr2", + start = sort(sample(seq(5e6, 50e6, by = 1000), 200)) + ) + chrx_peaks <- data.frame( + chrom = "chrX", + start = sort(sample(seq(5e6, 50e6, by = 1000), 200)) + ) + peaks <- rbind(chr1_peaks, chr2_peaks, chrx_peaks) + peaks$end <- peaks$start + 300L + + for (motif in motifs) { + gvtrack.create(vtrack = motif, src = paste0(track_dir, ".", motif), func = "lse") + } + shift <- (300 - 20) / 2 + gw_max_q <- sapply(motifs, function(motif) { + gvtrack.iterator(motif, sshift = -shift, eshift = shift) + gquantiles(motif, percentiles = 0.9999, iterator = 20) + }) + names(gw_max_q) <- motifs + max_cap <- gw_max_q + names(max_cap) <- track_names + + out_1 <- glm_extract_features( + track_names = track_names, intervals = peaks, + tile_size = 200L, flank_size = 350L, + max_cap = max_cap, dis_from_cap = 10, scale_factor = 10, + gc_track = "seq.G_or_C", gc_scale_factor = 10, + n_threads = 1L + ) + out_4 <- glm_extract_features( + track_names = track_names, intervals = peaks, + tile_size = 200L, flank_size = 350L, + max_cap = max_cap, dis_from_cap = 10, scale_factor = 10, + gc_track = "seq.G_or_C", gc_scale_factor = 10, + n_threads = 4L + ) + out_auto <- glm_extract_features( + track_names = track_names, intervals = peaks, + tile_size = 200L, flank_size = 350L, + max_cap = max_cap, dis_from_cap = 10, scale_factor = 10, + gc_track = "seq.G_or_C", gc_scale_factor = 10, + n_threads = 0L + ) + + expect_identical(out_1, out_4) + expect_identical(out_1, out_auto) +}) diff --git a/tests/testthat/test-gquantiles-dispatch.R b/tests/testthat/test-gquantiles-dispatch.R new file mode 100644 index 000000000..40614115c --- /dev/null +++ b/tests/testthat/test-gquantiles-dispatch.R @@ -0,0 +1,129 @@ +# Phase 6 dispatch tests for gquantiles. + +test_that("gquantiles single-expr default (fast=FALSE) unchanged", { + gdb.init_examples() + q <- gquantiles("dense_track", c(0.1, 0.5, 0.9), gintervals(c(1, 2))) + expect_type(q, "double") + expect_named(q) + expect_equal(length(q), 3) +}) + +test_that("gquantiles single-expr with fast=TRUE returns named numeric", { + gdb.init_examples() + q <- gquantiles("dense_track", c(0.9, 0.99), fast = TRUE) + expect_type(q, "double") + expect_named(q) + expect_equal(length(q), 2) + expect_true(all(is.finite(q))) + # Monotonicity: q[0.9] <= q[0.99] + expect_true(q[1] <= q[2]) +}) + +test_that("gquantiles multi-expr fast=TRUE returns data.frame", { + gdb.init_examples() + tracks <- c("dense_track", "subdir.dense_track2") + df <- gquantiles(tracks, c(0.5, 0.9), fast = TRUE) + expect_s3_class(df, "data.frame") + expect_equal(colnames(df), c("track", "0.5", "0.9")) + expect_equal(nrow(df), 2) + expect_equal(df$track, tracks) + expect_true(all(is.finite(df[["0.5"]]))) + expect_true(all(df[["0.5"]] <= df[["0.9"]])) +}) + +test_that("gquantiles multi-expr without fast=TRUE errors cleanly", { + gdb.init_examples() + expect_error( + gquantiles(c("dense_track", "subdir.dense_track2"), 0.9), + regexp = "multi-expression calls require fast=TRUE" + ) +}) + +test_that("gquantiles multi-expr with complex expression errors cleanly", { + gdb.init_examples() + # Complex expressions aren't fast-path eligible. + expect_error( + gquantiles(c("dense_track + 1", "subdir.dense_track2"), 0.9, + fast = TRUE + ), + regexp = "fast-path not eligible" + ) +}) + +test_that("gquantiles single-expr fast=TRUE matches legacy on small examples", { + gdb.init_examples() + # On the tiny example db, StreamPercentiler doesn't sub-sample, so the + # numbers should be close (not necessarily bit-equal because the window + # vs bin-by-bin semantics differ for non-matching iterator/bin_size). + # Here we use the track's natural bin size (50) as the iterator to + # align with the legacy path's implicit per-bin iteration. + q_fast <- gquantiles("dense_track", c(0.1, 0.5, 0.9), + iterator = 50L, fast = TRUE + ) + q_slow <- gquantiles("dense_track", c(0.1, 0.5, 0.9), iterator = 50L) + expect_equal(unname(q_fast), unname(q_slow), tolerance = 0.01) +}) + +test_that("gquantiles vtrack vector works for fast=TRUE", { + gdb.init_examples() + gvtrack.create(vtrack = "vt_q1", src = "dense_track", func = "lse") + gvtrack.create( + vtrack = "vt_q2", src = "subdir.dense_track2", + func = "lse" + ) + gvtrack.iterator("vt_q1", sshift = -50, eshift = 50) + gvtrack.iterator("vt_q2", sshift = -50, eshift = 50) + df <- gquantiles(c("vt_q1", "vt_q2"), 0.9, + iterator = 20L, fast = TRUE + ) + gvtrack.rm("vt_q1") + gvtrack.rm("vt_q2") + expect_s3_class(df, "data.frame") + expect_equal(nrow(df), 2) + expect_true(all(is.finite(df[["0.9"]]))) +}) + +# Window-semantics regression: the fast path must use the same window as +# the slow path -- [iter_start + sshift, iter_end + eshift] -- rather than +# [c + sshift, c + eshift] anchored at a single point. Previously a vtrack +# with default sshift=0, eshift=0 produced an empty window and returned +# NaN, and any non-trivial window produced silently-wrong values. +test_that("gquantiles fast=TRUE matches slow path for vtrack with default sshift=eshift=0", { + gdb.init_examples() + gvtrack.create("vt_zero", src = "dense_track", func = "lse") + gvtrack.iterator("vt_zero", sshift = 0, eshift = 0) + on.exit(gvtrack.rm("vt_zero")) + + q_slow <- gquantiles("vt_zero", 0.97, iterator = 20L, fast = FALSE) + q_fast <- gquantiles("vt_zero", 0.97, iterator = 20L, fast = TRUE) + expect_true(is.finite(q_fast)) + # Fast path is exact nth_element; slow path is approximate + # StreamPercentiler. Tolerance covers the latter's sampling error + # at p = 0.97 (documented as up to ~0.06 at p = 0.9999). + expect_equal(unname(q_fast), unname(q_slow), tolerance = 0.02) +}) + +test_that("gquantiles fast=TRUE matches slow path for vtrack with non-zero sshift/eshift", { + gdb.init_examples() + gvtrack.create("vt_w", src = "dense_track", func = "lse") + gvtrack.iterator("vt_w", sshift = -50, eshift = 50) + on.exit(gvtrack.rm("vt_w")) + + q_slow <- gquantiles("vt_w", c(0.5, 0.9), iterator = 20L, fast = FALSE) + q_fast <- gquantiles("vt_w", c(0.5, 0.9), iterator = 20L, fast = TRUE) + expect_equal(unname(q_fast), unname(q_slow), tolerance = 0.01) +}) + +test_that("gquantiles fast=TRUE matches slow path for bare track with iterator != bin_size", { + gdb.init_examples() + bsz <- as.integer(gtrack.info("dense_track")$bin.size) + iter <- 2L * bsz + + q_slow <- gquantiles("dense_track", c(0.1, 0.5, 0.9), + iterator = iter, fast = FALSE + ) + q_fast <- gquantiles("dense_track", c(0.1, 0.5, 0.9), + iterator = iter, fast = TRUE + ) + expect_equal(unname(q_fast), unname(q_slow), tolerance = 0.05) +}) diff --git a/tests/testthat/test-vtrack-glm-pred.R b/tests/testthat/test-vtrack-glm-pred.R new file mode 100644 index 000000000..b25db02f8 --- /dev/null +++ b/tests/testthat/test-vtrack-glm-pred.R @@ -0,0 +1,1438 @@ +create_isolated_test_db() + +# ============================================================ +# Helper: R-level logistic transform +# ============================================================ +r_logist <- function(x, L = 1, k = 1, x_0 = 0, pre_shift = 0, post_shift = 0) { + input <- x + pre_shift + L / (1 + exp(-k * (input - x_0))) + post_shift +} + +# Helper: R-level scaling (cap + normalize) +r_scale <- function(raw, max_cap, dis_from_cap, scale_factor = 10) { + ceiled <- pmin(raw - max_cap, 0) + floored <- pmax(ceiled, -dis_from_cap) + scaled <- scale_factor * (floored + dis_from_cap) / dis_from_cap + ifelse(is.finite(scaled), scaled, 0) +} + +# Helper: convert vtrack sshift/eshift to glm_pred shifts +# Regular vtrack: window = [iter.start + sshift, iter.end + eshift) +# glm_pred: center = (start+end)/2, window = [center + glm_ss, center + glm_es) +# To match: glm_ss = sshift - iter_size/2, glm_es = eshift + iter_size/2 +vtrack_to_glm_shifts <- function(sshift, eshift, iter_size) { + c(sshift - iter_size / 2, eshift + iter_size / 2) +} + +# ============================================================ +# Category 1: R parameter validation +# ============================================================ + +test_that("glm_pred.create requires tracks", { + expect_error( + glm_pred.create("bad", tracks = character(0), inner_func = "sum", weights = 1), + "tracks" + ) +}) + +test_that("glm_pred.create requires matching lengths", { + expect_error( + glm_pred.create("bad", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = "sum", weights = 1 + ), + "length" + ) +}) + +test_that("glm_pred.create validates inner_func values", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "bad", weights = 1 + ), + "inner_func" + ) +}) + +test_that("glm_pred.create accepts pure-shift and reverse-orientation entries", { + # Per commit 3c9d3545: sshift < eshift is no longer required. A + # shifts entry can translate the interval (sshift == eshift) and + # reverse orientation (sshift > eshift). Pin the new semantics so + # the validation is not silently re-tightened. + expect_silent( + glm_pred.create("vt_shift_translate", + tracks = "test.fixedbin", + inner_func = "sum", weights = 1, + shifts = list(c(50, 50)) + ) + ) + glm_pred.rm("vt_shift_translate") + expect_silent( + glm_pred.create("vt_shift_reverse", + tracks = "test.fixedbin", + inner_func = "sum", weights = 1, + shifts = list(c(100, -100)) + ) + ) + glm_pred.rm("vt_shift_reverse") +}) + +test_that("glm_pred.create validates interaction indices", { + expect_error( + glm_pred.create("bad", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(1, 1), + shifts = list(c(-100, 100), c(-100, 100)), + interactions = list(c(1L, 3L)), + interaction_weights = 0.5 + ), + "indices" + ) +}) + +test_that("glm_pred.create rejects wrong-length interaction_trans_family", { + # M = 3 interactions; user passes length-2 family -> should error, + # not silently pad with NA (regression for prior asymmetric validation + # vs the entry-side trans_family check). + expect_error( + glm_pred.create("bad", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(1, 1), + shifts = list(c(-100, 100), c(-100, 100)), + interactions = list(c(1L, 2L), c(1L, 2L), c(1L, 2L)), + interaction_weights = c(0.1, 0.2, 0.3), + interaction_trans_family = c("logist", "logist") + ), + "interaction_trans_family" + ) +}) + +test_that("glm_pred.create rejects wrong-length simple_cap", { + # N = 3 entries; user passes length-2 simple_cap. Without validation, + # the C++ side silently uses simple_cap[0..1] for entries 0..1 and + # the default (FALSE) for entry 2 - silent miswiring. + expect_error( + glm_pred.create("bad", + tracks = c("test.fixedbin", "test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum", "sum"), + weights = c(1, 1, 1), + shifts = list(c(-100, 100), c(-100, 100), c(-100, 100)), + max_cap = c(0, 0, 0), + dis_from_cap = c(1, 1, 1), + simple_cap = c(TRUE, FALSE) + ), + "simple_cap" + ) +}) + +test_that("glm_pred surfaces entry-track open errors (no silent NaN)", { + # Regression: prior catch silently nulled the cached entry track + # on TGLException (e.g., bad track name, corrupted file), causing + # gextract to return NaN for the affected positions with no + # indication. Now verror's, matching the selector path's policy. + glm_pred.create("vt_a5_silent", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0, + shifts = list(c(-50, 50)) + ) + on.exit(try(glm_pred.rm("vt_a5_silent"), silent = TRUE), add = TRUE) + + # Bypass R-side track-existence validation by mutating the stored + # vtrack to point at a non-existent track. This exercises the + # C++ start_chrom catch path that previously silently swallowed + # TGLException from track2path / get_type / create_and_init_1d_track. + misha_env <- get(".misha", envir = asNamespace("misha")) + gwd <- get("GWD", envir = misha_env) + misha_env$GVTRACKS[[gwd]]$vt_a5_silent$params$tracks <- "no.such.track" + + intervals <- gintervals(1, 500, 1000) + expect_error( + gextract("vt_a5_silent", intervals = intervals, iterator = 100), + "(?i)glm.*track|no\\.such\\.track" + ) +}) + +test_that("glm_pred.create rejects wrong-length inter_trans_params", { + expect_error( + glm_pred.create("bad", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(1, 1), + shifts = list(c(-100, 100), c(-100, 100)), + interactions = list(c(1L, 2L), c(1L, 2L), c(1L, 2L)), + interaction_weights = c(0.1, 0.2, 0.3), + interaction_trans_family = "logist", + inter_trans_params = list( + list(L = 1, k = 1, x_0 = 0), + list(L = 2, k = 1, x_0 = 0) + ) + ), + "inter_trans_params" + ) +}) + +# ============================================================ +# Category 2: Basic pipeline correctness +# ============================================================ + +test_that("glm_pred with bias only returns bias", { + glm_pred.create("vt_bias", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 0, + bias = 42.0, + shifts = list(c(-50, 50)) + ) + + intervals <- gintervals(1, 500, 1000) + result <- gextract("vt_bias", intervals = intervals, iterator = 100) + expect_true(all(abs(result$vt_bias - 42.0) < 1e-10)) +}) + +test_that("glm_pred with weight=1, no transform matches raw sum", { + iter <- 100L + ss <- -50 + es <- 50 + # glm_pred shifts are relative to center + gs <- vtrack_to_glm_shifts(ss, es, iter) + + glm_pred.create("vt_raw_sum", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0, + shifts = list(gs) + ) + + gvtrack.create("vt_ref_sum", "test.fixedbin", "sum") + gvtrack.iterator("vt_ref_sum", sshift = ss, eshift = es) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_raw_sum", intervals = intervals, iterator = iter) + ref <- gextract("vt_ref_sum", intervals = intervals, iterator = iter) + + ref_vals <- ref$vt_ref_sum + ref_vals[!is.finite(ref_vals)] <- 0 + + expect_equal(result$vt_raw_sum, ref_vals, tolerance = 1e-6) +}) + +test_that("glm_pred with weight=1, no transform matches raw lse", { + iter <- 100L + ss <- -50 + es <- 50 + gs <- vtrack_to_glm_shifts(ss, es, iter) + + glm_pred.create("vt_raw_lse", + tracks = "test.fixedbin", + inner_func = "lse", + weights = 1.0, + bias = 0, + shifts = list(gs) + ) + + gvtrack.create("vt_ref_lse", "test.fixedbin", "lse") + gvtrack.iterator("vt_ref_lse", sshift = ss, eshift = es) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_raw_lse", intervals = intervals, iterator = iter) + ref <- gextract("vt_ref_lse", intervals = intervals, iterator = iter) + + ref_vals <- ref$vt_ref_lse + ref_vals[!is.finite(ref_vals)] <- 0 + + expect_equal(result$vt_raw_lse, ref_vals, tolerance = 1e-6) +}) + +# ============================================================ +# Category 3: Scaling +# ============================================================ + +test_that("glm_pred scaling matches manual R computation", { + iter <- 100L + ss <- -50 + es <- 50 + gs <- vtrack_to_glm_shifts(ss, es, iter) + + glm_pred.create("vt_scaled", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0, + shifts = list(gs), + max_cap = -15, + dis_from_cap = 10, + scale_factor = 10 + ) + + gvtrack.create("vt_raw_for_scale", "test.fixedbin", "sum") + gvtrack.iterator("vt_raw_for_scale", sshift = ss, eshift = es) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_scaled", intervals = intervals, iterator = iter) + ref <- gextract("vt_raw_for_scale", intervals = intervals, iterator = iter) + + raw_vals <- ref$vt_raw_for_scale + raw_vals[!is.finite(raw_vals)] <- 0 + expected <- r_scale(raw_vals, max_cap = -15, dis_from_cap = 10, scale_factor = 10) + + expect_equal(result$vt_scaled, expected, tolerance = 1e-6) +}) + +# ============================================================ +# Category 4: Logistic transform +# ============================================================ + +test_that("glm_pred logistic transform matches manual R computation", { + iter <- 100L + ss <- -50 + es <- 50 + gs <- vtrack_to_glm_shifts(ss, es, iter) + trans <- list(L = 2, k = 0.5, x_0 = 5, pre_shift = 0, post_shift = -1) + + glm_pred.create("vt_logist", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0, + shifts = list(gs), + max_cap = -15, + dis_from_cap = 10, + scale_factor = 10, + trans_family = "logist", + trans_params = list(trans) + ) + + gvtrack.create("vt_raw_for_logist", "test.fixedbin", "sum") + gvtrack.iterator("vt_raw_for_logist", sshift = ss, eshift = es) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_logist", intervals = intervals, iterator = iter) + ref <- gextract("vt_raw_for_logist", intervals = intervals, iterator = iter) + + raw_vals <- ref$vt_raw_for_logist + raw_vals[!is.finite(raw_vals)] <- 0 + scaled <- r_scale(raw_vals, -15, 10, 10) + expected <- r_logist(scaled, + L = trans$L, k = trans$k, x_0 = trans$x_0, + pre_shift = trans$pre_shift, post_shift = trans$post_shift + ) + expected[!is.finite(expected)] <- 0 + + expect_equal(result$vt_logist, expected, tolerance = 1e-6) +}) + +# ============================================================ +# Category 5: Multi-entry with weights +# ============================================================ + +test_that("glm_pred with multiple entries matches manual computation", { + iter <- 100L + w1 <- 0.3 + w2 <- -0.5 + b <- 0.42 + trans1 <- list(L = 2, k = 0.5, x_0 = 0, post_shift = -1) + trans2 <- list(L = 1, k = 1, x_0 = 0, pre_shift = -5) + + # Entry 1: vtrack sshift=-100, eshift=0 on iter=100 → glm: (-150, 50) + gs1 <- vtrack_to_glm_shifts(-100, 0, iter) + gs2 <- vtrack_to_glm_shifts(0, 100, iter) + + glm_pred.create("vt_multi", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(w1, w2), + bias = b, + shifts = list(gs1, gs2), + max_cap = c(-15, -15), + dis_from_cap = c(10, 10), + scale_factor = 10, + trans_family = c("logist", "logist"), + trans_params = list(trans1, trans2) + ) + + gvtrack.create("vt_e1", "test.fixedbin", "sum") + gvtrack.iterator("vt_e1", sshift = -100, eshift = 0) + gvtrack.create("vt_e2", "test.fixedbin", "sum") + gvtrack.iterator("vt_e2", sshift = 0, eshift = 100) + + intervals <- gintervals(1, 500, 2000) + ref1 <- gextract("vt_e1", intervals = intervals, iterator = iter) + ref2 <- gextract("vt_e2", intervals = intervals, iterator = iter) + + r1 <- ref1$vt_e1 + r1[!is.finite(r1)] <- 0 + s1 <- r_scale(r1, -15, 10, 10) + t1 <- r_logist(s1, L = 2, k = 0.5, x_0 = 0, post_shift = -1) + t1[!is.finite(t1)] <- 0 + + r2 <- ref2$vt_e2 + r2[!is.finite(r2)] <- 0 + s2 <- r_scale(r2, -15, 10, 10) + t2 <- r_logist(s2, L = 1, k = 1, x_0 = 0, pre_shift = -5) + t2[!is.finite(t2)] <- 0 + + expected <- b + w1 * t1 + w2 * t2 + + result <- gextract("vt_multi", intervals = intervals, iterator = iter) + expect_equal(result$vt_multi, expected, tolerance = 1e-6) +}) + +# ============================================================ +# Category 6: Interactions +# ============================================================ + +test_that("glm_pred interactions compute correct products", { + iter <- 100L + w1 <- 0.3 + w2 <- 0.5 + iw <- 0.7 + b <- 0.1 + sf <- 10 + + gs1 <- vtrack_to_glm_shifts(-100, 0, iter) + gs2 <- vtrack_to_glm_shifts(0, 100, iter) + + glm_pred.create("vt_inter", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(w1, w2), + bias = b, + shifts = list(gs1, gs2), + max_cap = c(-15, -15), + dis_from_cap = c(10, 10), + scale_factor = sf, + interactions = list(c(1L, 2L)), + interaction_weights = iw + ) + + gvtrack.create("vt_i1", "test.fixedbin", "sum") + gvtrack.iterator("vt_i1", sshift = -100, eshift = 0) + gvtrack.create("vt_i2", "test.fixedbin", "sum") + gvtrack.iterator("vt_i2", sshift = 0, eshift = 100) + + intervals <- gintervals(1, 500, 2000) + ref1 <- gextract("vt_i1", intervals = intervals, iterator = iter) + ref2 <- gextract("vt_i2", intervals = intervals, iterator = iter) + + r1 <- ref1$vt_i1 + r1[!is.finite(r1)] <- 0 + s1 <- r_scale(r1, -15, 10, sf) + + r2 <- ref2$vt_i2 + r2[!is.finite(r2)] <- 0 + s2 <- r_scale(r2, -15, 10, sf) + + # Main effects: no transform + m1 <- w1 * s1 + m2 <- w2 * s2 + + # Interaction: product / scale_factor, no transform + inter <- iw * s1 * s2 / sf + + expected <- b + m1 + m2 + inter + + result <- gextract("vt_inter", intervals = intervals, iterator = iter) + expect_equal(result$vt_inter, expected, tolerance = 1e-6) +}) + +test_that("glm_pred interactions with transforms compute correctly", { + iter <- 100L + w1 <- 0.3 + w2 <- 0.5 + iw <- 0.7 + b <- 0.1 + sf <- 10 + trans_main1 <- list(L = 2, k = 0.5, x_0 = 0, post_shift = -1) + trans_main2 <- list(L = 2, k = 0.5, x_0 = 10) + trans_inter <- list(L = 1, k = 1, x_0 = 5) + + gs1 <- vtrack_to_glm_shifts(-100, 0, iter) + gs2 <- vtrack_to_glm_shifts(0, 100, iter) + + glm_pred.create("vt_inter_trans", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(w1, w2), + bias = b, + shifts = list(gs1, gs2), + max_cap = c(-15, -15), + dis_from_cap = c(10, 10), + scale_factor = sf, + trans_family = c("logist", "logist"), + trans_params = list(trans_main1, trans_main2), + interactions = list(c(1L, 2L)), + interaction_weights = iw, + interaction_trans_family = "logist", + inter_trans_params = list(trans_inter) + ) + + gvtrack.create("vt_it1", "test.fixedbin", "sum") + gvtrack.iterator("vt_it1", sshift = -100, eshift = 0) + gvtrack.create("vt_it2", "test.fixedbin", "sum") + gvtrack.iterator("vt_it2", sshift = 0, eshift = 100) + + intervals <- gintervals(1, 500, 2000) + ref1 <- gextract("vt_it1", intervals = intervals, iterator = iter) + ref2 <- gextract("vt_it2", intervals = intervals, iterator = iter) + + r1 <- ref1$vt_it1 + r1[!is.finite(r1)] <- 0 + s1 <- r_scale(r1, -15, 10, sf) + + r2 <- ref2$vt_it2 + r2[!is.finite(r2)] <- 0 + s2 <- r_scale(r2, -15, 10, sf) + + t1 <- r_logist(s1, L = 2, k = 0.5, x_0 = 0, post_shift = -1) + t1[!is.finite(t1)] <- 0 + t2 <- r_logist(s2, L = 2, k = 0.5, x_0 = 10) + t2[!is.finite(t2)] <- 0 + m1 <- w1 * t1 + m2 <- w2 * t2 + + product <- s1 * s2 / sf + inter_transformed <- r_logist(product, L = 1, k = 1, x_0 = 5) + inter_transformed[!is.finite(inter_transformed)] <- 0 + inter <- iw * inter_transformed + + expected <- b + m1 + m2 + inter + + result <- gextract("vt_inter_trans", intervals = intervals, iterator = iter) + expect_equal(result$vt_inter_trans, expected, tolerance = 1e-6) +}) + +# ============================================================ +# Category 7: Edge cases +# ============================================================ + +test_that("glm_pred handles zero-weight entries correctly", { + iter <- 100L + gs <- vtrack_to_glm_shifts(-50, 50, iter) + + glm_pred.create("vt_zero_w", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = c(0, 1), + bias = 5, + shifts = list(gs, gs) + ) + + gvtrack.create("vt_ref_zw", "test.fixedbin", "sum") + gvtrack.iterator("vt_ref_zw", sshift = -50, eshift = 50) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_zero_w", intervals = intervals, iterator = iter) + ref <- gextract("vt_ref_zw", intervals = intervals, iterator = iter) + + ref_vals <- ref$vt_ref_zw + ref_vals[!is.finite(ref_vals)] <- 0 + expected <- 5 + ref_vals + + expect_equal(result$vt_zero_w, expected, tolerance = 1e-6) +}) + +test_that("glm_pred works in expressions", { + glm_pred.create("vt_expr", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1, + bias = 0, + shifts = list(c(-50, 50)) + ) + + intervals <- gintervals(1, 500, 1000) + result <- gextract("vt_expr * 2", intervals = intervals, iterator = 100) + result_single <- gextract("vt_expr", intervals = intervals, iterator = 100) + + expect_equal(result$`vt_expr * 2`, result_single$vt_expr * 2, tolerance = 1e-6) +}) + +# ============================================================ +# Category 8: Sparse track support +# ============================================================ + +test_that("glm_pred works with sparse tracks", { + iter <- 200L + gs <- vtrack_to_glm_shifts(-50, 50, iter) + + glm_pred.create("vt_sparse", + tracks = "test.sparse", + inner_func = "sum", + weights = 1, + bias = 0, + shifts = list(gs) + ) + + gvtrack.create("vt_ref_sparse", "test.sparse", "sum") + gvtrack.iterator("vt_ref_sparse", sshift = -50, eshift = 50) + + intervals <- gintervals(1, 500, 5000) + result <- gextract("vt_sparse", intervals = intervals, iterator = iter) + ref <- gextract("vt_ref_sparse", intervals = intervals, iterator = iter) + + ref_vals <- ref$vt_ref_sparse + # Positions where the sparse track has no data should be NaN + # (glm_pred propagates NaN from all-NaN windows) + expect_equal(is.nan(result$vt_sparse), !is.finite(ref_vals)) + # Where both have data, values should match + valid <- is.finite(ref_vals) + expect_equal(result$vt_sparse[valid], ref_vals[valid], tolerance = 1e-6) +}) + +# ============================================================ +# Category 9: Multiple chromosomes +# ============================================================ + +test_that("glm_pred works across multiple chromosomes", { + glm_pred.create("vt_multi_chr", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0.5, + shifts = list(c(-50, 50)) + ) + + intervals <- gintervals(c(1, 2), 500, 2000) + result <- gextract("vt_multi_chr", intervals = intervals, iterator = 100) + expect_true(nrow(result) > 0) + expect_true(all(is.finite(result$vt_multi_chr))) +}) + +# ============================================================ +# Category 10: Unaligned window regression (bin_size=50) +# ============================================================ + +test_that("glm_pred sum matches vtrack sum with unaligned window", { + # test.fixedbin has bin_size=50. Using iterator=30, sshift=-10, eshift=70 + # produces a window not aligned to 50bp bin boundaries. + iter <- 30L + ss <- -10 + es <- 70 + gs <- vtrack_to_glm_shifts(ss, es, iter) + + glm_pred.create("vt_unaligned", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0, + shifts = list(gs) + ) + + gvtrack.create("vt_ref_unaligned", "test.fixedbin", "sum") + gvtrack.iterator("vt_ref_unaligned", sshift = ss, eshift = es) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_unaligned", intervals = intervals, iterator = iter) + ref <- gextract("vt_ref_unaligned", intervals = intervals, iterator = iter) + + ref_vals <- ref$vt_ref_unaligned + ref_vals[!is.finite(ref_vals)] <- 0 + + expect_equal(result$vt_unaligned, ref_vals, tolerance = 1e-6) +}) + +test_that("glm_pred lse matches vtrack lse with unaligned window", { + iter <- 30L + ss <- -10 + es <- 70 + gs <- vtrack_to_glm_shifts(ss, es, iter) + + glm_pred.create("vt_unaligned_lse", + tracks = "test.fixedbin", + inner_func = "lse", + weights = 1.0, + bias = 0, + shifts = list(gs) + ) + + gvtrack.create("vt_ref_unaligned_lse", "test.fixedbin", "lse") + gvtrack.iterator("vt_ref_unaligned_lse", sshift = ss, eshift = es) + + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_unaligned_lse", intervals = intervals, iterator = iter) + ref <- gextract("vt_ref_unaligned_lse", intervals = intervals, iterator = iter) + + ref_vals <- ref$vt_ref_unaligned_lse + ref_vals[!is.finite(ref_vals)] <- 0 + + expect_equal(result$vt_unaligned_lse, ref_vals, tolerance = 1e-6) +}) + +# ============================================================ +# Category 12: Validation tests +# ============================================================ + +test_that("glm_pred.create rejects missing tracks", { + expect_error( + glm_pred.create("bad", + tracks = "definitely_missing_track", + inner_func = "sum", weights = 1 + ), + "not found" + ) +}) + +test_that("glm_pred.create rejects mismatched max_cap/dis_from_cap", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", weights = 1, + max_cap = 1, dis_from_cap = NA + ), + "mismatch" + ) + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", weights = 1, + max_cap = NA, dis_from_cap = 10 + ), + "mismatch" + ) +}) + +# ============================================================ +# Category 14: Selector track validation +# ============================================================ + +test_that("glm_pred.create validates selector_track requires selector_breaks", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1, + selector_tracks = "test.fixedbin" + ), + "selector_breaks" + ) +}) + +test_that("glm_pred.create validates selector_breaks requires 2+ elements", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1, + selector_tracks = "test.fixedbin", + selector_breaks = list(0.5) + ), + "length >= 2" + ) +}) + +test_that("glm_pred.create validates selector_track must be dense", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", + weights = matrix(c(1, 2), nrow = 1), + selector_tracks = "test.sparse", + selector_breaks = list(c(0, 0.5, 1)) + ), + "fixed-bin.*dense" + ) +}) + +test_that("glm_pred.create validates weights must be matrix when K > 1", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1, + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0, 0.5, 1)) + ), + "matrix" + ) +}) + +test_that("glm_pred.create validates weight matrix dimensions", { + expect_error( + glm_pred.create("bad", + tracks = "test.fixedbin", + inner_func = "sum", + weights = matrix(c(1, 2, 3), nrow = 1, ncol = 3), + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0, 0.5, 1)) + ), + "dim = c\\(1, 2\\)" + ) +}) + +# ============================================================ +# Category 15: Selector track - K=2 basic +# ============================================================ + +test_that("glm_pred with selector_track selects per-bin weights", { + # test.fixedbin has values in [0, 0.26]. Use it as both source and selector. + # Breaks: [0, 0.1, 1.0] gives K=2 bins: + # bin 0: selector in [0, 0.1] + # bin 1: selector in (0.1, 1.0] + # Use different weights for each bin so we can verify selection. + + iter <- 50L + N <- 1L + K <- 2L + w_bin0 <- 2.0 + w_bin1 <- 5.0 + b <- 0 + + W <- matrix(c(w_bin0, w_bin1), nrow = N, ncol = K) + + glm_pred.create("vt_sel_basic", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = b, + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0, 0.1, 1.0)) + ) + + intervals <- gintervals(1, 0, 500) + result <- gextract("vt_sel_basic", intervals = intervals, iterator = iter) + + # Get the selector values and raw source values at each position + sel_vals <- gextract("test.fixedbin", intervals = intervals, iterator = iter) + + # For each position, determine which bin the selector falls in: + # bin 0 if selector in [0, 0.1], bin 1 if selector in (0.1, 1.0] + # Then the result should be weight[bin] * source_sum + # Since source == selector here (same track, no shift, iter=50=bin_size), + # source_sum = selector_value for each bin. + for (i in seq_len(nrow(result))) { + sv <- sel_vals$test.fixedbin[i] + val <- result$vt_sel_basic[i] + if (is.na(sv) || !is.finite(sv)) next + + if (sv >= 0 && sv <= 0.1) { + expected_w <- w_bin0 + } else if (sv > 0.1 && sv <= 1.0) { + expected_w <- w_bin1 + } else { + # Out of range - should be NaN + expect_true(is.nan(val), info = sprintf("row %d: sv=%g should be NaN", i, sv)) + next + } + + # No shift, iter = bin_size = 50, so source_sum = selector_value + expected <- expected_w * sv + expect_equal(val, expected, + tolerance = 1e-6, + info = sprintf("row %d: sv=%g, expected w=%g", i, sv, expected_w) + ) + } +}) + +test_that("glm_pred.info reconstructs weight matrix for K > 1", { + N <- 1L + K <- 2L + W <- matrix(c(2.0, 5.0), nrow = N, ncol = K) + + glm_pred.create("vt_sel_info", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = c(0.1, 0.2), + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0, 0.5, 1.0)) + ) + + info <- glm_pred.info("vt_sel_info") + expect_equal(info$func, "glm.predict") + expect_equal(info$params$num_bins, 2) + expect_true(is.matrix(info$params$weights)) + expect_equal(nrow(info$params$weights), 1) + expect_equal(ncol(info$params$weights), 2) + expect_equal(info$params$weights[1, 1], 2.0, ignore_attr = TRUE) + expect_equal(info$params$weights[1, 2], 5.0, ignore_attr = TRUE) + expect_equal(as.numeric(info$params$bias), c(0.1, 0.2)) + expect_equal(info$params$selector_tracks, "test.fixedbin") + expect_equal(info$params$selector_breaks, list(c(0, 0.5, 1.0))) +}) + +# ============================================================ +# Category 16: Selector track - out-of-range -> NaN +# ============================================================ + +test_that("glm_pred selector emits NaN for out-of-range selector values", { + # test.fixedbin has values in [0, 0.26]. + # Use breaks (0.3, 0.5, 1.0) so all values < 0.3 are out-of-range. + # Positions in [0, 0.3) should produce NaN. + # Most values are < 0.3, so most outputs should be NaN. + + iter <- 50L + W <- matrix(c(1.0, 2.0), nrow = 1, ncol = 2) + + glm_pred.create("vt_sel_oor", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = 0, + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0.3, 0.5, 1.0)) + ) + + intervals <- gintervals(1, 0, 5000) + result <- gextract("vt_sel_oor", intervals = intervals, iterator = iter) + sel_vals <- gextract("test.fixedbin", intervals = intervals, iterator = iter) + + for (i in seq_len(nrow(result))) { + sv <- sel_vals$test.fixedbin[i] + val <- result$vt_sel_oor[i] + if (is.na(sv) || !is.finite(sv) || sv < 0.3) { + # Out of range => NaN + expect_true(is.nan(val), + info = sprintf("row %d: sv=%g should produce NaN", i, sv) + ) + } else { + # In range => finite + expect_true(is.finite(val), + info = sprintf("row %d: sv=%g should be finite", i, sv) + ) + } + } + + # Verify at least some positions are NaN (most values are < 0.3) + expect_true(sum(is.nan(result$vt_sel_oor)) > 0) +}) + +# ============================================================ +# Category 17: Selector track - K=2 with interactions +# ============================================================ + +test_that("glm_pred K=2 interactions use per-bin weights", { + iter <- 100L + N <- 2L + K <- 2L + sf <- 10 + + gs1 <- vtrack_to_glm_shifts(-100, 0, iter) + gs2 <- vtrack_to_glm_shifts(0, 100, iter) + + # Different weights per bin for main effects and interaction + W <- matrix(c(0.3, 0.5, 0.7, 0.9), nrow = N, ncol = K) + IW <- matrix(c(0.4, 0.8), nrow = 1, ncol = K) + b <- c(0.1, 0.2) + + glm_pred.create("vt_sel_inter", + tracks = c("test.fixedbin", "test.fixedbin"), + inner_func = c("sum", "sum"), + weights = W, + bias = b, + shifts = list(gs1, gs2), + max_cap = c(-15, -15), + dis_from_cap = c(10, 10), + scale_factor = sf, + interactions = list(c(1L, 2L)), + interaction_weights = IW, + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0, 0.1, 1.0)) + ) + + # Verify it produces output (functional test - C++ handles the per-bin logic) + intervals <- gintervals(1, 500, 2000) + result <- gextract("vt_sel_inter", intervals = intervals, iterator = iter) + expect_true(nrow(result) > 0) + + # Check that glm_pred.info reconstructs interaction weight matrix + info <- glm_pred.info("vt_sel_inter") + expect_true(is.matrix(info$params$inter_weights)) + expect_equal(nrow(info$params$inter_weights), 1) + expect_equal(ncol(info$params$inter_weights), 2) + expect_equal(info$params$inter_weights[1, 1], 0.4, ignore_attr = TRUE) + expect_equal(info$params$inter_weights[1, 2], 0.8, ignore_attr = TRUE) +}) + +# ============================================================ +# Category 18: Selector track - per-bin bias +# ============================================================ + +test_that("glm_pred with selector uses per-bin bias", { + # With weight=0, the output should be just the bias for the selected bin + iter <- 50L + b <- c(10.0, 20.0) + + W <- matrix(c(0, 0), nrow = 1, ncol = 2) + + glm_pred.create("vt_sel_bias", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = b, + selector_tracks = "test.fixedbin", + selector_breaks = list(c(0, 0.1, 1.0)) + ) + + intervals <- gintervals(1, 0, 500) + result <- gextract("vt_sel_bias", intervals = intervals, iterator = iter) + sel_vals <- gextract("test.fixedbin", intervals = intervals, iterator = iter) + + for (i in seq_len(nrow(result))) { + sv <- sel_vals$test.fixedbin[i] + val <- result$vt_sel_bias[i] + if (is.na(sv) || !is.finite(sv)) next + + if (sv >= 0 && sv <= 0.1) { + expect_equal(val, 10.0, + tolerance = 1e-10, + info = sprintf("row %d: sv=%g, expected bias=10.0", i, sv) + ) + } else if (sv > 0.1 && sv <= 1.0) { + expect_equal(val, 20.0, + tolerance = 1e-10, + info = sprintf("row %d: sv=%g, expected bias=20.0", i, sv) + ) + } + } +}) + +# ============================================================ +# Category 19: Selector track - backward compat (K=1) +# ============================================================ + +test_that("glm_pred without selector still works (K=1 backward compat)", { + # Ensure that adding num_bins=1 to params doesn't break existing behavior + iter <- 100L + gs <- vtrack_to_glm_shifts(-50, 50, iter) + + glm_pred.create("vt_no_sel", + tracks = "test.fixedbin", + inner_func = "sum", + weights = 1.0, + bias = 0 + ) + + # Check that num_bins defaults to 1 + info <- glm_pred.info("vt_no_sel") + expect_equal(info$params$num_bins, 1) + expect_null(info$params$selector_tracks) + expect_null(info$params$selector_breaks) + + # Still produces correct output + intervals <- gintervals(1, 500, 1000) + result <- gextract("vt_no_sel", intervals = intervals, iterator = iter) + expect_true(nrow(result) > 0) + expect_true(all(is.finite(result$vt_no_sel))) +}) + +# ============================================================ +# Category 20: Multi-selector - Cartesian product strata +# ============================================================ + +# Mirrors BinFinder::val2bin(right=TRUE, include_lowest=TRUE). +# Returns 1-based bin index or NA for NaN/OOR. +.val2bin_finder <- function(v, breaks) { + as.integer(cut(v, breaks, include.lowest = TRUE, right = TRUE)) +} + +test_that("glm_pred multi-selector: Cartesian product strata, hand-computed result", { + # Two selectors. Both reuse test.fixedbin (values in [0, 0.26]) so per-position + # bin indices are correlated, but the test still validates the column-major + # compound-index math against a hand computation. + src <- "test.fixedbin" + sel1 <- "test.fixedbin" + sel2 <- "test.fixedbin" + + breaks1 <- c(0, 0.1, 0.3) # K1 = 2 bins + breaks2 <- c(0, 0.05, 0.15, 0.3) # K2 = 3 bins + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + K_total <- K1 * K2 # 6 + + # Distinct alpha and beta per stratum so a wrong index pattern shows up. + alpha <- array(seq(0.1, by = 0.1, length.out = K_total), dim = c(1L, K1, K2)) + beta <- array(seq(10, by = 10, length.out = K_total), dim = c(K1, K2)) + + glm_pred.create( + name = "vt_multi", + tracks = src, + inner_func = "sum", + weights = alpha, + bias = beta, + trans_family = NA_character_, + selector_tracks = c(sel1, sel2), + selector_breaks = list(breaks1, breaks2) + ) + on.exit(gvtrack.rm("vt_multi"), add = TRUE) + + intervals <- gintervals(1, 0, 5000) + iter <- 50L + df <- gextract(c("vt_multi", sel1, src), + intervals = intervals, + iterator = iter, + colnames = c("vt", "s", "x") + ) + + # Both selectors read the same value here, so b1 and b2 derive from df$s. + b1 <- .val2bin_finder(df$s, breaks1) + b2 <- .val2bin_finder(df$s, breaks2) + + # Compound index column-major: stride1 = 1, stride2 = K1. + # Flat-index into alpha/beta arrays: column-major flatten matches the C++ stride math. + k <- (b1 - 1L) + (b2 - 1L) * K1 + expected <- ifelse(is.na(k), NA_real_, + as.numeric(beta)[k + 1L] + as.numeric(alpha)[k + 1L] * df$x + ) + + expect_equal(df$vt, expected, tolerance = 1e-8) +}) + +test_that("glm_pred selector: c(-Inf, ..., Inf) breaks correctly distinguish bins", { + # Regression: BinFinder::init left m_binsize == Inf when every adjacent + # break-diff is Inf (e.g. c(-Inf, x, Inf)), which sent val2bin's + # uniform-binsize fast path through Inf/Inf -> NaN -> (int)NaN -> wrong + # bin, silently routing every position to the last bin. + src <- "test.fixedbin" + sel <- "test.fixedbin" + cut_at <- 0.13 # roughly mid-range for test.fixedbin (~[0, 0.26]) + breaks <- c(-Inf, cut_at, Inf) # K = 2 + + # Bin-distinct weights so a wrong bin selection produces a different value. + weights <- matrix(c(2.0, -3.0), nrow = 1L) + bias <- c(0.5, 7.5) + + glm_pred.create( + name = "vt_inf_breaks", + tracks = src, + inner_func = "sum", + weights = weights, + bias = bias, + trans_family = NA_character_, + selector_tracks = sel, + selector_breaks = list(breaks) + ) + on.exit(gvtrack.rm("vt_inf_breaks"), add = TRUE) + + df <- gextract(c("vt_inf_breaks", sel, src), + intervals = gintervals(1, 0, 5000), + iterator = 50L, + colnames = c("vt", "s", "x") + ) + + bin <- .val2bin_finder(df$s, breaks) + expected <- ifelse(is.na(bin), NA_real_, bias[bin] + weights[1L, bin] * df$x) + + expect_equal(df$vt, expected, tolerance = 1e-8) + + # Both bins must actually be hit by the data, otherwise the test would + # silently still pass with the buggy "always last bin" behaviour. + expect_true(any(bin == 1L, na.rm = TRUE)) + expect_true(any(bin == 2L, na.rm = TRUE)) +}) + +test_that("glm_pred multi-selector: any-NaN or any-OOR selector -> NaN output", { + src <- "test.fixedbin" + sel <- "test.fixedbin" + # test.fixedbin has values in [0, 0.26]. Pick breaks where many positions + # fall outside (0.3, 1.0] to guarantee OOR coverage. + breaks <- c(0.3, 0.5, 1.0) + K1 <- length(breaks) - 1L # 2 + weights <- array(rep(1.0, 4L), dim = c(1L, K1, K1)) # 1 x 2 x 2 + bias <- 0 # scalar recycled to the K1 x K1 stratum grid + + glm_pred.create( + name = "vt_oor", + tracks = src, + inner_func = "sum", + weights = weights, + bias = bias, + trans_family = NA_character_, + selector_tracks = c(sel, sel), + selector_breaks = list(breaks, breaks) + ) + on.exit(gvtrack.rm("vt_oor"), add = TRUE) + + intervals <- gintervals(1, 0, 5000) + iter <- 50L + df <- gextract(c("vt_oor", sel), + intervals = intervals, + iterator = iter, + colnames = c("vt", "s") + ) + + # in_range matches BinFinder::val2bin: include_lowest at 0.3, then (0.3, 1.0]. + # Since both selectors read the same s value, in-range for either ↔ in-range for both. + in_range <- !is.na(.val2bin_finder(df$s, breaks)) + expect_true(all(is.na(df$vt[!in_range]))) + expect_true(all(!is.na(df$vt[in_range]))) + # And exercise the OOR path: at least one position must be out of range. + expect_true(any(!in_range)) +}) + +test_that("glm_pred M=1 multi-selector matches single-selector hand computation", { + src <- "test.fixedbin" + sel <- "test.fixedbin" + breaks <- c(0, 0.1, 0.3) + w <- matrix(c(2.0, 5.0), nrow = 1L) + b <- c(0.5, 1.5) + + glm_pred.create( + name = "vt_m1", + tracks = src, + inner_func = "sum", + weights = w, + bias = b, + trans_family = NA_character_, + selector_tracks = sel, + selector_breaks = list(breaks) + ) + on.exit(gvtrack.rm("vt_m1"), add = TRUE) + + intervals <- gintervals(1, 0, 5000) + iter <- 50L + df <- gextract(c("vt_m1", sel, src), + intervals = intervals, + iterator = iter, + colnames = c("vt", "s", "x") + ) + + bin <- .val2bin_finder(df$s, breaks) + expected <- ifelse(is.na(bin), NA_real_, b[bin] + w[1L, bin] * df$x) + + expect_equal(df$vt, expected, tolerance = 1e-8) +}) + +# ============================================================ +# Category 21: Multi-selector - array shape on input/output (named strata) +# ============================================================ + +# Helper: cut() levels for a break vector - same labels glm_pred auto-derives. +.cut_labels <- function(br) { + levels(cut(br[-length(br)] + diff(br) / 2, + breaks = br, + include.lowest = TRUE, right = TRUE + )) +} + +test_that("glm_pred M>=2: array(N, K_1, K_2) input round-trips with auto-derived dimnames", { + src <- "test.fixedbin" + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + N <- 1L + + coefs <- seq(0.1, by = 0.1, length.out = N * K1 * K2) + W <- array(coefs, dim = c(N, K1, K2)) + b_arr <- array(seq(10, by = 10, length.out = K1 * K2), dim = c(K1, K2)) + + glm_pred.create( + name = "vt_arr_m2", + tracks = src, + inner_func = "sum", + weights = W, + bias = b_arr, + trans_family = NA_character_, + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(breaks1, breaks2) + ) + on.exit(gvtrack.rm("vt_arr_m2"), add = TRUE) + + info <- glm_pred.info("vt_arr_m2") + w_out <- info$params$weights + b_out <- info$params$bias + + # Shape preserved. + expect_equal(dim(w_out), c(N, K1, K2)) + expect_equal(dim(b_out), c(K1, K2)) + + # Auto-derived axis names from selector_tracks. + expect_equal(names(dimnames(w_out)), c("entry", "test.fixedbin", "test.fixedbin")) + expect_equal(names(dimnames(b_out)), c("test.fixedbin", "test.fixedbin")) + + # Auto-derived axis labels from cut() on selector_breaks. + expect_equal(dimnames(w_out)[[2]], .cut_labels(breaks1)) + expect_equal(dimnames(w_out)[[3]], .cut_labels(breaks2)) + expect_equal(dimnames(b_out)[[1]], .cut_labels(breaks1)) + expect_equal(dimnames(b_out)[[2]], .cut_labels(breaks2)) + + # Numeric content unchanged (column-major flatten matches input). + expect_equal(as.numeric(w_out), as.numeric(W)) + expect_equal(as.numeric(b_out), as.numeric(b_arr)) +}) + +test_that("glm_pred M>=2: user-supplied matching dimnames round-trip exactly", { + src <- "test.fixedbin" + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + N <- 1L + sel_names <- c("test.fixedbin", "test.fixedbin") + + W <- array(as.numeric(seq_len(N * K1 * K2)), dim = c(N, K1, K2)) + dimnames(W) <- setNames( + list(NULL, .cut_labels(breaks1), .cut_labels(breaks2)), + c("entry", sel_names) + ) + + expect_silent( + glm_pred.create( + name = "vt_arr_dn", + tracks = src, + inner_func = "sum", + weights = W, + bias = 0, + trans_family = NA_character_, + selector_tracks = sel_names, + selector_breaks = list(breaks1, breaks2) + ) + ) + on.exit(gvtrack.rm("vt_arr_dn"), add = TRUE) + + out <- glm_pred.info("vt_arr_dn")$params$weights + expect_identical(out, W) +}) + +test_that("glm_pred M>=2: flat N x K_total matrix is rejected with migration hint", { + expect_error( + glm_pred.create( + name = "vt_bad_flat", + tracks = "test.fixedbin", + inner_func = "sum", + weights = matrix(seq_len(6), nrow = 1L, ncol = 6L), + bias = 0, + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(c(0, 0.1, 0.3), c(0, 0.05, 0.15, 0.3)) + ), + "array\\(weights, dim = c\\(1, 2, 3\\)\\)" + ) +}) + +test_that("glm_pred M>=2: shuffled trailing-axis labels error pinpoints the axis", { + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + + W <- array(seq_len(K1 * K2), dim = c(1L, K1, K2)) + bad_labels <- rev(.cut_labels(breaks2)) + dimnames(W) <- list(NULL, .cut_labels(breaks1), bad_labels) + + expect_error( + glm_pred.create( + name = "vt_bad_lab", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = 0, + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(breaks1, breaks2) + ), + "dimnames\\(weights\\)\\[\\[3\\]\\] does not match cut\\(\\) labels for selector_breaks\\[\\[2\\]\\]" + ) +}) + +test_that("glm_pred M>=2: wrong trailing-axis name errors", { + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + + W <- array(seq_len(K1 * K2), dim = c(1L, K1, K2)) + dimnames(W) <- setNames( + list(NULL, .cut_labels(breaks1), .cut_labels(breaks2)), + c("entry", "test.fixedbin", "wrong_name") + ) + + expect_error( + glm_pred.create( + name = "vt_bad_nm", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = 0, + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(breaks1, breaks2) + ), + "names\\(dimnames\\(weights\\)\\)\\[3\\] must be 'test.fixedbin'; got 'wrong_name'" + ) +}) + +test_that("glm_pred M>=2: bias as flat numeric vector is rejected", { + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + + W <- array(seq_len(K1 * K2), dim = c(1L, K1, K2)) + + expect_error( + glm_pred.create( + name = "vt_bad_bias", + tracks = "test.fixedbin", + inner_func = "sum", + weights = W, + bias = seq_len(K1 * K2), # flat vector, ambiguous flatten + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(breaks1, breaks2) + ), + "'bias' must be an array with dim = c\\(2, 3\\)" + ) +}) + +test_that("glm_pred M>=2: interaction_weights array round-trips with auto-derived dimnames", { + src <- "test.fixedbin" + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + N <- 2L + M_int <- 1L + + W <- array(0.0, dim = c(N, K1, K2)) + IW <- array(seq(0.1, by = 0.1, length.out = M_int * K1 * K2), dim = c(M_int, K1, K2)) + + glm_pred.create( + name = "vt_arr_inter", + tracks = c(src, src), + inner_func = c("sum", "sum"), + weights = W, + bias = 0, + interactions = list(c(1L, 2L)), + interaction_weights = IW, + trans_family = NA_character_, + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(breaks1, breaks2) + ) + on.exit(gvtrack.rm("vt_arr_inter"), add = TRUE) + + info <- glm_pred.info("vt_arr_inter") + iw_out <- info$params$inter_weights + expect_equal(dim(iw_out), c(M_int, K1, K2)) + expect_equal(names(dimnames(iw_out)), c("interaction", "test.fixedbin", "test.fixedbin")) + expect_equal(dimnames(iw_out)[[2]], .cut_labels(breaks1)) + expect_equal(dimnames(iw_out)[[3]], .cut_labels(breaks2)) + expect_equal(as.numeric(iw_out), as.numeric(IW)) +}) + +test_that("glm_pred M>=2: scalar bias is recycled and labeled across all strata", { + breaks1 <- c(0, 0.1, 0.3) + breaks2 <- c(0, 0.05, 0.15, 0.3) + K1 <- length(breaks1) - 1L + K2 <- length(breaks2) - 1L + + glm_pred.create( + name = "vt_scalar_bias", + tracks = "test.fixedbin", + inner_func = "sum", + weights = array(0.0, dim = c(1L, K1, K2)), + bias = 7.5, + selector_tracks = c("test.fixedbin", "test.fixedbin"), + selector_breaks = list(breaks1, breaks2) + ) + on.exit(gvtrack.rm("vt_scalar_bias"), add = TRUE) + + b <- glm_pred.info("vt_scalar_bias")$params$bias + expect_equal(dim(b), c(K1, K2)) + expect_equal(names(dimnames(b)), c("test.fixedbin", "test.fixedbin")) + expect_true(all(as.numeric(b) == 7.5)) +}) + +# ============================================================ diff --git a/vignettes/GLM-Predictor.Rmd b/vignettes/GLM-Predictor.Rmd new file mode 100644 index 000000000..e5b79caed --- /dev/null +++ b/vignettes/GLM-Predictor.Rmd @@ -0,0 +1,184 @@ +--- +title: "GLM Predictor Virtual Tracks" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{GLM Predictor Virtual Tracks} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r, include = FALSE} +knitr::opts_chunk$set( + collapse = TRUE, + comment = "#>" +) +``` + +## Overview + +`glm_pred.create()` registers a virtual track that computes a fused linear model prediction at each genome position. The full pipeline — track reads, aggregation, capping, logistic transforms, linear weights, and pairwise interactions — runs in a single C++ pass, avoiding the overhead of composing multiple virtual tracks and R-level combining expressions. + +This vignette describes the mathematical formulation implemented by `glm_pred`. For usage examples and the R API, see `?glm_pred.create`. + +## Mathematical Formulation + +### Core Formula + +At each genome position $p$ (defined as the midpoint of the iterator interval), the GLM predictor computes: + +$$ +\hat{y}(p) = \beta_0 + \sum_{i=1}^{N} w_i \cdot f_i\bigl(\operatorname{scale}_i(\operatorname{smooth}_i(p))\bigr) + \sum_{m=1}^{M} u_m \cdot g_m\bigl(\operatorname{product}_m(p)\bigr) +$$ + +where: + +- $\beta_0$ is the intercept (`bias`), +- $w_i$ are the main-effect weights (`weights`), +- $u_m$ are the interaction weights (`interaction_weights`), +- $f_i$ and $g_m$ are optional per-entry and per-interaction logistic transforms, +- and $N$, $M$ are the number of entries and interactions respectively. + +The computation proceeds in four stages for each entry: **smooth**, **scale**, **transform**, **weight**. + +### Stage 1: Smooth (Aggregation) + +Each entry $i$ references a genomic track $T_i$ and an aggregation function (sum or log-sum-exp). A shift window $[s_i, e_i]$ offsets the query position. + +**Without kernel smoothing** (`kernel_bins = NULL`): + +$$ +\operatorname{smooth}_i(p) = \operatorname{agg}\bigl(T_i,\; [p + s_i,\; p + e_i]\bigr) +$$ + +where $\operatorname{agg}$ is one of: + +$$ +\operatorname{sum}(T, W) = \sum_{j \in W} T_j, \qquad +\operatorname{lse}(T, W) = \log\!\Bigl(\sum_{j \in W} \exp(T_j)\Bigr) +$$ + +The LSE is computed with the numerically stable two-pass form: $\max_j T_j + \log\bigl(\sum_j \exp(T_j - \max_j T_j)\bigr)$. + +**With kernel smoothing** (`kernel_bins` and `kernels` specified): + +Let $c_i = p + (s_i + e_i)/2$ be the window center and let $\{d_1, \ldots, d_B\}$ be the kernel bin offsets. Let $k_{i,b}$ be the kernel weight for entry $i$ at offset $b$. + +For **sum** aggregation: + +$$ +\operatorname{smooth}_i(p) = \sum_{b=1}^{B} k_{i,b} \cdot T_i(c_i + d_b) +$$ + +For **lse** aggregation, the kernel multiplies the exponentiated values before re-logarithmizing: + +$$ +\operatorname{smooth}_i(p) = \log\!\Bigl(\sum_{b=1}^{B} k_{i,b} \cdot \exp\bigl(T_i(c_i + d_b)\bigr)\Bigr) = \operatorname{LSE}_b\!\bigl(\log k_{i,b} + T_i(c_i + d_b)\bigr) +$$ + +where $T_i(q)$ denotes the value of track $T_i$ at the native bin containing position $q$. + +If all values in the window are `NaN`, the entire position emits `NaN`. + +### Stage 2: Scale (Cap and Normalize) + +Scaling maps the raw aggregated value to a bounded range. Two modes are available: + +**Standard cap-normalize** (default when `max_cap` is specified): + +$$ +\operatorname{scale}(x) = S \cdot \frac{\max\!\bigl(\min(x - C_i,\; 0),\; -D_i\bigr) + D_i}{D_i} +$$ + +where $C_i$ = `max_cap[i]`, $D_i$ = `dis_from_cap[i]`, and $S$ = `scale_factor`. + +This maps the interval $[C_i - D_i,\; C_i] \to [0,\; S]$. Values above $C_i$ are clamped to $S$; values below $C_i - D_i$ are clamped to $0$. + +**Simple cap-and-divide** (when `simple_cap[i] = TRUE`): + +$$ +\operatorname{scale}(x) = \frac{\min(x,\; C_i)}{D_i} +$$ + +When neither `max_cap` nor `dis_from_cap` are specified for entry $i$, scaling is the identity: $\operatorname{scale}(x) = x$. + +### Stage 3: Transform (Logistic) + +When `trans_family[i] = "logist"`, a generalized logistic function is applied: + +$$ +f_i(x) = \frac{L_i}{1 + \exp\!\bigl(-k_i \cdot ((x + \delta^{\text{pre}}_i) - x_{0,i})\bigr)} + \delta^{\text{post}}_i +$$ + +with parameters $L_i$, $k_i$, $x_{0,i}$, $\delta^{\text{pre}}_i$ (`pre_shift`), and $\delta^{\text{post}}_i$ (`post_shift`). When `trans_family[i]` is `NA`, the transform is the identity: $f_i(x) = x$. + +The implementation uses a fast $\exp$ approximation (degree-5 Taylor series with `ldexp`) for inputs in $[-20, 20]$, with maximum relative error $< 0.01\%$. + +### Stage 4: Weight and Sum + +Each main effect contributes: + +$$ +\text{main\_effect}_i = w_i \cdot f_i\!\bigl(\operatorname{scale}_i(\operatorname{smooth}_i(p))\bigr) +$$ + +### Interactions + +Interactions operate on **post-scaling, pre-transform** values. Both entries are in $[0, S]$ after scaling; their product is re-normalized by $S$ to remain in $[0, S]$. + +**Without kernel smoothing:** + +Let $\tilde{x}_i = \operatorname{scale}_i(\operatorname{smooth}_i(p))$ and $\tilde{x}_j = \operatorname{scale}_j(\operatorname{smooth}_j(p))$. For interaction $m$ between entries $(i, j)$: + +$$ +\operatorname{product}_m(p) = \frac{\tilde{x}_i \cdot \tilde{x}_j}{S} +$$ + +**With kernel smoothing:** + +The product is computed per kernel bin and then aggregated: + +$$ +\operatorname{product}_m(p) = \sum_{b=1}^{B} k_{i,b} \cdot \frac{\tilde{x}_{i,b} \cdot \tilde{x}_{j,b}}{S} +$$ + +where $\tilde{x}_{i,b}$ is the scaled value of entry $i$ at kernel bin offset $d_b$ (i.e., scaling is applied per bin before the kernel-weighted sum, and the logistic is not yet applied). + +An optional per-interaction logistic transform $g_m$ (same functional form as $f_i$) is applied to the product. The interaction contribution is: + +$$ +\text{interaction}_m = u_m \cdot g_m\!\bigl(\operatorname{product}_m(p)\bigr) +$$ + +## Selector-Stratified Models + +When `selector_tracks` (a length-$M$ character vector) and `selector_breaks` (a length-$M$ list of break vectors) are provided, the model becomes position-dependent: at each position $p$, every selector track value is binned independently, and the resulting tuple selects one of $K = \prod_{m=1}^{M} K_m$ compound strata. The compound bin index uses **column-major flatten** (first selector varies fastest): + +$$ +b(p) = \sum_{m=1}^{M} \bigl(b_m(p) - 1\bigr) \cdot \prod_{m' < m} K_{m'} +$$ + +so $b(p) \in \{0, \ldots, K-1\}$. The model formula becomes: + +$$ +\hat{y}(p) = \beta_{0,b} + \sum_{i=1}^{N} w_{i,b} \cdot f_i\!\bigl(\operatorname{scale}_i(\operatorname{smooth}_i(p))\bigr) + \sum_{m=1}^{M} u_{m,b} \cdot g_m\!\bigl(\operatorname{product}_m(p)\bigr) +$$ + +where $b = b(p)$. Only the weights and bias vary across strata — the pipeline structure (tracks, shifts, capping, transforms) is shared. If **any** selector value $v_m(p)$ falls outside its break range or is non-finite, the position emits `NaN`. + +The `weights` parameter is then an $N \times K$ matrix (one column per compound stratum), `bias` is a length-$K$ vector, and `interaction_weights` is an $M_{\text{int}} \times K$ matrix. To build $K$ in R from a multi-axis array, use the column-major flatten: + +```r +# (N × K_1 × K_2 × ... × K_M) array, then flatten to (N × K) matrix. +w <- array(coef, dim = c(N, K_1, K_2)) # extend for more selectors +weights <- matrix(w, nrow = N) # R's default = column-major +``` + +The single-selector case ($M = 1$) is just a length-1 `selector_tracks` and a length-1 `selector_breaks` list. + +## NaN Handling + +`NaN` bins within an aggregation window are skipped, consistent with the default behavior of misha virtual tracks (e.g., `gvtrack.create(func = "sum")`). A window with some `NaN` bins aggregates the finite bins only. If **all** bins in an entry's window are `NaN`, the entire position's result is `NaN`. + +Note: `Inf` values in track data are converted to `NaN` at the track-reading layer, so they are treated as missing. + +As a defensive guard, non-finite intermediate values from later stages (which can only arise from degenerate parameter configurations such as `dis_from_cap = 0` or `scale_factor = 0`) are replaced with $0$.