Create binary matrix under certain conditions
I am trying to create a function that gives m
and p
returns a matrix with columns m
and columns mxp
. The matrix must have 0
, with the exception of positions p
, starting at p
(number of rows).
For example, given m=4
and p=2
, the matrix should look like this:
1 1 0 0 0 0 0 0
0 0 1 1 0 0 0 0
0 0 0 0 1 1 0 0
0 0 0 0 0 0 1 1
I want to work with large matrices. I know how to do this with loops in other programming languages like python, but I'm sure it should be an easier and more elegant way to do it in R. I've been playing around with for a while diag()
without finding a solution.
source to share
This solution p=2
uses changing the number of lines for:
m <- 4
d <- diag(m)
matrix(rbind(d,d), m)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
# [1,] 1 1 0 0 0 0 0 0
# [2,] 0 0 1 1 0 0 0 0
# [3,] 0 0 0 0 1 1 0 0
# [4,] 0 0 0 0 0 0 1 1
For other values p
(from the comment A5C1D2H2I1M1N2O1R2T1):
p <- 3; m <- 4
matrix(rep(diag(m), each = p), nrow = m, byrow = TRUE)
source to share
How about this:
f <- function(m, p){
a <- diag(m)
a[,rep(seq_len(m), each=p)]
}
> f(m = 4, p = 2)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
#[1,] 1 1 0 0 0 0 0 0
#[2,] 0 0 1 1 0 0 0 0
#[3,] 0 0 0 0 1 1 0 0
#[4,] 0 0 0 0 0 0 1 1
> f(m = 3, p = 4)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8] [,9] [,10] [,11] [,12]
#[1,] 1 1 1 1 0 0 0 0 0 0 0 0
#[2,] 0 0 0 0 1 1 1 1 0 0 0 0
#[3,] 0 0 0 0 0 0 0 0 1 1 1 1
The idea is to first create a diagonal matrix of size m
(which we will call a
) and then repeat each column of that matrix p
times (so m*p
matrix).
source to share
This method uses a subset of matrices to fill the 1s.
myMatFunc <- function(m, p) {
# initialize matrix of correct size, filled with 0s
myMat <- matrix(0L, m, m * p)
#fill in 1s using matrix subsetting
myMat[cbind(rep(seq_len(m), each=p), seq_len(m * p))] <- 1L
myMat
}
then
myMatFunc(4, 2)
[,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
[1,] 1 1 0 0 0 0 0 0
[2,] 0 0 1 1 0 0 0 0
[3,] 0 0 0 0 1 1 0 0
[4,] 0 0 0 0 0 0 1 1
Thanks to the comments from @ joseph-wood, @jogo, and @ A5C1D2H2I1M1N2O1R2T1 below, I've improved efficiency by removing call nrow
and call ncol
, cut the matrix size in half by converting to integers, and fixed the original type check.
source to share
Here's a basic R solution that's pretty fast:
Joseph <- function(m, p) {
mat <- matrix(0L, nrow = m, ncol = m*p)
for (i in 1:m) {mat[i, p*(i-1L) + 1:p] <- 1L}
mat
}
Here are some parsing comparisons:
fun989 <- function(m, p){
a <- diag(m)
a[,rep(seq_len(m), each=p)]
}
IMO <- function(m, p) {
myMat <- matrix(0L, m, m*p)
myMat[cbind(rep(seq_len(nrow(myMat)), each=p), seq_len(ncol(myMat)))] <- 1
myMat
}
JOGO <- function(m, p) {matrix(rep(diag(m), each = p), nrow = m, byrow = TRUE)}
APOM <- function(m, p) {t(apply(diag(m), 2, rep, each = p))}
library(compiler)
enableJIT(3) ## compiling each function
all.equal(Joseph(100, 50), fun989(100, 50))
[1] TRUE
all.equal(Joseph(100, 50), APOM(100, 50))
[1] TRUE
all.equal(Joseph(100, 50), JOGO(100, 50))
[1] TRUE
all.equal(Joseph(100, 50), IMO(100, 50))
[1] TRUE
enableJIT(0) ## return to standard setting
Here are the steps:
library(microbenchmark)
microbenchmark(Joseph(100, 50), JOGO(100, 50), fun989(100, 50), APOM(100, 50), IMO(100, 50), unit = "relative")
Unit: relative
expr min lq mean median uq max neval cld
Joseph(100, 50) 1.000000 1.000000 1.000000 1.000000 1.000000 1.000000 100 a
JOGO(100, 50) 33.388929 20.892988 6.593804 22.365625 19.161056 1.167957 100 b
fun989(100, 50) 7.192071 4.577225 2.044973 4.432824 4.129563 1.029050 100 a
APOM(100, 50) 40.244128 28.176729 8.805715 27.785985 23.966477 1.209582 100 b
IMO(100, 50) 6.119685 3.898451 2.712222 6.192030 6.033916 1.044422 100 a
source to share
Here's another way to do it, but I would choose @ 989's answer to mine;
cadv.func = function(m,p)
{
cmat <- matrix(data=NA,nrow=m,ncol=m*p)
cmat[is.na(cmat)] <- 0
for (i in 1:m){
for (j in 1:p){
cmat[i,j+p*(i-1)] = 1
}
}
return(cmat)
}
cadv.func(4,2)
# [,1] [,2] [,3] [,4] [,5] [,6] [,7] [,8]
# [1,] 1 1 0 0 0 0 0 0
# [2,] 0 0 1 1 0 0 0 0
# [3,] 0 0 0 0 1 1 0 0
# [4,] 0 0 0 0 0 0 1 1
source to share