Consider the 8 by 6 binary matrix, M:
M <- matrix(c(0,0,1,1,0,0,1,1,
0,1,1,0,0,1,1,0,
0,0,0,0,1,1,1,1,
0,1,0,1,1,0,1,0,
0,0,1,1,1,1,0,0,
0,1,1,0,1,0,0,1),nrow = 8,ncol = 6)
Here is the M
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 0 0 0 0
[2,] 0 1 0 1 0 1
[3,] 1 1 0 0 1 1
[4,] 1 0 0 1 1 0
[5,] 0 0 1 1 1 1
[6,] 0 1 1 0 1 0
[7,] 1 1 1 1 0 0
[8,] 1 0 1 0 0 1
The following matrix contains the column index of the 1's in matrix M
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 3 2 5 2 3 2
[2,] 4 3 6 4 4 3
[3,] 7 6 7 5 5 5
[4,] 8 7 8 7 6 8
Let's denote that
ind <- matrix(c(3,4,7,8,
2,3,6,7,
5,6,7,8,
2,4,5,7,
3,4,5,6,
2,3,5,8),nrow = 4, ncol=6)
I'm trying to change a single position of 1 into 0only in SOME columns of M.
For an example, consider the case for changing two ones in every two columns. One possibility is given changing two positions in first two columns. Let N be the resulting matrices. This will produce the following matrix N
N <- matrix(c(0,0,0,1,0,0,1,1,
0,1,1,0,0,0,1,0,
0,0,0,0,1,1,1,1,
0,1,0,1,1,0,1,0,
0,0,1,1,1,1,0,0,
0,1,1,0,1,0,0,1),nrow = 8,ncol = 6)
Here is that N
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 0 0 0 0
[2,] 0 1 0 1 0 1
[3,] 0 1 0 0 1 1
[4,] 1 0 0 1 1 0
[5,] 0 0 1 1 1 1
[6,] 0 0 1 0 1 0
[7,] 1 1 1 1 0 0
[8,] 1 0 1 0 0 1
For EACH of the resulting matrices of N, I do the following calculations.
X <- cbind(c(rep(1,nrow(N))),N)
ans <- sum(diag(solve(t(X)%*%X)[-1,-1]))
Then, I want to obtain the matrix N, which produce the smallest value of ans. This 8 by 6 matrix is just one example. How do I do this?
I asked a question similar to this one before which changes positions in every column. Here is the link to that.
Related
I have identity matrix which can be generated via diag(5)
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 0 0
[2,] 0 1 0 0 0
[3,] 0 0 1 0 0
[4,] 0 0 0 1 0
[5,] 0 0 0 0 1
I want to convert it to the matrix wherein series starts after 1. For example 1st column, values 1 through 5. Second column - values 1 through 4.
Desired Output
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 0 0
[2,] 2 1 0 0 0
[3,] 3 2 1 0 0
[4,] 4 3 2 1 0
[5,] 5 4 3 2 1
Try the code below (given m <- diag(5))
> (row(m) - col(m) + 1)*lower.tri(m,diag = TRUE)
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 0 0
[2,] 2 1 0 0 0
[3,] 3 2 1 0 0
[4,] 4 3 2 1 0
[5,] 5 4 3 2 1
Another option is using apply + cumsum
> apply(lower.tri(m, diag = TRUE), 2, cumsum)
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 0 0
[2,] 2 1 0 0 0
[3,] 3 2 1 0 0
[4,] 4 3 2 1 0
[5,] 5 4 3 2 1
1) If d <- diag(5) is the identity matrix then:
pmax(row(d) - col(d) + 1, 0)
giving:
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 0 0
[2,] 2 1 0 0 0
[3,] 3 2 1 0 0
[4,] 4 3 2 1 0
[5,] 5 4 3 2 1
2) This alternative is slightly longer (though still a one-liner) but also works if the columns of d are rearranged and/or some columns are missing. For example,
dd <- d[, 4:1] # test data
pmax(outer(1:nrow(dd) + 1, max.col(t(dd)), `-`), 0)
giving the same result for d and this for dd:
[,1] [,2] [,3] [,4]
[1,] 0 0 0 1
[2,] 0 0 1 2
[3,] 0 1 2 3
[4,] 1 2 3 4
[5,] 2 3 4 5
A solution based on nested cumsum:
n <- 5
m <- diag(n)
apply(m, 2, function(x) cumsum(cumsum(x)))
#> [,1] [,2] [,3] [,4] [,5]
#> [1,] 1 0 0 0 0
#> [2,] 2 1 0 0 0
#> [3,] 3 2 1 0 0
#> [4,] 4 3 2 1 0
#> [5,] 5 4 3 2 1
One option could be:
x <- 1:5
embed(c(rep(0, length(x) - 1), x), length(x))
[,1] [,2] [,3] [,4] [,5]
[1,] 1 0 0 0 0
[2,] 2 1 0 0 0
[3,] 3 2 1 0 0
[4,] 4 3 2 1 0
[5,] 5 4 3 2 1
So I'm trying to create a 2000 * 2000 matrix that has 50*50 blocks of zeroes along the diagonal, and 1's everywhere else.
Here is a miniature example of what I mean. a is a 6x6 matrix with 1's and each block is a 2*2 matrix with zeroes along the diagonal
a <- matrix(rep(1, times = 36), nrow = 6, byrow = TRUE)
a[1:2,1:2] <- 0
a[3:4,3:4] <- 0
a[5:6,5:6] <- 0
giving
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 1 1 1 1
[2,] 0 0 1 1 1 1
[3,] 1 1 0 0 1 1
[4,] 1 1 0 0 1 1
[5,] 1 1 1 1 0 0
[6,] 1 1 1 1 0 0
Of course my choice of code is bad for creating such a big matrix, as I would have to repeat the bottom part 50 times.
What would be a much better code to create this type of matrix?
rawr is correct,
a <- +!kronecker(diag(1, 3), matrix(1, 2, 2))
gives
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 1 1 1 1
[2,] 0 0 1 1 1 1
[3,] 1 1 0 0 1 1
[4,] 1 1 0 0 1 1
[5,] 1 1 1 1 0 0
[6,] 1 1 1 1 0 0
and +!kronecker(diag(1, 40), matrix(1, 50, 50)) solves my original question with the 2000*2000 matrix
Consider the 8 by 6 binary matrix, M:
M <- matrix(c(0,0,1,1,0,0,1,1,
0,1,1,0,0,1,1,0,
0,0,0,0,1,1,1,1,
0,1,0,1,1,0,1,0,
0,0,1,1,1,1,0,0,
0,1,1,0,1,0,0,1),nrow = 8,ncol = 6)
Here is the M
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 0 0 0 0
[2,] 0 1 0 1 0 1
[3,] 1 1 0 0 1 1
[4,] 1 0 0 1 1 0
[5,] 0 0 1 1 1 1
[6,] 0 1 1 0 1 0
[7,] 1 1 1 1 0 0
[8,] 1 0 1 0 0 1
The following matrix contains the column index of the 1's in matrix M
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 3 2 5 2 3 2
[2,] 4 3 6 4 4 3
[3,] 7 6 7 5 5 5
[4,] 8 7 8 7 6 8
Let's denote that
ind <- matrix(c(3,4,7,8,
2,3,6,7,
5,6,7,8,
2,4,5,7,
3,4,5,6,
2,3,5,8),nrow = 4, ncol=6)
I'm trying to change a single position of 1 into 0in each column of M.
For an example, one possibility of index of1s in each column would be (4,2,5,4,3,2), i.e. 4th position of Column1, 2nd position of Column2, 5thposition of Column3 and so on. Let N be the resulting matrices. This will produce the following matrix N
N <- matrix(c(0,0,1,0,0,0,1,1,
0,0,1,0,0,1,1,0,
0,0,0,0,0,1,1,1,
0,1,0,0,1,0,1,0,
0,0,0,1,1,1,0,0,
0,0,1,0,1,0,0,1),nrow = 8,ncol = 6)
Here is that N
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 0 0 0 0
[2,] 0 0 0 1 0 0
[3,] 1 1 0 0 0 1
[4,] 0 0 0 0 1 0
[5,] 0 0 0 1 1 1
[6,] 0 1 1 0 1 0
[7,] 1 1 1 1 0 0
[8,] 1 0 1 0 0 1
For EACH of the resulting matrices of N, I do the following calculations.
X <- cbind(c(rep(1,nrow(N))),N)
ans <- sum(diag(solve(t(X)%*%X)[-1,-1]))
Then, I want to obtain the matrix N, which produce the smallest value of ans. How do I do this efficiently?
Let me know if this works.
We first build a conversion function that I'll need, and we build also the reverse function as you may need it at some point:
ind_to_M <- function(ind){
M <- matrix(rep(0,6*8),ncol=6)
for(i in 1:ncol(ind)){M[ind[,i],i] <- 1}
return(M)
}
M_to_ind <- function(M){apply(M==1,2,which)}
Then we will build a matrix of possible ways to ditch a value
all_possible_ways_to_ditch_value <- 1:4
for (i in 2:ncol(M)){
all_possible_ways_to_ditch_value <- merge(all_possible_ways_to_ditch_value,1:4,by=NULL)
}
# there's probably a more elegant way to do that
head(all_possible_ways_to_ditch_value)
# x y.x y.y y.x y.y y
# 1 1 1 1 1 1 1 # will be used to ditch the 1st value of ind for every column
# 2 2 1 1 1 1 1
# 3 3 1 1 1 1 1
# 4 4 1 1 1 1 1
# 5 1 2 1 1 1 1
# 6 2 2 1 1 1 1
Then we iterate through those, each time storing ans and N (as data is quite small overall).
ans_list <- list()
N_list <- list()
for(j in 1:nrow(all_possible_ways_to_ditch_value)){
#print(j)
ind_N <- matrix(rep(0,6*3),ncol=6) # initiate ind_N as an empty matrix
for(i in 1:ncol(M)){
ind_N[,i] <- ind[-all_possible_ways_to_ditch_value[j,i],i] # fill with ind except for the value we ditch
}
N <- ind_to_M(ind_N)
X <- cbind(c(rep(1,nrow(N))),N)
ans_list[[j]] <- try(sum(diag(solve(t(X)%*%X)[-1,-1])),silent=TRUE) # some systems are not well defined, we'll just ignore the errors
N_list[[j]] <- N
}
We finally retrieve the minimal ans and the relevant N
ans <- ans_list[[which.min(ans_list)]]
# [1] -3.60288e+15
N <- N_list[[which.min(ans_list)]]
# [,1] [,2] [,3] [,4] [,5] [,6]
# [1,] 0 0 0 0 0 0
# [2,] 0 1 0 1 0 1
# [3,] 1 1 0 0 1 1
# [4,] 1 0 0 1 1 0
# [5,] 0 0 1 1 1 1
# [6,] 0 1 1 0 0 0
# [7,] 1 0 1 0 0 0
# [8,] 0 0 0 0 0 0
EDIT:
To get minimal positive ans
ans_list[which(!sapply(ans_list,is.numeric))] <- Inf
ans <- ans_list[[which.min(abs(unlist(ans_list)))]]
# [1] 3.3
N <- N_list[[which.min(abs(unlist(ans_list)))]]
# [,1] [,2] [,3] [,4] [,5] [,6]
# [1,] 0 0 0 0 0 0
# [2,] 0 1 0 1 0 0
# [3,] 1 1 0 0 0 1
# [4,] 1 0 0 0 1 0
# [5,] 0 0 0 1 1 1
# [6,] 0 1 1 0 1 0
# [7,] 1 0 1 1 0 0
# [8,] 0 0 1 0 0 1
EDIT 2 : to generalize the number of rows of ind to ditch
It seems to give the same result for ans for n_ditch = 1, and results make sense for n_ditch = 2
n_ditch <- 2
ditch_possibilities <- combn(1:4,n_ditch) # these are all the possible sets of indices to ditch for one given columns
all_possible_ways_to_ditch_value <- 1:ncol(ditch_possibilities) # this will be all the possible sets of indices of ditch_possibilities to test
for (i in 2:ncol(M)){
all_possible_ways_to_ditch_value <- merge(all_possible_ways_to_ditch_value,1:ncol(ditch_possibilities),by=NULL)
}
ans_list <- list()
N_list <- list()
for(j in 1:nrow(all_possible_ways_to_ditch_value)){
#print(j)
ind_N <- matrix(rep(0,6*(4-n_ditch)),ncol=6) # initiate ind_N as an empty matrix
for(i in 1:ncol(M)){
ind_N[,i] <- ind[-ditch_possibilities[,all_possible_ways_to_ditch_value[j,i]],i] # fill with ind except for the value we ditch
}
N <- ind_to_M(ind_N)
X <- cbind(c(rep(1,nrow(N))),N)
ans_list[[j]] <- try(sum(diag(solve(t(X)%*%X)[-1,-1])),silent=TRUE) # some systems are not well defined, we'll just ignore the errors
N_list[[j]] <- N
}
I want to do a matrix multiplication with a twist.
I have this matrix:
A <- matrix(c(1,-1,-1,0,-1,0,1,0,0,1,0,0,0,1,-1,1,-1,0,0,-1,1,0,1,0,1,-1,-1,1,-1,1), nrow = 6, ncol = 5)
A
[,1] [,2] [,3] [,4] [,5]
[1,] 1 1 0 0 1
[2,] -1 0 1 -1 -1
[3,] -1 0 -1 1 -1
[4,] 0 1 1 0 1
[5,] -1 0 -1 1 -1
[6,] 0 0 0 0 1
And I want to get two different matrices. The first matrix is this:
C
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 0 0 2 0 1
[2,] 0 0 2 1 2 0
[3,] 0 2 0 0 4 0
[4,] 2 1 0 0 0 1
[5,] 0 2 4 0 0 0
[6,] 1 0 0 1 0 0
This "convergence matrix" is something like the multiplication of A for its transpose (in R is something like this A%*%t(A)), but with a little twist, during the sum to obtain each cell I only want de sum of the positives values. For example, for the cell C23 the regular sum would be:
(-1)(-1) + (0)(0) + (1)(-1) + (-1)(1) + (-1)(-1) = 0
, but I only want the sum of the positive products, in this example the first [(-1)(-1)] and the last [(-1)(-1)] to obtain 2.
The second matrix is this:
D
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 2 2 0 2 0
[2,] 2 0 2 1 2 1
[3,] 2 2 0 2 0 1
[4,] 0 1 2 0 2 0
[5,] 2 2 0 2 0 1
[6,] 0 1 1 0 1 0
This "divergence matrix" is similar to the previous one, with the difference that I only want to sum de absolute values of the negative values. For example, for the cell D23 the regular sum would be:
(-1)(-1) + (0)(0) + (1)(-1) + (-1)(1) + (-1)(-1) = 0
, but I only want the sum of the absolute values of negative products, in this example the third abs [(1)(-1)] and the fourth abs[(-1)(-1)] to obtain 2.
I've been trying with apply, sweep and loops but I can't get it.
Thanks for your responses.
Another take:
D <- A
D[D<0] = -1i*D[D<0]
D <- Im(tcrossprod(D))
C <- tcrossprod(A) + D
A is defined in the question.
Output:
> D
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 2 2 0 2 0
[2,] 2 0 2 1 2 1
[3,] 2 2 0 2 0 1
[4,] 0 1 2 0 2 0
[5,] 2 2 0 2 0 1
[6,] 0 1 1 0 1 0
> C
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 3 0 0 2 0 1
[2,] 0 4 2 1 2 0
[3,] 0 2 4 0 4 0
[4,] 2 1 0 3 0 1
[5,] 0 2 4 0 4 0
[6,] 1 0 0 1 0 1
This is a try in base R. So basically you follow the matrix cross-product approach but you try to manage the sum step manually:
f <- function(A, convergence=TRUE){
sapply(seq_len(nrow(A)), function(i) {
r <- t(matrix(A[i,],ncol(A),nrow(A)))*A
if(convergence)
r[r<0] <- 0
else
r[r>0] <- 0
rowSums(abs(r))
})
}
> f(A, convergence = TRUE)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 3 0 0 2 0 1
[2,] 0 4 2 1 2 0
[3,] 0 2 4 0 4 0
[4,] 2 1 0 3 0 1
[5,] 0 2 4 0 4 0
[6,] 1 0 0 1 0 1
> f(A, convergence = FALSE)
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 0 2 2 0 2 0
[2,] 2 0 2 1 2 1
[3,] 2 2 0 2 0 1
[4,] 0 1 2 0 2 0
[5,] 2 2 0 2 0 1
[6,] 0 1 1 0 1 0
It will be significantly less efficient, but you could break the matrix into a list of row vectors, which are easier to calculate with. Using purrr, which is handy for lists,
library(purrr)
A <- matrix(c(1,-1,-1,0,-1,0,1,0,0,1,0,0,0,1,-1,1,-1,0,0,-1,1,0,1,0,1,-1,-1,1,-1,1),
nrow = 6, ncol = 5)
C <- seq(nrow(A)) %>% # generate a sequence of row indices
map(~A[.x, ]) %>% # subset matrix into a list of rows
cross2(., .) %>% # do a Cartesian join to get pairs of rows
# calculate products, then subset before summing. Simplify to vector
map_dbl(~{ij <- .x[[1]] * .x[[2]]; sum(ij[ij >= 0])}) %>%
matrix(nrow(A)) # reassemble to matrix
C
#> [,1] [,2] [,3] [,4] [,5] [,6]
#> [1,] 3 0 0 2 0 1
#> [2,] 0 4 2 1 2 0
#> [3,] 0 2 4 0 4 0
#> [4,] 2 1 0 3 0 1
#> [5,] 0 2 4 0 4 0
#> [6,] 1 0 0 1 0 1
# same except subsetting and `-` to make negatives positive
D <- seq(nrow(A)) %>%
map(~A[.x, ]) %>%
cross2(., .) %>%
map_dbl(~{ij <- .x[[1]] * .x[[2]]; sum(-ij[ij <= 0])}) %>%
matrix(nrow(A))
D
#> [,1] [,2] [,3] [,4] [,5] [,6]
#> [1,] 0 2 2 0 2 0
#> [2,] 2 0 2 1 2 1
#> [3,] 2 2 0 2 0 1
#> [4,] 0 1 2 0 2 0
#> [5,] 2 2 0 2 0 1
#> [6,] 0 1 1 0 1 0
I am trying to create a matrix from a given vector in R, but I don't know how to achieve it in simple ways. I am giving an example below. The matrix was made using the "cbind" function.
Given x as
[1,] 1
[2,] 3
[3,] 4
how can I create the matrix below with simple method?
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 1 0 0 0 0 0
[2,] 3 1 0 0 0 0
[3,] 4 3 1 0 0 0
[4,] 0 4 3 1 0 0
[5,] 0 0 4 3 1 0
[6,] 0 0 0 4 3 1
[7,] 0 0 0 0 4 3
[8,] 0 0 0 0 0 4
Thank you for your help!
Using append and sapply
sapply(0:5, append, x = rep(0,5), values = c(1,3,4))
# [,1] [,2] [,3] [,4] [,5] [,6]
# [1,] 1 0 0 0 0 0
# [2,] 3 1 0 0 0 0
# [3,] 4 3 1 0 0 0
# [4,] 0 4 3 1 0 0
# [5,] 0 0 4 3 1 0
# [6,] 0 0 0 4 3 1
# [7,] 0 0 0 0 4 3
# [8,] 0 0 0 0 0 4
matrix(c(1,3,4,rep(0,6)),ncol=6,nrow=8)
You'll get a warning, but the correct matrix. If you don't like the warning just use suppressWarnings:
suppressWarnings(matrix(c(1,3,4,rep(0,6)),ncol=6,nrow=8))
Of course, be careful with that function if you are trying to abstract this to more general cases.
This method is very intuitive:
x <- c(1,3,4)
n <- 6
m <- matrix(0,ncol=n,nrow=n+length(x)-1)
diag(m) <- 1
diag(m[-1,]) <- 3
diag(m[-c(1, 2),]) <- 4
Assigning along diagonals can be automated easily, for example with a 'for' loop
for(i in seq_along(x)) diag(m[1:n + i - 1,]) <- x[i]
Both approaches yield:
R> m
[,1] [,2] [,3] [,4] [,5] [,6]
[1,] 1 0 0 0 0 0
[2,] 3 1 0 0 0 0
[3,] 4 3 1 0 0 0
[4,] 0 4 3 1 0 0
[5,] 0 0 4 3 1 0
[6,] 0 0 0 4 3 1
[7,] 0 0 0 0 4 3
[8,] 0 0 0 0 0 4
This works. (edit: no votes, maybe too telegraphic?) The idea is to create an all-zero matrix with the appropriate dimensions, and then use row/column arithmetic (using the row() and col() functions) to fill in the desired values in the elements where row-column is between 0 and 2 (i.e. the diagonal and the first two lower off-diagonals). This does rely on the column-major structure of matrices in R ...
x <- c(1,3,4)
n <- 6
m <- matrix(0,ncol=n,nrow=n+length(x)-1)
betw <- function(x,a,b) x>=a & x<= b
m[betw(row(m)-col(m),0,2)] <- x