How do I find equal columns in R? - r

Given the following:
a <- c(1,2,3)
b <- c(1,2,3)
c <- c(4,5,6)
A <- cbind(a,b,c)
I want to find which columns in A are equal to for example my vector a.
My first attempt would be:
> which(a==A)
[1] 1 2 3 4 5 6
Which did not do that. (Too be honest I don't even understand what that did)
Second attempt was:
a==A
a b c
[1,] TRUE TRUE FALSE
[2,] TRUE TRUE FALSE
[3,] TRUE TRUE FALSE
which definitely is a step in the right direction but it seems extended into a matrix. What I would have preferred is something like just one of the rows. How do I compare a vector to columns and how do I find columns in a matrix that are equal to a vector?

Use identical. That is R's "scalar" comparison operator; it returns a single logical value, not a vector.
apply(A, 2, identical, a)
# a b c
# TRUE TRUE FALSE
If A is a data frame in your real case, you're better off using sapply or vapply because apply coerces it's input to a matrix.
d <- c("a", "b", "c")
B <- data.frame(a, b, c, d)
apply(B, 2, identical, a) # incorrect!
# a b c d
# FALSE FALSE FALSE FALSE
sapply(B, identical, a) # correct
# a b c d
# TRUE TRUE FALSE FALSE
But note that data.frame coerces character inputs to factors unless you ask otherwise:
sapply(B, identical, d) # incorrect
# a b c d
# FALSE FALSE FALSE FALSE
C <- data.frame(a, b, c, d, stringsAsFactors = FALSE)
sapply(C, identical, d) # correct
# a b c d
# FALSE FALSE FALSE TRUE
Identical is also considerably faster than using all + ==:
library(microbenchmark)
a <- 1:1000
b <- c(1:999, 1001)
microbenchmark(
all(a == b),
identical(a, b))
# Unit: microseconds
# expr min lq median uq max
# 1 all(a == b) 8.053 8.149 8.2195 8.3295 17.355
# 2 identical(a, b) 1.082 1.182 1.2675 1.3435 3.635

If you add an extra row:
> A
a b c
[1,] 1 1 4 4
[2,] 2 2 5 2
[3,] 3 3 6 1
Then you can see that this function is correct:
> hasCol=function(A,a){colSums(a==A)==nrow(A)}
> A[,hasCol(A,a)]
a b
[1,] 1 1
[2,] 2 2
[3,] 3 3
But the earlier version accepted doesn't:
> oopsCol=function(A,a){colSums(a==A)>0}
> A[,oopsCol(A,a)]
a b
[1,] 1 1 4
[2,] 2 2 2
[3,] 3 3 1
It returns the 4,2,1 column because the 2 matches the 2 in 1,2,3.

Surely there's a better solution but the following works:
> a <- c(1,2,3)
> b <- c(1,2,3)
> c <- c(4,5,6)
> A <- cbind(a,b,c)
> sapply(1:ncol(A), function(i) all(a==A[,i]))
[1] TRUE TRUE FALSE
And to get the indices:
> which(sapply(1:ncol(A), function(i) all(a==A[,i])))
[1] 1 2

colSums(a==A)==nrow(A)
Recycling of == makes a effectively a matrix which has all columns equal to a and dimensions equal to those of A. colSums sums each column; while TRUE behaves like 1 and FALSE like 0, columns equal to a will have sum equal to the number of rows. We use this observation to finally reduce the answer to a logical vector.
EDIT:
library(microbenchmark)
A<-rep(1:14,1000);c(7,2000)->dim(A)
1:7->a
microbenchmark(
apply(A,2,function(b) identical(a,b)),
apply(A,2,function(b) all(a==b)),
colSums(A==a)==nrow(A))
# Unit: microseconds
# expr min lq median
# 1 apply(A, 2, function(b) all(a == b)) 9446.210 9825.6465 10278.335
# 2 apply(A, 2, function(b) identical(a, b)) 9324.203 9915.7935 10314.833
# 3 colSums(A == a) == nrow(A) 120.252 121.5885 140.185
# uq max
# 1 10648.7820 30588.765
# 2 10868.5970 13905.095
# 3 141.7035 162.858

Related

R values that go into matrix multiplication

What is the fastest approach to saving unique values that go into matrix multiplication (without 0)?
For example, if I have a data.table object
library(data.table)
A = data.table(j3=c(3,0,3),j5=c(0,5,5),j7=c(0,7,0),j8=c(8,0,8))
I would like to see which unique values go into A*transpose(A) (or as.matrix(A) %*% as.matrix(t(A))). Right now, I can do it using for loops as:
B=t(A)
L = list()
models = c('A1','A2','A3')
for(i in 1:nrow(A)){
for(j in 1:ncol(B)){
u = union(unlist(A[i,]),B[,j])
u = u[u!=0] # remove 0
L[[paste(models[i],models[j])]]= u
}
}
However, is there a faster and more RAM-efficient way? The output doesn't have to be a list object, as in my case, it can be a data.table (data.frame) as well. Also, the order of values is not important. For example, 3 5 8 is as good as 5 3 8, 8 5 3 etc.
Any help is appreciated.
EDIT: So as.matrix(A) %*% as.matrix(t(A)) is:
[,1] [,2] [,3]
[1,] 73 0 73
[2,] 0 74 25
[3,] 73 25 98
The first element is calculated as 3*3+0*0+0*0+8*8 = 73, the second element is 3*0+0*5+0*7+8*0 = 0, etc. I need unique numbers that go to this calculation but without 0.
Therefore outputs (saved in the list L) are:
> L
$`A1 A1`
[1] 3 8
$`A1 A2`
[1] 3 8 5 7
$`A1 A3`
[1] 3 8 5
$`A2 A1`
[1] 5 7 3 8
$`A2 A2`
[1] 5 7
$`A2 A3`
[1] 5 7 3 8
$`A3 A1`
[1] 3 5 8
$`A3 A2`
[1] 3 5 8 7
$`A3 A3`
[1] 3 5 8
Once again, the output doesn't have to be a list object. I would prefer data.table if it is doable. Is it possible to rewrite my approach as Rcpp function?
Potential optimizations
Following up on #user2554330's answer, note that if A is an m-by-n matrix, then AAT = A %*% t(A) (equivalently tcrossprod(A)) is an m-by-m symmetric matrix. AAT[i, j] and AAT[j, i] are computed using the same entries of A, so you only need to inspect m*(m+1)/2 pairs of rows of A, not m*m.
You can do even better by finding and caching the unique elements of each row before pairing them. Preprocessing in this way avoids redundant computation and should noticeably improve performance when m << n.
Limitations
Another aspect of the problem is how unique works under the hood. unique has an argument nmax that you can use to specify an expected maximum number of unique elements. From ?duplicated:
Except for factors, logical and raw vectors the default nmax = NA is equivalent to nmax = length(x). Since a hash table of size 8*nmax bytes is allocated, setting nmax suitably can save large amounts of memory. For factors it is automatically set to the smaller of length(x) and the number of levels plus one (for NA). If nmax is set too small there is liable to be an error: nmax = 1 is silently ignored.
Long vectors are supported for the default method of duplicated, but may only be usable if nmax is supplied.
These comments apply to unique as well. Since you have a 300-by-4e+07 matrix, you would be evaluating (with preprocessing):
unique(<4e+07-length vector>), 300 times,
unique(<up to 8e+07-length vector>), 299*300/2 times.
That can consume a lot of memory if you don't know anything about your matrix that might allow you to set nmax. And it can take a long time if you don't have access to many CPUs.
So I agree with comments asking you to consider why you need to do this at all and whether your underlying problem has a nicer solution.
Two answers
FWIW, here are two approaches to your general problem that actually take advantage of symmetry. f and g are without and with preprocessing. [[.utri allows you to extract elements from the return value, an m*(m+1)/2-length list, as if it were an m-by-m matrix. as.matrix.utri constructs the full, symmetric m-by-m list matrix.
f <- function(A, nmax = NA) {
a <- seq_len(nrow(A))
J <- cbind(sequence(a), rep.int(a, a))
FUN <- function(i) {
if (i[1L] == i[2L]) {
x <- A[i[1L], ]
} else {
x <- c(A[i[1L], ], A[i[2L], ])
}
unique.default(x[x != 0], nmax = nmax)
}
res <- apply(J, 1L, FUN, simplify = FALSE)
class(res) <- "utri"
res
}
g <- function(A, nmax = NA) {
l <- lapply(asplit(A, 1L), function(x) unique.default(x[x != 0], nmax = nmax))
a <- seq_along(l)
J <- cbind(sequence(a), rep.int(a, a))
FUN <- function(i) {
if (i[1L] == i[2L]) {
l[[i[1L]]]
} else {
unique.default(c(l[[i[1L]]], l[[i[2L]]]))
}
}
res <- apply(J, 1L, FUN, simplify = FALSE)
class(res) <- "utri"
res
}
`[[.utri` <- function(x, i, j) {
stopifnot(length(i) == 1L, length(j) == 1L)
class(x) <- NULL
if (i <= j) {
x[[i + (j * (j - 1L)) %/% 2L]]
} else {
x[[j + (i * (i - 1L)) %/% 2L]]
}
}
as.matrix.utri <- function(x) {
p <- length(x)
n <- as.integer(round(0.5 * (-1 + sqrt(1 + 8 * p))))
i <- rep.int(seq_len(n), n)
j <- rep.int(seq_len(n), rep.int(n, n))
r <- i > j
ir <- i[r]
i[r] <- j[r]
j[r] <- ir
res <- x[i + (j * (j - 1L)) %/% 2L]
dim(res) <- c(n, n)
res
}
Here is a simple test on a 4-by-4 integer matrix:
mkA <- function(m, n) {
A <- sample(0:(n - 1L), size = as.double(m) * n, replace = TRUE,
prob = rep.int(c(n - 1, 1), c(1L, n - 1L)))
dim(A) <- c(m, n)
A
}
set.seed(1L)
A <- mkA(4L, 4L)
A
## [,1] [,2] [,3] [,4]
## [1,] 0 0 2 3
## [2,] 0 1 0 0
## [3,] 2 1 0 3
## [4,] 1 2 0 0
identical(f(A), gA <- g(A))
## [1] TRUE
gA[[1L, 1L]] # used for 'tcrossprod(A)[1L, 1L]'
## [1] 2 3
gA[[1L, 2L]] # used for 'tcrossprod(A)[1L, 2L]'
## [1] 2 3 1
gA[[2L, 1L]] # used for 'tcrossprod(A)[2L, 1L]'
## [1] 2 3 1
gA # under the hood, an 'm*(m+1)/2'-length list
## [[1]]
## [1] 2 3
##
## [[2]]
## [1] 2 3 1
##
## [[3]]
## [1] 1
##
## [[4]]
## [1] 2 3 1
##
## [[5]]
## [1] 1 2 3
##
## [[6]]
## [1] 2 1 3
##
## [[7]]
## [1] 2 3 1
##
## [[8]]
## [1] 1 2
##
## [[9]]
## [1] 2 1 3
##
## [[10]]
## [1] 1 2
##
## attr(,"class")
## [1] "utri"
mgA <- as.matrix(gA) # the full, symmetric, 'm'-by-'m' list matrix
mgA
## [,1] [,2] [,3] [,4]
## [1,] integer,2 integer,3 integer,3 integer,3
## [2,] integer,3 1 integer,3 integer,2
## [3,] integer,3 integer,3 integer,3 integer,3
## [4,] integer,3 integer,2 integer,3 integer,2
mgA[1L, ] # used for first row of 'tcrossprod(A)'
## [[1]]
## [1] 2 3
##
## [[2]]
## [1] 2 3 1
##
## [[3]]
## [1] 2 3 1
##
## [[4]]
## [1] 2 3 1
## If you need names
dimnames(mgA) <- rep.int(list(sprintf("A%d", seq_len(nrow(mgA)))), 2L)
mgA["A1", ]
## $A1
## [1] 2 3
##
## $A2
## [1] 2 3 1
##
## $A3
## [1] 2 3 1
##
## $A4
## [1] 2 3 1
## If you need an 'm'-by-'m' 'data.table' result
DT <- data.table::as.data.table(mgA)
DT
## A1 A2 A3 A4
## 1: 2,3 2,3,1 2,3,1 2,3,1
## 2: 2,3,1 1 1,2,3 1,2
## 3: 2,3,1 1,2,3 2,1,3 2,1,3
## 4: 2,3,1 1,2 2,1,3 1,2
And here are two benchmarks on two large integer matrices, showing that preprocessing can help quite a bit:
set.seed(1L)
A <- mkA(100L, 1e+04L)
microbenchmark::microbenchmark(f(A), g(A), times = 10L, setup = gc(FALSE))
## Unit: milliseconds
## expr min lq mean median uq max neval
## f(A) 2352.0572 2383.3100 2435.7954 2403.8968 2431.6214 2619.553 10
## g(A) 843.0206 852.5757 858.7262 858.2746 863.8239 881.450 10
A <- mkA(100L, 1e+06L)
microbenchmark::microbenchmark(f(A), g(A), times = 10L, setup = gc(FALSE))
## Unit: seconds
## expr min lq mean median uq max neval
## f(A) 290.93327 295.54319 302.57001 301.17810 307.50226 318.14203 10
## g(A) 72.85608 73.83614 76.67941 76.57313 77.78056 83.73388 10
Perhaps we can try this
f <- function(A, models) {
AA <- replace(A, A == 0, NA)
setNames(
c(t(outer(
1:nrow(A),
1:nrow(A),
Vectorize(function(x, y) unique(na.omit(c(t(AA[c(x, y)])))))
))),
t(outer(models, models, paste))
)
}
which gives
$`A1 A1`
[1] 3 8
$`A1 A2`
[1] 3 8 5 7
$`A1 A3`
[1] 3 8 5
$`A2 A1`
[1] 5 7 3 8
$`A2 A2`
[1] 5 7
$`A2 A3`
[1] 5 7 3 8
$`A3 A1`
[1] 3 5 8
$`A3 A2`
[1] 3 5 8 7
$`A3 A3`
[1] 3 5 8
If you care about the speed, you can try
lst <- asplit(replace(A, A == 0, NA), 1)
mat <- matrix(list(), nrow = nrow(A), ncol = nrow(A))
mat[lower.tri(mat)] <- combn(lst, 2, function(...) unique(na.omit(unlist(...))), simplify = FALSE)
mat[upper.tri(mat)] <- t(mat)[upper.tri(mat)]
diag(mat) <- Map(function(x) unname(x)[!is.na(x)], lst)
L <- c(t(mat))
Thanks for posting the additional information in your edits. From what you posted, it appears that for all pairs of rows of a matrix or data table A, you want the unique non-zero values in those two rows.
To do that efficiently I'd suggest ensuring that A is a matrix. Row indexing in dataframes or data tables is a lot slower than doing so in matrices. (Column indexing can be faster, but I doubt if it's worth transposing the table to get that.)
Once you have a matrix, A[i, ] is a vector containing the values in row i, and that's a pretty fast calculation. You want the unique non-zero values in c(A[i, ], A[j, ]). The unique function will produce this, but won't leave out the zeros. I'd suggest experimenting. Depending on the contents of each row, it is conceivable that leaving the zeros out of the rows first before computing the unique entries could be either faster or slower than calculating all the unique values and deleting 0 afterwards.
You say you want to do this for a few hundred rows, but each row is very long. I'd guess you won't be able to improve much on nested loops: the time will be spent on each entry, not on the loops. However, you could experiment with vectorization using the apply() function, e.g.
result <- vector("list", nrows)
for (i in 1:nrows)
result[[i]] <- apply(A, 1, function(row) setdiff(unique(c(row, A[i,])), 0))
This will give a list of lists; if you want to examine entry i, j, you can use result[[c(i,j)]].

Test if all elements of a list (lists themselves) are equal

I have a list of lists and want to check whether all elements of this list (which are of list type) are the same. How to make it in the fastest way?
Update: I put a reproducible example below. The point is to get a FALSE value of such a test, because two elements of the eventual.list are different: eventual.list[[1]][[1]] data.frame has other values than eventual.list[[2]][[1]] data.frame.
Code:
a <- 1:3
b <- 1:3
c <- 2:4
l1.el1 <- data.frame(a, b)
l1.el2 <- a
l1 <- list(l1.el1,
l1.el2)
l2.el1 <- data.frame(a, c)
l2.el2 <- a
l2 <- list(l2.el1,
l2.el2)
eventual.list <- list(l1,
l2)
eventual.list
Console output:
> eventual.list
[[1]]
[[1]][[1]]
a b
1 1 1
2 2 2
3 3 3
[[1]][[2]]
[1] 1 2 3
[[2]]
[[2]][[1]]
a c
1 1 2
2 2 3
3 3 4
[[2]][[2]]
[1] 1 2 3
This is the canonical method for determining whether all items in a list are the same:
length(unique(object))==1
In your case:
> length( unique( eventual.list ) )
[1] 2
> length( unique( eventual.list ) ) == 1
[1] FALSE
The help page for unique might have led one to think that lists would not be handled, until one reflects on this result that surprised me when I encountered it the first time:
is.vector( eventual.list )
[1] TRUE
So lists are technically vectors in R parlance, they're just not 'atomic' vectors, they are "recursive".
> is.atomic(eventual.list)
[1] FALSE
> is.recursive(eventual.list)
[1] TRUE

Identify which objects of list are contained (subset of) in another list in R

Thank you for your kind reply to my previous questions. I have two lists: list1 and list2. I would like to know if each object of list1 is contained in each object of list2. For example:
> list1
[[1]]
[1] 1
[[2]]
[1] 2
[[3]]
[1] 3
> list2
[[1]]
[1] 1 2 3
[[2]]
[1] 2 3
[[3]]
[1] 2 3
Here are my questions:
1.) How do you I ask R to check if an object is a subset of another object in a list?
For instance I would like to check if list2[[3]]={2,3} is contained in (subset of) list1[[2]]={2}. When I do list2[[3]] %in% list1[[2]], I get [1] TRUE FALSE. However, this is not what I desire to do?! I just want to check if list2[[3]] is a subset of list1[[2]], i.e. is {2,3} \subset of {3} as in the set theoretic notion? I do not want to perform elementwise check as R seems to be doing with the %in% command. Any suggestions?
2.) Is there some sort of way to efficiently make all pairwise subset comparisons (i.e. list1[[i]] subset of list2[[j]], for all i,j combinations? Would something like outer(list1,list2, func.subset) work once question number 1 is answered?
Thank you for your feedback!
setdiff compares unique values
length(setdiff(5, 1:5)) == 0
Alternatively, all(x %in% y) will work nicely.
To do all comparisons, something like this would work:
dt <- expand.grid(list1,list2)
dt$subset <- apply(dt,1, function(.v) all(.v[[1]] %in% .v[[2]]) )
Var1 Var2 subset
1 1 1, 2, 3 TRUE
2 2 1, 2, 3 TRUE
3 3 1, 2, 3 TRUE
4 1 2, 3 FALSE
5 2 2, 3 TRUE
6 3 2, 3 TRUE
7 1 2, 3 FALSE
8 2 2, 3 TRUE
9 3 2, 3 TRUE
Note that the expand.grid isn't the fastest way to do this when dealing with a lot of data (dwin's solution is better in that regard) but it allows you to quickly check visually whether this is doing what you want.
You can use the sets package as follows:
library(sets)
is.subset <- function(x, y) as.set(x) <= as.set(y)
outer(list1, list2, Vectorize(is.subset))
# [,1] [,2] [,3]
# [1,] TRUE FALSE FALSE
# [2,] TRUE TRUE TRUE
# [3,] TRUE TRUE TRUE
#Michael or #DWin's base version of is.subset will work just as well, but for part two of your question, I'd maintain that outer is the way to go.
is.subset <- function(x,y) {length(setdiff(x,y)) == 0}
First the combos of list1 elements that are subsets of list2 items:
> sapply(1:length(list1), function(i1) sapply(1:length(list2),
function(i2) is.subset(list1[[i1]], list2[[i2]]) ) )
[,1] [,2] [,3]
[1,] TRUE TRUE TRUE
[2,] FALSE TRUE TRUE
[3,] FALSE TRUE TRUE
Then the unsurprising lack of any of the list2 items (all of length > 1) that are subsets of list one items (all of length 1):
> sapply(1:length(list1), function(i1) sapply(1:length(list2),
function(i2) is.subset(list2[[i2]], list1[[i1]]) ) )
[,1] [,2] [,3]
[1,] FALSE FALSE FALSE
[2,] FALSE FALSE FALSE
[3,] FALSE FALSE FALSE
adding to #Michael's, here's a neat way to avoid the messiness of expand.grid using the AsIs function:
list2 <- list(1:3,2:3,2:3)
a <- data.frame(list1 = 1:3, I(list2))
a$subset <- apply(a, 1, function(.v) all(.v[[1]] %in% .v[[2]]) )
list1 list2 subset
1 1 1, 2, 3 TRUE
2 2 2, 3 TRUE
3 3 2, 3 TRUE

