Ускорение вложенных циклов в R

Question

У меня есть большой datframe (около 3 миллионов строк), которые содержат ID, год и три даты каждый: lookupdate, date1 и date2. data.frame сортируется по ID и date1. Я хочу, чтобы выполнить поиск по всему набору данных и найти записи i которых:

• имеют financial_year == 2013 и
• содержат один и тот же ID, как и любой другой линии j таким образом, что date1[j] < lookupdate[i] < date2[j]

Я реализованного эта логика ниже, но это смехотворно медленно. Вы знаете, как ускорить этот код?

calc_hits_bruteforce <- function(d){ 
    N <- nrow(d) 
    hits <- rep(FALSE, N) 
    for (i in 2:N) { 
    if(d[i,"financial_year"]!=2013) next 
    for (j in i:1) { 
     if (d[i,"ID"]!=d[j,"ID"]) { 
     break 
     } 
     else { 
     if (d[j,"date1"] < d[i,"lookupdate"] & d[j, "date2"] > d[i, "lookupdate"]) { 
      hits[i] <- TRUE 
      break 
     } 
     } 
    } 
    } 
    hits 
} 

Я не знаю, сколько записей есть для каждого ID, но я знаю lookupdate для каждой записи лежит перед date1 и date2, т.е. lookupdate[i] < date1[i] < date2[i] для всех i.

Вот пример dataframe и выход:

> d.ex 
    ID  lookupdate  date1  date2 financial_year 
1 C143896B 2011-02-24 2011-11-09 2011-11-21   2011 
2 C143896G 2010-11-23 2011-10-29 2011-11-21   2011 
3 C143896G 2011-11-11 2012-10-12 2012-11-05   2012 
4 C143896G 2012-06-17 2013-01-30 2013-02-11   2013 
5 C143896G 2012-10-31 2013-09-15 2013-09-29   2013 
> calc_hits_bruteforce(d.ex) 
[1] FALSE FALSE FALSE FALSE TRUE 

В последней строке это значение TRUE, поскольку 2012-10-12 < < 2012-10-31 2012-11-05.

Answer 1

От того, как вы ставите вопрос, это звучит, как вы заинтересованы в логическом вектора длиной, равной количеству строк в d, так предварительно выделить что

hits = logical(nrow(d)) ## initialized to 'FALSE' 

You» заинтересованы в подмножество строк из конкретного финансового года, так векторизовать выбор

i_idx <- which(d$financial_year == 2013) 

Для каждого из них вы будете обновлять hits истинно, если любая другая строка удовлетворяет некоторому сложному условию; это не очевидно, как избежать внешнего контура (хотя конкретные особенности ваших данных (например, только несколько идентификаторов), могут предложить другую стратегию), но внутренняя петля может быть векторизована в

for (i in i_idx) 
    hits[i] <- any(d[, date1] < d[i, lookupdate] & 
        d[, date2] > d[i, lookupdate] & 
        d[, ID] == d[i, ID] & 
        seq_len(nrow(d)) < i) 
} 

Так комбинированные и с небольшой оптимизацией

calc_hits_bruteforce <- function(d) { 
    hits <- logical(nrow(d)) 
    i_idx <- which(d$financial_year == 2013) 
    for (i in i_idx) { 
     lkup <- d[i, lookupdate] 
     hits[i] <- any((d$date1 < lkup) & (d$date2 > lkup) & 
         (d$ID == d[i, ID]) & (seq_len(nrow(d)) < i)) 

    } 
    hits 
} 

Это будет быстрее, чем оригинал, но не использует отсортированный характер ваших данных и масштабируется примерно с количеством строк в кадре данных (а не с квадратом количество строк, как в вашем исходном алгоритме).

Одним из возможных улучшений является использование пакета Bioconductor IRanges. Установить и прикрепить с помощью

source("http://bioconductor.org/biocLite.R") 
biocLite("IRanges") 
library(IRanges) 

Иерархии являются целыми, поэтому представление дат становится важным.Я прочитал ваши данные как

txt <- "ID  lookupdate  date1  date2 financial_year 
C143896B 2011-02-24 2011-11-09 2011-11-21   2011 
C143896G 2010-11-23 2011-10-29 2011-11-21   2011 
C143896G 2011-11-11 2012-10-12 2012-11-05   2012 
C143896G 2012-06-17 2013-01-30 2013-02-11   2013 
C143896G 2012-10-31 2013-09-15 2013-09-29   2013" 

d <- read.delim(textConnection(txt), 
       colClasses=c("factor", "Date", "Date", "Date", "integer"), 
       sep="") 

Тогда представляют даты и поиск как IRanges (представление диапазон включает в себя конечные точки, но вы не заинтересованы в том, что).

dates = with(d, IRanges(as.integer(date1) + 1, as.integer(date2) - 1)) 
lkup = with(d, IRanges(as.integer(lookupdate), width=1)) 

Найти перекрывающиеся диапазоны (это находит все перекрывающиеся диапазоны, мы отсеять нежелательные значения позже, сравнение является эффективным, как описано на странице помощи IntervalTree?)

olaps = findOverlaps(query=dates, subject=lkup) 

и тонкой настройке

q_hits = queryHits(olaps); s_hits = subjectHits(olaps) 
keep = (d[s_hits, "financial_year"] == 2013) & 
    (d[s_hits, "ID"] == d[q_hits, "ID"]) & (q_hits < s_hits) 
tabulate(s_hits[keep], length(lkup)) != 0 

Это будет быстро, хотя я, возможно, ошибаюсь.

Answer 2

test <- structure(list(ID = c("C143896B", "C143896G", "C143896G", "C143896G", 
"C143896G"), lookupdate = structure(c(15029, 14936, 15289, 15508, 
15644), class = "Date"), date1 = structure(c(15287, 15276, 15625, 
15735, 15963), class = "Date"), date2 = structure(c(15299, 15299, 
15649, 15747, 15977), class = "Date"), financial_year = c(2011, 
2011, 2012, 2013, 2013)), .Names = c("ID", "lookupdate", "date1", 
"date2", "financial_year"), row.names = c(NA, -5L), class = "data.frame") 

Я хотел бы предложить это, но я боюсь, что я не мог проверить его производительность:

calc_hits_bruteforce2 <- function(db){ 
a <- sapply(test[,2],FUN=function(x)(test[,3] < x & x < test[,4])) 
b <- sapply(test[,1],FUN=function(x)(x==test[,1])) 
c <- matrix(sapply(test[,5], FUN=function(x)(x==2013)),nrow(a),nrow(a), byrow=T) 
d <- a==TRUE & a==b & a==c 
rows <- round(which(d==TRUE)/nrow(a)) 
test[rows,] 
} 


##   ID lookupdate  date1  date2 financial_year 
## 5 C143896G 2012-10-31 2013-09-15 2013-09-29   2013