faster way to compare rows in a data frame - r

Question

Consider the data frame below. I want to compare each row with rows below and then take the rows that are equal in more than 3 values.
I wrote the code below, but it is very slow if you have a large data frame.
How could I do that faster?
data <- as.data.frame(matrix(c(10,11,10,13,9,10,11,10,14,9,10,10,8,12,9,10,11,10,13,9,13,13,10,13,9), nrow=5, byrow=T))
rownames(data)<-c("sample_1","sample_2","sample_3","sample_4","sample_5")
>data
V1 V2 V3 V4 V5
sample_1 10 11 10 13 9
sample_2 10 11 10 14 9
sample_3 10 10 8 12 9
sample_4 10 11 10 13 9
sample_5 13 13 10 13 9
output <- data.frame(sample = NA, duplicate = NA, matches = NA)
dfrow <- 1
for(i in 1:nrow(data)) {
sample <- data[i, ]
for(j in (i+1):nrow(data)) if(i+1 <= nrow(data)) {
matches <- 0
for(V in 1:ncol(data)) {
if(data[j,V] == sample[,V]) {
matches <- matches + 1
}
}
if(matches > 3) {
duplicate <- data[j, ]
pair <- cbind(rownames(sample), rownames(duplicate), matches)
output[dfrow, ] <- pair
dfrow <- dfrow + 1
}
}
}
>output
sample duplicate matches
1 sample_1 sample_2 4
2 sample_1 sample_4 5
3 sample_2 sample_4 4

Answer 1

Here is an Rcpp solution. However, if the result matrix gets too big (i.e., there are too many hits), this will throw an error. I run the loops twice, first to get the necessary size of the result matrix and then to fill it. There is probably a better possibility. Also, obviously, this will only work with integers. If your matrix is numeric, you'll have to deal with floating point precision.
library(Rcpp)
library(inline)
#C++ code:
body <- '
const IntegerMatrix M(as<IntegerMatrix>(MM));
const int m=M.ncol(), n=M.nrow();
long count1;
int count2;
count1 = 0;
for (int i=0; i<(n-1); i++)
{
for (int j=(i+1); j<n; j++)
{
count2 = 0;
for (int k=0; k<m; k++) {
if (M(i,k)==M(j,k)) count2++;
}
if (count2>3) count1++;
}
}
IntegerMatrix R(count1,3);
count1 = 0;
for (int i=0; i<(n-1); i++)
{
for (int j=(i+1); j<n; j++)
{
count2 = 0;
for (int k=0; k<m; k++) {
if (M(i,k)==M(j,k)) count2++;
}
if (count2>3) {
count1++;
R(count1-1,0) = i+1;
R(count1-1,1) = j+1;
R(count1-1,2) = count2;
}
}
}
return wrap(R);
'
fun <- cxxfunction(signature(MM = "matrix"),
body,plugin="Rcpp")
#with your data
fun(as.matrix(data))
# [,1] [,2] [,3]
# [1,] 1 2 4
# [2,] 1 4 5
# [3,] 2 4 4
#Benchmarks
set.seed(42)
mat1 <- matrix(sample(1:10,250*26,TRUE),ncol=26)
mat2 <- matrix(sample(1:10,2500*26,TRUE),ncol=26)
mat3 <- matrix(sample(1:10,10000*26,TRUE),ncol=26)
mat4 <- matrix(sample(1:10,25000*26,TRUE),ncol=26)
library(microbenchmark)
microbenchmark(
fun(mat1),
fun(mat2),
fun(mat3),
fun(mat4),
times=3
)
# Unit: milliseconds
# expr min lq median uq max neval
# fun(mat1) 2.675568 2.689586 2.703603 2.732487 2.761371 3
# fun(mat2) 272.600480 274.680815 276.761151 276.796217 276.831282 3
# fun(mat3) 4623.875203 4643.634249 4663.393296 4708.067638 4752.741979 3
# fun(mat4) 29041.878164 29047.151348 29052.424532 29235.839275 29419.254017 3

Answer 2