Find matrix rows (by column) greater than values specified in a matrix or vector

I have the following matrices:
m = matrix(c(1:12), nrow=4)
p = matrix(c(2,7,11), nrow=1)
Per each column of m and p, I want to find the values in the columns of m which are less than the values in columns of p
p = 1 6 11
m = 1 5 9
2 6 10
3 7 11
4 8 12
So that I can get something like this:
ans = m[,] > p[,]
ans =
F F F
T F F
T T F
T T T
(or something similar)
I have tried m[,] > p[,] and also set p to be a vector, but neither works.
mapply(function(x,y) x > max(y), as.data.frame(m), as.data.frame(p))
m > p[rep(1, 4,),]
Replicates row 1 of p 4 times so that they are now the same size and the > comparison can be done.
It can be made more general by using:
m > p[rep(1, nrow(m),),]
That way, p single row is replicated as many times as m rows.
lapply(1:length(p), function(x) m[p[x] > m[,x],x])
[[1]]
[1] 1
[[2]]
[1] 5 6
[[3]]
[1] 9 10
you can also apply the equality test to each row of m
> t(apply(m, 1, function(x) x > p))
[,1] [,2] [,3]
[1,] FALSE FALSE FALSE
[2,] FALSE FALSE FALSE
[3,] TRUE FALSE FALSE
[4,] TRUE TRUE TRUE
>
I get your answer if I use your second p
p <- c(1, 6, 11)
> t(apply(m, 1, function(x) x > p))
[,1] [,2] [,3]
[1,] FALSE FALSE FALSE
[2,] TRUE FALSE FALSE
[3,] TRUE TRUE FALSE
[4,] TRUE TRUE TRUE
>

