increase efficiency and speed of R function - r

Question

When using R I always have in mind: "Avoid using loops if possible". However, I am stuck right now, I haven't been able to figure out a CRANTASTIC way to code what I need.
For the record, after several comments, my statement above is not the right statement, there's no need to avoid loops here to improve the efficiency.
I have two string vectors as input, let us call them, a and b - they can only contain the letters "M", "I" and "D".
a = c("M","I","D","D","M","M","M","M","M","M")
b = c("M","M","M","M","M","M","D","M","M")
My desired output is:
d = c("M","I","D","D","M","M","M","M","I","M","M")
The following function gives me such output:
my.function <- function(a, b)
{
nrow.df = length(a) + length(which(b=="D"))
my.df = data.frame(a = rep(NA, nrow.df),
b = rep(NA, nrow.df),
d = rep(NA, nrow.df))
my.df$a[1:length(a)] = a
my.df$b[1:length(b)] = b
for (i in 1:nrow.df)
{
if(my.df$a[i] == "D") {
my.df$d[i] = "D"
my.df$b[(i+1):nrow.df] = my.df$b[i:(nrow.df-1)]
} else if (my.df$b[i] == "D") {
my.df$d[i] = "I"
my.df$a[(i+1):nrow.df] = my.df$a[i:(nrow.df-1)]
} else if (my.df$a[i] == "I") {
my.df$d[i] = "I"
} else if (my.df$b[i] == "I") {
my.df$d[i] = "D"
} else {
my.df$d[i] = my.df$a[i]
}
}
return(my.df$d)
}
> d = my.function(a,b)
> d
[1] "M" "I" "D" "D" "M" "M" "M" "M" "I" "M" "M"
The function logic is as follows, whenever there is a "D" in a, it puts a "D" in d and shift the vector b by 1, and vice versa, whenever there is a "D" in b, it puts an "I" in d and shifts a by 1.
Next, when there is an "I" in a, but not a "D" in b, put an "I" in a, and vice versa, whenever there is an "I" in b, and not a "D" in a, put a "D" in d. Otherwise, d = a.
It is not a complex function but I am struggling on how to make it R efficient. I am applying this function millions of times with mclapply so having a fast implementation of such function would save me lots of time.
Do you recommend using Rcpp? Would it be much faster? Is there any slow down on communicating R with Cpp millions of time, or it's just auto with Rcpp?

Answer 1

Building on my comment, if speed is one concern, step 1 is to not unnecessarily use data.frames. This answer doesn't address the loop (as others have already said, there is nothing wrong with using a loop in R if it is done properly).
Here is a very slightly modified version of your function, using vectors instead of data.frames to store the data.
my.function.v <- function(a, b) {
nrow.df = length(a) + length(which(b=="D"))
A <- B <- D <- vector(length = nrow.df)
A[1:length(a)] = a
B[1:length(b)] = b
for (i in 1:nrow.df)
{
if(A[i] == "D") {
D[i] = "D"
B[(i+1):nrow.df] = B[i:(nrow.df-1)]
} else if (B[i] == "D") {
D[i] = "I"
A[(i+1):nrow.df] = A[i:(nrow.df-1)]
} else if (A[i] == "I") {
D[i] = "I"
} else if (B[i] == "I") {
D[i] = "D"
} else {
D[i] = A[i]
}
}
return(D)
}
Notice the relative difference in speed below:
library(microbenchmark)
microbenchmark(my.function(a, b), my.function.v(a, b), f(a, b))
# Unit: microseconds
# expr min lq median uq max neval
# my.function(a, b) 1448.416 1490.8780 1511.3435 1547.3880 6674.332 100
# my.function.v(a, b) 157.248 165.8725 171.6475 179.1865 324.722 100
# f(a, b) 168.874 177.5455 184.8775 193.3455 416.551 100
As can be seen, #mrip's function also fares much better than your original function.

Answer 2

