矢量化R滤波并获得数据帧中的多个滞后值

Question

我有一个矢量化问题，而且我似乎无法在线找到解决方案。我有一个非常大的数据帧，而我目前使用下面的循环过滤，并得到滞后值：

rowtype <-c('A','B','A','A','B','B','B','B','A','B','B','A','B','A','B','B','A','A'); 
values1<-c(2,1,8,5,-4,6,42,10,20,5,7,8,-2,8,9,3,2,5); 
index<-seq(1:length(values1)); 

df<-data.frame(rowtype, values1, index); 

mininumBsize <- 2; 

df$firstBLagged<-0; 
df$secondBLagged<-0; 
df$thirdBLagged<-0; 

for (idx in which(df$rowtype=='A')) 
{ 
    #get the past 5 lagged values of type 'B' that exceed a threshold 
    laggedValues <- rev(df[df$rowtype=='B' & df$values1 > mininumBsize & df$index < idx,]$values1)[1:5]; 

    #take out any NA values here 
    laggedValues[is.na(laggedValues)]<-0; 

    #store those lagged values back into the dataframe 
    df$firstBLagged[idx]<-laggedValues[1]; 
    df$secondBLagged[idx]<-laggedValues[2]; 
    df$thirdBLagged[idx]<-laggedValues[3]; 
} 

数据帧的输出是这样的：

> df 
    rowtype values1 index firstBLagged secondBLagged thirdBLagged 
1  A  2  1   0    0   0 
2  B  1  2   0    0   0 
3  A  8  3   0    0   0 
4  A  5  4   0    0   0 
5  B  -4  5   0    0   0 
6  B  6  6   0    0   0 
7  B  42  7   0    0   0 
8  B  10  8   0    0   0 
9  A  20  9   10   42   6 
10  B  5 10   0    0   0 
11  B  7 11   0    0   0 
12  A  8 12   7    5   10 
13  B  -2 13   0    0   0 
14  A  8 14   7    5   10 
15  B  9 15   0    0   0 
16  B  3 16   0    0   0 
17  A  2 17   3    9   7 
18  A  5 18   3    9   7 

从本质上讲，每个行的类型为'A'，我想获得超过特定阈值“mininumBsize”的类型“B”的过去5个值。然后，我想将它存储回数据框中，保存为df $ firstBlagged等，以便稍后用于回归和其他分析。

不幸的是，这段代码运行时间太长（我也想知道如何编写更好的R）。网上的大多数例子都显示了如何过滤行本身，而不是如何根据条件获得滞后值。有谁知道如何解决这个问题？谢谢！

Answer 1

我没有看到一个简单的方法来完全矢量化这个，但如果它存在的话，会有兴趣学习一个。但是，我可以使它更有效率。

让我们用一个更大的data.frame，所以我们可以使用system.time：

rowtype <-rep(c('A','B','A','A','B','B','B','B','A','B','B','A','B','A','B','B','A','A'),1000) 
values1<-rep(c(2,1,8,5,-4,6,42,10,20,5,7,8,-2,8,9,3,2,5),1000) 
index<-seq(1:length(values1)) 

df<-data.frame(rowtype, values1, index) 

现在我们换你的代码放到一个函数：

addlagged<-function(df,mininumBsize = 2){ 
    df$firstBLagged<-0; 
    df$secondBLagged<-0; 
    df$thirdBLagged<-0; 

    for (idx in which(df$rowtype=='A')) 
    { 
    #get the past 5 lagged values of type 'B' that exceed a threshold 
    laggedValues <- rev(df[df$rowtype=='B' & df$values1 > mininumBsize & df$index < idx,]$values1)[1:5]; 

    #take out any NA values here 
    laggedValues[is.na(laggedValues)]<-0; 

    #store those lagged values back into the dataframe 
    df$firstBLagged[idx]<-laggedValues[1]; 
    df$secondBLagged[idx]<-laggedValues[2]; 
    df$thirdBLagged[idx]<-laggedValues[3]; 
    } 
    return(df) 
} 

