如何在 R 中加速类似循环的函数

Question

为了避免在 R 中使用 for 循环，我编写了一个函数，该函数在给定来自另一个数据帧的特定行值的情况下返回一个数据帧的平均值。然后我将这个函数传递给 sapply 的行号范围。我的函数有效，但它每秒返回约 2.5 个结果，这并不比使用 for 循环好多少。所以，我觉得我还没有充分利用 apply 系列函数的向量化方面。谁能帮我重新考虑我的方法？这是一个最低限度的工作示例。提前致谢。

#Creating first dataframe
dates<-seq(as.Date("2013-01-01"), as.Date("2016-07-01"), by = 1)
n<-length(seq(as.Date("2013-01-01"), as.Date("2016-07-01"), by = 1))
df1<-data.frame(date = dates, 
             hour = sample(1:24, n,replace = T), 
             cat = sample(c("a", "b"), n, replace = T),
             lag = sample(1:24, n, replace = T))

#Creating second dataframe
df2<-data.frame(date = sort(rep(dates, 24)), 
                hour = rep(1:24, length(dates)), 
                p = runif(length(rep(dates, 24)), min = -20, max = 100))

df2<-df2[order(df2$date, df2$hour),]

df2$cat<-"a"
temp<-df2
temp$cat<-"b"
df2<-rbind(df2,temp)

#function
period_mean<-function(x){

    tmp<-df2[df$cat == df1[x,]$cat,]

    #This line extracts the row name index from tmp,
    #in which the two dataframes match on date and hour
    he_i<-which(tmp$date == df1[x,]$date & tmp$hour == df1[x,]$hour)

    #My lagged period is given by the variable "lag". I want the average
    #over the period hour - (hour - lag). Since df2 is sorted such hours  
    #are consecutive, this method requires that I subset on only the 
    #relevant value for cat (hence the creation of tmp in the first line 
    #of the function
    p<-mean(tmp[(he_i - df1[x,]$lag):he_i,]$p)

    print(x)
    print(p)
    return(p)
}

#Execute function
out<-sapply(1:length(row.names(df1)), period_mean)

编辑我随后了解到，我最初的问题迭代如此缓慢的部分原因是我的两个数据帧之间的数据类不一样。 df1$date 是一个日期字段，而 df2$date 是一个字符字段。当然，这在我发布的示例中并不明显，因为数据类型在构造上是相同的。希望这可以帮助。

Answer 1

这里有一个建议：

getIdx <- function(i) {
    date <- df1$date[i]
    hour <- df1$hour[i]    
    cat <- df1$cat[i]
    which(df2$date==date & df2$hour==hour & df2$cat==cat)
}
v_getIdx <- Vectorize(getIdx)

df1$index <- v_getIdx(1:nrow(df1))
b_start <- match("b", df2$cat)
out2 <- apply(df1[,c("cat","lag","index")], MAR=1, function(x) {
    flr <- ifelse(x[1]=="a", 1, b_start)
    x <- as.numeric(x[2:3])
    mean(df2$p[max(flr, (x[2]-x[1])):x[2]])
})

我们创建一个函数 (getIdx) 来从 df2 中检索与 df1 中每一行的值匹配的行，然后是 Vectorize 函数。

然后我们运行向量化函数来获取行名向量。我们将b_start 设置为“b”类别开始的行。

然后我们用apply 遍历df1 的行。在mean(...) 函数中，我们将“floor”设置为第 1 行（如果 cat=="a"）或 b_start（如果 cat=="b"），这样就不需要子集（您对 tmp 所做的事情） )。

性能：

> system.time(out<-sapply(1:length(row.names(df1)), period_mean))
   user  system elapsed 
 11.304   0.393  11.917 

> system.time({
+     df1$index <- v_getIdx(1:nrow(df1))
+     b_start <- match("b", df2$cat)
+     out2 <- apply(df1[,c("cat","lag","index")], MAR=1, function(x) {
+         flr <- ifelse(x[1]=="a", 1, b_start)
+         x <- as.numeric(x[2:3])
+         mean(df2$p[max(flr, (x[2]-x[1])):x[2]])
+     })
+ })
   user  system elapsed 
  2.839   0.405   3.274 

> all.equal(out, out2)
[1] TRUE