I have a matrix (m.idx) containing position elements of a vector I want to index.
> m.idx
[,1] [,2] [,3] [,4] [,5]
[1,] 1 2 3 4 5
[2,] 3 4 5 6 7
[3,] 5 6 7 8 9
Suppose x is my vector.
x <- c(9,3,2,5,3,2,4,8,9)
I want to repopulate the matrix index with the corresponding position elements of x.
so I would have...
> m.pop
[,1] [,2] [,3] [,4] [,5]
[1,] 9 3 2 5 3
[2,] 2 5 3 2 4
[3,] 3 2 4 8 9
I can kind of do it in a kludgy way with the following.
> m.pop <- t(matrix(t(matrix(x[c(t(m.idx))])),ncol(m.idx),nrow(m.idx)))
> m.pop
[,1] [,2] [,3] [,4] [,5]
[1,] 9 3 2 5 3
[2,] 2 5 3 2 4
[3,] 3 2 4 8 9
But it seems like there may be an easier method to index the values.
What is the best (and fastest/efficient for large sets) way to do this?
How about:
m.idx[] <- x[m.idx]
m.idx
# [,1] [,2] [,3] [,4] [,5]
# [1,] 9 3 2 5 3
# [2,] 2 5 3 2 4
# [3,] 3 2 4 8 9
Or if you don't want to overwrite the m.idx matrix, you can do this instead:
m.pop <- m.idx
m.pop[] <- x[m.pop]
Added:
One other method, using structure, is also quite fast:
structure(x[m.idx], .Dim = dim(m.idx))
# [,1] [,2] [,3] [,4] [,5]
# [1,] 9 3 2 5 3
# [2,] 2 5 3 2 4
# [3,] 3 2 4 8 9
When applied to the large m.idx matrix in Ananda Mahto's answer, the timings on my machine are
fun5 <- function() structure(x[m.idx], .Dim = dim(m.idx))
microbenchmark(fun1(), fun2(), fun3(), fun4(), fun5(), times = 10)
# Unit: milliseconds
# expr min lq median uq max neval
# fun1() 303.3473 307.2064 309.2275 352.5076 353.6911 10
# fun2() 548.0928 555.3363 587.6144 593.4492 596.5611 10
# fun3() 480.6181 487.5807 507.5960 529.9696 533.0403 10
# fun4() 1222.6718 1231.3384 1259.8395 1269.6629 1292.2309 10
# fun5() 401.8450 403.7216 432.7162 455.4638 487.1755 10
identical(fun1(), fun5())
# [1] TRUE
You can see that structure is actually not too bad in terms of speed.
matrix(x[m.idx],ncol=5)
[,1] [,2] [,3] [,4] [,5]
[1,] 9 3 2 5 3
[2,] 2 5 3 2 4
[3,] 3 2 4 8 9
Maybe you can just use dim after matching the vector/matrix:
`dim<-`(x[m.idx], dim(m.idx))
# [,1] [,2] [,3] [,4] [,5]
# [1,] 9 3 2 5 3
# [2,] 2 5 3 2 4
# [3,] 3 2 4 8 9
The x[m.idx] gets you the values you're interested in:
> x[m.idx]
[1] 9 2 3 3 5 2 2 3 4 5 2 8 3 4 9
And, since this should be returned int he same dimensions at the original, you just reassign the same dim to it.
For fun, some timings:
fun1 <- function() `dim<-`(x[m.idx], dim(m.idx))
fun2 <- function() { m.idx[] <- x[m.idx]; m.idx }
fun3 <- function() matrix(x[m.idx], ncol = ncol(m.idx))
fun4 <- function() t(matrix(t(matrix(x[c(t(m.idx))])),ncol(m.idx),nrow(m.idx)))
m.idx <- matrix(c(1, 2, 3, 4, 5,
3, 4, 5, 6, 7,
5, 6, 7, 8, 9),
nrow = 3, byrow = TRUE)
x <- c(9, 3, 2, 5, 3, 2, 4, 8, 9)
set.seed(1)
nrow = 10000 ## Adjust nrow and ncol to test different sizes
ncol = 1000
m.idx <- matrix(sample(unique(m.idx), nrow*ncol, TRUE), ncol = ncol)
library(microbenchmark)
microbenchmark(fun1(), fun2(), fun3(), fun4(), times = 10)
# Unit: milliseconds
# expr min lq median uq max neval
# fun1() 388.7123 403.3614 419.5792 475.7645 553.3420 10
# fun2() 800.5524 838.2398 872.8189 912.1007 978.1500 10
# fun3() 694.1511 720.5165 737.9900 799.5069 876.2552 10
# fun4() 1941.1999 2022.6578 2095.1537 2175.4864 2341.3900 10
Related
Given n=2, I want the set of values (1, 1), (1, 2), and (2, 2). For n=3, I want (1, 1), (1, 2), (1, 3), (2, 2), (2, 3), and (3, 3). And so on for n=4, 5, etc.
I'd like to do this entirely within the base libraries. Recently, I've taken to using
gen <- function(n)
{
x <- seq_len(n)
cbind(combn(x, 2), rbind(x, x))
}
which gives some workable but hacky output. We get the below for n=4.
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
x 1 1 1 2 2 3 1 2 3 4
x 2 3 4 3 4 4 1 2 3 4
Is there a better way? Between expand.grid, outer, combn, and R's many other ways of generating vectors, I was hoping to be able to do this with just one combination-producing function rather than having to bind together the output of combn with something else. I could write the obvious for loop, but that seems like a waste of R's powers.
Starting with expand.grid and then subsetting is an option that many answers so far have taken, but I find the idea of generating twice the set that I need to be a poor use of memory. This probably also rules out outer.
Here are some ways to do this.
1) upper.tri
n <- 4
d <- diag(n)
u <- upper.tri(d, diag = TRUE)
rbind(row(d)[u], col(d)[u])
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
## [1,] 1 1 2 1 2 3 1 2 3 4
## [2,] 1 2 2 3 3 3 4 4 4 4
The last line of code could alternately be written as:
t(sapply(c(row, col), function(f) f(d)[u]))
2) combn
n <- 4
combn(n+1, 2, function(x) if (x[2] == n+1) x[1] else x)
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
## [1,] 1 1 1 1 2 2 2 3 3 4
## [2,] 2 3 4 1 3 4 2 4 3 4
A variation of this is:
co <- combn(n+1, 2)
co[2, ] <- ifelse(co[2, ] == n+1, co[1, ], co[2, ])
co
3) list comprehension
library(listcompr)
t(gen.matrix(c(i, j), i = 1:n, j = i:n))
## [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
## [1,] 1 1 2 1 2 3 1 2 3 4
## [2,] 1 2 2 3 3 3 4 4 4 4
Performance
library(microbenchmark)
library(listcompr)
n <- 25
microbenchmark(
upper.tri = {
d <- diag(n)
u <- upper.tri(d, diag = TRUE)
rbind(row(d)[u], col(d)[u]) },
upper.tri2 = {
d <- diag(n)
u <- upper.tri(d, diag = TRUE)
t(sapply(c(row, col), function(f) f(d)[u])) },
combn = combn(n+1, 2, function(x) if (x[2] == n+1) x[1] else x),
combn2 = {
co <- combn(n+1, 2)
co[2, ] <- ifelse(co[2, ] == n+1, co[1, ], co[2, ])
co
},
listcompr = t(gen.matrix(c(i, j), i = 1:n, j = i:n)))
giving:
Unit: microseconds
expr min lq mean median uq max neval cld
upper.tri 41.8 52.00 65.761 61.30 77.15 132.6 100 a
upper.tri2 110.8 128.95 187.372 154.85 178.60 3024.6 100 a
combn 1342.8 1392.25 1514.038 1432.90 1473.65 7034.7 100 a
combn2 687.5 725.50 780.686 765.85 812.65 1129.4 100 a
listcompr 97889.0 100321.75 106442.425 101347.95 105826.55 307089.4 100 b
Update
Here is another version, inspired by #G. Grothendieck
gen <- function(n) t(which(upper.tri(diag(n), diag = TRUE), arr.ind = TRUE))
or
gen <- function(n) {
unname(do.call(
cbind,
sapply(
seq(n),
function(k) rbind(k, k:n)
)
))
}
You can try expand.grid + subset like below
gen <- function(n) {
unname(t(
subset(
expand.grid(rep(list(seq(n)), 2)),
Var1 <= Var2
)
))
}
and you will see
> gen(2)
[,1] [,2] [,3]
[1,] 1 1 2
[2,] 1 2 2
> gen(3)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 1 1 2 1 2 3
[2,] 1 2 2 3 3 3
> gen(4)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10]
[1,] 1 1 2 1 2 3 1 2 3 4
[2,] 1 2 2 3 3 3 4 4 4 4
Here's a slightly modified version of #G. Grothendieck's upper.tri, and a comparison of both to #rawr's method in the comments
upper.tri3 <- function(n){
mrow <- row(diag(n))
mcol <- t(mrow)
i <- mrow <= mcol
rbind(mrow[i], mcol[i])
}
library(bench)
n <- 1e4
mark(
upper.tri = {
d <- diag(n)
u <- upper.tri(d, diag = TRUE)
rbind(row(d)[u], col(d)[u]) },
upper.tri3 = upper.tri3(n),
rawr = {
s <- 1:n
rbind(sequence(s), rep(s, s))
}
)
#> Warning: Some expressions had a GC in every iteration; so filtering is disabled.
#> # A tibble: 3 × 6
#> expression min median `itr/sec` mem_alloc `gc/sec`
#> <bch:expr> <bch:tm> <bch:tm> <dbl> <bch:byt> <dbl>
#> 1 upper.tri 3.96s 3.96s 0.252 4.47GB 0.757
#> 2 upper.tri3 2.46s 2.46s 0.406 3.73GB 1.62
#> 3 rawr 372.25ms 429.55ms 2.33 763.06MB 1.16
Created on 2021-10-18 by the reprex package (v2.0.1)
You can use expand.grid. I see it as the most intuitive and easy to read solution.
simple_solution <- function(x) {
df <- expand.grid(1:x, 1:x)
return(df[df$Var1 <= df$Var2, ])
}
> simple_solution(4)
Var1 Var2
1 1 1
5 1 2
6 2 2
9 1 3
10 2 3
11 3 3
13 1 4
14 2 4
15 3 4
16 4 4
I have a 5x4 matrix. I have created a function call fun1, fun1 use double for loop to loop through the matrix and use distance function to work out the distance between two-row. The final results matrix will be a 5x5 matrix.
I am struggling to covert this fun1 to a vectorization function(no loop, only apply function).
x =
[,1] [,2] [,3] [,4]
[1,] 1 6 11 16
[2,] 2 7 12 17
[3,] 3 8 13 18
[4,] 4 9 14 19
[5,] 5 10 15 20
distance = function(a, b) {
sqrt(sum((a - b)^2))
}
fun1 = function(x) {
n = nrow(x)
results = matrix(0, nrow = n, ncol = n)
for (i in seq_len(n)) {
for (j in seq_len(n)) {
results[i,j] = distance(m[i,], m[j,])
}
}
results
}
You can do it with just a matrix multiplication, some additions and a transpose.
x <- matrix(1:20, nrow = 5)
z <- x %*% t(x)
sqrt(diag(z)+t(diag(z)-2*z))
#> [,1] [,2] [,3] [,4] [,5]
#> [1,] 0 2 4 6 8
#> [2,] 2 0 2 4 6
#> [3,] 4 2 0 2 4
#> [4,] 6 4 2 0 2
#> [5,] 8 6 4 2 0
Interestingly this is faster than the in built method mentioned in the comments above!
mdist <- function(x) {
z <- x %*% t(x)
sqrt(diag(z)+t(diag(z)-2*z))
}
n <- 1000
l <- 100
x <- matrix(runif(n*l), ncol = l)
microbenchmark::microbenchmark(
z1 = as.matrix(dist(x)),
z2 = dist(x, diag = TRUE, upper = TRUE),
z3 = mdist(x),
times = 100
)
#> Unit: milliseconds
#> expr min lq mean median uq max neval
#> z1 82.98502 90.20049 98.54552 94.85027 101.78114 140.1809 100
#> z2 72.54279 76.22054 82.75410 79.31865 83.47765 231.3008 100
#> z3 54.58258 59.73461 65.62313 63.14435 67.49865 115.0379 100
In a pinch, Vectorize can do what you need:
outer(seq_len(nrow(m)), seq_len(nrow(m)),
Vectorize(function(i,j) distance(m[i,], m[j,]), vectorize.args=c("i","j")))
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 2 4 6 8
# [2,] 2 0 2 4 6
# [3,] 4 2 0 2 4
# [4,] 6 4 2 0 2
# [5,] 8 6 4 2 0
Vectorize takes a function as an argument and returns a function that accepts vectors, iterating internally. The function passed to it is called once for each element within the vector passed. By default, Vectorize only vectorizes the first argument of the function, but it can "zip" along multiple arguments, assuming they are all the same length, by using vectorize.args=.
This might be a little easier to visualize by redefining distance:
distance_ind = function(i, j, data) {
sqrt(sum((data[i,] - data[j,])^2))
}
distance_ind(1, 2, m)
# [1] 2
distance_ind(c(1,3), c(2,3), m)
# [1] 2 ### wrong
distance_ind_vec <- Vectorize(distance_ind, vectorize.args = c("i", "j"))
distance_ind_vec(c(1,3), c(2,3), m)
# [1] 2 0
And the outer call:
outer(seq_len(nrow(m)), seq_len(nrow(m)), distance_ind_vec, data = m)
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 2 4 6 8
# [2,] 2 0 2 4 6
# [3,] 4 2 0 2 4
# [4,] 6 4 2 0 2
# [5,] 8 6 4 2 0
I want to split matrices of size k x l into blocks of size n x n considering an ofset o (Like Mathematica's Partition function does).
For example, given a matrix A like
A <- matrix(seq(1:16), nrow = 4, ncol = 4)
[,1] [,2] [,3] [,4]
[1,] 1 5 9 13
[2,] 2 6 10 14
[3,] 3 7 11 15
[4,] 4 8 12 16
and block size = 3, offset = 1, I want as output the four submatrices that I'd get from
A[1:3, 1:3]
A[1:3, 2:4]
A[2:4, 1:3]
A[2:4, 2:4]
If offset were equal to 2 or 3, the output for this example should be only the submatrix that I get from
A[1:3, 1:3]
How can I vectorize this?
There might be a more elegant way. Here is how I'd do it by writing a myPartition function which simulates the mathematica Partition function. Firstly use Map to construct possible index along the row and column axis where we use seq to take offset into consideration, and then use cross2 from purrr to construct a list of all possible combinations of the subset index. Finally use lapply to subset the matrix and return a list of subset matrix;
The testing results on offset 1, 2 and 3 are as follows which seems to behave as expected:
library(purrr)
ind <- function(k, n, o) Map(`:`, seq(1, k-n+1, by = o), seq(n, k, by = o))
# this is a little helper function that generates subset index according to dimension of the
# matrix, the first sequence construct the starting point of the subset index with an interval
# of o which is the offset while the second sequence construct the ending point of the subset index
# use Map to construct vector from start to end which in OP's case will be 1:3 and 2:4.
myPartition <- function(mat, n, o) {
lapply(cross2(ind(nrow(mat),n,o), ind(ncol(mat),n,o)), function(i) mat[i[[1]], i[[2]]])
}
# This is basically an lapply. we use cross2 to construct combinations of all subset index
# which will be 1:3 and 1:3, 1:3 and 2:4, 2:4 and 1:3 and 2:4 and 2:4 in OP's case. Use lapply
# to loop through the index and subset.
# Testing case for offset = 1
myPartition(A, 3, 1)
# [[1]]
# [,1] [,2] [,3]
# [1,] 1 5 9
# [2,] 2 6 10
# [3,] 3 7 11
# [[2]]
# [,1] [,2] [,3]
# [1,] 2 6 10
# [2,] 3 7 11
# [3,] 4 8 12
# [[3]]
# [,1] [,2] [,3]
# [1,] 5 9 13
# [2,] 6 10 14
# [3,] 7 11 15
# [[4]]
# [,1] [,2] [,3]
# [1,] 6 10 14
# [2,] 7 11 15
# [3,] 8 12 16
# Testing case for offset = 2
myPartition(A, 3, 2)
# [[1]]
# [,1] [,2] [,3]
# [1,] 1 5 9
# [2,] 2 6 10
# [3,] 3 7 11
# Testing case for offset = 3
myPartition(A, 3, 3)
# [[1]]
# [,1] [,2] [,3]
# [1,] 1 5 9
# [2,] 2 6 10
# [3,] 3 7 11
How about this using base R, the idea is to generate all possible windows (i.e. winds) of size n*n while taking into account the offset. Then print all possible permutations of winds's elements in matrix A (i.e. perms). It works for any A of size k*l.
A <- matrix(seq(1:16), nrow = 4, ncol = 4)
c <- ncol(A); r <- nrow(A)
offset <- 1; size <- 3
sq <- seq(1, max(r,c), offset)
winds <- t(sapply(sq, function(x) c(x,(x+size-1))))
winds <- winds[winds[,2]<=max(r, c),] # check the range
if (is.vector(winds)) dim(winds) <- c(1,2) # vector to matrix
perms <- expand.grid(list(1:nrow(winds), 1:nrow(winds)))
out=apply(perms, 1, function(x) {
a11 <- winds[x[1],1];a12 <- winds[x[1],2];a21 <- winds[x[2],1];a22 <- winds[x[2],2]
if (ifelse(r<c, a12<=r, a22<=c)) { # check the range
cat("A[", a11, ":", a12, ", ", a21, ":", a22, "]", sep="", "\n")
print(A[a11:a12, a21:a22])
}
})
# A[1:3, 1:3]
# [,1] [,2] [,3]
# [1,] 1 5 9
# [2,] 2 6 10
# [3,] 3 7 11
# A[2:4, 1:3]
# [,1] [,2] [,3]
# [1,] 2 6 10
# [2,] 3 7 11
# [3,] 4 8 12
# A[1:3, 2:4]
# [,1] [,2] [,3]
# [1,] 5 9 13
# [2,] 6 10 14
# [3,] 7 11 15
# A[2:4, 2:4]
# [,1] [,2] [,3]
# [1,] 6 10 14
# [2,] 7 11 15
# [3,] 8 12 16
For size=3 and offset=2 or offset=3:
# A[1:3, 1:3]
# [,1] [,2] [,3]
# [1,] 1 5 9
# [2,] 2 6 10
# [3,] 3 7 11
For offset=2 and size=2:
# A[1:2, 1:2]
# [,1] [,2]
# [1,] 1 5
# [2,] 2 6
# A[3:4, 1:2]
# [,1] [,2]
# [1,] 3 7
# [2,] 4 8
# A[1:2, 3:4]
# [,1] [,2]
# [1,] 9 13
# [2,] 10 14
# A[3:4, 3:4]
# [,1] [,2]
# [1,] 11 15
# [2,] 12 16
In R, I want create a 5x5 matrix of 0,1,3,5,7 such that:
0 1 3 5 7
1 0 3 5 7
1 3 0 5 7
1 3 5 0 7
1 3 5 7 0
So obviously I can generate the starting matrix:
z <- c(0,1,3,5,7)
matrix(z, ncol=5, nrow=5, byrow = TRUE)
but I'm unsure of how to move the 0's position. I'm sure I have to use some sort of for/in loop, but I really don't know what exactly I need to do.
How about this:
m <- 1 - diag(5)
m[m==1] <- rep(c(1,3,5,7), each=5)
m
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 1 3 5 7
# [2,] 1 0 3 5 7
# [3,] 1 3 0 5 7
# [4,] 1 3 5 0 7
# [5,] 1 3 5 7 0
Or we can do:
z <- c(1,3,5,7)
mat <- 1-diag(5)
mat[mat==1] <- z
t(mat)
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 1 3 5 7
# [2,] 1 0 3 5 7
# [3,] 1 3 0 5 7
# [4,] 1 3 5 0 7
# [5,] 1 3 5 7 0
Yet another solution just to enjoy combn as well:
r <- integer(5)
t(combn(5, 1, function(v) {r[v]<-0;r[-v]<-z;r}))
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 1 3 5 7
# [2,] 1 0 3 5 7
# [3,] 1 3 0 5 7
# [4,] 1 3 5 0 7
# [5,] 1 3 5 7 0
Or using sapply:
v <- integer(5)
t(sapply(seq(5), function(x) {v[x]<-0;v[-x]<-z;v}))
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 1 3 5 7
# [2,] 1 0 3 5 7
# [3,] 1 3 0 5 7
# [4,] 1 3 5 0 7
# [5,] 1 3 5 7 0
Here's a solution that builds the data vector with a couple of calls to rep(), a couple of calls to c(), a seq(), and an rbind(), and then wraps it in a call to matrix():
N <- 5L;
matrix(rep(c(0,rbind(seq(1,(N-1)*2,2),0)),rep(c(1,N),len=N*2-1)),N);
## [,1] [,2] [,3] [,4] [,5]
## [1,] 0 1 3 5 7
## [2,] 1 0 3 5 7
## [3,] 1 3 0 5 7
## [4,] 1 3 5 0 7
## [5,] 1 3 5 7 0
Another idea, using two calls to diag() and a cumsum():
N <- 5L;
(1-diag(N))*(cumsum(diag(N)*2)-1);
## [,1] [,2] [,3] [,4] [,5]
## [1,] 0 1 3 5 7
## [2,] 1 0 3 5 7
## [3,] 1 3 0 5 7
## [4,] 1 3 5 0 7
## [5,] 1 3 5 7 0
Benchmarking
Note: For the following benchmarking tests I modified everyone's solutions where necessary to ensure they are parameterized on the matrix size N. For the most part, this just involved replacing some literals with N, and replacing instances of c(1,3,5,7) with seq(1,(N-1)*2,2). I think this is fair.
library(microbenchmark);
josh <- function(N) { m <- 1-diag(N); m[m==1] <- rep(seq(1,(N-1)*2,2),each=N); m; };
marat <- function(N) matrix(rbind(0,col(diag(N))*2-1),nrow=N,ncol=N);
gregor <- function(N) { x = seq(1,(N-1)*2,2); t(mapply(FUN = append, after = c(0, seq_along(x)), MoreArgs = list(x = x, values = 0))); };
barkley <- function(N) { my_vec <- seq(1,(N-1)*2,2); my_val <- 0; my_mat <- matrix(NA, ncol = length(my_vec)+1, nrow = length(my_vec)+1); for (i in 1:nrow(my_mat)) { my_mat[i, i] <- my_val; my_mat[i, -i] <- my_vec; }; my_mat; };
m0h3n <- function(N) { z <- seq(1,(N-1)*2,2); mat=1-diag(N); mat[mat==1]=z; t(mat); };
bgoldst1 <- function(N) matrix(rep(c(0,rbind(seq(1,(N-1)*2,2),0)),rep(c(1,N),len=N*2-1)),N);
bgoldst2 <- function(N) (1-diag(N))*(cumsum(diag(N)*2)-1);
## small-scale: 5x5
N <- 5L;
ex <- josh(N);
identical(ex,marat(N));
## [1] TRUE
identical(ex,gregor(N));
## [1] TRUE
identical(ex,barkley(N));
## [1] TRUE
identical(ex,m0h3n(N));
## [1] TRUE
identical(ex,bgoldst1(N));
## [1] TRUE
identical(ex,bgoldst2(N));
## [1] TRUE
microbenchmark(josh(N),marat(N),gregor(N),barkley(N),m0h3n(N),bgoldst1(N),bgoldst2(N));
## Unit: microseconds
## expr min lq mean median uq max neval
## josh(N) 20.101 21.8110 25.71966 23.0935 24.8045 108.197 100
## marat(N) 5.987 8.1260 9.01131 8.5535 8.9820 24.805 100
## gregor(N) 49.608 51.9605 57.61397 53.8850 61.7965 98.361 100
## barkley(N) 29.081 32.0750 36.33830 33.7855 41.9110 54.740 100
## m0h3n(N) 22.666 24.8040 28.45663 26.0870 28.4400 59.445 100
## bgoldst1(N) 20.528 23.0940 25.49303 23.5220 24.8050 56.879 100
## bgoldst2(N) 3.849 5.1320 5.73551 5.5600 5.9880 16.251 100
## medium-scale: 50x50
N <- 50L;
ex <- josh(N);
identical(ex,marat(N));
## [1] TRUE
identical(ex,gregor(N));
## [1] TRUE
identical(ex,barkley(N));
## [1] TRUE
identical(ex,m0h3n(N));
## [1] TRUE
identical(ex,bgoldst1(N));
## [1] TRUE
identical(ex,bgoldst2(N));
## [1] TRUE
microbenchmark(josh(N),marat(N),gregor(N),barkley(N),m0h3n(N),bgoldst1(N),bgoldst2(N));
## Unit: microseconds
## expr min lq mean median uq max neval
## josh(N) 106.913 110.7630 115.68488 113.1145 116.1080 179.187 100
## marat(N) 62.866 65.4310 78.96237 66.7140 67.9980 1163.215 100
## gregor(N) 195.438 205.2735 233.66129 213.6130 227.9395 1307.334 100
## barkley(N) 184.746 194.5825 227.43905 198.6455 207.1980 1502.771 100
## m0h3n(N) 73.557 76.1230 92.48893 78.6885 81.6820 1176.045 100
## bgoldst1(N) 51.318 54.3125 95.76484 56.4500 60.0855 1732.421 100
## bgoldst2(N) 18.817 21.8110 45.01952 22.6670 23.5220 1118.739 100
## large-scale: 1000x1000
N <- 1e3L;
ex <- josh(N);
identical(ex,marat(N));
## [1] TRUE
identical(ex,gregor(N));
## [1] TRUE
identical(ex,barkley(N));
## [1] TRUE
identical(ex,m0h3n(N));
## [1] TRUE
identical(ex,bgoldst1(N));
## [1] TRUE
identical(ex,bgoldst2(N));
## [1] TRUE
microbenchmark(josh(N),marat(N),gregor(N),barkley(N),m0h3n(N),bgoldst1(N),bgoldst2(N));
## Unit: milliseconds
## expr min lq mean median uq max neval
## josh(N) 40.32035 43.42810 54.46468 45.36386 80.17241 90.69608 100
## marat(N) 41.00074 45.34248 54.74335 47.00904 50.74608 93.85429 100
## gregor(N) 33.65923 37.82393 50.50060 40.24914 75.09810 83.27246 100
## barkley(N) 31.02233 35.42223 43.08745 36.85615 39.81999 85.28585 100
## m0h3n(N) 27.08622 31.00202 38.98395 32.33244 34.33856 90.82652 100
## bgoldst1(N) 12.53962 13.02672 18.31603 14.92314 16.96433 59.87945 100
## bgoldst2(N) 13.23926 16.87965 28.81906 18.92319 54.60009 62.01258 100
## very large scale: 10,000x10,000
N <- 1e4L;
ex <- josh(N);
identical(ex,marat(N));
## [1] TRUE
identical(ex,gregor(N));
## [1] TRUE
identical(ex,barkley(N));
## [1] TRUE
identical(ex,m0h3n(N));
## [1] TRUE
identical(ex,bgoldst1(N));
## [1] TRUE
identical(ex,bgoldst2(N));
## [1] TRUE
microbenchmark(josh(N),marat(N),gregor(N),barkley(N),m0h3n(N),bgoldst1(N),bgoldst2(N));
## Unit: seconds
## expr min lq mean median uq max neval
## josh(N) 3.698714 3.908910 4.067409 4.046770 4.191938 4.608312 100
## marat(N) 6.440882 6.977273 7.272962 7.223293 7.493600 8.471888 100
## gregor(N) 3.546885 3.850812 4.032477 4.022563 4.221085 4.651799 100
## barkley(N) 2.955906 3.162409 3.324033 3.279032 3.446875 4.444848 100
## m0h3n(N) 3.355968 3.667484 3.829618 3.777151 3.973279 4.649226 100
## bgoldst1(N) 1.044510 1.260041 1.363827 1.369945 1.441194 1.819248 100
## bgoldst2(N) 1.144168 1.391711 1.517189 1.519653 1.629994 2.478636 100
Perhaps not the most beautiful solution ever, but maybe elegant in its simplicity:
my_vec <- c(1,3,5,7)
my_val <- 0
my_mat <- matrix(NA, ncol = length(my_vec)+1, nrow = length(my_vec)+1)
for (i in 1:nrow(my_mat)) {
my_mat[i, i] <- my_val
my_mat[i, -i] <- my_vec
}
my_mat
[,1] [,2] [,3] [,4] [,5]
[1,] 0 1 3 5 7
[2,] 1 0 3 5 7
[3,] 1 3 0 5 7
[4,] 1 3 5 0 7
[5,] 1 3 5 7 0
You could use
n <- 5
matrix(rbind(0,col(diag(n))*2-1),nrow=n,ncol=n)
Fun question! In poking around, I saw that append has a after argument.
x = c(1, 3, 5, 7)
t(mapply(FUN = append, after = c(0, seq_along(x)),
MoreArgs = list(x = x, values = 0)))
# [,1] [,2] [,3] [,4] [,5]
# [1,] 0 1 3 5 7
# [2,] 1 0 3 5 7
# [3,] 1 3 0 5 7
# [4,] 1 3 5 0 7
# [5,] 1 3 5 7 0
Another option, directly constructing each row:
v = c(1, 3, 5, 7)
n = length(v)
t(sapply(0:n, function(i) c(v[0:i], 0, v[seq(to = n, length.out = n - i)])))
# [,1] [,2] [,3] [,4] [,5]
#[1,] 0 1 3 5 7
#[2,] 1 0 3 5 7
#[3,] 1 3 0 5 7
#[4,] 1 3 5 0 7
#[5,] 1 3 5 7 0
Problem: I have n, m-length vectors in a n by m matrix.
These vectors are left-padded with NA values.
Example:
x = matrix( 1:12, ncol=4 )
x[lower.tri(x)] = NA
print(x)
# [,1] [,2] [,3] [,4]
# [1,] 1 4 7 10
# [2,] NA 5 8 11
# [3,] NA NA 9 12
Question: What is an efficient way to make the rows right-padded? My actual matrix is 4,000 by 25,000.
What I want:
y = matrix( c( 1, 5, 9, 4, 8, 12,
7, 11, NA, 10, NA, NA ), ncol=4 )
print(y)
# [,1] [,2] [,3] [,4]
# [1,] 1 4 7 10
# [2,] 5 8 11 NA
# [3,] 9 12 NA NA
Here are two one-line solutions:
t(apply(x, 1, FUN=function(ii) c(ii[!is.na(ii)],ii[is.na(ii)])))
[,1] [,2] [,3] [,4]
[1,] 1 4 7 10
[2,] 5 8 11 NA
[3,] 9 12 NA NA
matrix(apply(x, 1, FUN=function(ii) c(ii[!is.na(ii)],ii[is.na(ii)])),
byrow=T,ncol=4)
The idea here is just to look through each row and find the NA sand move them behind the values that are not NAs (i.e. !is.na).
The second version is actually slightly faster on my machine:
library(microbenchmark)
microbenchmark(
t(apply(x, 1, FUN=function(ii) c(ii[!is.na(ii)],ii[is.na(ii)]))),
matrix(apply(x, 1, FUN=function(ii) c(ii[!is.na(ii)],ii[is.na(ii)])),
byrow=T,ncol=4)
)
Unit: microseconds
min lq median uq max neval
58.159 61.152 62.2215 66.711 174.475 100
51.317 53.883 54.7380 57.731 127.863 100