R中的并行优化

我在有8个多核处理器的LinuxBox上运行R，有一个优化问题，我想通过并行化优化例程本身来加速。重要的是，这个问题涉及（1）多个参数，（2）固有的模型运行缓慢。一个相当普遍的问题

有人知道这种情况下的并行优化器吗

更具体地说，像

nlm（）

这样的解算器在算法每次在参数空间中迈出一步时都会运行多个模型求值（每个参数值两个），因此在这些情况下，当拟合多个参数值时，并行化多个模型运行实例将大大加快速度

似乎使用包

parallel

的代码可以这样编写，用户只需对代码进行最小的修改，就可以从使用

nlm（）

或

optim（）

转到这个并行优化例程。也就是说，似乎可以重写这些例程，基本上不做任何更改，除了多次调用模型的步骤（在基于梯度的方法中很常见）将并行完成

理想情况下，类似nlmPara（）的代码

fit <- nlm(MyObjFunc, params0);

---

fit我使用软件包doSNOW在8个内核上运行代码。
我可以复制并粘贴引用此包的部分代码。
希望有帮助

    # use multicore libraries
      # specify number of cores to use
    cores<- 8
      cluster <- makeCluster(cores, type="SOCK")
      registerDoSNOW(cluster)

      # check how many cores will be used
      ncores <- getDoParWorkers()
    print(paste("Computing algorithm for ", cores, " cores", sep=""))
      fph <- rep(-100,12)

      # start multicore cicle on 12  subsets
      fph <- foreach(i=1:12, .combine='c') %dopar% {
        PhenoRiceRun(sub=i, mpath=MODIS_LOCAL_DIR, masklocaldir=MASK_LOCAL_DIR, startYear=startYear, tile=tile, evismoothopt=FALSE)
      }


  stopCluster(cluster) # check if gives error
  gc(verbose=FALSE)

#使用多核库
#指定要使用的核心数
cores这是一个粗略的解决方案，至少有一些希望。非常感谢Ben Bolker指出许多/大多数优化例程允许用户指定的梯度函数

具有更多参数值的测试问题可能会显示出更显著的改进，但在8核机器上，使用并行梯度函数的运行时间约为串行版本的70%。请注意，此处使用的粗略梯度近似似乎会减慢收敛速度，从而为该过程增加一些时间

## Set up the cluster
require("parallel");
.nlocalcores = NULL; # Default to "Cores available - 1" if NULL.
if(is.null(.nlocalcores)) { .nlocalcores = detectCores() - 1; }
if(.nlocalcores < 1) { print("Multiple cores unavailable! See code!!"); return()}
print(paste("Using ",.nlocalcores,"cores for parallelized gradient computation."))
.cl=makeCluster(.nlocalcores);
print(.cl)


# Now define a gradient function: both in serial and in parallel
mygr <- function(.params, ...) {
  dp = cbind(rep(0,length(.params)),diag(.params * 1e-8)); # TINY finite difference
  Fout = apply(dp,2, function(x) fn(.params + x,...));     # Serial 
  return((Fout[-1]-Fout[1])/diag(dp[,-1]));                # finite difference 
}

mypgr <- function(.params, ...) { # Now use the cluster 
  dp = cbind(rep(0,length(.params)),diag(.params * 1e-8));   
  Fout = parCapply(.cl, dp, function(x) fn(.params + x,...)); # Parallel 
  return((Fout[-1]-Fout[1])/diag(dp[,-1]));                  #
}


## Lets try it out!
fr <- function(x, slow=FALSE) { ## Rosenbrock Banana function from optim() documentation.
  if(slow) { Sys.sleep(0.1); }   ## Modified to be a little slow, if needed.
  x1 <- x[1]
  x2 <- x[2]
  100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}

grr <- function(x, slow=FALSE) { ## Gradient of 'fr'
  if(slow) { Sys.sleep(0.1); }   ## Modified to be a little slow, if needed.
  x1 <- x[1]
  x2 <- x[2]
  c(-400 * x1 * (x2 - x1 * x1) - 2 * (1 - x1),
    200 *      (x2 - x1 * x1))
}

