![](/img/trans.png)
[英]Fastest and most efficient way to pass rows of a large data.frame as arguments to a function in R
[英]Most efficient way to calculate function with large number of parameter combinations
我正在嘗試做的極簡示例:
dX_i <- rnorm(100, 0, 0.0002540362)
p_vec <- seq(0, 1, 0.25)
gamma_vec <- seq(1, 2, 0.25)
a_vec <- seq(2, 6, 1)
sigma_hat_vec <- c(0.03201636, 0.05771143, 0.07932116, 0.12262327, 0.15074560)
delta_j_vec <- c(0.0000005850109, 0.0000011700217, 0.0000017550326, 0.0000035100651, 0.0000052650977)
parameters <- expand.grid("p" = p_vec, "gamma" = gamma_vec, "a" = a_vec, "sigma_hat" = sigma_hat_vec, "delta_j" = delta_j_vec)
result <- sapply(1:nrow(parameters), function(x) {
tmp <- parameters[x,]
p <- tmp$p
a <- tmp$a
gamma <- tmp$gamma
sigma_hat <- tmp$sigma_hat
delta_j <- tmp$delta_j
B <- sum( (abs(dX_i)^p) * ( abs(dX_i) < gamma * a * sigma_hat * delta_j^(1/2) ))
return(B)
})
目標:我需要計算B
給定P,A,γ,sigma_hat,delta_j的所有組合矢量DX。
然而,實際上網格parameters
有~600k 行, dX_i
長度為~80k。 此外,我有一個 ~1000 dX_i
的列表。 因此,我想讓這個計算盡可能高效。 其他方法,例如將parameters
轉換為 data.table 並在該 data.table 中運行sapply
似乎沒有加速。
我嘗試並行化該函數(我僅限於在虛擬 Windows 機器上運行腳本):
cl <- makePSOCKcluster(numCores)
num.iter <- 1:nrow(parameters)
parSapply(cl, num.iter, function(x, parameters, dX_i) {
tmp <- parameters[x,]
p <- tmp$p
a <- tmp$a
gamma <- tmp$gamma
sigma_hat <- tmp$sigma_hat
delta_j <- tmp$delta_j
sum( (abs(dX_i)^p) * ( abs(dX_i) < gamma * a * sigma_hat * delta_j^(1/2) ))
}, parameters, dX_i)
stopCluster(cl)
雖然這給了我一個加速,但我仍然覺得我並沒有真正以最有效的方式解決這個問題,並且希望得到任何建議。
@josliber 的回答非常好。 然而,它使它看起來像 R 很糟糕......你必須切換到 C++ 以獲得性能。
他們的答案中實施了三個技巧:
dX_i
的絕對值前兩個技巧只是一個稱為“向量化”的 R 技巧-> 基本上在整個向量上而不是在單個元素上執行您的操作(例如gamma * a * sigma_hat * delta_j^(1/2)
或abs()
)一個循環。
這正是您在使用sum( dX_i^p * vec_boolean )
; 它是矢量化的( *
和sum
),因此它應該非常快。
如果我們只實現這兩個技巧(我們真的不能用同樣的方法來做第三個,因為它破壞了矢量化),它給出:
abs_dX_i <- abs(dX_i)
thresh <- with(parameters, gamma * a * sigma_hat * sqrt(delta_j))
p <- parameters$p
result3 <- sapply(1:nrow(parameters), function(i) {
in_sum <- (abs_dX_i < thresh[i])
sum(abs_dX_i[in_sum]^p[i])
})
all.equal(result, result3) # TRUE
如果我們對所有三個解決方案進行基准測試:
microbenchmark::microbenchmark(
OP = {
result <- sapply(1:nrow(parameters), function(x) {
tmp <- parameters[x,]
p <- tmp$p
a <- tmp$a
gamma <- tmp$gamma
sigma_hat <- tmp$sigma_hat
delta_j <- tmp$delta_j
B <- sum( (abs(dX_i)^p) * ( abs(dX_i) < gamma * a * sigma_hat * delta_j^(1/2) ))
return(B)
})
},
RCPP = {
result2 <- proc(sort(abs(dX_i)), parameters$gamma * parameters$a *
parameters$sigma_hat * parameters$delta_j^(1/2), parameters$p)
},
R_VEC = {
abs_dX_i <- abs(dX_i)
thresh <- with(parameters, gamma * a * sigma_hat * sqrt(delta_j))
p <- parameters$p
result3 <- sapply(1:nrow(parameters), function(i) {
in_sum <- (abs_dX_i < thresh[i])
sum(abs_dX_i[in_sum]^p[i])
})
},
times = 10
)
我們得到:
Unit: milliseconds
expr min lq mean median uq max neval
OP 224.8414 235.4075 289.90096 270.2767 347.1727 399.3262 10
RCPP 14.8172 15.4691 18.83703 16.3979 20.3829 29.6624 10
R_VEC 28.3136 29.5964 32.82456 31.4124 33.2542 45.8199 10
它通過稍微修改 R 中的原始代碼提供了巨大的加速。這比 Rcpp 代碼慢不到兩倍,並且可以像之前使用parSapply()
一樣輕松地並行化。
當我想加速難以矢量化的代碼時,我經常求助於 Rcpp。 在一天結束時,您試圖總結abs(dX_i)^p
,將abs(dX_i)
值限制為小於閾值gamma * a * sigma_hat * delta_j^(1/2)
。 您想為一堆p
和閾值對執行此操作。 您可以通過以下方式完成此操作:
library(Rcpp)
cppFunction(
"NumericVector proc(NumericVector dX_i, NumericVector thresh, NumericVector p) {
const int n = thresh.size();
const int m = dX_i.size();
NumericVector B(n);
for (int i=0; i < n; ++i) {
B[i] = 0;
for (int j=0; j < m; ++j) {
if (dX_i[j] < thresh[i]) {
B[i] += pow(dX_i[j], p[i]);
} else {
break;
}
}
}
return B;
}"
)
result2 <- proc(sort(abs(dX_i)), parameters$gamma * parameters$a * parameters$sigma_hat * parameters$delta_j^(1/2), parameters$p)
all.equal(result, result2)
# [1] TRUE
請注意,我的代碼對 dX_i 的絕對值進行排序,因此一旦遇到超過閾值的第一個值,它就可以停止計算。
在我的機器上,我看到了 20 倍的加速,從您的代碼的 0.158 秒到 Rcpp 代碼的 0.007 秒(使用system.time
測量)。
一個觀察結果是,您的參數集中每個p
值實際上都有大量重復。 您可以單獨處理每個p
值; 這樣,您只需將dX_i
求和到特定的p
值一次。
result4 <- rep(NA, nrow(parameters))
sa_dX_i <- sort(abs(dX_i))
thresh <- parameters$gamma * parameters$a * parameters$sigma_hat * parameters$delta_j^(1/2)
loc <- findInterval(thresh, sa_dX_i)
loc[loc == 0] <- NA # Handle threshold smaller than everything in dX_i
for (pval in unique(parameters$p)) {
this.p <- parameters$p == pval
cs_dX_i_p <- cumsum(sa_dX_i^pval)
result4[this.p] <- cs_dX_i_p[loc[this.p]]
}
result4[is.na(result4)] <- 0 # Handle threshold smaller than everything in dX_i
all.equal(result, result4)
# [1] TRUE
為了看到這一點,讓我們將原始數據集放大到問題中描述的內容(在dX_i
~600k 行參數和~80k 值):
set.seed(144)
dX_i <- rnorm(80000, 0, 0.0002540362)
p_vec <- seq(0, 1, 0.025)
gamma_vec <- seq(1, 2, 0.025)
a_vec <- seq(2, 6, 0.3)
sigma_hat_vec <- c(0.03201636, 0.05771143, 0.07932116, 0.12262327, 0.15074560)
delta_j_vec <- c(0.0000005850109, 0.0000011700217, 0.0000017550326, 0.0000035100651, 0.0000052650977)
parameters <- expand.grid("p" = p_vec, "gamma" = gamma_vec, "a" = a_vec, "sigma_hat" = sigma_hat_vec, "delta_j" = delta_j_vec)
dim(parameters)
# [1] 588350 5
length(unique(parameters$p))
# [1] 41
加速相當驚人——這段代碼在我的電腦上需要 0.27 秒,而在我對這個問題的另一個答案中發布的 Rcpp 代碼需要 655 秒(2400 倍的加速,使用純 R!)。 顯然,這種加速僅在parameters
數據框中的p
值相對較少(每個重復多次)時才有效。 如果每個p
值都是唯一的,這可能會比提出的其他方法慢得多。
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.