Merge pull request #124 from tidyomics/new-slices

New slices

Author: mikelove

NAMESPACE

@@ -174,6 +174,21 @@ S3method(setdiff_ranges_directed,GenomicRanges)
 S3method(slice,GroupedGenomicRanges)
 S3method(slice,GroupedIntegerRanges)
 S3method(slice,Ranges)
+S3method(slice_head,GroupedGenomicRanges)
+S3method(slice_head,GroupedIntegerRanges)
+S3method(slice_head,Ranges)
+S3method(slice_max,GroupedGenomicRanges)
+S3method(slice_max,GroupedIntegerRanges)
+S3method(slice_max,Ranges)
+S3method(slice_min,GroupedGenomicRanges)
+S3method(slice_min,GroupedIntegerRanges)
+S3method(slice_min,Ranges)
+S3method(slice_sample,GroupedGenomicRanges)
+S3method(slice_sample,GroupedIntegerRanges)
+S3method(slice_sample,Ranges)
+S3method(slice_tail,GroupedGenomicRanges)
+S3method(slice_tail,GroupedIntegerRanges)
+S3method(slice_tail,Ranges)
 S3method(slide_ranges,Ranges)
 S3method(stretch,AnchoredGenomicRanges)
 S3method(stretch,AnchoredIntegerRanges)
@@ -434,6 +449,11 @@ importFrom(dplyr,pull)
 importFrom(dplyr,sample_n)
 importFrom(dplyr,select)
 importFrom(dplyr,slice)
+importFrom(dplyr,slice_head)
+importFrom(dplyr,slice_max)
+importFrom(dplyr,slice_min)
+importFrom(dplyr,slice_sample)
+importFrom(dplyr,slice_tail)
 importFrom(dplyr,summarise)
 importFrom(dplyr,summarize)
 importFrom(dplyr,tbl_vars)

R/dplyr-slice.R

@@ -9,14 +9,44 @@ generate_slice <- function(.data, dots) {
   inx
 }
 
-#' Choose rows by their position
+#' Choose ranges by their position
+#' 
+#' @description
+#' The `slice` family of functions let you select ranges by position.  They
+#' follow the same conventions as their dplyr counterparts for data frames:
+#'
+#' * `slice()` selects ranges by explicit integer position.
+#' * `slice_head()` / `slice_tail()` select the first or last ranges.
+#' * `slice_sample()` randomly selects ranges.
+#' * `slice_min()` / `slice_max()` select ranges with the smallest or largest
+#'   values of a metadata column.
+#'
+#' All functions preserve grouping: when `.data` has been grouped with
+#' [group_by()], selection is performed within each group.
+#'
+#' @param .data a `Ranges` object.
+#' @param ... <[`data-masking`][rlang::args_data_masking]> Integer row values
+#'   indicating positions to keep.  Only used by `slice()`; ignored elsewhere.
+#' @param n Number of ranges to select.  Mutually exclusive with `prop`.
+#'   For `slice_min()` and `slice_max()`, negative values are not supported.
+#' @param prop Fraction of ranges to select, in `(0, 1]`.  Mutually exclusive
+#'   with `n`.
+#' @param order_by <[`data-masking`][rlang::args_data_masking]> Unquoted name
+#'   of a numeric metadata column to order by.  Used by `slice_min()` and
+#'   `slice_max()`.
+#' @param with_ties If `TRUE` (the default), all ranges tied at the boundary
+#'   rank are kept, which may return more than `n` ranges.  Set to `FALSE` to
+#'   return exactly `n`.  Used by `slice_min()` and `slice_max()`.
+#' @param weight_by <[`data-masking`][rlang::args_data_masking]> Unquoted name
+#'   of a non-negative numeric metadata column used as sampling weights.  Used
+#'   by `slice_sample()`.
+#' @param replace Should sampling be with replacement?  Default `FALSE`.  Used
+#'   by `slice_sample()`.
+#' @param .preserve Ignored; retained for compatibility with the dplyr generic.
+#'
+#' @return A `GRanges` (or `IRanges`) object of the same class as `.data`, with
+#'   grouping structure re-applied when `.data` was grouped.
 #' 
