I have wrote a Rcpp code to compute element wise matrix multiplication in R. But when try to run this code R stops working and its exiting. How to correct this function?
Thanks in advance.
library(Rcpp)
func <- 'NumericMatrix mmult( NumericMatrix m , NumericMatrix v, bool byrow=true )
{
if( ! m.nrow() == v.nrow() ) stop("Non-conformable arrays") ;
if( ! m.ncol() == v.ncol() ) stop("Non-conformable arrays") ;
NumericMatrix out(m) ;
for (int i = 1; i <= m.nrow(); i++)
{
for (int j = 1; j <= m.ncol(); j++)
{
out(i,j)=m(i,j) * v(i,j) ;
}
}
return out ;
}'
cppFunction( func )
m1<-matrix(1:4,2,2)
m2<-m1
r1<-mmult(m1,m2)
r2<-m1*m2
The (at least to me) obvious choice is to use RcppArmadillo:
R> cppFunction("arma::mat matmult(arma::mat A, arma::mat B) { return A % B; }",
+ depends="RcppArmadillo")
R> m1 <- m2 <- matrix(1:4,2,2)
R> matmult(m1,m2)
[,1] [,2]
[1,] 1 9
[2,] 4 16
R>
as Armadillo is strongly typed, and has an element-by-element multiplication operator (%) which we use in the one-liner it takes.
You have to keep in mind that c++ uses 0 indexed arrays. (See Why does the indexing start with zero in 'C'? and Why are zero-based arrays the norm? .)
So you need to define your loop to run from 0 to m.nrow() - 1
Try this:
func <- '
NumericMatrix mmult( NumericMatrix m , NumericMatrix v, bool byrow=true )
{
if( ! m.nrow() == v.nrow() ) stop("Non-conformable arrays") ;
if( ! m.ncol() == v.ncol() ) stop("Non-conformable arrays") ;
NumericMatrix out(m) ;
for (int i = 0; i < m.nrow(); i++)
{
for (int j = 0; j < m.ncol(); j++)
{
out(i,j)=m(i,j) * v(i,j) ;
}
}
return out ;
}
'
Then I get:
> mmult(m1,m2)
[,1] [,2]
[1,] 1 9
[2,] 4 16
> m1*m2
[,1] [,2]
[1,] 1 9
[2,] 4 16
Related
I'm looking for a simple way to build a 3D array using Rcpp and make that array accessible in R. I'm still very new to Rcpp and c++ coding in general, so any help would be greatly appreciated.
Here is my source code:
#include <Rcpp.h>
using namespace Rcpp;
int d[5][5][5] = {0};
// [[Rcpp::export]]
int fit(){
for (int X = 0; X < 5; X++){
for (int Y = 0; Y < 5; Y++){
for (int Z = 0; Z < 5; Z++){
d[X][Y][Z] = X + Y + Z;
}
}
}
return d;
}
The idea being I could assign fit() to an element in R (say D), and be able to call from locations in that array.
I realize I could just make "fit" a function of x, y, and z; but for my purposes, having the array in R works much faster.
Again, any help would be super appreciated.
Edit
Thank you for the help Dirk,
One thing I'm still struggling with is running the loops. When I run this loop:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
IntegerVector rcpp_matrix(){
IntegerVector v = IntegerVector(Dimension(2,2));
for (int i = 0; i < 2; i++){
for (int j = 0; j < 2; j++){
v(i,j) = (i + 1) * (j + 1);
}
}
// Return the vector to R
return v;
}
It works as intended. However, when I try to span out to three dimensions, like so:
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
IntegerVector rcpp_matrix(){
IntegerVector v = IntegerVector(Dimension(2,2,2));
for (int i = 0; i < 2; i++){
for (int j = 0; j < 2; j++){
for (int k = 0; k < 2; k++){
v(i,j,k) = (i + 1) * (j + 1) * (k + 1);
}
}
}
// Return the vector to R
return v;
}
I get errors:
file10c2d06d0b.cpp: In function ‘Rcpp::IntegerVector rcpp_matrix()’:
file10c2d06d0b.cpp:14:16: error: no match for call to ‘(Rcpp::IntegerVector {aka Rcpp::Vector<13>}) (int&, int&, int&)’
14 | v(i,j,k) = (i + 1) * (j + 1) * (k + 1);
| ^
Is there some other aspect I'm missing?
Thank you again.
Vectors are key in R, and an array is just a vector with 2-d dimension attribute:
> v <- 1:12
> dim(v) <- c(3,4)
> v
[,1] [,2] [,3] [,4]
[1,] 1 4 7 10
[2,] 2 5 8 11
[3,] 3 6 9 12
>
So we can also do 3-d:
> dim(v) <- c(2,3,2)
> v
, , 1
[,1] [,2] [,3]
[1,] 1 3 5
[2,] 2 4 6
, , 2
[,1] [,2] [,3]
[1,] 7 9 11
[2,] 8 10 12
>
and so on. And that is the exact same thing in Rcpp as seen e.g. here from a unit test snippet:
// [[Rcpp::export]]
IntegerVector integer_dimension_ctor_3(){
return IntegerVector( Dimension( 2, 3, 4) ) ;
}
which we can test quickly:
> Rcpp::cppFunction("IntegerVector ivec3() { return IntegerVector(Dimension(2, 3, 4));}")
> ivec3()
, , 1
[,1] [,2] [,3]
[1,] 0 0 0
[2,] 0 0 0
, , 2
[,1] [,2] [,3]
[1,] 0 0 0
[2,] 0 0 0
, , 3
[,1] [,2] [,3]
[1,] 0 0 0
[2,] 0 0 0
, , 4
[,1] [,2] [,3]
[1,] 0 0 0
[2,] 0 0 0
>
All that said, I recommend you look into Armadillo 'Cubes' and what you can do from RcppArmadillo -- likely more fully featured.
Edit: Here is much simpler Armadillo variant of your approach, using a cube<int> aka icube:
Code
#include <RcppArmadillo/Lightest> // new 'lighter' header
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::export]]
arma::icube make3dvec(){
arma::icube v(2,2,2);
for (int x = 0; x < 2; x++){
for (int y = 0; y < 2; y++){
for (int z = 0; z < 2; z++){
v(x,y,z) = (x + 1) * (y + 1) * (z + 1);
}
}
}
return v;
}
/*** R
make3dvec()
*/
Output
> Rcpp::sourceCpp("~/git/stackoverflow/75036466/answer.cpp")
> make3dvec()
, , 1
[,1] [,2]
[1,] 1 2
[2,] 2 4
, , 2
[,1] [,2]
[1,] 2 4
[2,] 4 8
>
Okay. I found a solution, albeit a little convoluted, to the specific issue I was having.
sourceCpp(code = "
#include <Rcpp.h>
using namespace Rcpp;
// [[Rcpp::export]]
IntegerVector fit(){
int d[2][2][2] = {0};
IntegerVector V = IntegerVector(Dimension(8));
int Count = 0;
for (int X = 0; X < 2; X++){
for (int Y = 0; Y < 2; Y++){
for (int Z = 0; Z < 2; Z++){
d[X][Y][Z] = (X + 1) * (Y + 1) * (Z + 1);
V(Count) = d[X][Y][Z];
Count = Count + 1;
}
}
}
return V;
}
")
Which creates a vector for fit(), which I can use in R to get the array I want, vis-a-vis:
array(fit(),dim=c(2,2,2)
Thank you again for the help. This is speeding up my original model quite a bit.
My Rcpp function returns the same result. Into this function i change some studyClones numbers, but when i take result, i have identical matrix studyClones. What I do wrong?
Rcpp code:
NumericMatrix myFunction(NumericMatrix study, NumericMatrix numMatrix, double coef){
int ind = 0;
int sizeImage = study.rows();
NumericVector randomNumbers;
for(int i=0; i<numMatrix.rows(); i++){
for(int j=ind; j<(numMatrix(i,0)+ind); j++){
randomNumbers = sample(sizeImage, ceil(numMatrix(i,0)*coef), false);
for(int k=0; k<randomNumbers.length(); k++){
if(study(randomNumbers[k],j)==1){
study[randomNumbers[k],j] = 0;
}else{
study[randomNumbers[k],j] = 1;
}
}
}
ind += numMatrix(i,0);
}
return study;
}
R code:
result <- myFunction(studyMatrix, numericMatrix, coefficienM)
all(result==studyMatrix)
[1] TRUE
What you did wrong it that you missed that study is (roughly) a pointer to the original R data. when you modify study at C++ level you modify the original matrix not a copy. Thus the R object studyMatrix is modified in place and you also return it. So basically result and studyMatrix are both the same original object modified in place in memory. Thus they are equal.
Try this code to understand:
void f(NumericMatrix M)
{
M(0,0) = 0;
return;
}
Then in R
m = matrix(1, 2,2)
m
#> [,1] [,2]
#> [1,] 1 1
#> [2,] 1 1
f(m)
m
#> [,1] [,2]
#> [1,] 0 1
#> [2,] 1 1
To fix your issue you can use clone
NumericMatrix f(NumericMatrix M)
{
NumericMatrix MM = clone(M);
MM(0,0) = 0;
return MM;
}
In R, we can use Matrix::nearPD() to calculate nearest positive definite matrix.
I have written a Rcpp-version, nearPD_c, myself as follows (c++ file),
// [[Rcpp::depends(RcppArmadillo)]]
#include <RcppArmadillo.h>
using namespace arma;
using namespace Rcpp;
// [[Rcpp::plugins(cpp11)]]
// [[Rcpp::export]]
vec rep_each(const vec& x, const int each) {
std::size_t n=x.n_elem;
std::size_t n_out=n*each;
vec res(n_out);
auto begin = res.begin();
for (std::size_t i = 0, ind = 0; i < n; ind += each, ++i) {
auto start = begin + ind;
auto end = start + each;
std::fill(start, end, x[i]);
}
return res;
}
mat mat_vec_same_len(mat mt1, vec v1){
//do not check the input...
int t=0;
for(int i=0;i<mt1.n_cols;i++){
for(int j=0;j<mt1.n_rows;j++){
mt1(j,i)=mt1(j,i)*v1(t);
t++;
}
}
return(mt1);
}
// [[Rcpp::export]]
vec pmax_c(double a, vec b){
vec c(b.n_elem);
for(int i=0;i<b.n_elem;i++){
c(i)=std::max(a,b(i));
}
return c;
}
// [[Rcpp::depends(RcppArmadillo)]]
// [[Rcpp::export]]
mat nearPD_c(mat x,
bool corr = false, bool keepDiag = false
,bool do2eigen = true // if TRUE do a sfsmisc::posdefify() eigen step
,bool doSym = false // symmetrize after tcrossprod()
, bool doDykstra = true // do use Dykstra's correction
,bool only_values = false // if TRUE simply return lambda[j].
, double eig_tol = 1e-6 // defines relative positiveness of eigenvalues compared to largest
, double conv_tol = 1e-7 // convergence tolerance for algorithm
,double posd_tol = 1e-8 // tolerance for enforcing positive definiteness
, int maxit = 100 // maximum number of iterations allowed
, bool trace = false // set to TRUE (or 1 ..) to trace iterations
){
int n = x.n_cols;
vec diagX0;
if(keepDiag) {
diagX0 = x.diag();
}
mat D_S;
if(doDykstra) {
//D_S should be like x, but filled with '0' -- following also works for 'Matrix':
D_S = x;
D_S.zeros(); //set all element
}
mat X = x;
int iter = 0 ;
bool converged = false;
double conv = R_PosInf;
mat Y;
mat R;
mat B;
while (iter < maxit && !converged) {
Y = X;
if(doDykstra){
R = Y - D_S;
}
vec d;
mat Q;
if(doDykstra){
B=R;
}else{
B=Y;
}
eig_sym(d, Q, B);
// create mask from relative positive eigenvalues
uvec p= (d>eig_tol*d[1]);
if(sum(p)==0){
//stop("Matrix seems negative semi-definite")
break;
}
// use p mask to only compute 'positive' part
uvec p_indexes(sum(p));
int p_i_i=0;
for(int i=0;i<p.n_elem;i++){
if(p(i)){
p_indexes(p_i_i)=i;
p_i_i++;
}
}
Q=Q.cols(p_indexes);
X=mat_vec_same_len(Q,rep_each(d.elem(p_indexes),Q.n_rows))*Q.t();
// update Dykstra's correction D_S = \Delta S_k
if(doDykstra){
D_S = X - R;
}
// project onto symmetric and possibly 'given diag' matrices:
if(doSym){
X = (X + X.t())/2;
}
if(corr){
X.diag().ones(); //set diagnols as ones
}
else if(keepDiag){
X.diag() = diagX0;
}
conv = norm(Y-X,"inf")/norm(Y,"inf");
iter = iter + 1;
if (trace){
// cat(sprintf("iter %3d : #{p}=%d, ||Y-X|| / ||Y||= %11g\n",
// iter, sum(p), conv))
Rcpp::Rcout << "iter " << iter <<" : #{p}= "<< sum(p) << std::endl;
}
converged = (conv <= conv_tol);
// force symmetry is *NEVER* needed, we have symmetric X here!
//X <- (X + t(X))/2
if(do2eigen || only_values) {
// begin from posdefify(sfsmisc)
eig_sym(d, Q, X);
double Eps = posd_tol * std::abs(d[1]);
// if (d[n] < Eps) { //should be n-1?
if (d(n-1) < Eps) {
uvec d_comp = d < Eps;
for(int i=0;i<sum(d_comp);i++){
if(d_comp(i)){
d(i)=Eps;
}
}
// d[d < Eps] = Eps; //how to assign values likes this?
if(!only_values) {
vec o_diag = X.diag();
X = Q * (d *Q.t());
vec D = sqrt(pmax_c(Eps, o_diag)/X.diag());
x=D * X * rep_each(D, n);
}
}
if(only_values) return(d);
// unneeded(?!): X <- (X + t(X))/2
if(corr) {
X.diag().ones(); //set diag as ones
}
else if(keepDiag){
X.diag()= diagX0;
}
} //end from posdefify(sfsmisc)
}
if(!converged){ //not converged
Rcpp::Rcout << "did not converge! " <<std::endl;
}
return X;
// return List::create(_["mat"] = X,_["eigenvalues"]=d,
//
// _["corr"] = corr, _["normF"] = norm(x-X, "fro"), _["iterations"] = iter,
// _["rel.tol"] = conv, _["converged"] = converged);
}
However, although nearPD and nearPD_c give similar results, they are not identical. For example (in R):
> mt0=matrix(c(0.5416, -0.0668 , -0.1538, -0.2435,
+ -0.0668 , 0.9836 , -0.0135 , -0.0195,
+ -0.1538 , -0.0135 , 0.0226 , 0.0334,
+ -0.2435, -0.0195 , 0.0334 , 0.0487),4,byrow = T)
> nearPD(mt0)$mat
4 x 4 Matrix of class "dpoMatrix"
[,1] [,2] [,3] [,4]
[1,] 0.55417390 -0.06540967 -0.14059121 -0.22075966
[2,] -0.06540967 0.98375373 -0.01203943 -0.01698557
[3,] -0.14059121 -0.01203943 0.03650733 0.05726836
[4,] -0.22075966 -0.01698557 0.05726836 0.08983952
> nearPD_c(mt0)
[,1] [,2] [,3] [,4]
[1,] 0.55417390 -0.06540967 -0.14059123 -0.22075967
[2,] -0.06540967 0.98375373 -0.01203944 -0.01698557
[3,] -0.14059123 -0.01203944 0.03650733 0.05726837
[4,] -0.22075967 -0.01698557 0.05726837 0.08983952
There are some differences in 7th or 8th decimal, which make nearPD(mt0) positive define while nearPD_c(mt0) not.
> chol(nearPD(mt0)$mat)
4 x 4 Matrix of class "Cholesky"
[,1] [,2] [,3] [,4]
[1,] 7.444286e-01 -8.786561e-02 -1.888579e-01 -2.965491e-01
[2,] . 9.879440e-01 -2.898297e-02 -4.356729e-02
[3,] . . 1.029821e-04 1.014128e-05
[4,] . . . 1.071201e-04
> chol(nearPD_c(mt0))
Error in chol.default(nearPD_c(mt0)) :
the leading minor of order 3 is not positive definite
I sense that there might be some rounding issue in Rcpp. But I couldn't identify it. Any insights of what goes wrong?
There is at least one logic error in your post-processing. In R we have:
e <- eigen(X, symmetric = TRUE)
d <- e$values
Eps <- posd.tol * abs(d[1])
if (d[n] < Eps) {
d[d < Eps] <- Eps
[...]
While you have:
eig_sym(d, Q, X);
double Eps = posd_tol * std::abs(d[1]);
// if (d[n] < Eps) { //should be n-1?
if (d(n-1) < Eps) {
uvec d_comp = d < Eps;
for(int i=0;i<sum(d_comp);i++){
if(d_comp(i)){
d(i)=Eps;
}
}
According to the Armadillo docs, eigen values are in ascending order, while they are in decreasing order in R. So R builds Eps based on the largest eigen value, while you use the second(!) smallest. Then R compares with the smallest eigen value, while you compare with the largest. Something like this should give the same results as R (untested):
eig_sym(d, Q, X);
double Eps = posd_tol * std::abs(d[n-1]);
if (d(0) < Eps) {
uvec d_comp = d < Eps;
for(int i=0;i<sum(d_comp);i++){
if(d_comp(i)){
d(i)=Eps;
}
}
BTW, you only need // [[Rcpp::export]] for functions that you want to call from R.
I have a large matrix (9600x9600, 703.6 Mb) that keeps changing for no apparent reason. When created it looks fine, but after being used for calculations all of the sudden all the values except for a few columns are replaced by 0s. It's driving me a bit crazy since I cannot debug the problem. Is there a way to trace what is making this variable change? Like a change or access log? Or alternatively is there a way to lock the variable so that it cannot be modified?
Any help is greatly appreciated.
edit:
It seems matrix "L" is modified after applying this equation, even after it has been locked through 'lockBinding':
F.calc.E = function(M,p){
M$V1 <- paste(M$V1,M$V2,sep = ", ")
p.loc = grep(pattern = p,x = M$V1) # loc of target pressure
p.vector = as.numeric(M[p.loc,4:ncol(M),with=FALSE])
pL = mmult(L,p.vector)
return(pL)
}
The code for the mmult function is this, obtained through another SO post:
func <- 'NumericMatrix mmult( NumericMatrix m , NumericVector v , bool byrow = true ){
if( byrow );
if( ! m.nrow() == v.size() ) stop("Non-conformable arrays") ;
if( ! byrow );
if( ! m.ncol() == v.size() ) stop("Non-conformable arrays") ;
NumericMatrix out(m) ;
if( byrow ){
for (int j = 0; j < m.ncol(); j++) {
for (int i = 0; i < m.nrow(); i++) {
out(i,j) = m(i,j) * v[j];
}
}
}
if( ! byrow ){
for (int i = 0; i < m.nrow(); i++) {
for (int j = 0; j < m.ncol(); j++) {
out(i,j) = m(i,j) * v[i];
}
}
}
return out ;
}'
I am still unable to debug.
You could use lockBinding:
m <- matrix(1:4, 2)
evil.fun <- function(x) .GlobalEnv[[x]][2,2] <- 0
evil.fun("m")
m
# [,1] [,2]
#[1,] 1 3
#[2,] 2 0
m <- matrix(1:4, 2)
lockBinding("m", .GlobalEnv)
evil.fun("m")
#Error in .GlobalEnv[[x]][2, 2] <- 0 :
# cannot change value of locked binding for 'm'
unlockBinding("m", .GlobalEnv)
I am trying to find an optimal way for finding the index of the maximum value in each row. The problem is that I cannot find a really efficient way in doing it.
An example:
Dummy <- matrix(runif(500000000,0,3), ncol = 10000)
> system.time(max.col(Dummy, "first"))
user system elapsed
5.532 0.075 5.599
> system.time(apply(Dummy,1,which.max))
user system elapsed
14.638 0.210 14.828
> system.time(rowRanges(Dummy))
user system elapsed
2.083 0.029 2.109
My main question is, why is it more than 2 times so slow to calculate the indices of the max value in comparison with calculating the max and the min with the rowRanges function. Is there a way how I can improve the performance of calculating the index of the max of each row?
Expanding on krlmlr's answer, some benchmarks:
On dataset:
set.seed(007); Dummy <- matrix(runif(50000000,0,3), ncol = 1000)
maxCol_R is an R by-column loop, maxCol_col is a C by-column loop, maxCol_row is a C by-row loop.
microbenchmark::microbenchmark(max.col(Dummy, "first"), maxCol_R(Dummy), maxCol_col(Dummy), maxCol_row(Dummy), times = 30)
#Unit: milliseconds
# expr min lq median uq max neval
# max.col(Dummy, "first") 1209.28408 1245.24872 1268.34146 1291.26612 1504.0072 30
# maxCol_R(Dummy) 1060.99994 1084.80260 1099.41400 1154.11213 1436.2136 30
# maxCol_col(Dummy) 86.52765 87.22713 89.00142 93.29838 122.2456 30
# maxCol_row(Dummy) 577.51613 583.96600 598.76010 616.88250 671.9191 30
all.equal(max.col(Dummy, "first"), maxCol_R(Dummy))
#[1] TRUE
all.equal(max.col(Dummy, "first"), maxCol_col(Dummy))
#[1] TRUE
all.equal(max.col(Dummy, "first"), maxCol_row(Dummy))
#[1] TRUE
And the functions:
maxCol_R = function(x)
{
ans = rep_len(1L, nrow(x))
mx = x[, 1L]
for(j in 2:ncol(x)) {
tmp = x[, j]
wh = which(tmp > mx)
ans[wh] = j
mx[wh] = tmp[wh]
}
ans
}
maxCol_col = inline::cfunction(sig = c(x = "matrix"), body = '
int nr = INTEGER(getAttrib(x, R_DimSymbol))[0], nc = INTEGER(getAttrib(x, R_DimSymbol))[1];
double *px = REAL(x), *buf = (double *) R_alloc(nr, sizeof(double));
for(int i = 0; i < nr; i++) buf[i] = R_NegInf;
SEXP ans = PROTECT(allocVector(INTSXP, nr));
int *pans = INTEGER(ans);
for(int j = 0; j < nc; j++) {
for(int i = 0; i < nr; i++) {
if(px[i + j*nr] > buf[i]) {
buf[i] = px[i + j*nr];
pans[i] = j + 1;
}
}
}
UNPROTECT(1);
return(ans);
', language = "C")
maxCol_row = inline::cfunction(sig = c(x = "matrix"), body = '
int nr = INTEGER(getAttrib(x, R_DimSymbol))[0], nc = INTEGER(getAttrib(x, R_DimSymbol))[1];
double *px = REAL(x), *buf = (double *) R_alloc(nr, sizeof(double));
for(int i = 0; i < nr; i++) buf[i] = R_NegInf;
SEXP ans = PROTECT(allocVector(INTSXP, nr));
int *pans = INTEGER(ans);
for(int i = 0; i < nr; i++) {
for(int j = 0; j < nc; j++) {
if(px[i + j*nr] > buf[i]) {
buf[i] = px[i + j*nr];
pans[i] = j + 1;
}
}
}
UNPROTECT(1);
return(ans);
', language = "C")
EDIT Jun 10 '16
With slight changes to find the indices of both max and min:
rangeCol = inline::cfunction(sig = c(x = "matrix"), body = '
int nr = INTEGER(getAttrib(x, R_DimSymbol))[0], nc = INTEGER(getAttrib(x, R_DimSymbol))[1];
double *px = REAL(x),
*maxbuf = (double *) R_alloc(nr, sizeof(double)),
*minbuf = (double *) R_alloc(nr, sizeof(double));
memcpy(maxbuf, &(px[0 + 0*nr]), nr * sizeof(double));
memcpy(minbuf, &(px[0 + 0*nr]), nr * sizeof(double));
SEXP ans = PROTECT(allocMatrix(INTSXP, nr, 2));
int *pans = INTEGER(ans);
for(int i = 0; i < LENGTH(ans); i++) pans[i] = 1;
for(int j = 1; j < nc; j++) {
for(int i = 0; i < nr; i++) {
if(px[i + j*nr] > maxbuf[i]) {
maxbuf[i] = px[i + j*nr];
pans[i] = j + 1;
}
if(px[i + j*nr] < minbuf[i]) {
minbuf[i] = px[i + j*nr];
pans[i + nr] = j + 1;
}
}
}
UNPROTECT(1);
return(ans);
', language = "C")
set.seed(007); m = matrix(sample(24) + 0, 6, 4)
m
# [,1] [,2] [,3] [,4]
#[1,] 24 7 23 6
#[2,] 10 17 21 11
#[3,] 3 22 20 14
#[4,] 2 18 1 15
#[5,] 5 19 12 8
#[6,] 16 4 9 13
rangeCol(m)
# [,1] [,2]
#[1,] 1 4
#[2,] 3 1
#[3,] 2 1
#[4,] 2 3
#[5,] 2 1
#[6,] 1 2
Here's a pretty basic Rcpp implementation:
#include <Rcpp.h>
// [[Rcpp::export]]
Rcpp::NumericVector MaxCol(Rcpp::NumericMatrix m) {
R_xlen_t nr = m.nrow(), nc = m.ncol(), i = 0;
Rcpp::NumericVector result(nr);
for ( ; i < nr; i++) {
double current = m(i, 0);
R_xlen_t idx = 0, j = 1;
for ( ; j < nc; j++) {
if (m(i, j) > current) {
current = m(i, j);
idx = j;
}
}
result[i] = idx + 1;
}
return result;
}
/*** R
microbenchmark::microbenchmark(
"Rcpp" = MaxCol(Dummy),
"R" = max.col(Dummy, "first"),
times = 200L
)
#Unit: milliseconds
# expr min lq mean median uq max neval
# Rcpp 221.7777 224.7442 242.0089 229.6407 239.6339 455.9549 200
# R 513.4391 524.7585 562.7465 539.4829 562.3732 944.7587 200
*/
I had to scale your sample data down by an order of magnitude since my laptop did not have enough memory, but the results should translate on your original sample data:
Dummy <- matrix(runif(50000000,0,3), ncol = 10000)
all.equal(MaxCol(Dummy), max.col(Dummy, "first"))
#[1] TRUE
This can be changed slightly to return the indices of the min and max in each row:
// [[Rcpp::export]]
Rcpp::NumericMatrix MinMaxCol(Rcpp::NumericMatrix m) {
R_xlen_t nr = m.nrow(), nc = m.ncol(), i = 0;
Rcpp::NumericMatrix result(nr, 2);
for ( ; i < nr; i++) {
double cmin = m(i, 0), cmax = m(i, 0);
R_xlen_t min_idx = 0, max_idx = 0, j = 1;
for ( ; j < nc; j++) {
if (m(i, j) > cmax) {
cmax = m(i, j);
max_idx = j;
}
if (m(i, j) < cmin) {
cmin = m(i, j);
min_idx = j;
}
}
result(i, 0) = min_idx + 1;
result(i, 1) = max_idx + 1;
}
return result;
}
R stores matrices in column-major order. Therefore, iterating over the columns will be usually faster because the values for one column are close to each other in memory and will travel through the cache hierarchy in one go:
Dummy <- matrix(runif(100000000,0,3), ncol = 10000)
system.time(apply(Dummy,1,function(x) NULL))
## user system elapsed
## 1.360 0.160 1.519
system.time(apply(Dummy,2,function(x) NULL))
## user system elapsed
## 0.94 0.12 1.06
This should be close to the minimal time even the fastest Rcpp solution will be able to obtain. Any solution that uses apply() will have to copy each column/row, this can be saved when using Rcpp. You decide if the potential speed-up by a factor of 2 is worth the effort to you.
Generally, the fastest way to do things in R is to call C, C++, or FORTRAN.
It appears that matrixStats::rowRanges is implemented in C which explains why it is the fastest.
If you want to improve performance even more, there is presumably a little bit of speed to gain in modifying the rowRanges.c code to ignore the minimum and just get the maximum, but I think the gains will be very small.
Tried with STL algorithms and RcppArmadillo.
microbenchmark::microbenchmark(MaxColArmadillo(Dummy), #Using RcppArmadillo
MaxColAlgorithm(Dummy), #Using STL algorithm max_element
maxCol_col(Dummy), #Column processing
maxCol_row(Dummy)) #Row processing
Unit: milliseconds
expr min lq mean median uq max neval
MaxColArmadillo(Dummy) 227.95864 235.01426 261.4913 250.17897 276.7593 399.6183 100
MaxColAlgorithm(Dummy) 292.77041 345.84008 392.1704 390.66578 433.8009 552.2349 100
maxCol_col(Dummy) 40.64343 42.41487 53.7250 48.10126 61.3781 128.4968 100
maxCol_row(Dummy) 146.96077 158.84512 173.0941 169.20323 178.7959 272.6261 100
STL implementation
#include <Rcpp.h>
// [[Rcpp::export]]
// Argument is a matrix ansd returns a
// vector of max of each of the rows of the matrix
Rcpp::NumericVector MaxColAlgorithm(Rcpp::NumericMatrix m) {
//int numOfRows = m.rows();
//Create vector with 0 of size numOfRows
Rcpp::NumericVector total(m.rows());
for(int i = 0; i < m.rows(); ++i)
{
//Create vector of the rows of matrix
Rcpp::NumericVector rVec = m.row(i);
//Apply STL max of elemsnts on the vector and store in a vector
total(i) = *std::max_element(rVec.begin(), rVec.end());
}
return total;
}
RcppArmadillo implementation
#include <RcppArmadillo.h>
// [[Rcpp::depends(RcppArmadillo)]]
using namespace Rcpp;
// [[Rcpp::export]]
arma::mat MaxColArmadillo(arma::mat x)
{
//RcppArmadillo max function where dim = 1 means max of each row
// of the matrix
return(max(x,1));
}