group mutate revamp

NAMESPACE

@@ -316,6 +316,7 @@ exportClasses(DeferredGenomicRanges)
 exportClasses(FileOperator)
 exportClasses(GroupedGenomicRanges)
 exportClasses(GroupedIntegerRanges)
+import(dplyr)
 importFrom(BiocGenerics,"%in%")
 importFrom(BiocGenerics,"end<-")
 importFrom(BiocGenerics,"score<-")
@@ -476,5 +477,6 @@ importFrom(rtracklayer,import.gff1)
 importFrom(rtracklayer,import.gff2)
 importFrom(rtracklayer,import.gff3)
 importFrom(rtracklayer,import.wig)
+importFrom(tidyselect,all_of)
 importFrom(tidyselect,eval_select)
 importFrom(utils,relist)

R/dplyr-mutate.R

@@ -1,37 +1,59 @@
-mutate_mcols <- function(.data, .mutated) {
+mutate_mcols <- function(.data, dots) {
+
+  overscope <- overscope_ranges(.data)
+  .mutated <- overscope_eval_update(overscope, dots)
+
   all_cols <- names(.mutated)
   only_mcols <- !(all_cols %in%
                     c("start", "end", "width", "seqnames", "strand"))
   .mutated <- .mutated[only_mcols]
   update_cols <- all_cols[only_mcols]
-
+  
   matches_mcols <- match(update_cols, names(mcols(.data)))
   idx_mcols <- !is.na(matches_mcols)
-
+  
   if (any(idx_mcols)) {
     mcols(.data)[matches_mcols[idx_mcols]] <- .mutated[idx_mcols]
   }
-
+  
   if (!all(idx_mcols)) {
     if (is.null(mcols(.data))) {
       mcols(.data) <- S4Vectors::DataFrame(.mutated[!idx_mcols])
     } else {
+
       mcols(.data) <- S4Vectors::DataFrame(list(mcols(.data), 
                                                 .mutated[!idx_mcols]))
     }
   }
   .data
 }
 
+
+#' @import dplyr
+#' @importFrom tidyselect all_of
+mutate_mcols_grp <- function(df, dots) {
+
+  core_cols <- intersect(colnames(df),c("start", "end", "width", "seqnames", "strand"))
+
+  df <- mutate(df, !!!dots) %>%
+    ungroup() %>%
+    dplyr::select(-tidyselect::all_of(core_cols)) %>%
+    as("DataFrame")
+}
+
 #' @importFrom methods selectMethod
-mutate_core <- function(.data, .mutated) {
+mutate_core <- function(.data, dots) {
+
+  overscope <- overscope_ranges(.data)
+  .mutated <- overscope_eval_update(overscope, dots)
+
   all_cols <- names(.mutated)
   core_cols <- all_cols[all_cols %in%
-                           c("start", "end", "width", "seqnames", "strand")]
+                          c("start", "end", "width", "seqnames", "strand")]
   if (length(core_cols == 0)) {
     .data
   }
-
+  
   for (col in core_cols) {
     modifier <- match.fun(paste0("set_", col))
     .data <- modifier(.data, .mutated[[col]])
@@ -40,36 +62,68 @@ mutate_core <- function(.data, .mutated) {
 }
 
 
-mutate_rng <- function(.data, dots) {
+
+mutate_rng <- function(.data, ...) {
+
+  dots <- set_dots_named(...)
+
   col_names <- names(dots)
+  core_cols <- col_names %in% c("start", "end", "width", "seqnames", "strand")
   if (any(col_names %in% "")) {
     stop("mutate must have name-variable pairs as input", call. = FALSE)
   }
-
-  overscope <- overscope_ranges(.data)
-  .mutated <- overscope_eval_update(overscope, dots)
-  .data <- mutate_core(.data, .mutated)
-  mutate_mcols(.data, .mutated)
+
+  if(any(core_cols)) {
+    .data <- mutate_core(.data, dots)
+  }
+
+  if(any(!core_cols)) {
+    .data <- mutate_mcols(.data,
+                          dots)
+  }
+  return(.data)
 }
 
-# idea could simply dispatch to summarise here, and store 
-# list columns, if the length is smaller then we can repeat,
-# otherwise we try to expand 
+#' @importFrom dplyr group_by
 mutate_grp <- function(.data, ...) {
   dots <- set_dots_named(...)
-  inx <- .group_rows(.data)
-  rng <- unname(S4Vectors::split(.data@delegate, .data@group_indices))
-  rng <- S4Vectors::endoapply(rng, function(x) {
-    mutate_rng(x, dots)    
-  })
-
-  rng <- unlist(rng)[BiocGenerics::order(unlist(inx))]
-  new(class(.data),
-      delegate = rng, 
-      group_keys =  .data@group_keys, 
-      group_indices = .data@group_indices,
-      n = .data@n )
+
+
+  col_names <- names(dots)
+  core_cols <- col_names %in% c("start", "end", "width", "seqnames", "strand")
+  if (any(col_names %in% "")) {
+    stop("mutate must have name-variable pairs as input", call. = FALSE)
+  }
+
+  if(any(core_cols)) {
+    inx <- .group_rows(.data)
+    rng <- unname(S4Vectors::split(.data@delegate, .data@group_indices))
+    rng <- S4Vectors::endoapply(rng, function(x) {
+      mutate_core(x, dots)  
+    })
+
+    rng <- unlist(rng)[BiocGenerics::order(unlist(inx))]
+    new(class(.data),
+        delegate = rng, 
+        group_keys =  .data@group_keys, 
+        group_indices = .data@group_indices,
+        n = .data@n )
+  }
+
+  if (any(!core_cols)) {
+    grps <- group_vars(.data)
+
+    df <- as.data.frame(ungroup(.data))
+
+    df <- group_by(df,!!!rlang::syms(grps))
+
+    mcols(.data) <-
+      mutate_mcols_grp(df,
+                   dots)
+  }
+  return(.data)
 }
+
 #' Modify a Ranges object
 #'
 #' @param .data a `Ranges` object
@@ -123,8 +177,7 @@ mutate_grp <- function(.data, ...) {
 #'     mutate(width = width * 2)
 #' @export
 mutate.Ranges <- function(.data, ...) {
-  dots <- set_dots_named(...)
-  mutate_rng(.data, dots)
+  mutate_rng(.data, ...)
 }
 
 #' @method mutate AnchoredIntegerRanges

R/ranges-colwise.R

@@ -40,7 +40,8 @@ names_to_column <- function(.data, var = "name") {
   if (is.null(names(.data))) {
     stop("No names present in .data")
   }
-  .data <- mutate(.data, `:=`(!!var, names(.data)))
+  r_names <- names(.data)
+  .data <- mutate(.data, `:=`(!!rlang::sym(var), r_names))
   .data <- select(.data, !!var, tidyselect::everything())
   remove_names(.data)
 }
@@ -52,8 +53,8 @@ id_to_column <- function(.data, var = "id") {
   if (var %in% names(mcols(.data))) {
     stop(paste("Column", var, "already exists in .data."))
   }
-
-  .data <- mutate(.data, `:=`(!!var, seq_len(length(.data))))
+  r_id <- seq_len(length(.data))
+  .data <- mutate(.data, `:=`(!!var, r_id))
   .data <- select(.data, !!var, tidyselect::everything())
   remove_names(.data)
 }

R/ranges-expand.R

@@ -25,6 +25,7 @@
 #' grng <- mutate(grng, 
 #'                exon_id = IntegerList(a = 1, b = c(4,5), c = 3, d = c(2,5))
 #'                )
+#' grng                
 #' expand_ranges(grng)
 #' expand_ranges(grng, .id = "name")
 #' 

tests/testthat/test-disjoin.R

@@ -64,8 +64,8 @@ test_that("matches IRanges/GRanges tests", {
   gr_by_group <- stack(grl, "name") %>% group_by(name)
 
   target <- stack(disjoin(grl, ignore.strand = TRUE), "name")
-  current <- disjoin_ranges(gr_by_group) %>%
-    mutate(name = Rle(name))
+  current <- disjoin_ranges(gr_by_group)
+
   expect_identical(target, current)
 })
 

tests/testthat/test-unnest.R

@@ -12,9 +12,10 @@ test_that("expanding makes sense", {
 
   # by default expand_ranges does cartesian product of list columns
   gr <- as_granges(data.frame(seqnames = "chr1", start = 20:22, width = 1000))
+
   gr <- mutate(gr,
-                 col1 = IntegerList(a = 1, b = c(4,5), c = c(2,3)),
-                 col2 = IntegerList(c(1,2), c(3,4), c(5)),
+                 col1 = IntegerList(a = 1L, b = c(4L,5L), c = c(2L,3L)),
+                 col2 = IntegerList(c(1L,2L), c(3L,4L), c(5L)),
                  score = 1:3)
 
   correct_gr <- GRanges(seqnames = "chr1",
@@ -23,7 +24,9 @@ test_that("expanding makes sense", {
                         col1 = c(1L,1L,4L,4L,5L,5L,2L,3L),
                         col2 = c(1L,2L,3L,4L,3L,4L,5L,5L),
                         score = c(1L,1L,2L,2L,2L,2L,3L,3L))
+
   test_gr <- expand_ranges(gr, .recursive = TRUE)
+
   expect_identical(correct_gr, test_gr)
   test_gr <- expand_ranges(gr, col1, col2, .recursive = TRUE)
   expect_identical(correct_gr, test_gr)
@@ -42,7 +45,7 @@ test_that("expanding makes sense", {
                           ranges = IRanges(start = c(20,21,21,22,22),
                                            width = 1000),
                           col1 = as.integer(c(1,4,5,2,3)),
-                          col2 = IntegerList(c(1,2), c(3,4), c(3,4), 5,5),
+                          col2 = IntegerList(c(1L,2L), c(3L,4L), c(3L,4L), 5L,5L),
                           score = as.integer(c(1,2,2,3,3)))
   test_gr <- expand_ranges(gr, col1)
   expect_identical(correct_gr, test_gr)
@@ -75,7 +78,7 @@ test_that("expanding makes sense", {
                         ranges = IRanges(start = c(20,21,21,22,22),
                                          width = 1000),
                         col1 = as.integer(c(1,4,5,2,3)),
-                        col2 = IntegerList(c(1,2), c(3,4), c(3,4), 5,5),
+                        col2 = IntegerList(c(1L,2L), c(3L,4L), c(3L,4L), 5L,5L),
                         score = as.integer(c(1,2,2,3,3)),
                         id1 = c("a", "b", "b", "c", "c"))
   test_gr <- expand_ranges(gr, col1, .id = "id1", .recursive = TRUE)