-#' @param .data a `Ranges` object
-#' @param ... Integer row values indicating rows to keep. If `.data` has
-#' been grouped via [group_by.GenomicRanges()], then the positions are selected within each group.
-#' @param .preserve when FALSE (the default) the grouping structure is 
-#' recomputed, otherwise it is kept as is. Currently ignored. 
-#' @return a GRanges object
 #' @method slice Ranges
 #' @importFrom dplyr slice
 #' @rdname slice-ranges
@@ -97,5 +127,292 @@ check_length <- function(length, n, replace = FALSE) {
   )
 }
 
+# the following generated by Claude Sonnet 4.6 as part of adding new slice functionality
+# 2026-03-18
+
+# ── slice_head() methods ───────────────────────────────────────────────────────
+
+#' @rdname slice-ranges
+#' @importFrom dplyr slice_head
+#' @method slice_head Ranges
+#' @export
+slice_head.Ranges <- function(.data, ..., n = NULL, prop = NULL,
+                              .preserve = FALSE) {
+  inx <- head_tail_index(length(.data), n = n, prop = prop, from_head = TRUE)
+  .data[inx, ]
+}
+
+#' @rdname slice-ranges
+#' @method slice_head GroupedGenomicRanges
+#' @export
+slice_head.GroupedGenomicRanges <- function(.data, ..., n = NULL, prop = NULL,
+                                            .preserve = FALSE) {
+  apply_grouped_slice(
+    .data,
+    function(grp_size) head_tail_index(grp_size, n = n, prop = prop,
+                                       from_head = TRUE)
+  )
+}
+
+#' @rdname slice-ranges
+#' @method slice_head GroupedIntegerRanges
+#' @export
+slice_head.GroupedIntegerRanges <- slice_head.GroupedGenomicRanges
+
+
+# ── slice_tail() methods ───────────────────────────────────────────────────────
+
+#' @rdname slice-ranges
+#' @importFrom dplyr slice_tail
+#' @method slice_tail Ranges
+#' @export
+slice_tail.Ranges <- function(.data, ..., n = NULL, prop = NULL,
+                              .preserve = FALSE) {
+  inx <- head_tail_index(length(.data), n = n, prop = prop, from_head = FALSE)
+  .data[inx, ]
+}
+
+#' @rdname slice-ranges
+#' @method slice_tail GroupedGenomicRanges
+#' @export
+slice_tail.GroupedGenomicRanges <- function(.data, ..., n = NULL, prop = NULL,
+                                            .preserve = FALSE) {
+  apply_grouped_slice(
+    .data,
+    function(grp_size) head_tail_index(grp_size, n = n, prop = prop,
+                                       from_head = FALSE)
+  )
+}
+
+#' @rdname slice-ranges
+#' @method slice_tail GroupedIntegerRanges
+#' @export
+slice_tail.GroupedIntegerRanges <- slice_tail.GroupedGenomicRanges
+
+
+# ── slice_sample() methods ─────────────────────────────────────────────────────
+
+#' @rdname slice-ranges
+#' @importFrom dplyr slice_sample
+#' @method slice_sample Ranges
+#' @export
+slice_sample.Ranges <- function(.data, ..., n = NULL, prop = NULL,
+                                weight_by = NULL, replace = FALSE,
+                                .preserve = FALSE) {
+  total   <- length(.data)
+  size    <- resolve_n_prop(total, n = n, prop = prop, replace = replace)
+  weights <- eval_weight_by(.data, rlang::enquo(weight_by))
+  inx     <- sample.int(total, size, replace = replace, prob = weights)
+  .data[inx, ]
+}
+
+#' @rdname slice-ranges
+#' @method slice_sample GroupedGenomicRanges
+#' @export
+slice_sample.GroupedGenomicRanges <- function(.data, ..., n = NULL,
+                                              prop = NULL, weight_by = NULL,
+                                              replace = FALSE,
+                                              .preserve = FALSE) {
+  weight_quo <- rlang::enquo(weight_by)
+  rng        <- .data@delegate
+  grp_rows   <- .group_rows(.data)
 
+  selected <- lapply(grp_rows, function(i) {
+    sub       <- rng[i]
+    size      <- resolve_n_prop(length(i), n = n, prop = prop, replace = replace)
+    w         <- eval_weight_by(sub, weight_quo)
+    local_inx <- sample.int(length(i), size, replace = replace, prob = w)
+    i[local_inx]
+  })
 
+  rng_out <- rng[sort(unlist(selected))]
+  group_by(rng_out, !!!groups(.data))
+}
+
+#' @rdname slice-ranges
+#' @method slice_sample GroupedIntegerRanges
+#' @export
+slice_sample.GroupedIntegerRanges <- slice_sample.GroupedGenomicRanges
+
+
+# ── slice_min() methods ────────────────────────────────────────────────────────
+
+#' @rdname slice-ranges
+#' @importFrom dplyr slice_min
+#' @method slice_min Ranges
+#' @export
+slice_min.Ranges <- function(.data, order_by, n = NULL, prop = NULL,
+                             with_ties = TRUE, .preserve = FALSE) {
+  order_quo <- rlang::enquo(order_by)
+  inx <- minmax_index(.data, order_quo, n = n, prop = prop,
+                      with_ties = with_ties, decreasing = FALSE)
+  .data[inx, ]
+}
+
+#' @rdname slice-ranges
+#' @method slice_min GroupedGenomicRanges
+#' @export
+slice_min.GroupedGenomicRanges <- function(.data, order_by, n = NULL,
+                                           prop = NULL, with_ties = TRUE,
+                                           .preserve = FALSE) {
+  order_quo <- rlang::enquo(order_by)
+  apply_grouped_minmax(.data, order_quo, n = n, prop = prop,
+                       with_ties = with_ties, decreasing = FALSE)
+}
+
+#' @rdname slice-ranges
+#' @method slice_min GroupedIntegerRanges
+#' @export
+slice_min.GroupedIntegerRanges <- slice_min.GroupedGenomicRanges
+
+
+# ── slice_max() methods ────────────────────────────────────────────────────────
+
+#' @rdname slice-ranges
+#' @importFrom dplyr slice_max
+#' @method slice_max Ranges
+#' @export
+slice_max.Ranges <- function(.data, order_by, n = NULL, prop = NULL,
+                             with_ties = TRUE, .preserve = FALSE) {
+  order_quo <- rlang::enquo(order_by)
+  inx <- minmax_index(.data, order_quo, n = n, prop = prop,
+                      with_ties = with_ties, decreasing = TRUE)
+  .data[inx, ]
+}
+
+#' @rdname slice-ranges
+#' @method slice_max GroupedGenomicRanges
+#' @export
+slice_max.GroupedGenomicRanges <- function(.data, order_by, n = NULL,
+                                           prop = NULL, with_ties = TRUE,
+                                           .preserve = FALSE) {
+  order_quo <- rlang::enquo(order_by)
+  apply_grouped_minmax(.data, order_quo, n = n, prop = prop,
+                       with_ties = with_ties, decreasing = TRUE)
+}
+
+#' @rdname slice-ranges
+#' @method slice_max GroupedIntegerRanges
+#' @export
+slice_max.GroupedIntegerRanges <- slice_max.GroupedGenomicRanges
+
+
+# ── Internal helpers ───────────────────────────────────────────────────────────
+
+generate_slice <- function(.data, dots) {
+  os  <- overscope_ranges(.data)
+  inx <- overscope_eval_update(os, dots, bind_envir = FALSE)
+  check_num <- vapply(inx, is.numeric, logical(1))
+  if (any(!check_num)) {
+    stop("slice condition does not evaluate to an integer or numeric vector")
+  }
+  inx
+}
+
+# Resolve n / prop to a concrete integer size.
+resolve_n_prop <- function(total, n = NULL, prop = NULL, replace = FALSE) {
+  if (!is.null(n) && !is.null(prop)) {
+    stop("Exactly one of `n` or `prop` must be supplied, not both.")
+  }
+  if (!is.null(prop)) {
+    if (prop <= 0 || prop > 1) stop("`prop` must be in (0, 1].")
+    n <- max(1L, floor(prop * total))
+  }
+  if (is.null(n)) n <- 1L  # default to n = 1
+  n <- as.integer(n)
+  if (!replace && n > total) {
+    stop(paste("`n` (", n, ") must be <= length of .data (", total, ").",
+               "Set `replace = TRUE` to use sampling with replacement."))
+  }
+  n
+}
+
+# Build a positional index for head / tail selection.
+head_tail_index <- function(total, n = NULL, prop = NULL, from_head) {
+  size <- resolve_n_prop(total, n = n, prop = prop)
+  if (from_head) seq_len(size) else seq.int(total - size + 1L, total)
+}
+
+# Evaluate an optional weight_by quosure against .data's mcols.
+eval_weight_by <- function(.data, weight_quo) {
+  if (rlang::quo_is_null(weight_quo)) return(NULL)
+  col_name <- rlang::as_name(weight_quo)
+  w <- mcols(.data)[[col_name]]
+  if (is.null(w)) stop(paste0("Column '", col_name, "' not found in .data."))
+  if (any(w < 0, na.rm = TRUE)) stop("`weight_by` values must be non-negative.")
+  w
+}
+
+# Shared guard used by slice_min / slice_max.
+check_column_numeric <- function(x, col) {
+  if (!is.numeric(x)) {
+    stop(paste0("`", col, "` must be a numeric column for slice_min / slice_max"))
+  }
+}
+
+# Build an ordering index for slice_min / slice_max.
+minmax_index <- function(.data, order_quo, n = NULL, prop = NULL, with_ties,
+                         decreasing) {
+  col_name <- rlang::as_name(order_quo)
+  vals     <- mcols(.data)[[col_name]]
+  if (is.null(vals)) stop(paste0("Column '", col_name, "' not found in .data."))
+  check_column_numeric(vals, col_name)
+
+  total <- length(.data)
+  size  <- resolve_n_prop(total, n = n, prop = prop)
+  ord   <- order(vals, decreasing = decreasing, na.last = NA)
+
+  if (with_ties) {
+    threshold <- vals[ord[min(size, length(ord))]]
+    keep <- if (decreasing) which(vals >= threshold) else which(vals <= threshold)
+    sort(keep)
+  } else {
+    sort(ord[seq_len(min(size, length(ord)))])
+  }
+}
+
+# Apply a grouped slice using a per-group index function.
+# `index_fn` receives the group size and returns *local* indices.
+apply_grouped_slice <- function(.data, index_fn) {
+  rng      <- .data@delegate
+  grp_rows <- .group_rows(.data)
+
+  selected <- lapply(grp_rows, function(i) {
+    local_inx <- index_fn(length(i))
+    local_inx <- local_inx[local_inx >= 1L & local_inx <= length(i)]
+    i[local_inx]
+  })
+
+  rng_out <- rng[sort(unlist(selected))]
+  group_by(rng_out, !!!groups(.data))
+}
+
+# Grouped min / max helper.
+apply_grouped_minmax <- function(.data, order_quo, n = NULL, prop = NULL,
+                                 with_ties, decreasing) {
+  col_name <- rlang::as_name(order_quo)
+  rng      <- .data@delegate
+  grp_rows <- .group_rows(.data)
+
+  selected <- lapply(grp_rows, function(i) {
+    sub  <- rng[i]
+    vals <- mcols(sub)[[col_name]]
+    if (is.null(vals)) stop(paste0("Column '", col_name, "' not found."))
+    check_column_numeric(vals, col_name)
+
+    size <- resolve_n_prop(length(i), n = n, prop = prop)
+    ord  <- order(vals, decreasing = decreasing, na.last = NA)
+
+    local_inx <- if (with_ties) {
+      threshold <- vals[ord[min(size, length(ord))]]
+      if (decreasing) which(vals >= threshold) else which(vals <= threshold)
+    } else {
+      ord[seq_len(min(size, length(ord)))]
+    }
+
+    i[sort(local_inx)]
+  })
+
+  rng_out <- rng[sort(unlist(selected))]
+  group_by(rng_out, !!!groups(.data))
+}