r - R中的贪婪优化

Question

我正在尝试为 Ensemble selection from libraries of models (pdf) 复制 Caruana 等人的方法.该方法的核心是一个贪心算法，用于向集成中添加模型(模型可以添加多次)。我已经为这个贪心优化算法写了一个实现，但是它很慢:

library(compiler)
set.seed(42)
X <- matrix(runif(100000*10), ncol=10)
Y <- rnorm(100000)

greedOpt <- cmpfun(function(X, Y, iter=100){
  weights <- rep(0, ncol(X))

  while(sum(weights) < iter) {

    errors <- sapply(1:ncol(X), function(y){
      newweights <- weights
      newweights[y] <- newweights[y] + 1  
      pred <- X %*% (newweights)/sum(newweights)
      error <- Y - pred
      sqrt(mean(error^2))
    })

    update <- which.min(errors)
    weights[update] <- weights[update]+1
  }
  return(weights/sum(weights))
})

system.time(a <- greedOpt(X,Y))

我知道 R 不能很好地执行循环，但是我想不出任何方法可以在没有循环的情况下进行这种类型的逐步搜索。

有什么改进这个功能的建议吗？

Answer 1

我尝试编写此函数的 Rcpp 版本:

library(Rcpp)
cppFunction('
  NumericVector greedOptC(NumericMatrix X, NumericVector Y, int iter) {
    int nrow = X.nrow(), ncol = X.ncol();
    NumericVector weights(ncol);
    NumericVector newweights(ncol);
    NumericVector errors(nrow);
    double RMSE;
    double bestRMSE;
    int bestCol;

    for (int i = 0; i < iter; i++) {
      bestRMSE = -1;
      bestCol = 1;
      for (int j = 0; j < ncol; j++) {
        newweights = weights + 0;
        newweights[j] = newweights[j] + 1;
        newweights = newweights/sum(newweights);

        NumericVector pred(nrow);
        for (int k = 0; k < ncol; k++){
          pred = pred + newweights[k] * X( _, k);
        }

        errors = Y - pred;
        RMSE = sqrt(mean(errors*errors));

        if (RMSE < bestRMSE || bestRMSE==-1){
          bestRMSE = RMSE;
          bestCol = j;
        }
      }

      weights[bestCol] = weights[bestCol] + 1;
    }

    weights = weights/sum(weights);
    return weights;
  }
')

它的速度是 R 版本的两倍多:

set.seed(42)
X <- matrix(runif(100000*10), ncol=10)
Y <- rnorm(100000)
> system.time(a <- greedOpt(X, Y, 1000))
   user  system elapsed 
  36.19    6.10   42.40 
> system.time(b <- greedOptC(X, Y, 1000))
   user  system elapsed 
  16.50    1.44   18.04
> all.equal(a,b)
[1] TRUE

不错，但我希望在从 R 飞跃到 Rcpp 时有更大的加速。这是我写过的第一个 Rcpp 函数之一，所以也许进一步优化是可能的。