如何加速 R 中的自舉向量生成

Question

玩具 data.table

考慮這個 data.table

library(pacman)
p_load(data.table,magrittr,dplyr,glue)

dt <- data.table(x = c(1,3,4,5,8,12,13,20,21,25), 
           y = c(1,1,2,2,8,2,4,6,5,5),keep.rownames = T)
dt[,newval:=NA_real_]
dt[,rn:=as.integer(rownames(dt))]
dt[1,newval:=y] 
dt[,x_pre := shift(x,n = 1)]
dt[,x_nxt := shift(x,n = -1)]
setcolorder(dt,"rn")
dt[]
#>     rn  x y newval x_pre x_nxt
#>  1:  1  1 1      1    NA     3
#>  2:  2  3 1     NA     1     4
#>  3:  3  4 2     NA     3     5
#>  4:  4  5 2     NA     4     8
#>  5:  5  8 8     NA     5    12
#>  6:  6 12 2     NA     8    13
#>  7:  7 13 4     NA    12    20
#>  8:  8 20 6     NA    13    21
#>  9:  9 21 5     NA    20    25
#> 10: 10 25 5     NA    21    NA

# note the last 2 columns are simply the shifted values of x

for循環的使用

以下是一個低效的 function 在 R 中使用for循環來引導 data.tale 列。

# function using a for loop on each observation
 func_loop <- function(dt){
   # create a for loop for updating the newval column iteratively
   for(i in seq_len(nrow(dt))[-c((nrow(dt) - c(0:1)))]){
     dt[i + 2,newval:=y] # temporary value to be erased later
     dt[,new_pre:=shift(newval, n = 1)]
     dt[,new_nxt:=shift(newval, n = -1)]
     # the following line of code uses the previously computed value (new_pre)
     dt[rn > 1,newval:=ifelse(rn==i+1, new_pre + (new_nxt - new_pre)* (x - x_pre) /((x_nxt - x_pre)),newval) ]
     dt[rn==i+2,newval:=NA_real_]
   }
   dt
 }

調用for - loop function

 # call the function 
 func_loop(dt)[]
#>     rn  x y   newval x_pre x_nxt  new_pre  new_nxt
#>  1:  1  1 1 1.000000    NA     3       NA 1.666667
#>  2:  2  3 1 1.666667     1     4 1.000000 1.833333
#>  3:  3  4 2 1.833333     3     5 1.666667 3.375000
#>  4:  4  5 2 3.375000     4     8 1.833333 2.785714
#>  5:  5  8 8 2.785714     5    12 3.375000 3.757143
#>  6:  6 12 2 3.757143     8    13 2.785714 4.037500
#>  7:  7 13 4 4.037500    12    20 3.757143 4.879688
#>  8:  8 20 6 4.879688    13    21 4.037500       NA
#>  9:  9 21 5 4.903750    20    25 4.879688 5.000000
#> 10: 10 25 5       NA    21    NA       NA       NA

# benchmark the speed
 microbenchmark::microbenchmark(func_loop(dt))
#> Unit: milliseconds
#>           expr      min       lq     mean   median       uq      max neval
#>  func_loop(dt) 23.00165 24.24735 26.19917 25.11379 27.11327 39.43801   100

^{由reprex package (v2.0.1) 創建於 2022-07-19}

預計這會為 10 行提供 30 毫秒的可怕效率，這意味着對於一百萬行將需要 50 分鍾。 我有幾百萬行要計算。

我知道froll*系列並廣泛使用它們，但在這里我無法應用frollapply ，因為此算法依賴於先前的計算。

我也嘗試過data.table::set並且由於我們必須重復調用dt[]是一個昂貴的調用，所以這並沒有大大減少時間。 請參閱下面 Henrik 的評論。

我希望將性能提高幾個數量級，而不僅僅是 20% 或 40%。 我希望使用良好的向量算法可以得到當前響應時間的 1/10 或 1/50。

Answer 1

盡量避免出現在頂部的ifelse大約快 10%。

for (rn in seq_len(nrow(dt1) - 6L)) {
  set(dt1, i=rn, j=3L, value=dt1[rn + 1:10, sum(value < 90)])
}

另一個改進可能是在括號內使用vapply ，它現在快了大約 20%。

dt2[, newval:=colSums(vapply(seq_len(nrow(dt2)), \(rn) dt3[rn + 1:10, value], numeric(10L)) < 90)]