EDIT: Not sure what I was thinking last night when I subtracted rows considering I could've directly tested for equality. Removed that uncessary step from the code below.
Here is one approach that may either be slightly clever or poorly thought out... but hopefully the former. The idea is that instead of doing a series of comparisons row-by-row you can instead perform some vectorized operations by subtracting the row from the rest of the data frame and then looking at the number of elements that are equal to zero. Here is a simple implementation of the approach:
> library(data.table)
> data <- as.data.frame(matrix(c(10,11,10,13,9,10,11,10,14,9,10,10,8,12,9,10,11,10,13,9,13,13,10,13,9), nrow=5, byrow=T))
> rownames(data)<-c("sample_1","sample_2","sample_3","sample_4","sample_5")
>
> findMatch <- function(i,n){
+ tmp <- colSums(t(data[-(1:i),]) == unlist(data[i,]))
+ tmp <- tmp[tmp > n]
+ if(length(tmp) > 0) return(data.table(sample=rownames(data)[i],duplicate=names(tmp),match=tmp))
+ return(NULL)
+ }
>
> system.time(tab <- rbindlist(lapply(1:(nrow(data)-1),findMatch,n=3)))
user system elapsed
0.003 0.000 0.003
> tab
sample duplicate match
1: sample_1 sample_2 4
2: sample_1 sample_4 5
3: sample_2 sample_4 4
EDIT: Here is version2 that uses matrices and pre-tranposes the data so you only need to do that once. It should scale better to your example with a non-trivial amount of data.
library(data.table)
data <- matrix(round(runif(26*250000,0,25)),ncol=26)
tdata <- t(data)
findMatch <- function(i,n){
tmp <- colSums(tdata[,-(1:i)] == data[i,])
j <- which(tmp > n)
if(length(tmp) > 0) return(data.table(sample=i,duplicate=j+1,match=tmp[j]))
return(NULL)
}
tab <- rbindlist(lapply(1:(nrow(data)-1),findMatch,n=3))
I ran than on my machine for a bit and got through the first 1500 iterations a full 250,000 x 26 matrix in under 15 minutes and required 600 Mb memory. Since previous iterations do not impact future iterations you could certainly chunk this into parts and run it separately if needed.

Answer 3

This is not a complete answer, just a quick workout that comes in mind is to use matrices instead of data.frame (those are quite slow tbh). Matrices are quite fast in R and by completing at least some operations in it and then appending the vector with column names will result in significant speed increase.
Just a quick demo:
data <- matrix(c(10,11,10,13,9,10,11,10,14,9,10,10,8,12,9,10,11,10,13,9,13,13,10,13,9), nrow=5, byrow=T)rownames(data)<-c("sample_1","sample_2","sample_3","sample_4","sample_5")
mu<-c("sample_1","sample_2","sample_3","sample_4","sample_5")
t=proc.time()
tab <- data.frame(sample = NA, duplicate = NA, matches = NA)
dfrow <- 1
for(i in 1:nrow(data)) {
sample <- data[i, ]
for(j in (i+1):nrow(data)) if(i+1 <= nrow(data)) {
matches <- 0
for(V in 1:ncol(data)) {
if(data[j,V] == sample[V]) {
matches <- matches + 1
}
}
if(matches > 3) {
duplicate <- data[j, ]
pair <- cbind(mu[i], mu[j], matches)
tab[dfrow, ] <- pair
dfrow <- dfrow + 1
}
}
}
proc.time()-t
On the average, on my machine, yields
user system elapsed
0.00 0.06 0.06
While in your case I get
user system elapsed
0.02 0.06 0.08
I'm not sure whether there's something more quicker than matrices. You can also play around with parallelisation, but for loops C++ code inlining are quite often used (package Rcpp).

Answer 4

