эффективно объединить несколько апельсинов, которые охватывают один и тот же диапазон (сохраняя протоколы) - PullRequest
Новая
       33

эффективно объединить несколько апельсинов, которые охватывают один и тот же диапазон (сохраняя протоколы)

1 голос
/ 10 апреля 2019

Это продолжение вопроса, который я задал вчера , теперь расширен, чтобы включить более 2 входов.Я смог найти два связанных ответов по SO, но ни один из них не дал достаточно информации, чтобы я мог решить эту проблему эффективным способом.

Я хотел быобъединить список IRanges в один IRanges.Вот пример ввода: 

[[1]]
IRanges object with 2 ranges and 1 metadata column:
          start       end     width | on_betalac
      <integer> <integer> <integer> |  <logical>
  [1]         1        21        21 |      FALSE
  [2]        22        22         1 |       TRUE

[[2]]
IRanges object with 2 ranges and 1 metadata column:
          start       end     width |  on_other
      <integer> <integer> <integer> | <logical>
  [1]         1        21        21 |     FALSE
  [2]        22        22         1 |      TRUE

[[3]]
IRanges object with 1 range and 1 metadata column:
          start       end     width |    on_pen
      <integer> <integer> <integer> | <logical>
  [1]         1        22        22 |     FALSE

[[4]]
IRanges object with 3 ranges and 1 metadata column:
          start       end     width |   on_quin
      <integer> <integer> <integer> | <logical>
  [1]         1         3         3 |     FALSE
  [2]         4        13        10 |      TRUE
  [3]        14        22         9 |     FALSE

Для простоты репликации dput этого списка находится в конце моего поста.

И мой желаемый вывод: 

IRanges object with 4 ranges and 4 metadata columns:
          start       end     width | on_betalac  on_other    on_pen   on_quin
      <integer> <integer> <integer> |  <logical> <logical> <logical> <logical>
  [1]         1         3         3 |      FALSE     FALSE     FALSE     FALSE
  [2]         4        13        10 |      FALSE     FALSE     FALSE      TRUE
  [3]        14        21         8 |      FALSE     FALSE     FALSE     FALSE
  [4]        22        22         1 |       TRUE      TRUE     FALSE     FALSE

Вы можете видеть, что выходные данные похожи на разъединение входных данных, но с распространяющимися через них протоколами, так что у каждой выходной строки есть протоколы входной строки, которые "породили" ее.

Вот мое решение, которое работает, но довольно медленно. 

combine_exposures <- function(exposures) {

  cd <- do.call(what = c, args = exposures)
  mc <- mcols(cd)
  dj <- disjoin(x = cd, with.revmap = TRUE)
  r <- mcols(dj)$revmap

  d <- as.data.frame(matrix(nrow = length(dj), ncol = ncol(mc)))
  names(d) <- names(mc)

  for (i in 1:length(dj)) {
    d[i,] <- sapply(X = 1:ncol(mc), FUN = function(j) { mc[r[[i]][j], j] })
  }

  mcols(dj) <- d

  return(dj)
}

А вот результат ввода образца: 

list(new("IRanges", start = c(1L, 22L), width = c(21L, 1L), NAMES = NULL, 
    elementType = "ANY", elementMetadata = new("DataFrame", rownames = NULL, 
        nrows = 2L, listData = list(on_betalac = c(FALSE, TRUE
        )), elementType = "ANY", elementMetadata = NULL, metadata = list()), 
    metadata = list()), new("IRanges", start = c(1L, 22L), width = c(21L, 
1L), NAMES = NULL, elementType = "ANY", elementMetadata = new("DataFrame", 
    rownames = NULL, nrows = 2L, listData = list(on_other = c(FALSE, 
    TRUE)), elementType = "ANY", elementMetadata = NULL, metadata = list()), 
    metadata = list()), new("IRanges", start = 1L, width = 22L, 
    NAMES = NULL, elementType = "ANY", elementMetadata = new("DataFrame", 
        rownames = NULL, nrows = 1L, listData = list(on_pen = FALSE), 
        elementType = "ANY", elementMetadata = NULL, metadata = list()), 
    metadata = list()), new("IRanges", start = c(1L, 4L, 14L), 
    width = c(3L, 10L, 9L), NAMES = NULL, elementType = "ANY", 
    elementMetadata = new("DataFrame", rownames = NULL, nrows = 3L, 
        listData = list(on_quin = c(FALSE, TRUE, FALSE)), elementType = "ANY", 
        elementMetadata = NULL, metadata = list()), metadata = list()))

1 Ответ

0 голосов
/ 11 апреля 2019

Я придумал более эффективную версию, но все еще подозреваю, что она может быть намного быстрее. 

new_combine <- function(exposures) {

  cd <- do.call(what = c, args = exposures)
  mc <- mcols(cd)
  dj <- disjoin(x = cd, with.revmap = TRUE)
  r <- mcols(dj)$revmap

  m <- as.matrix(mc)[cbind(unlist(r),
                           rep(1:length(dj), times = ncol(mc)))]


  mcols(dj) <- setNames(as.data.frame(matrix(m, nrow = length(dj), byrow = TRUE)),
                        nm = names(mc))

  return(dj)
}

Я запустил bench :: mark и обнаружил, что эта версия примерно в 3 раза быстрее. Вероятно, этого достаточно для моего приложения, но я чувствую, что не совсем правильно использую IRanges. 

expression    min   mean median     max `itr/sec` mem_alloc  n_gc n_itr total_time
  <chr>      <bch:> <bch:> <bch:> <bch:t>     <dbl> <bch:byt> <dbl> <int>   <bch:tm>
1 old        77.9ms 83.9ms 81.3ms 138.1ms      11.9    35.6KB    74    40      3.36s
2 new        27.6ms 29.1ms 28.9ms  34.2ms      34.4    10.6KB    73   252      7.32s
...