加速R中的嵌套循环

时间:2014-09-01 17:51:53

标签: r performance loops nested

我有一个大型数据框(大约300万行),其中包含ID,一年和三个日期:lookupdatedate1date2data.frameIDdate1排序。我想搜索整个数据集并找到记录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位于date1date2之前,即所有lookupdate[i] < date1[i] < date2[i]都是i

以下是数据框和输出的示例:

> 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

自2012-10-12以来,最后一行为TRUE&lt; 2012-10-31&lt; 2012年11月5日。

2 个答案:

答案 0 :(得分:2)

从您提出问题的方式来看,听起来您对长度等于d中的行数的逻辑向量感兴趣,因此预先分配 < / p>

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

您对特定财政年度的行子集感兴趣,因此 vectorize 选择

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

对于其中的每一个,如果任何其他行满足某些复杂条件,您将更新hits为真;如何避免外部循环并不明显(尽管数据的特定功能(例如,只有少数ID)可能会提出不同的策略),但内部循环可以矢量化

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)

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

这会很快,但我可能会遇到边缘情况错误。

答案 1 :(得分:0)

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