I am new to Rcpp and am looking to make the following code as fast as possible. Any tips would be greatly appreciated.
It is running a lot slower than I would like.
I have tried vectorising as much as possible but i'm not sure how to vectorise further
// [[Rcpp::export]]
arma::mat fn_update_log_posterior(arma::mat current_logdiffs_set_mat,
int K,
int N,
int l_class,
int ord_test,
int n_bin_tests,
arma::mat first_cutpoint_mat,
arma::mat prev,
arma::cube prob_test,
arma::mat prob,
arma::vec class_ind,
arma::cube Xbeta,
double prior_ind_dir,
arma::mat yp1,
arma::mat y,
double prior_densities) {
arma::mat current_cutpoints_set_full = fn_calculate_cutpoints(current_logdiffs_set_mat, first_cutpoint_mat, K);
arma::mat log_prob(1,1);
arma::vec lp(N);
arma::vec lower_ord_inv_prob(N);
arma::vec upper_ord_inv_prob(N);
arma::vec lower_ord_prob(N);
arma::vec upper_ord_prob(N);
arma::mat prob_test_n(prob_test.n_cols, prob_test.n_slices);
for (int n = 0; n < N;++ n) {
upper_ord_inv_prob.at(n) = current_cutpoints_set_full.at(yp1.at(n, ord_test)) - Xbeta.at(l_class , n , ord_test);
lower_ord_inv_prob.at(n) = current_cutpoints_set_full.at(y.at(n, ord_test)) - Xbeta.at(l_class, n , ord_test);
}
upper_ord_prob = fn_Phi_approx_vec_2(upper_ord_inv_prob);
lower_ord_prob = fn_Phi_approx_vec_2(lower_ord_inv_prob);
for (int n = 0; n < N; ++n) {
prob_test.at(n, ord_test, l_class) = log( upper_ord_prob(n) - lower_ord_prob(n) );
prob_test_n = prob_test.row(n);
prob.at(n,l_class) = sum(prob_test_n.col(l_class)) + log(prev.at(0, l_class));
lp.at(n) = prob.at(n,class_ind(n) - 1); // works for any number of classes
}
log_prob(0,0) = sum(lp) + prior_densities;
return(log_prob);
}
Related
I am working on speeding up a program I wrote in R. The code involves repeatedly computing LogSumExp over multidimensional arrays, i.e computing s_lnj = exp(u_lnj) / (1 + sum_k exp(u_lnk)). The base R version of the code I am trying to increase the speed of is the following:
log_sum_exp_func <- function(vec){
max_vec <- max(vec)
return(max_vec + log(sum(exp(vec-max_vec))))
}
compute_share_from_utils_func <- function(u_lnj){
### get dimensions
L <- dim(u_lnj)[1]; n_poly <- dim(u_lnj)[2]; J <- dim(u_lnj)[3]
### compute denominator of share, 1 + sum exp utils
den_ln <- 1 + exp(apply(u_lnj, c(1,2), log_sum_exp_func))
den_lnj <- array(rep(den_ln, J), dim = c(L, n_poly, J))
### take ratio of utils and denominator
s_lnj <- exp(u_lnj) / den_lnj
return(s_lnj)
}
I tried to use xtensor and Rcpp to speed things up, but ran into several issues. The Rcpp code I wrote is the following
// [[Rcpp::depends(xtensor)]]
// [[Rcpp::plugins(cpp14)]]
#include <numeric> // Standard library import for std::accumulate
#define STRICT_R_HEADERS // Otherwise a PI macro is defined in R
#include "xtensor/xmath.hpp" // xtensor import for the C++ universal functions
#include "xtensor/xarray.hpp"
#include "xtensor/xio.hpp"
#include "xtensor/xview.hpp"
#include "xtensor-r/rarray.hpp" // R bindings
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
double cxxlog_sum_exp_vec(xt::rarray<double>& m)
{
auto shape_m = m.shape();
double maxvec = xt::amax(m)[0];
xt::rarray<double> arr_maxvec = maxvec * xt::ones<double>(shape_m);
xt::rarray<double> vec_min_max = m - arr_maxvec;
xt::rarray<double> exp_vec_min_max = xt::exp(vec_min_max);
double sum_exp = xt::sum(exp_vec_min_max)[0];
double log_sum_exp = std::log(sum_exp);
return log_sum_exp + maxvec;
}
// [[Rcpp::export]]
xt::rarray<double> cxxshare_from_utils(xt::rarray<double>& u_lnj)
{
int L = u_lnj.shape(0);
int N = u_lnj.shape(1);
int J = u_lnj.shape(2);
xt::rarray<double> res = xt::ones<double>({L,N,J});
for (std::size_t l = 0; l < u_lnj.shape()[0]; ++l)
{
for (std::size_t n = 0; n < u_lnj.shape()[1]; ++n)
{
xt::rarray<double> utils_j = xt::view(u_lnj, l, n, xt::all());
double inv_lse = 1 / (1 + std::exp(cxxlog_sum_exp_vec(utils_j)));
for (std::size_t j = 0; j < J; ++j)
{
res(l, n, j) = std::exp(u_lnj(l, n, j)) * inv_lse;
}
}
}
return res;
}
The Rcpp implementation does seem to yield the same results as the base R code, however it seems to encounter problems whenever the dimensions of the input array increase. My R Session fails if I run
L <- 100
n <- 100
J <- 200
u_lnj <- array(rnorm(L*n*J,0,2), dim = c(L, n, J))
test <- cxxshare_from_utils(u_lnj)
But the code runs fine for L, n, J = 10,10,20 for instance. Moreover, the C++ implementation of log_sum_exp does not seem to outperform the base R version that much.
EDIT: I could not figure out what was the issue with the way I am using xtensor. But I did get some speed up with the following RcppArmadillo code. The drawback of this version is that is likely not as robust to overflow as the base R function relying on Log Sum Exp.
#include <RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::plugins(cpp14)]]
// [[Rcpp::export]]
arma::cube cxxarma_share_from_utils(arma::cube u_lnj) {
// Extract the different dimensions
// Normal Matrix dimensions
unsigned int L = u_lnj.n_rows;
unsigned int N = u_lnj.n_cols;
// Depth of Array
unsigned int J = u_lnj.n_slices;
//resulting cube
arma::cube s_lnj = arma::exp(u_lnj);
for (unsigned int l = 0; l < L; l++) {
for (unsigned int n = 0; n < N; n++) {
double den = 1 / (1 + arma::accu(s_lnj.subcube(arma::span(l), arma::span(n), arma::span())));
for (unsigned int j = 0; j < J; j++) {
s_lnj(l, n, j) = s_lnj(l, n, j) * den;
}
}
}
return s_lnj;
}
When using Rcpp,I create a function named rpois_rcpp and l try to call it below in genDataList function, an error occurs and said :
"no matching function for call to 'cpprbinom',
candidate function not viable: no known conversion from 'arma::vec' (aka 'Col') to 'Rcpp::NumericVector' (aka 'Vector<14>') for 3rd argument
arma::vec cpprbinom(int n, double size, NumericVector prob).
Can someone help me ,thanks!
Here is my code:
//create a random matrix X with covariance matrix sigma
// [[Rcpp::export]]
arma::mat mvrnormArma(const int n, arma::vec mu, const int p, const
double rho) {
arma::mat sigma(p, p, arma::fill::zeros);
for (int i = 0; i < sigma.n_rows; ++i) {
for (int j = 0; j < sigma.n_cols; ++j) {
sigma(i,j) = pow(rho, abs((i + 1) - (j + 1)));
}
}
int ncols = sigma.n_cols;
arma::mat Y = arma::randn(n, ncols);
return arma::repmat(mu, 1, n).t() + Y * arma::chol(sigma);
}
//create a vector sampled from poisson distribution with mean vector
//lambda
// [[Rcpp::export]]
arma::vec rpois_rcpp( NumericVector &lambda) {
int n= lambda.length();
unsigned int lambda_i = 0;
IntegerVector sim(n);
for (unsigned int i = 0; i < n; i++) {
sim[i] = R::rpois(lambda[lambda_i]);
// update lambda_i to match next realized value with correct mean
lambda_i++;
}
return as<arma::vec>(sim);
}
//create a vector sampled from binomial distribution with probability
vector prob
// [[Rcpp::export]]
arma::vec cpprbinom(int n, double size, NumericVector prob) {
NumericVector v = no_init(n);
std::transform( prob.begin(), prob.end(), v.begin(), [=](double p){
return R::rbinom(size, p); });
return as<arma::vec>(v);}
// [[Rcpp::export]]44
List genDataList(int n, arma::vec& mu, int p, double rho,
arma::vec& beta, const double SNR, const std::string &
Test_case) {
arma::mat U, V, data, normData, Projection;
arma::vec s, y, means, noise;
data = mvrnormArma(n, mu, p, rho);
normData = arma::normalise(data,2,0);
arma::svd_econ(U,s,V,normData,"right");
Projection = V * trans(V);
beta = Projection * beta;
if(Test_case == "gaussian")
{
means=normData * beta;
y = means + arma::randn(n) * sqrt(arma::var(means) / SNR);}
else if (Test_case == "poisson")
{
means=exp(normData * beta);
y = rpois_rcpp(means);}
else
{
means=exp(normData * beta)/(1 + exp(normData * beta));
y = cpprbinom(n,1,means);}
List ret;
ret["data"] = data;
ret["normData"] = normData;
ret["V"] = V;
ret["beta"] = beta;
ret["y"] = y;
return ret;
}
Thanks for adding your code. When I tried to compile, I got the same error as you, but also an error for the line calling rpois_rcpp()
invalid initialization of reference to type 'Rcpp::NumericVector&'
Pretty much everything seems to be in arma, except the R bindings and calls to the R:: namespace, which takes doubles, ints, etc. It seems the easiest thing to do (to my mind), is just take arma::vec as arguments instead:
arma::vec rpois_rcpp( arma::vec &lambda) {
int n= lambda.n_elem;
and
arma::vec cpprbinom(int n, double size, arma::vec prob) {
You never utilize the fact that lambda and prob are Rcpp::NumericVectors specifically, you just use doubles from them, so this seems the easiest route to me. After those changes, your code compiles fine on my machine. I don't have any test cases to make sure they run as you'd expect, but I imagine they will.
I have a matrix, for which I want to compute the distance (let's say Euclidean) between the ith row and every other row(i.e. I want the ith row of the pairwise distance matrix).
#include <Rcpp.h>
#include <cmath>
#include <algorithm>
#include <RcppParallel.h>
//#include <RcppArmadillo.h>
#include <queue>
using namespace std;
using namespace Rcpp;
using namespace RcppParallel;
// [[Rcpp::export]]
double dist_fun(NumericVector row1, NumericVector row2){
double rval = 0;
for (int i = 0; i < row1.length(); i++){
rval += (row1[i] - row2[i]) * (row1[i] - row2[i]);
}
return rval;
}
// [[Rcpp::export]]
NumericVector dist_row(NumericMatrix mat, int i){
NumericVector row(mat.nrow());
NumericMatrix::Row row1 = mat.row(i - 1);
for (int j = 0; j < mat.nrow(); j++){
NumericMatrix::Row row2 = mat.row(j);
row(j) = dist_fun(row1, row2);
}
return row;
}
// [[Rcpp::depends(RcppParallel)]]
struct JsDistance: public Worker {
// input matrix to read from
const NumericMatrix mat;
int i;
// output vector to write to
NumericVector output;
// initialize from Rcpp input and output matrixes (the RMatrix class
// can be automatically converted to from the Rcpp matrix type)
JsDistance(const NumericMatrix mat, int i, NumericVector output)
: mat(mat), i(i), output(output) {}
// function call operator that work for the specified range (begin/end)
void operator()(std::size_t begin, std::size_t end) {
NumericVector row1 = mat.row(i);
for (std::size_t j = begin; j < end; j++) {
NumericVector row2 = mat.row(j);
output[j] = dist_fun(row1, row2);
}
}
};
// [[Rcpp::export]]
NumericVector parallel_dist_row(NumericMatrix mat, int i) {
// allocate the matrix we will return
NumericVector output(mat.nrow());
// create the worker
JsDistance JsDistance(mat, i, output);
// call it with parallelFor
parallelFor(0, mat.nrow(), JsDistance);
return output;
}
The sequential way using Rcpp is the function 'row_dist' as written above. Yet the matrix I want to work with is very large so I want to parallelize it. But then I will run into a segfault error which I don't quite understand why. To trigger the error you can run the following code:
library(Rcpp)
library(RcppParallel)
setThreadOptions(numThreads = 20)
set.seed(42)
X = matrix(rnorm(10000 * 400), 10000, 400)
sourceCpp("question.cpp")
start1 = proc.time()
print(dist_row(X, 2)[1:30])
print(proc.time() - start1)
start2 = proc.time()
print(parallel_dist_row(X, 2)[1:30])
print(proc.time() - start2)
Can someone give me some hint about what I did wrong? Thanks in advance for your time!
=======================================================================
Edit:
inline double d(double a, double b){
return fabs(a - b);
}
// [[Rcpp::depends(RcppParallel)]
struct dtwDistance: public Worker {
// Input matrix to read from must be of the RMatrix<T> form
// if using Rcpp objects
const RMatrix<double> mat;
int i;
// Output vector to write to must be of the RVector<T> form
// if using Rcpp objects
RVector<double> output;
// initialize from Rcpp input and output matrixes (the RMatrix class
// can be automatically converted to from the Rcpp matrix type)
dtwDistance(const NumericMatrix mat, int i, NumericVector output)
: mat(mat), i(i - 1), output(output) {}
// Note the -1 ^^^^ to match results from prior function
// Function call operator to iterate over a specified range (begin/end)
void operator()(std::size_t begin, std::size_t end) {
RMatrix<double>::Row row1 = mat.row(i);
for (std::size_t j = begin; j < end; ++j) {
RMatrix<double>::Row row2 = mat.row(j);
size_t n = row1.length();
size_t m = row2.length();
NumericMatrix cost(n + 1, m + 1);
for (int ii = 1; ii <= n; ii++){
cost(i, 0) = numeric_limits<double>::infinity();
}
for (int jj = 1; jj <= m; jj++){
cost(0, j) = numeric_limits<double>::infinity();
}
for (int ii = 1; ii <= n; ii++){
for (int jj = 1; jj <= m; jj++){
double dist = d(row1[ii - 1], row2[jj - 1]);
cost(ii, jj) = dist + min(min(cost(ii - 1, jj), cost(ii, jj - 1)), cost(ii - 1, jj - 1));
//cout << ii << ", " << jj << ", " << cost(ii, jj) << "\n";
}
}
output[j] = cost(n, m);
}
}
};
// [[Rcpp::export]]
NumericVector parallel_dist_row_dtw(NumericMatrix mat, int i) {
// allocate the matrix we will return
//RMatrix<double> input(mat);
NumericVector y(mat.nrow());
//RVector<double> output(y);
// create the worker
dtwDistance dtwDistance(mat, i, y);
// call it with parallelFor
parallelFor(0, mat.nrow(), dtwDistance);
return y;
}
The distance I needed to calculate is the dynamic time warping distance. I implemented it as above. Yet when running, it will give a 'stack imbalance' warning. And there will be a segfault after several runs. I'm wondering what is the problem now.
To trigger the problem, I did:
library(Rcpp)
library(RcppParallel)
setThreadOptions(numThreads = 4)
sourceCpp("scripts/chisq_dtw.cpp")
set.seed(42)
X = matrix(rnorm(1000), 100, 10)
parallel_dist_row_dtw(X, 1)
parallel_dist_row_dtw(X, 2)
parallel_dist_row_dtw(X, 3)
parallel_dist_row_dtw(X, 4)
parallel_dist_row_dtw(X, 5)
The issue is you are not using the thread-safe wrapper around R objects via RMatrix<T> and RVector<T>. These classes are important because of the parallelization being executed on a background thread, which is an area that is not safe to call R or Rcpp APIs. The official documentation emphasizes this in the Safe Accessors section.
In particular, we have:
To provide safe and convenient access to the arrays underlying R vectors and matrices RcppParallel introduces several accessor classes:
RVector<T> — Wrap R vectors of various types
RMatrix<T> — Wrap R matrices of various types (also includes Row and Column classes)
To create a thread safe accessor for an Rcpp vector or matrix just construct an instance of RVector or RMatrix with it.
Code Fix
So, your work can be fixed by switching *Matrix to RMatrix<T> and *Vector to RVector<T>.
struct JsDistance: public Worker {
// Input matrix to read from must be of the RMatrix<T> form
// if using Rcpp objects
const RMatrix<double> mat;
int i;
// Output vector to write to must be of the RVector<T> form
// if using Rcpp objects
RVector<double> output;
// initialize from Rcpp input and output matrixes (the RMatrix class
// can be automatically converted to from the Rcpp matrix type)
JsDistance(const NumericMatrix mat, int i, NumericVector output)
: mat(mat), i(i - 1), output(output) {}
// Note the -1 ^^^^ to match results from prior function
// Function call operator to iterate over a specified range (begin/end)
void operator()(std::size_t begin, std::size_t end) {
RMatrix<double>::Row row1 = mat.row(i);
for (std::size_t j = begin; j < end; ++j) {
RMatrix<double>::Row row2 = mat.row(j);
double rval = 0;
for (unsigned int k = 0; k < row1.length(); ++k) {
rval += (row1[k] - row2[k]) * (row1[k] - row2[k]);
}
output[j] = rval;
}
}
};
In particular, the data types used here are of the form RMatrix<double> even for accessing the matrix.
Also, within the parallelized version there is a missing i-1 statement. To remedy this, I've opted to have it taken care of in the constructor of JSDistance.
Test
set.seed(42)
X = matrix(rnorm(10000 * 400), 10000, 400)
start1 = proc.time()
print(dist_row(X, 2)[1:30])
# [1] 811.8873 0.0000 799.8153 810.1442 720.3232 730.6083 797.8441 781.8066 827.1511 834.1863 842.9392 850.2476 724.5842 673.1428 775.0994
# [16] 805.5752 804.9281 774.9770 799.7669 870.3187 815.1129 934.7581 726.1554 804.2097 758.4943 772.8931 806.6026 715.8257 847.8980 831.7555
print(proc.time() - start1)
# user system elapsed
# 0.22 0.00 0.23
start2 = proc.time()
print(parallel_dist_row(X, 2)[1:30])
# [1] 811.8873 0.0000 799.8153 810.1442 720.3232 730.6083 797.8441 781.8066 827.1511 834.1863 842.9392 850.2476 724.5842 673.1428 775.0994
# [16] 805.5752 804.9281 774.9770 799.7669 870.3187 815.1129 934.7581 726.1554 804.2097 758.4943 772.8931 806.6026 715.8257 847.8980 831.7555
print(proc.time() - start2)
# user system elapsed
# 0.28 0.00 0.06
all.equal(parallel_dist_row(X, 2), dist_row(X, 2))
# [1] TRUE
I am a new user of Rcpp and I am writing an package.
I have defined two functions in one script and try to call one from another in the loop.
One of my function defined as below:
#include <RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo)]]
using namespace Rcpp;
using namespace arma;
// [[Rcpp::export]]
double timesTwo(colvec x, NumericVector group, double k,
NumericVector unique_group)
{
vec beta(x.begin(),x.size(),false);
vec Group(group.begin(),group.size(),false);
vec unigroup(unique_group.begin(),unique_group.size(),false);
beta = pow(beta,k);
int g = unigroup.size();
int j = 0;
uvec st ;
double b=0;
for(j = 0; j < g; j++)
{
st = find(Group == unigroup[j]);
b = b + abs(pow(sum(beta.elem(st)),1/k));
}
double s = b;
return s;
}
And the loop I use to to call this function is like below:
XtXi_beta_plus.col(i) = X_MAT * BETA_NEW.col(2*i);
XtXi_beta_minus.col(i) = X_MAT * BETA_NEW.col(2*i+1);
loss_new_1.col(i) = (Y - ited / (ited + exp( -XtXi_beta_plus.col(i))));
loss_new_2.col(i) = (Y - ited / (ited + exp( -XtXi_beta_minus.col(i))));
new_loss(2*i) = accu(loss_new_1.col(i) % loss_new_1.col(i));
new_loss(2*i+1) = accu(loss_new_2.col(i) % loss_new_2.col(i));
z = BETA_NEW.col(2*i);
w = BETA_NEW.col(2*i+1);
// when 88 line was change to BETA_NEW.col(2*i) there is an error
// if you keep use Z, there is no update
// best!
pen_new_positive(i) = as<double>(timesTwo(z,group,k,unique_group));
My question is just like the comment I said in the loop, since I want to update that pen_new_postive(i) based on the BETA_NEW.col(2*i) However when I directly put BETA_NEW.COL(2*i) inside the timesTwo function, no matter how I change input
type of function (colvec or mat or whatever) there is error like below:
cannot convert "const::arma::subview_col<double> to "SEXP" in
initialization"
However when I directly use z in the timesTwo function, there is no update for my z in the loop.
Anyone could give me a hint about how to deal with this?
The full version of my code in second block as below:
#include <RcppArmadillo.h>
#include <math.h>
//#include <omp.h>
using namespace Rcpp;
using namespace arma;
//// [[Rcpp::plugins(openmp)]]
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::export]]
List minghan21041(NumericMatrix beta_new, NumericVector diff_loss,
NumericVector beta, double step_size, NumericVector y,
double k,
NumericVector group,
NumericVector unique_group,
NumericMatrix X) {
int n = X.nrow(), p=X.ncol() , n1=beta_new.nrow(), p1=beta_new.ncol();
mat X_MAT(X.begin(),n,p,false), BETA_NEW(beta_new.begin(),n1,p1,false);
vec BETA(beta.begin(),beta.size(),false);
vec Y(y.begin(),y.size(),false),
Diff_Loss(diff_loss.begin(),diff_loss.size(),false), iter(p,fill::zeros);
mat XtXi_beta_plus(n,p,fill::zeros);
mat XtXi_beta_minus(n,p,fill::zeros);
vec ited(n,fill::ones);
mat loss_new_1(n,p, fill::zeros),loss_new_2(n,p, fill::zeros);
colvec loss_new_3(n,fill::zeros);
vec new_loss(p1,fill::zeros);
uword index;
vec beta_final(p,fill::zeros);
vec pen_new_positive(p,fill::zeros);
vec pen_new_negative(p,fill::zeros);
double pen_old = 0;
Function timesTwo( "timesTwo" );
double cs=0;
//Col dc(BETA.begin(),p,1);
//pen_old = as<double>(timesTwo(dc,group,k,unique_group));
vec z(p,fill::zeros);
vec w(p,fill::zeros);
int i = 0;
vec XtXi_beta_old = X_MAT*BETA;
loss_new_3= (Y - ited / (ited + exp(-XtXi_beta_old)));
double loss_old_one = accu(loss_new_3%loss_new_3);
//#pragma omp parallel private(i) num_threads(4)
//{
//#pragma omp for ordered schedule(static,1)
for(i= 0; i<p; i++){
//#pragma omp ordered
//{
iter(i) = step_size;
BETA_NEW.col(2*i) = BETA + iter;
BETA_NEW.col(2*i+1) = BETA - iter;
XtXi_beta_plus.col(i) = X_MAT * BETA_NEW.col(2*i);
XtXi_beta_minus.col(i) = X_MAT * BETA_NEW.col(2*i+1);
loss_new_1.col(i) = (Y - ited / (ited + exp( -XtXi_beta_plus.col(i))));
loss_new_2.col(i) = (Y - ited / (ited + exp( -XtXi_beta_minus.col(i))));
new_loss(2*i) = accu(loss_new_1.col(i) % loss_new_1.col(i));
new_loss(2*i+1) = accu(loss_new_2.col(i) % loss_new_2.col(i));
z = BETA_NEW.col(2*i);
w = BETA_NEW.col(2*i+1);
// when 88 line was change to BETA_NEW.col(2*i) there is an error
// if you keep use Z, there is no update, you can source this file and I
//believe there is no other error
// best!
pen_new_positive(i) = as<double>(timesTwo(BETA_NEW.col(2*i),group,k,unique_group));
cs = pen_new_positive(i);
//Rcout << "cs" << cs << std::endl;
Rcout << "cs" << z << std::endl;
//pen_new_negative = as< std::vector<double> >(time(w,group,k,unique_group));
Diff_Loss(2*i) = new_loss(2*i) - loss_old_one + cs;
Diff_Loss(2*i+1) = new_loss(2*i+1) - loss_old_one + cs;
iter(i) = 0;
}
//}
//}
index = Diff_Loss.index_min();
beta_final = BETA_NEW.col(index);
return List::create( _["index"] = wrap(index),
_["Diff_Loss"]= wrap(Diff_Loss[index]),
_["ste"] =wrap(Diff_Loss),
_["beta_new"] = wrap(beta_final),
_["New_LOSS"]= wrap(new_loss[index]),
_["t"] = wrap(pen_new_positive));
}
I want to improve the speed of some of my R code using Rcpp. However, my knowledge of C++ is very little. So, I checked the documentation provided with Rcpp, and other documents provided at Dirk Eddelbuttel’s site. After reading all the stuff, I tried to execute a simple loop that I wrote in R. unfortunately, I was unable to do it. Here is the R function:
Inverse Wishart
beta = matrix(rnorm(15),ncol=3)
a = rnorm(3)
InW = function(beta,a) {
n = nrow(beta)
p = ncol(beta)
I = diag(rep(1,times = p))
H = matrix(0,nrow=p,ncol=p)
for(i in 1:n){
subBi = beta[i,]
H = H + tcrossprod(a - subBi)
}
H = H + p * I
T = t(chol(chol2inv(chol(H))))
S = 0
for(i in 1:(n+p)){
u <- rnorm(p)
S = S + tcrossprod(T %*% u)
}
D = chol2inv(chol((S)))
ans = list(Dinv = S,D=D)
}
I truly, appreciate if someone can help me as it will serve as starting point in learning Rcpp.
A basic example of RcppArmadillo goes like this,
require(RcppArmadillo)
require(inline)
code <- '
arma::mat beta = Rcpp::as<arma::mat>(beta_);
int n = beta.n_rows; int p = beta.n_cols;
arma::mat Ip = arma::eye<arma::mat>( p, p );
int ii;
double S=0;
for (ii=0; ii<(n+p); ii++) {
S += ii; // dummy calculation
}
return Rcpp::wrap(S);
'
fun <- cxxfunction(signature(beta_ ="matrix"),
code, plugin="RcppArmadillo")
m <- matrix(1:9,3)
fun(m)
and you can browse armadillo's doc to find the more advanced bits and pieces.
an answer to my first question is shown below. It may be not the efficient way but the Rcpp code gives the same results as the R code. I appreciate the help from baptiste.
code <- '<br/>
arma::mat beta = Rcpp::as<arma::mat>(beta_);
arma::rowvec y = Rcpp::as<arma::rowvec>(y_);
int n = beta.n_rows; int p = beta.n_cols;
arma::mat Ip = arma::eye<arma::mat>( p, p );
int ii;
arma::mat H1 = beta, d;
arma::mat H2=H1.zeros(p,p);
arma::rowvec S;
for (ii=0;ii<n;ii++){
S= beta.row(ii);
d = trans(y - S)*(y-S);
H2 = H2 + d ;
}
arma::mat H = chol(H2+p*Ip);
arma::mat Q , R;
qr(Q,R,H);
arma::mat RR = R;
arma::mat TT = trans(chol(solve(trans(RR)*RR,Ip)));
int jj;
arma::mat SS = H1.zeros(p,p);
arma::colvec u;
arma::colvec V;
for(jj=0;jj<(n+p);jj++) {
u = rnorm(p);
V = TT*u;
SS = SS + V * trans(V);
}
arma::mat SS1 = chol(SS);
arma::mat Q1 , R1;
qr(Q1,R1,SS1);
arma::mat SS2 = R1;
arma::mat D = solve(trans(SS2)*SS2,Ip);
return Rcpp::List::create(Rcpp::Named("Dinv")=SS,Rcpp::Named("D")=D);
'
fun = cxxfunction(signature(beta_ ="matrix",y_="numeric"),code, plugin="RcppArmadillo")
m = matrix(rnorm(100),ncol=5)
vec = rnorm(5)
fun(m,vec)