How to vectorize this operation on every row of a matrix

I have a matrix filled with TRUE/FALSE values and I am trying to find the index position of the first TRUE value on each row (or return NA if there is no TRUE value in the row). The following code gets the job done, but it uses an apply() call, which I believe is just a wrapper around a for loop. I'm working with some large datasets and performance is suffering. Is there a faster way?
> x <- matrix(rep(c(F,T,T),10), nrow=10)
> x
[,1] [,2] [,3]
[1,] FALSE TRUE TRUE
[2,] TRUE TRUE FALSE
[3,] TRUE FALSE TRUE
[4,] FALSE TRUE TRUE
[5,] TRUE TRUE FALSE
[6,] TRUE FALSE TRUE
[7,] FALSE TRUE TRUE
[8,] TRUE TRUE FALSE
[9,] TRUE FALSE TRUE
[10,] FALSE TRUE TRUE
> apply(x,1,function(y) which(y)[1])
[1] 2 1 1 2 1 1 2 1 1 2
Not sure this is any better, but this is one solution:
> x2 <- t(t(matrix(as.numeric(x), nrow=10)) * 1:3)
> x2[x2 == 0] <- Inf
> rowMins(x2)
[1] 2 1 1 2 1 1 2 1 1 2
Edit: Here's a better solution using base R:
> x2 <- (x2 <- which(x, arr=TRUE))[order(x2[,1]),]
> x2[as.logical(c(1,diff(x2[,1]) != 0)),2]
[1] 2 1 1 2 1 1 2 1 1 2
A couple of years later, I want to add two alternative approaches.
1) With max.col:
> max.col(x, "first")
[1] 2 1 1 2 1 1 2 1 1 2
2) With aggregate:
> aggregate(col ~ row, data = which(x, arr.ind = TRUE), FUN = min)$col
[1] 2 1 1 2 1 1 2 1 1 2
As performance is an issue, let's test the different methods on a larger dataset. First create a function for each method:
abiel <- function(n){apply(n, 1, function(y) which(y)[1])}
maxcol <- function(n){max.col(n, "first")}
aggr.min <- function(n){aggregate(col ~ row, data = which(n, arr.ind = TRUE), FUN = min)$col}
shane.bR <- function(n){x2 <- (x2 <- which(n, arr=TRUE))[order(x2[,1]),]; x2[as.logical(c(1,diff(x2[,1]) != 0)),2]}
joris <- function(n){z <- which(t(n))-1;((z%%ncol(n))+1)[match(1:nrow(n), (z%/%ncol(n))+1)]}
Second, create a larger dataset:
xl <- matrix(sample(c(F,T),9e5,replace=TRUE), nrow=1e5)
Third, run the benchmark:
library(microbenchmark)
microbenchmark(abiel(xl), maxcol(xl), aggr.min(xl), shane.bR(xl), joris(xl),
unit = 'relative')
which results in:
Unit: relative
expr min lq mean median uq max neval cld
abiel(xl) 55.102815 33.458994 15.781460 33.243576 33.196486 2.911675 100 d
maxcol(xl) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000 100 a
aggr.min(xl) 439.863935 262.595535 118.436328 263.387427 256.815607 16.709754 100 e
shane.bR(xl) 12.477856 8.522470 7.389083 13.549351 24.626431 1.748501 100 c
joris(xl) 7.922274 5.449662 4.418423 5.964554 9.855588 1.491417 100 b
You can gain a lot of speed by using %% and %/%:
x <- matrix(rep(c(F,T,T),10), nrow=10)
z <- which(t(x))-1
((z%%ncol(x))+1)[match(1:nrow(x), (z%/%ncol(x))+1)]
This can be adapted as needed: if you want to do this for columns, you don't have to transpose the matrix.
Tried out on a 1,000,000 X 5 matrix :
x <- matrix(sample(c(F,T),5000000,replace=T), ncol=5)
system.time(apply(x,1,function(y) which(y)[1]))
#> user system elapsed
#> 12.61 0.07 12.70
system.time({
z <- which(t(x))-1
(z%%ncol(x)+1)[match(1:nrow(x), (z%/%ncol(x))+1)]}
)
#> user system elapsed
#> 1.11 0.00 1.11
You could gain quite a lot this way.

Resources