library(data.table)
#creating the data
dt <- data.table(read.table(textConnection(
"Sample V1 V2 V3 V4 V5
sample_1 10 11 10 13 9
sample_2 10 11 10 14 9
sample_3 10 10 8 12 9
sample_4 10 11 10 13 9
sample_5 13 13 10 13 9"), header= TRUE))
# some constants which will be used frequently
nr = nrow(dt)
nc = ncol(dt)-1
#list into which we will insert the no. of matches for each sample
#for example's sake, i still suggest you write output to a file possibly
totalmatches <- vector(mode = "list", length = (nr-1))
#looping over each sample
for ( i in 1:(nr-1))
{
# all combinations of i with i+1 to nr
samplematch <- cbind(dt[i],dt[(i+1):nr])
# renaming the comparison sample columns
setnames(samplematch,append(colnames(dt),paste0(colnames(dt),"2")))
#calculating number of matches
samplematch[,noofmatches := 0]
for (j in 1:nc)
{
samplematch[,noofmatches := noofmatches+1*(get(paste0("V",j)) == get(paste0("V",j,"2")))]
}
# removing individual value columns and matches < 3
samplematch <- samplematch[noofmatches >= 3,list(Sample,Sample2,noofmatches)]
# adding to the list
totalmatches[[i]] <- samplematch
}
The output -
rbindlist(totalmatches)
Sample Sample2 noofmatches
1: sample_1 sample_2 4
2: sample_1 sample_4 5
3: sample_1 sample_5 3
4: sample_2 sample_4 4
5: sample_4 sample_5 3
The performance on matrices seems to be better though, this method clocked -
user system elapsed
0.17 0.01 0.19

Answer 5

Everything that has been said in the comments is very valid; in particular, I also don't necessarily think R is the best place to do this. That said, this works a lot quicker for me than what you've posed on a much larger dataset (~9.7 sec vs. unfinished after two minutes):
data <- matrix(sample(1:30, 10000, replace=TRUE), ncol=5)
#Pre-prepare
x <- 1
#Loop
for(i in seq(nrow(data)-2)){
#Find the number of matches on that row
sums <- apply(data[seq(from=-1,to=-i),], 1, function(x) sum(x==data[i,]))
#Find how many are greater than/equal to 3
matches <- which(sums >= 3)
#Prepare output
output[seq(from=x, length.out=length(matches)),1] <- rep(i, length(matches))
output[seq(from=x, length.out=length(matches)),2] <- matches
output[seq(from=x, length.out=length(matches)),3] <- sums[matches]
#Alter the counter of how many we've made...
x <- x + length(matches)
}
#Cleanup output
output <- output[!is.na(output[,1]),]})
...I'm fairly certain my weird x variable and the assignment of output could be improved/turned into an apply-type problem, but it's late and I'm tired! Good luck!

Answer 6

Well, I took a stab at it, the following code runs about 3 times faster than the original.
f <- function(ind, mydf){
res <- NULL
matches <- colSums(t(mydf[-(1:ind),])==mydf[ind,])
Ndups <- sum(matches > 3)
if(Ndups > 0){
res <- data.frame(sample=rep(ind,Ndups),duplicate=which(matches > 3),
matches= matches[matches > 3],stringsAsFactors = F)
rownames(res) <- NULL
return(as.matrix(res))
}
return(res)
}
f(1,mydf=as.matrix(data))
f(2,mydf=as.matrix(data))
system.time(
for(i in 1:1000){
tab <- NULL
for(j in 1:(dim(data)[1]-1))
tab <- rbind(tab,f(j,mydf=as.matrix(data)))
}
)/1000
tab

Answer 7

Assuming that all the entries in your dataset are of the same mode (numeric), turn it into a matrix. By transposing, you can take advantage of how == can be vectorized.
data <- as.matrix(data)
data <- t(data)
output <- lapply(seq_len(ncol(data) - 1), function(x) {
tmp <- data[,x] == data[, (x+1):ncol(data)]
n_matches <- {
if (x == ncol(data) - 1) {
setNames(sum(tmp),colnames(data)[ncol(data)])
} else {
colSums(tmp)
}
}
good_matches <- n_matches[n_matches >= 3]
})
The big question is how to output the results. As it stands I have your data in a list. I would think that this is the least memory-intensive way of storing your data.
[[1]]
sample_2 sample_4 sample_5
4 5 3
[[2]]
sample_4
4
[[3]]
named numeric(0)
[[4]]
sample_5
3
If you want a data frame output, then you'll want to tweak the return value of the function within lapply. Perhaps add in the last line of the function:
return(data.frame(
sample = colnames(data)[x],
duplicate = names(good_matches),
noofmatches = good_matches,
stringsAsFactors = FALSE))
And then use:
newoutput <- do.call(rbind, output)
## or, using plyr
# require(plyr)
# newoutput <- rbind.fill(output)