## Make sure the nodes can see these functions & other objects as called by the optimizer
fn <- fr;  # A bit of a hack
clusterExport(cl, "fn");

# First, test our gradient approximation function mypgr
print( mypgr(c(-1.2,1)) - grr(c(-1.2,1)))

## Some test calls, following the examples in the optim() documentation
tic = Sys.time();
fit1 = optim(c(-1.2,1), fr, slow=FALSE);                          toc1=Sys.time()-tic
fit2 = optim(c(-1.2,1), fr, gr=grr, slow=FALSE, method="BFGS");   toc2=Sys.time()-tic-toc1
fit3 = optim(c(-1.2,1), fr, gr=mygr, slow=FALSE, method="BFGS");  toc3=Sys.time()-tic-toc1-toc2
fit4 = optim(c(-1.2,1), fr, gr=mypgr, slow=FALSE, method="BFGS"); toc4=Sys.time()-tic-toc1-toc2-toc3


## Now slow it down a bit
tic = Sys.time();
fit5 = optim(c(-1.2,1), fr, slow=TRUE);                           toc5=Sys.time()-tic
fit6 = optim(c(-1.2,1), fr, gr=grr, slow=TRUE, method="BFGS");    toc6=Sys.time()-tic-toc5
fit7 = optim(c(-1.2,1), fr, gr=mygr, slow=TRUE, method="BFGS");   toc7=Sys.time()-tic-toc5-toc6
fit8 = optim(c(-1.2,1), fr, gr=mypgr, slow=TRUE, method="BFGS");  toc8=Sys.time()-tic-toc5-toc6-toc7

print(cbind(fast=c(default=toc1,exact.gr=toc2,serial.gr=toc3,parallel.gr=toc4),
            slow=c(toc5,toc6,toc7,toc8)))

##设置集群
要求（“平行”）；
.nlocalcores=NULL；#如果为空，则默认为“Cores available-1”。
如果（is.null（.nlocalcores））{.nlocalcores=detectCores（）-1；}
如果（.nlocalcores<1）{print（“多核不可用！请参阅代码！！”）；return（）}
打印（粘贴（“使用”、.nlocalcores，“用于并行梯度计算的cores”））
.cl=生成群集（.nlocalcores）；
打印（.cl）
#现在定义一个梯度函数：串行和并行
mygr由于您尚未接受答案，此想法可能会有所帮助：
对于全局优化，软件包
DEoptim（）
具有用于并行优化的内置选项。很好的一点是，它易于使用，并且文档编写得很好

c、 f。
（目前下降）


注意：差分进化全局优化器可能仍然会遇到局部优化。
我是Optimir包的作者。它提供了基于梯度的优化方法的并行版本
optim（）
。这个包的主要功能是
optimParallel（）
，它的用法和输出与
optim（）
相同。使用
optimParallel（）
可以显著减少优化时间，如下图所示（
p
是参数的数量）


有关更多信息，请参阅和
 再多读一点不同的优化器，这类黑客似乎需要重写C代码（例如，重写OPTIF9例程的C端口以使用多个线程）或编写本机优化器以利用更高级别的并行化选项，如
并行
，
多核
，
snow
，等等。
optimx
/
optimplus
软件包有许多优化算法的原生版本：也许从那里开始最容易？感谢Ben:-）optimx允许您输入梯度函数。我将尝试一下，看看我是否能给它一个并行化的代码块，这应该可以做到。我还有一些想法——可能会有一些并行+记忆化的技巧？一些内置的
optim（）
优化器也采用可选的
gr
参数rgenoud包可以为您工作吗？该软件包中的genoud函数采用了一个支持通过snow软件包进行并行计算的
cluster
参数，尽管您必须使用
cluster=rep（'localhost'，6）
而不是
cluster=6
。感谢FraNut，但问题不在于如何在R中并行运行某些东西，我特别寻找一个基于梯度的优化例程，它可以自动并行梯度计算。请看我上面问题下面的评论——我认为Ben的建议导致了一个可行的解决方案，具体来说，
optimx
允许用户定义梯度函数，这仍然要求用户使用
并行
（或
doSNOW
等）编写代码但这可能是一个相当简单的问题解决方案。顺便说一句，如果您对初始总体使用
lhs
包中所述的拉丁超立方体采样，使用DE进行优化通常会收敛得更快。谢谢！我必须使用DEoptim（）并查看它的比较结果
## Set up the cluster
require("parallel");
.nlocalcores = NULL; # Default to "Cores available - 1" if NULL.
if(is.null(.nlocalcores)) { .nlocalcores = detectCores() - 1; }
if(.nlocalcores < 1) { print("Multiple cores unavailable! See code!!"); return()}
print(paste("Using ",.nlocalcores,"cores for parallelized gradient computation."))
.cl=makeCluster(.nlocalcores);
print(.cl)


