Complicated double sum using "outer" - r

Question

I have to calculate the following in R
where kip, c are constants. One way of doing this is like:
xfun<- function(x,k,p,c){
ghhh<-numeric()
for(i in 1: length(x)){
ghhh[i]<-sum(k/(x[i]-x[1:(i-1)]+c)^p)
}
res<-sum(log(ghhh))
return(res)
}
. But can I calculate this using "outer" ? So that it becomes faster?
The data is like:
t <- numeric(2000)
t[1]<-0
for (i in 2:2000){
t[i]<- t[i-1]+rexp(1, 0.2)
}
k=0.5; p=1.2; c=0.02

Answer 1

Your equation is a bit confusing. I'm not sure what should happen in the inner sum if i == 1. Sum from 1 to zero?
Based on some guessing (if I guessed wrong, you need to adjust the following), I suspect your function should be corrected to this:
xfun<- function(x,k,p,c){
ghhh<-numeric() # it would be better practice to use numeric(length(x) - 1)
for(i in 1: (length(x) - 1)){
ghhh[i]<-sum(k/(x[i+1]-x[1:i]+c)^p)
}
res<-sum(log(ghhh))
return(res)
}
t <- numeric(2000)
t[1]<-0
set.seed(42)
for (i in 2:2000){
t[i]<- t[i-1]+rexp(1, 0.2)
}
k=0.5; p=1.2; c=0.02
xfun(t, k, p, c)
#[1] -1526.102
Rewritten with outer:
xfun1 <- function(x ,k ,p ,c){
o <- outer(seq_along(x), seq_along(x), function(i, j) {
res <- numeric(length(i))
test <- j < i
res[test] <- k / (x[i[test]] - x[j[test]] + c) ^ p
res
})
sum(log(rowSums(o)[-1]))
}
xfun1(t, k, p, c)
#[1] -1526.102
Benchmarking:
library(microbenchmark)
microbenchmark(loop = xfun(t, k, p, c),
outer = xfun1(t, k, p, c),
times = 10)
#Unit: milliseconds
# expr min lq mean median uq max neval cld
# loop 186.0454 186.2375 188.9567 187.4005 189.0597 196.6992 10 a
# outer 263.4137 274.6610 346.4505 344.6918 423.3651 425.2885 10 b
As you see, the solution with outer is not faster for data of this size. The main reasons are that R needs to allocate memory for a vector of length 2000^2 and work on this large vector. Also, your simple loop is optimized by the JIT bytecode compiler.
If you want to be faster, you need to switch to a compiled language. Luckily, this is rather easy with Rcpp:
library(Rcpp)
library(inline)
cppFunction(
'double xfun2(const NumericVector x, const double k, const double p, const double c) {
int n = x.length() - 1;
NumericVector ghhh(n);
for (int i = 0; i < n; ++i) {
for (int j = 0; j <= i ; ++j) {
ghhh(i) += k / pow(x(i + 1) - x(j) + c, p);
}
}
ghhh = log(ghhh);
double res;
res = sum(ghhh);
return res;
}')
xfun2(t, k, p, c)
#[1] -1526.102
microbenchmark(loop = xfun(t, k, p, c),
outer = xfun1(t, k, p, c),
Rcpp = xfun2(t, k, p, c),
times = 10)
#Unit: milliseconds
# expr min lq mean median uq max neval cld
# loop 186.0395 188.7875 189.7487 189.9298 191.6967 192.7213 10 b
# outer 408.4452 416.7730 432.3356 419.7510 422.4000 559.4279 10 c
# Rcpp 136.1496 136.1606 136.1929 136.1762 136.2129 136.3089 10 a
As you see, speed gains are minimal for data of this size (JIT compilation is truly marvelous). I suggest to stay with your R loop.

Answer 2

Considering that the logic you implement is the correct one you could try the parallel R functionalities:
library(foreach)
library(doParallel)
xfun2<- function(x,k,p,c){
no_cores <- detectCores() - 1
cl<-makeCluster(no_cores)
registerDoParallel(cl)
ghhh <- foreach(i = 1: length(x), .combine = c) %dopar% sum(k/(x[i]-x[1:(i-1)]+c)^p)
res <- sum(log(ghhh))
}
I ran it with x <- rnorm(100000, 1, 0.5) and the parallel version was almost twice as fast.
You can read more about the doParallel package here