How to speed up this simple function in R - r

Question

I am trying to do Conway–Maxwell-Poisson regression using COMPoissonReg in R
However, it is extremely slow for large dataset. Thus I tried to profile and check the source code.
The majority time (>95%) is spent on a function COMPoissonReg:::computez, which is equivalent to:
test <- function (lambda, nu, max=100)
{
forans <- matrix(0, ncol = max + 1, nrow = length(lambda))
for (j in 1:max) {
temp <- matrix(0, ncol = j, nrow = length(lambda))
for (i in 1:j) {
temp[, i] <- lambda/(i^nu)
}
for (k in 1:length(lambda)) {
forans[k, j + 1] <- prod(temp[k, ])
}
}
forans[, 1] <- rep(1, length(lambda))
ans <- rowSums(forans)
return(ans)
}
v is nu here, and lambda is a vector, max is the upper-limit of s (here it is set to 100 as an approximate to infinity).
The question doesn't really need special background stats knowledge, but the link or link2 is here just in case.
A simple script to test performance, this takes 8 secs, and if I lazily cmpfun compile it, it takes 4 secs. I believe it has the potential to be further improved. (without rewriting in C, and I am aiming for around ~ 0.05 sec so that I don't have to refactor the code in package which iteratively calls this function.)
lambda <- rnorm(10000, 1.5, 0.3)
Rprof(tmp <- tempfile())
sum(log(test(lambda, 1.2)))
Rprof()
summaryRprof(tmp)
Update
I realized another issue: floating point arithmetic limitation. Doing power series is dangerous, it can overflow very soon, especially if we have to vectorize. E.g. lambda ^ 100 is certainly NAN if lambda > 10000. Maybe I will use reduce if I program in other languages, but I fear in R reduce is slow.

Answer 1

You can make it much faster than the function you are using by avoiding loops. For example:
test2<-function(lambda,nu,max=100){
len<-length(lambda)
mm<-matrix(rep(lambda,each=max+1),max+1,len)
mm<-mm^(0:max)
mm<-mm/factorial(0:max)^nu
colSums(mm)
}
This runs about 50 times faster with lambda of length 100:
> require(microbenchmark)
> lam<-rnorm(100)
> max(abs(test(lam,1.2)-test2(lam,1.2)))
[1] 4.510281e-16
> microbenchmark(test(lam,1.2),test2(lam,1.2),times=10)
Unit: milliseconds
expr min lq median uq max neval
test(lam, 1.2) 77.124705 77.422619 78.241945 79.635746 81.260280 10
test2(lam, 1.2) 1.335716 1.373116 1.401411 1.507765 1.562447 10
You can probably optimize it a little more, but this should get most of the gains, unless there is some kind of builtin function you can exploit rather than doing the sum explicitly.
On input of length 10000, it takes 0.148 seconds on my machine, versus 6.850 seconds for test:
> lam<-rnorm(10000)
> max(abs(test(lam,1.2)-test2(lam,1.2)))
[1] 3.552714e-15
> system.time(test2(lam,1.2))
user system elapsed
0.132 0.016 0.148
> system.time(test(lam,1.2))
user system elapsed
6.780 0.056 6.850

Answer 2

OK, here's an Rcpp answer. As expected, it's a lot faster than either of the others.
require(Rcpp)
rcppfun<-"
Rcpp::NumericVector myfun(Rcpp::NumericVector lambda,
Rcpp::NumericVector weights)
{
int num = lambda.size();
int max = weights.size();
std::vector<double> r(num);
for(int i=0; i<num; i++){
double total = 0;
double prod = 1;
for(int j=0; j<max; j++){
total += prod/weights[j];
prod *= lambda[i];
}
r[i]=total;
}
return Rcpp::wrap(r);
}
"
testRcpp<-cppFunction(rcppfun)
test5<-function(lambda,nu,max=100){
wts<-factorial(0:max)^nu
testRcpp(lambda,wts)
}
This is about 40x faster than my original test2 and about 12x faster than than #NealFultz's improved logarithmic implementation.
> lam<-abs(rnorm(10000))
> max(abs(test5(lam,1.2)-test2(lam,1.2)))
[1] 7.105427e-15
> microbenchmark(test2(lam,1.2),test3(lam,1.2),test4(lam,1.2),test5(lam,1.2))
Unit: milliseconds
expr min lq median uq max neval
test2(lam, 1.2) 125.601616 126.790516 127.700099 135.182263 222.340179 100
test3(lam, 1.2) 125.523424 126.666410 126.921035 131.316254 178.633839 100
test4(lam, 1.2) 41.734015 42.640340 43.190553 50.932952 97.765219 100
test5(lam, 1.2) 3.432029 3.501046 3.519007 3.532603 3.754232 100
On edit, here's one more Rcpp version that should at least partially address the overflow issue, by computing each term incrementally, rather than the numerator and denominator separately.
rcppfun2<-"
Rcpp::NumericVector myfun2(Rcpp::NumericVector lambda, Rcpp::NumericVector nu){
int num = lambda.size();
int max = nu.size();
std::vector<double> r(num);
for(int i=0; i<num; i++){
double term = 1;
double total = 1;
for(int j=0; j< max; j++){
term *= (lambda[i]/nu[j]);
total += term;
}
r[i]=total;
}
return Rcpp::wrap(r);
}
"
testRcpp2<-cppFunction(rcppfun2)
test6<-function(lambda,nu,max=100){
testRcpp2(lambda,(1:max)^nu)
}
> lam<-abs(rnorm(10000))
> max(abs(test2(lam,1.2)-test6(lam,1.2)))
[1] 1.065814e-14
> microbenchmark(test5(lam,1.2),test6(lam,1.2))
Unit: milliseconds
expr min lq median uq max neval
test5(lam, 1.2) 3.416786 3.426013 3.435492 3.444196 3.604486 100
test6(lam, 1.2) 3.554147 3.572285 3.580865 3.588030 3.840713 100

Answer 3

I slept on it, came up with another big improvement if you can use the gsl package. All you're doing is evaluating a polynomial:
require(gsl)
test5 <- function(lambda, nu, max=100){
gsl_poly(factorial(0:max)^-nu, lambda)
}
R>microbenchmark(test2(1:50,5.1), test4(1:50,5.1), test5(1:50,5.1))
Unit: microseconds
expr min lq median uq max neval
test2(1:50, 5.1) 4518.957 4838.5185 5318.5040 5617.6330 19978.039 100
test4(1:50, 5.1) 2043.422 2268.3490 2472.0430 2727.1045 10328.376 100
test5(1:50, 5.1) 311.144 407.2465 476.0755 540.6095 1138.766 100

Answer 4

Following up #mrips, sometimes working on the log can be a bit faster because you can multiply instead of exponentiate:
test4 <- function(lambda,nu,max=100){
mm<-matrix(log(lambda),max,length(lambda), byrow=TRUE)
mm<-mm * 1:max - nu*lfactorial(1:max)
1 + colSums(exp(mm))
}
I've also factored out the special case where s = 0. Here's my timings:
R>microbenchmark(test2(1:50,5), test4(1:50,5))
Unit: microseconds
expr min lq median uq max neval
test2(1:50, 5) 952.360 1432.6600 1436.4525 1440.1860 3467.981 100
test4(1:50, 5) 695.189 1041.4785 1042.8315 1045.6525 2970.441 100