I don't see any easy way to avoid a loop here. However, there is still a more efficient way of doing this. The problem is that you are actually shifting a and b every time you come across the character D, and shifting a vector like this is an O(n) operation, so the running time of this loop would actually be O(n^2).
You can simplify the code and get slightly better performance like this:
f<-function(a,b){
aSkipped<-0
bSkipped<-0
d<-rep(0,length(a)+sum(b=="D"))
for(i in 1:length(d)){
if(a[i-aSkipped] == "D") {
d[i] = "D"
bSkipped<-bSkipped+1
} else if (b[i-bSkipped] == "D") {
d[i] = "I"
aSkipped<-aSkipped+1
} else if (a[i-aSkipped] == "I") {
d[i] = "I"
} else if (b[i-bSkipped] == "I") {
d[i] = "D"
} else {
d[i] = a[i-aSkipped]
}
}
d
}
On edit. You will really see large performance improvements when the input gets big. For small strings, and not too many "D"s this and Ananda Mahto's solution run in about the same time:
> set.seed(123)
> a<-c(sample(c("M","I"),500,T))
> b<-c(sample(c("M","I"),500,T))
> a[sample(500,50)]<-"D"
> b[sample(500,50)]<-"D"
> microbenchmark(f(a,b),my.function.v(a,b))
Unit: milliseconds
expr min lq median uq max neval
f(a, b) 4.259970 4.324046 4.368018 4.463925 9.694951 100
my.function.v(a, b) 4.442873 4.497172 4.533196 4.639543 9.901044 100
But for strings of length 50000 with 5000 "D"s the difference is substantial:
> set.seed(123)
> a<-c(sample(c("M","I"),50000,T))
> b<-c(sample(c("M","I"),50000,T))
> a[sample(50000,5000)]<-"D"
> b[sample(50000,5000)]<-"D"
> system.time(f(a,b))
user system elapsed
0.460 0.000 0.463
> system.time(my.function.v(a,b))
user system elapsed
7.056 0.008 7.077

Answer 3

OK, here's the Rcpp solution, and as expected, it beats the R solution by a lot:
rcppFun<-"
CharacterVector fcpp(CharacterVector a,CharacterVector b,int size){
int aSkipped = 0;
int bSkipped = 0;
int asize = a.size();
Rcpp::CharacterVector d(size);
for(int i=0; i<size; i++){
if(i-aSkipped<asize && a[i-aSkipped][0] == 'D') {
d[i] = \"D\";
bSkipped++;
} else if (b[i-bSkipped][0] == 'D') {
d[i] = \"I\";
aSkipped++;
} else if (a[i-aSkipped][0] == 'I') {
d[i] = \"I\";
} else if (b[i-bSkipped][0] == 'I') {
d[i] = \"D\";
} else {
d[i] = a[i-aSkipped];
}
}
return d;
}"
require("Rcpp")
fcpp<-cppFunction(rcppFun)
f3<-function(a,b){
fcpp(a,b,as.integer(length(a)+sum(b=="D")))
}
Warning: that function does no parameter checking at all, so if you feed it bad data you can easily get a seg fault.
If you are going to be calling this a lot, Rcpp is definitely the way to go:
> with(ab(10),microbenchmark(f(a,b),f3(a,b),f2(a,b),my.function.v(a,b)))
Unit: microseconds
expr min lq median uq max neval
f(a, b) 103.993 107.5155 108.6815 109.7455 178.801 100
f3(a, b) 7.354 8.1305 8.5575 9.1220 18.014 100
f2(a, b) 87.081 90.4150 92.2730 94.2585 146.502 100
my.function.v(a, b) 84.389 86.5140 87.6090 88.8340 109.106 100
> with(ab(100),microbenchmark(f(a,b),f3(a,b),f2(a,b),my.function.v(a,b)))
Unit: microseconds
expr min lq median uq max neval
f(a, b) 992.082 1018.9850 1032.0180 1071.0690 2784.710 100
f3(a, b) 12.873 14.3605 14.7370 15.5095 35.582 100
f2(a, b) 119.396 125.4405 129.3015 134.9915 1909.930 100
my.function.v(a, b) 769.618 786.7865 802.2920 824.0820 905.737 100
> with(ab(1000),microbenchmark(f(a,b),f3(a,b),f2(a,b),my.function.v(a,b)))
Unit: microseconds
expr min lq median uq max neval
f(a, b) 9816.295 10065.065 10233.1350 10392.696 12383.373 100
f3(a, b) 66.057 67.869 83.9075 87.231 1167.086 100
f2(a, b) 1637.972 1760.258 2667.6985 3138.229 47610.317 100
my.function.v(a, b) 9692.885 10272.425 10997.2595 11402.602 54315.922 100
> with(ab(10000),microbenchmark(f(a,b),f3(a,b),f2(a,b)))
Unit: microseconds
expr min lq median uq max neval
f(a, b) 101644.922 103311.678 105185.5955 108342.4960 144620.777 100
f3(a, b) 607.702 610.039 669.8515 678.1845 785.415 100
f2(a, b) 221305.641 247952.345 254478.1580 341195.5510 656408.378 100
>