# Now define a gradient function: both in serial and in parallel
mygr <- function(.params, ...) {
  dp = cbind(rep(0,length(.params)),diag(.params * 1e-8)); # TINY finite difference
  Fout = apply(dp,2, function(x) fn(.params + x,...));     # Serial 
  return((Fout[-1]-Fout[1])/diag(dp[,-1]));                # finite difference 
}

mypgr <- function(.params, ...) { # Now use the cluster 
  dp = cbind(rep(0,length(.params)),diag(.params * 1e-8));   
  Fout = parCapply(.cl, dp, function(x) fn(.params + x,...)); # Parallel 
  return((Fout[-1]-Fout[1])/diag(dp[,-1]));                  #
}


## Lets try it out!
fr <- function(x, slow=FALSE) { ## Rosenbrock Banana function from optim() documentation.
  if(slow) { Sys.sleep(0.1); }   ## Modified to be a little slow, if needed.
  x1 <- x[1]
  x2 <- x[2]
  100 * (x2 - x1 * x1)^2 + (1 - x1)^2
}

grr <- function(x, slow=FALSE) { ## Gradient of 'fr'
  if(slow) { Sys.sleep(0.1); }   ## Modified to be a little slow, if needed.
  x1 <- x[1]
  x2 <- x[2]
  c(-400 * x1 * (x2 - x1 * x1) - 2 * (1 - x1),
    200 *      (x2 - x1 * x1))
}

## Make sure the nodes can see these functions & other objects as called by the optimizer
fn <- fr;  # A bit of a hack
clusterExport(cl, "fn");

# First, test our gradient approximation function mypgr
print( mypgr(c(-1.2,1)) - grr(c(-1.2,1)))

## Some test calls, following the examples in the optim() documentation
tic = Sys.time();
fit1 = optim(c(-1.2,1), fr, slow=FALSE);                          toc1=Sys.time()-tic
fit2 = optim(c(-1.2,1), fr, gr=grr, slow=FALSE, method="BFGS");   toc2=Sys.time()-tic-toc1
fit3 = optim(c(-1.2,1), fr, gr=mygr, slow=FALSE, method="BFGS");  toc3=Sys.time()-tic-toc1-toc2
fit4 = optim(c(-1.2,1), fr, gr=mypgr, slow=FALSE, method="BFGS"); toc4=Sys.time()-tic-toc1-toc2-toc3


## Now slow it down a bit
tic = Sys.time();
fit5 = optim(c(-1.2,1), fr, slow=TRUE);                           toc5=Sys.time()-tic
fit6 = optim(c(-1.2,1), fr, gr=grr, slow=TRUE, method="BFGS");    toc6=Sys.time()-tic-toc5
fit7 = optim(c(-1.2,1), fr, gr=mygr, slow=TRUE, method="BFGS");   toc7=Sys.time()-tic-toc5-toc6
fit8 = optim(c(-1.2,1), fr, gr=mypgr, slow=TRUE, method="BFGS");  toc8=Sys.time()-tic-toc5-toc6-toc7

print(cbind(fast=c(default=toc1,exact.gr=toc2,serial.gr=toc3,parallel.gr=toc4),
            slow=c(toc5,toc6,toc7,toc8)))