Rfast::colsums也是進一步的改進。

dt3[, newval:=Rfast::colsums(vapply(seq_len(nrow(dt3)), \(rn) dt3[rn + 1:10, value], numeric(10L)) < 90)]

但是，由於您正在尋找“一個數量級”的改進，您可能希望將其parallelize ，速度提高約 80%。

library(parallel)
CL <- makeCluster(detectCores() - 1)
clusterExport(CL, c('dt4'))
dt4[, newval:=Rfast::colsums(parSapply(CL, seq_len(nrow(dt4)), \(rn) dt4[rn + 1:10, value]) < 90)]
stop(CL)

基准

stopifnot(all.equal(dt, dt1) & all.equal(dt, dt2) & all.equal(dt, dt3) & all.equal(dt, dt4))


Unit: milliseconds
      expr       min        lq      mean    median       uq       max neval  cld
    ifelse 1263.3652 1281.3704 1298.7852 1292.7541 1306.278 1353.0677    10    d
 no_ifelse 1168.6300 1176.8546 1222.1445 1217.7133 1250.281 1322.8730    10   c 
    vapply 1104.0449 1119.0288 1134.4834 1137.6018 1144.726 1170.4476    10  b  
     rfast 1123.2294 1153.7249 1157.6447 1157.1926 1175.710 1178.3570    10  b  
  parallel  274.9018  280.9225  299.0452  293.1892  307.682  339.4506    10 a   

Answer 2

這個frollapply解決方案似乎非常接近所需的輸出：

dt[,newval_roll:=shift(frollapply(vol,n=n,align = 'center',FUN=median,fill=NA),-1)]

dt$newval==dt$newval_roll
#[1]    NA    NA    NA    NA FALSE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
#[19]  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
#[37]  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
#[55]  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
#[73]  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE  TRUE
#[91]  TRUE  TRUE  TRUE  TRUE    NA    NA    NA    NA    NA    NA

不確定我是否完全理解approxfun位，因為它適用於已經存在的坐標，這意味着不需要近似值。

如果需要填充第一個元素，您還可以使用zoo::rollapply允許partial計算。 其他可能性是只為第一個元素運行循環。

Answer 3

一個簡單的Rcpp函數會快得多。

library(data.table)

Rcpp::cppFunction(
  "NumericVector iterInterp(const NumericVector& x, const NumericVector& y) {
    const int n = x.size();
    NumericVector newval(n);
    newval(0) = y(0);
    newval(n - 1) = NA_REAL;
    
    for (int i = 1; i < n - 1; i++) {
      newval(i) = newval(i - 1) + (y(i + 1) - newval(i - 1))*(x(i) - x(i - 1))/(x(i + 1) - x(i - 1));
    }
    
    return newval;
  }"
)

dt <- data.table(
  x = c(1,3,4,5,8,12,13,20,21,25),
  y = c(1,1,2,2,8,2,4,6,5,5)
)

microbenchmark::microbenchmark(iterInterp = dt[, newval := iterInterp(x, y)])
#> Unit: microseconds
#>        expr   min    lq    mean median    uq   max neval
#>  iterInterp 153.5 156.9 164.894  159.7 163.8 391.8   100

dt
#>     x y   newval
#> 1   1 1 1.000000
#> 2   3 1 1.666667
#> 3   4 2 1.833333
#> 4   5 2 3.375000
#> 5   8 8 2.785714
#> 6  12 2 3.757143
#> 7  13 4 4.037500
#> 8  20 6 4.879688
#> 9  21 5 4.903750
#> 10 25 5       NA

對於 10M 行來說，這會小於 3 分鍾，除了開銷不會隨着data.table的大小而擴展，如基准測試所示：

dt <- data.table(
  x = rep(c(1,3,4,5,8,12,13,20,21,25), 1e6) + 25*rep(0:(1e6 - 1L), each = 10),
  y = rep(c(1,1,2,2,8,2,4,6,5,5), 1e6)
)

microbenchmark::microbenchmark(iterInterp = dt[, newval := iterInterp(x, y)])
#> Unit: milliseconds
#>        expr     min       lq     mean   median       uq     max neval
#>  iterInterp 157.585 159.0541 178.3298 168.0882 172.2245 274.102   100

對於 10M 行來說，這只是幾分之一秒。