Answer 4

Just for the sake of showing how it might be done, it can be done without a loop in R; here's one way. It's faster when the length is about roughly 1000 or less but slower when larger. One takeaway is that you surely could speed this up in Rcpp.
f2 <- function(a,b) {
da <- which(a=="D")
db <- which(b=="D")
dif <- outer(da, db, `<`)
da <- da + rowSums(!dif)
db <- db + colSums(dif)
ia <- which(a=="I")
ia <- ia + colSums(outer(db, ia, `<`))
ib <- which(b=="I")
ib <- ib + colSums(outer(da, ib, `<`))
out <- rep("M", length(a) + length(db))
out[da] <- "D"
out[db] <- "I"
out[ia] <- "I"
out[ib] <- "D"
out
}
For generating data
ab <- function(N) {
set.seed(123)
a<-c(sample(c("M","I"),N,TRUE))
b<-c(sample(c("M","I"),N,TRUE))
a[sample(N,N/10)]<-"D"
b[sample(N,N/10)]<-"D"
list(a=a,b=b)
}
Timings:
> library(microbenchmark)
> with(ab(10), microbenchmark(my.function.v(a, b), f(a, b), f2(a,b)))
Unit: microseconds
expr min lq median uq max neval
my.function.v(a, b) 79.102 86.9005 89.3680 93.2410 279.761 100
f(a, b) 84.334 91.1055 94.1790 98.2645 215.579 100
f2(a, b) 94.807 101.5405 105.1625 108.9745 226.149 100
> with(ab(100), microbenchmark(my.function.v(a, b), f(a, b), f2(a,b)))
Unit: microseconds
expr min lq median uq max neval
my.function.v(a, b) 732.849 750.4480 762.906 845.0835 1953.371 100
f(a, b) 789.380 805.8905 819.022 902.5865 1921.064 100
f2(a, b) 124.442 129.1450 134.543 137.5910 237.498 100
> with(ab(1000), microbenchmark(my.function.v(a, b), f(a, b), f2(a,b)))
Unit: milliseconds
expr min lq median uq max neval
my.function.v(a, b) 10.146865 10.387144 10.695895 11.123164 13.08263 100
f(a, b) 7.776286 7.973918 8.266882 8.633563 9.98204 100
f2(a, b) 1.322295 1.355601 1.385302 1.465469 1.85349 100
> with(ab(10000), microbenchmark(my.function.v(a, b), f(a, b), f2(a,b), times=10))
Unit: milliseconds
expr min lq median uq max neval
my.function.v(a, b) 429.4030 435.00373 439.06706 442.51650 465.00124 10
f(a, b) 80.7709 83.71715 85.14887 88.02067 89.00047 10
f2(a, b) 164.7807 170.37608 175.94281 247.78353 251.14653 10