现在更有效的功能：

addlagged2<-function(df,mininumBsize = 2){ 
    #make sure rowtype is not a factor, but a character 
    df$rowtype<-as.character(df$rowtype) 
    #subset before the loop 
    df2<-subset(df,!(rowtype=="B" & values1<mininumBsize)) 


    #initialize vectors 
    firstBLagged <- rep(0,nrow(df2)) 
    secondBLagged <- rep(0,nrow(df2)) 
    thirdBLagged <- rep(0,nrow(df2)) 

    for (idx in which(df2$rowtype=='A')) 
    { 
    #get the past 3 lagged values of type 'B'  
    laggedValues <- df2$values1[1:idx][df2$rowtype[1:idx]=='B'] 
    #do not use rev 
    laggedValues <- laggedValues[length(laggedValues):(length(laggedValues)-2)] 

    #don't save to data.frame inside loop, use vectors 
    firstBLagged[idx]<-laggedValues[1]; 
    secondBLagged[idx]<-laggedValues[2]; 
    thirdBLagged[idx]<-laggedValues[3]; 
    } 
    #take out any NA values here (do it only ones and not inside the loop) 
    firstBLagged[is.na(firstBLagged)]<-0 
    secondBLagged[is.na(secondBLagged)]<-0 
    thirdBLagged[is.na(thirdBLagged)]<-0 

    #create columns in df  
    df$firstBLagged<-0 
    df$secondBLagged<-0 
    df$thirdBLagged<-0 

    #transfer results to df 
    df$firstBLagged[!(as.character(df$rowtype)=="B" & df$values1<mininumBsize)]<-firstBLagged 
    df$secondBLagged[!(as.character(df$rowtype)=="B" & df$values1<mininumBsize)]<-secondBLagged 
    df$thirdBLagged[!(as.character(df$rowtype)=="B" & df$values1<mininumBsize)]<-thirdBLagged 
    return(df) 
} 

速度更快吗？

> system.time(df2<-addlagged(df)) 
     User  System verstrichen 
    37.157  24.591  61.735 
> system.time(df3<-addlagged2(df)) 
     User  System verstrichen 
     2.866  0.517  3.382 

结果是否一致？

> df3$rowtype<-factor(df3$rowtype) 
> identical(df2,df3) 
[1] TRUE 

什么是改进功能的大部分计算时间？让我们看看Rprof输出：

> summaryRprof() 
$by.self 
       self.time self.pct total.time total.pct 
"=="     0.346 61.79  0.346  61.79 
":"     0.189 33.75  0.189  33.75 
"$"     0.016  2.86  0.016  2.86 
"$<-.data.frame"  0.005  0.89  0.005  0.89 
"try"    0.001  0.18  0.002  0.36 
"-"     0.001  0.18  0.001  0.18 
"is.na"    0.001  0.18  0.001  0.18 
"tryCatch"   0.001  0.18  0.001  0.18 

$by.total 
       total.time total.pct self.time self.pct 
"=="     0.346  61.79  0.346 61.79 
":"     0.189  33.75  0.189 33.75 
"$"     0.016  2.86  0.016  2.86 
"$<-.data.frame"  0.005  0.89  0.005  0.89 
"$<-"     0.005  0.89  0.000  0.00 
"try"     0.002  0.36  0.001  0.18 
"-"     0.001  0.18  0.001  0.18 
"is.na"    0.001  0.18  0.001  0.18 
"tryCatch"   0.001  0.18  0.001  0.18 

$sample.interval 
[1] 0.001 

$sampling.time 
[1] 0.56 

大部分的时间与所有subseting和创造的循环序列花。使用* apply函数对此没有帮助。我试图使用data.table和它的二进制搜索，但它没有帮助;很可能是因为我必须在循环中设置一个键。我对data.table没有多少经验，所以可能我做错了什么。

最后，这是代码审查，并不真正属于堆栈溢出。