是否可以/可能在Rcpp中的pragma openmp并行for循环中调用R函数或fortran代码？

Question

在Rcpp项目中，我希望能够call an R function（cobs包中的cobs函数进行凹形样条拟合）或call the fortran code它依赖于（cobs函数使用quantreg的{​​{3}}函数来拟合受约束的样条模型，而样条模型又依赖于{{ 1}}包中）（我的代码的其余部分主要需要一些简单的线性代数，所以这没问题，但是可悲的是，每个内循环迭代也需要我进行凹形样条拟合）。我想知道是否允许或可能这样做，因为我认为这样的调用不是线程安全的？是否有一个简单的解决方法，例如用quantreg包围这些呼叫？有人对此有任何例子吗？还是在这种情况下唯一的方法是首先使用线程安全的Armadillo类对#pragma omp critical和Rcpp函数进行完整的cobs端口操作？

Answer 1

引用the manual：

  

从线程代码中调用任何R API都是“仅供专家使用”，强烈建议不要这样做。 R API中的许多函数会修改内部R数据结构，并且如果从多个线程中同时调用这些数据结构，则可能会破坏这些数据结构。大多数R API函数都可以发出错误信号，该错误只能在R主线程上发生。另外，外部库（例如LAPACK）可能不是线程安全的。

我一直将其解释为“一个绝不能从线程代码中调用R API函数”。不管在内部使用什么，从omp并行区域内部调用R函数就是这样。使用#pragma omp critical 可能可以工作，但是如果出现故障，则必须保留碎片...

重新实现有问题的代码或在C ++ / C / Fortran中查找现有实现并直接调用它会更安全。

Answer 2

所以我刚刚尝试过，看来#pragma openmp parallel for循环中的R函数只有在#pragma omp critical之前才有效（否则会导致堆栈不平衡，并使R崩溃）。当然，这将导致该部分代码按顺序执行，但这在某些情况下可能仍然有用。

示例：

Rcpp部分，另存为文件"fitMbycol.cpp"：

// [[Rcpp::plugins(cpp11)]]
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
// #define RCPP_ARMADILLO_RETURN_COLVEC_AS_VECTOR
using namespace Rcpp;
using namespace arma;
using namespace std;

#include <omp.h>
// [[Rcpp::plugins(openmp)]]

// [[Rcpp::export]]
arma::mat fitMbycol(arma::mat& M, Rcpp::Function f, const int nthreads) {

  // ARGUMENTS
  // M: matrix for which we want to fit given function f over each column
  // f: fitting function to use with one single argument (vector y) that returns the fitted values as a vector
  // nthreads: number of threads to use

  // we apply fitting function over columns
  int c = M.n_cols;
  int r = M.n_rows;
  arma::mat out(r,c);
  int i;
  omp_set_num_threads(nthreads);
#pragma omp parallel for shared(out)
  for (i = 0; i < c; i++) {
      arma::vec y = M.col(i); // ith column of M
#pragma omp critical
{
      out.col(i) = as<arma::colvec>(f(NumericVector(y.begin(),y.end())));
}
  }

  return out;

}

然后在R中：

首先是纯R版本：

（我们用泊松噪声模拟了一些高斯峰形状，然后使用cobs函数对它们进行了对数凹线样条拟合）

x=1:100
n=length(x)
ncols=50
gauspeak=function(x, u, w, h=1) h*exp(((x-u)^2)/(-2*(w^2)))
Y_nonoise=do.call(cbind,lapply(seq(min(x), max(x), length.out=ncols), function (u) gauspeak(x, u=u, w=10, h=u*100)))
set.seed(123)
Y=apply(Y_nonoise, 2, function (col) rpois(n,col))

# log-concave spline fit on each column of matrix Y using cobs
require(cobs)
logconcobs = function(y, tau=0.5, nknots=length(y)/10) {
  x = 1:length(y)
  offs = max(y)*1E-6
  weights = y^(1/2)
  fit.y = suppressWarnings(cobs(x=x,y=log10(y+offs), 
              constraint = "concave", lambda=0, 
              knots = seq(min(x),max(x), length.out = nknots), 
              nknots=nknots, knots.add = FALSE, repeat.delete.add = FALSE,
              keep.data = FALSE, keep.x.ps = TRUE,
              w=weights, 
              tau=tau, print.warn = F, print.mesg = F, rq.tol = 0.1, maxiter = 100)$fitted)
  return(pmax(10^fit.y - offs, 0))
}
library(microbenchmark)
microbenchmark(Y.fitted <- apply(Y, 2, function(col) logconcobs(y=col, tau=0.5)),times=5L) # 363 ms, ie 363/50=7 ms per fit
matplot(Y,type="l",lty=1)
matplot(Y_nonoise,type="l",add=TRUE, lwd=3, col=adjustcolor("blue",alpha.f=0.2),lty=1)
matplot(Y.fitted,type="l",add=TRUE, lwd=3, col=adjustcolor("red",alpha.f=0.2),lty=1)

现在使用Rcpp在logconcobs中调用我们的R拟合函数#pragma openmp parallel for loop，并用#pragma omp critical括起来：

library(Rcpp)
library(RcppArmadillo)
Rcpp::sourceCpp('fitMbycol.cpp')
microbenchmark(Y.fitted <- fitMbycol(Y, function (y) logconcobs(y, tau=0.5, nknots=10), nthreads=8L ), times=5L) # 361 ms

在这种情况下，OpenMP最终不会产生任何效果，因为#pragma omp critical会导致所有操作按顺序执行，但在更复杂的示例中，这仍然有用。