Question

我有很多行，每行都计算出非线性函数的uniroot。我有一个四核Ubuntu机器，它已经两天没有停止运行我的代码了。毫不奇怪，我正在寻找加快速度的方法; - ）

经过一些研究，我注意到目前只使用了一个核心，并且可以进行并行化。深入挖掘，我得出结论（可能不正确？）包foreach并不真正意味着我的问题，因为产生了太多的开销（例如，参见SO）。对于Unix机器来说，一个好的选择似乎是multicore。特别是，在检查帮助页面后，pvec函数似乎是最有效的函数。

但是，如果我理解正确，此功能只需一个向量并相应地将其拆分。我需要一个可以并行化的函数，但需要多个向量（或data.frame），就像mapply函数一样。我错过了什么吗？

以下是我想要做的一个小例子:(请注意，我在此处包含plyr示例，因为它可以替代基本mapply函数，并且它具有并行化选项。但是，它在我的实现中速度较慢，而且在内部，它调用foreach进行并行化，所以我认为它无济于事。这是正确的吗？）

library(plyr)
library(foreach)
n <- 10000
df <- data.frame(P   = rnorm(n, mean=100, sd=10),
                 B0  = rnorm(n, mean=40,  sd=5),
                 CF1 = rnorm(n, mean=30,  sd=10),
                 CF2 = rnorm(n, mean=30,  sd=5),
                 CF3 = rnorm(n, mean=90,  sd=8))

get_uniroot <- function(P, B0, CF1, CF2, CF3) {

  uniroot(function(x) {-P + B0 + CF1/x + CF2/x^2 + CF3/x^3}, 
          lower = 1,
          upper = 10,
          tol   = 0.00001)$root

}

system.time(x1 <- mapply(get_uniroot, df$P, df$B0, df$CF1, df$CF2, df$CF3))
   #user  system elapsed 
   #0.91    0.00    0.90 
system.time(x2 <- mdply(df, get_uniroot))
   #user  system elapsed 
   #5.85    0.00    5.85
system.time(x3 <- foreach(P=df$P, B0=df$B0, CF1=df$CF1, CF2=df$CF2, CF3=df$CF3, .combine = "c") %do% {
    get_uniroot(P, B0, CF1, CF2, CF3)})
   #user  system elapsed 
  # 10.30    0.00   10.36
all.equal(x1, x2$V1) #TRUE
all.equal(x1, x3)    #TRUE

另外，我尝试从上面的SO链接实现Ryan Thompson的函数chunkapply（只删除了doMC部分，因为我无法安装它。尽管如此，即使在调整了他的函数之后，他的例子也可以工作。）但没有得到它的工作。但是，由于它使用foreach，我认为上面提到的相同论点适用，所以我没有尝试太久。

#chunkapply(get_uniroot, list(P=df$P, B0=df$B0, CF1=df$CF1, CF2=df$CF2, CF3=df$CF3))
#Error in { : task 1 failed - "invalid function value in 'zeroin'"

PS：我知道我可以增加tol来减少查找uniroot所需的步骤数。但是，我已经将tol设置得尽可能大。

Answer 1

我使用R 2.14中内置的parallel包并使用矩阵。然后，您可以像这样简单地使用mclapply：

dfm <- as.matrix(df)
result <- mclapply(seq_len(nrow(dfm)),
          function(x) do.call(get_uniroot,as.list(dfm[x,])),
          mc.cores=4L
          )
unlist(result)

这基本上做了相同的mapply，但是以平行的方式。

<强>可是...

请注意，并行化总是需要一些开销。正如我在您链接到的问题中所解释的那样，如果您的内部函数计算的时间明显长于所涉及的开销，那么并行只会得到回报。在您的情况下，您的uniroot功能非常快。然后，您可以考虑以更大的块来剪切数据框，并将mapply和mclapply结合起来。可能的方法是：

ncores <- 4
id <- floor(
        quantile(0:nrow(df),
                 1-(0:ncores)/ncores
        )
      )
idm <- embed(id,2)

mapply_uniroot <- function(id){
  tmp <- df[(id[1]+1):id[2],]
  mapply(get_uniroot, tmp$P, tmp$B0, tmp$CF1, tmp$CF2, tmp$CF3)
}
result <-mclapply(nrow(idm):1,
                  function(x) mapply_uniroot(idm[x,]),
                  mc.cores=ncores)
final <- unlist(result)

这可能需要一些调整，但它基本上会破坏你的df与核心一样多的位，并在每个核心上运行mapply。为了证明这一点：

> x1 <- mapply(get_uniroot, df$P, df$B0, df$CF1, df$CF2, df$CF3)
> all.equal(final,x1)
[1] TRUE

Answer 2

这不是最佳实践建议，但通过以“矢量化”方式识别所有参数的根，可以获得相当大的加速。例如，

bisect <-
    function(f, interval, ..., lower=min(interval), upper=max(interval),
             f.lower=f(lower, ...), f.upper=f(upper, ...), maxiter=20)
{
    nrow <- length(f.lower)
    bounds <- matrix(c(lower, upper), nrow, 2, byrow=TRUE)
    for (i in seq_len(maxiter)) {
        ## move lower or upper bound to mid-point, preserving opposite signs
        mid <- rowSums(bounds) / 2
        updt <- ifelse(f(mid, ...) > 0, 0L, nrow) + seq_len(nrow)
        bounds[updt] <- mid
    }
    rowSums(bounds) / 2
}

然后

> system.time(x2 <- with(df, {
+     f <- function(x, PB0, CF1, CF2, CF3)
+         PB0 + CF1/x + CF2/x^2 + CF3/x^3
+     bisect(f, c(1, 10), PB0, CF1, CF2, CF3)
+ }))
   user  system elapsed 
  0.180   0.000   0.181 
> range(x1 - x2)
[1] -6.282406e-06  6.658593e-06

对于每个单独应用uniroot大约1.3s。这也将P和B0提前组合成单个值，因为这是他们进入等式的方式。

最终值的界限是+/- diff(interval) * (.5 ^ maxiter)左右。一个更高级的实现将用线性或二次插值取代二分法（如?uniroot中引用的参考文献），但是然后统一有效的收敛（在所有情况下，错误处理）将更难以安排。

Answer 3

这是一个古老的话题，但你现在parallel::mcmapply doc是here。不要忘记在选项中设置mc.cores。我通常使用mc.cores=parallel::detectCores()-1让一个cpu可用于操作系统操作。

x4 <- mcmapply(get_uniroot, df$P, df$B0, df$CF1, df$CF2, df$CF3,mc.cores=parallel::detectCores()-1)

是否有一种有效的并行化mapply方法？

3 个答案: