從optim調用Rcpp函數

Question

我正在嘗試獲取基本上等於邏輯回歸模型的MAP估計值。 我使用的是optim函數，該函數采用對數后驗密度及其解析梯度作為參數。 我有密度和梯度函數的R版本和Rcpp版本。 我可以成功地估計與所述R的功能和MAP，但的Optim正在進入asymtopia和未能收斂到與RCPP功能最佳。

我已驗證密度函數的R版本和密度函數的Rcpp版本返回相同的值：

ll_cpp = cpp_posterior_density(THETAi = as.vector(THETA0_LF[i,]),
                  Yi = as.vector(Y[i,]),
                  MUi =as.vector(MU_LF[i,]),
                  invS = invS ,TAU = TAU ,LAMBDA = LAMBDA, J = J ,K = K)

ll_R = lf_posterior_density(THETAi = as.vector(THETA0_LF[i,]),
                  Yi = as.vector(Y[i,]),
                  MUi =as.vector(MU_LF[i,]),
                  invS = invS ,TAU = TAU ,LAMBDA = LAMBDA, J = J ,K = K)


print(paste0(c("R: log posterior: ", ll_R)))
print(paste0(c("cpp: log posterior: ", ll_cpp)))

結果是

"R: log posterior: " "15.8951804436067"  
"cpp: log posterior: " "15.8951804436067"   

我還驗證了兩個版本之間的梯度相等。

d_cpp = grad(cpp_posterior_density, x = as.vector(THETA0_LF[i,]),
        Yi = as.vector(Y[i,]),
        MUi =as.vector(MU_LF[i,]),
        invS = invS ,TAU = TAU ,LAMBDA = LAMBDA, J = J ,K = K)

d_R = grad(lf_posterior_density, x = as.vector(THETA0_LF[i,]),
         Yi = as.vector(Y[i,]),
         MUi =as.vector(MU_LF[i,]),
         invS = invS ,TAU = TAU ,LAMBDA = LAMBDA, J = J ,K = K)

print(paste0(c("R: gradient of log posterior: ", paste(d_R, collapse = ", "))))
print(paste0(c("cpp: gradient of log posterior: ", paste(d_cpp, collapse = ", "))))

結果是

[1] "R: gradient of log posterior: "                                        
[2] "6.49720418347811, 4.67847452089852, 5.93682469664212, 1.47670777676947"

[1] "cpp: gradient of log posterior: " 
"6.49720418347811, 4.67847452089852, 5.93682469664212, 1.47670777659075"

但是，當我使用Rcpp函數調用optim時，無法收斂：

#Using Rcpp
out_LF = optim(par = as.vector(THETA0_LF[i,]),
           fn = cpp_posterior_density,
           gr = cpp_grad_posterior_density,
           Yi = as.vector(Y[i,]),
           MUi = as.vector(MU_LF[i,]),
           invS =invS,
           TAU = TAU,
           LAMBDA = LAMBDA,
           J = J,
           K = K,
           method = "BFGS",
           hessian = TRUE,
           control = list(trace = 6)) #does not converge

結果是

initial  value 15.895180 
final  value -4748.586405 

最終值必須嚴格大於零，表示不收斂。 但是，使用R函數，我確實可以收斂：

#With R functions for density and gradient
out_LF2 = optim(par = as.vector(THETA0_LF[i,]),
           fn = lf_posterior_density,
           gr = lf_grad_posterior_density,
           Yi = as.vector(Y[i,]),
           MUi = as.vector(MU_LF[i,]),
           invS =invS,
           TAU = TAU,
           LAMBDA = LAMBDA,
           J = J,
           K = K,
           method = "BFGS",
           hessian = TRUE,
           control = list(trace = 6)) #converged

結果是

initial  value 15.895180 
final  value 11.980282

有什么線索嗎？

為了重現性，這里是指向Dropbox文件夾的鏈接，其中包含所需的數據（例如THETA0_LF，Y，MU_LF等）以及目標函數和漸變（R版本和Rcpp版本）。 還包括一個R文件，該文件復制了上面的輸出（請參閱“ debug-rcpp-for-credi.R”）。

以下是目標函數的Rcpp版本

#include <RcppArmadillo.h>
using namespace Rcpp;
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::export]]

double cpp_posterior_density(const arma::vec& THETAi, const arma::vec& Yi, const arma::vec& MUi, const arma::mat& invS, const arma::vec& TAU, const arma::mat& LAMBDA, const int J, const int K) {

  int j;
  double lodd_j;
  double b;
  // PYi
  arma::vec LT = LAMBDA*THETAi;
  arma::vec PYi(J);
  for (j = 0; j < J; j++){
    lodd_j =  LT(j) - TAU(j);
    if(lodd_j<0){
      b = 0;
    } else {
      b = lodd_j;
    }
    PYi(j) = exp(lodd_j-b)/(exp(-b) + exp(lodd_j-b));
  }

  double ll = 0.0;
  for (j = 0; j < J; j++){
    if (Yi(j)==1L){
      ll += log(PYi(j));
    }
    if (Yi(j)==0L){
      ll += log(1.0-PYi(j));
    }
  }

  //Prior distriubtion
  arma::vec dMUi = THETAi-MUi;
  double twoprior = as_scalar(dMUi.t()*invS*dMUi);

  // Return result
  double dpost = -1.0*ll - 0.5*twoprior;
  return dpost;
}

下面是目標函數的R版本：

    lf_posterior_density<-function(THETAi, Yi, MUi, invS, TAU, LAMBDA,J,K, weight = NULL){

  if (is.null(weight)){weight = rep(1,J)}

  # Defined variables
  # PYi - J (vector)
  # ll - (scalar)
  # dMUi -  K (vector)
  # prior - (scalar)

  # Computations

  PYi = as.vector(1/(1 + exp(TAU - LAMBDA%*%THETAi))) # J (vector)

  # likelihood component
  ll = as.numeric(0) #(scalar)
  for (j in 1:J){
    if (Yi[j] == 1L){ll = ll + weight[j]*log(PYi[j])}
    if (Yi[j] == 0L){ll = ll + weight[j]*log(1.0-PYi[j])}
  }

  # prior distribution component
  dMUi = (THETAi - MUi) # K (vector)
  prior = as.numeric(-0.5*(dMUi%*%invS%*%dMUi)) #(scalar)

  # Return
  return(-ll - prior)

}

Answer 1

您的目標函數有所不同：

  ll_cpp = cpp_posterior_density(THETAi = 2*as.vector(THETA0_LF[i,]),
                        Yi = as.vector(Y[i,]),
                        MUi =as.vector(MU_LF[i,]),
                        invS = invS ,TAU = TAU ,LAMBDA = LAMBDA, J = J ,K = K)

  ll_R = lf_posterior_density(THETAi = 2*as.vector(THETA0_LF[i,]),
                        Yi = as.vector(Y[i,]),
                        MUi =as.vector(MU_LF[i,]),
                        invS = invS ,TAU = TAU ,LAMBDA = LAMBDA, J = J ,K = K)

  print(paste0(c("R: log posterior: ", ll_R)))
  #> [1] "R: log posterior: " "22.495400131601"   
  print(paste0(c("cpp: log posterior: ", ll_cpp)))
  #> [1] "cpp: log posterior: " "16.7463952181814"    

我尚未調試您的源代碼以查找錯誤。

在這種情況下，將REPORT = 1添加到control列表中很有用。 對於R，它給出：

initial  value 45.707620 
iter   2 value 28.881100
iter   3 value 22.426070
iter   4 value 20.145499
iter   5 value 19.922129
iter   6 value 19.805083
iter   7 value 19.684769
iter   8 value 19.684366
iter   9 value 19.684345
iter  10 value 19.684343
iter  10 value 19.684343
final  value 19.684343 
converged

對於Rcpp：

initial  value 45.707620 
iter   2 value 23.059207
iter   3 value -33.279972
iter   4 value -77.878965
iter   4 value -77.878965
iter   5 value -93.872445
iter   5 value -93.872445
iter   6 value -2830.594586
iter   6 value -2830.594586
iter   6 value -2830.594586
final  value -2830.594586 
converged