Arranging vector x as an anti-diagonal matrix - r

I am trying to input a vector x onto a matrix where values of x are located on the anti-diagonal of the matrix
x = c(1,2,3,4,5)
ID = function(x){
n = length(x)
A = matrix(0, nrow = n, ncol = n)
for ( i in 1:n){
A[i, n-i+1] = x[i]
}
print(A) # Why did my code not work when I did not include this
}
Z = ID(x)
I was wondering why does my code not work when I do not include the print(A) within the function. When I don't include Print(A), my z turns out to be NULL.
Thank you in advance.


If a return statement is not encountered before the end of the function body, then the function returns the value of the last "top level" expression. When you exclude print(A), the last top level expression is the for call, which returns NULL invisibly, as documented in ?`for`.
I would modify your function in three ways:
Replace matrix(0, n, n) with matrix(vector(typeof(x), n * n), n, n) so that the type of the matrix result matches the type of the vector argument.
Replace the for loop with a vectorized subassignment.
Replace print(A) with A so that print(ID(x)) doesn't print the matrix twice.
Hence my version of your function would look something like this:
antidiag <- function(x) {
n <- length(x)
A <- matrix(vector(typeof(x), n * n), n, n)
if (n > 0L) {
A[cbind(n:1, 1:n)] <- x
}
A
}
antidiag(1:4)
## [,1] [,2] [,3] [,4]
## [1,] 0 0 0 4
## [2,] 0 0 3 0
## [3,] 0 2 0 0
## [4,] 1 0 0 0
antidiag(1:4 > 0L)
## [,1] [,2] [,3] [,4]
## [1,] FALSE FALSE FALSE TRUE
## [2,] FALSE FALSE TRUE FALSE
## [3,] FALSE TRUE FALSE FALSE
## [4,] TRUE FALSE FALSE FALSE
antidiag(letters[1:4])
## [,1] [,2] [,3] [,4]
## [1,] "" "" "" "d"
## [2,] "" "" "c" ""
## [3,] "" "b" "" ""
## [4,] "a" "" "" ""


I would do this without a loop -
x = c(1,2,3,4,5)
ID = function(x){
n = length(x)
A = matrix(0, nrow = n, ncol = n)
diag(A[nrow(A):1, ]) <- x
A
}
ID(x)
# [,1] [,2] [,3] [,4] [,5]
#[1,] 0 0 0 0 5
#[2,] 0 0 0 4 0
#[3,] 0 0 3 0 0
#[4,] 0 2 0 0 0
#[5,] 1 0 0 0 0

Related

Changing particular cells of a Matrix iteratively in R

Suppose that we have a (4,4) matrix. My goal is to change iteratively that cells (1,1),(2,1),(3,1),(1,2),(2,2),(1,3)
I wrote the following
for(i in 1:3){
for(j in 1:3){
if(i>j){
A[i,j] = A[i,j] + sample(c(-1,1),prob=c(0.5,0.5))
}
}
However, it doesn't change the correct cells and misses cells that have to be changed.
The matrix A can be of the form
A = matrix(c(1,1,1,1,1,1,1,0,1,1,0,0,1,0,0,0),4,4,byrow=T)
I think that the following chunk of code might be the solution, at least it gives the correct answer for a few runs that I did.
A = matrix(c(1,1,1,0,1,1,0,0,1,0,0,0,0,0,0,0),4,4,byrow=T)
k = 0
for(i in 1:3){
for(j in 1:(3-k)){
A[i,j] = A[i,j] + sample(c(-1,1),prob=c(0.5,0.5), size = 1)
}
k = k + 1
}

I think you simple forgot to set the size= parameter of sample to get one draw of the Rademacher universe.
set.seed(42)
for (i in 1:3) {
for (j in 1:3) {
if (i > j) {
A[i, j] <- A[i, j] + sample(c(-1, 1), size=1, prob=c(0.5, 0.5))
}
}
}
A
# [,1] [,2] [,3] [,4]
# [1,] 1 1 1 1
# [2,] 0 1 1 0
# [3,] 0 2 0 0
# [4,] 1 0 0 0
Another idea is to use a permutation matrix, which you may subset to your needs, and over which you may loop.
id <- RcppAlgos::permuteGeneral(ncol(B) - 1, ncol(B) - 2, repetition=T)
(id <- id[c(1, 4, 7, 2, 5, 3), ])
# [,1] [,2]
# [1,] 1 1
# [2,] 2 1
# [3,] 3 1
# [4,] 1 2
# [5,] 2 2
# [6,] 1 3
set.seed(42)
for (i in 1:nrow(id)) {
A[id[i, 1], id[i, 2]] <- A[id[i, 1], id[i, 2]] +
sample(c(-1, 1), size=1, prob=c(0.5, 0.5))
}
A
# [,1] [,2] [,3] [,4]
# [1,] 0 0 0 1
# [2,] 0 0 1 0
# [3,] 2 1 0 0
# [4,] 1 0 0 0

We can create a row/column index (vectorized approach) by cbinding the vector of index. Use the index to subset the cells of the matrix and assign (<-) after adding the sample output to those elements
n <- 3
j1 <- rep(seq_len(n), rev(seq_len(n)))
i1 <- ave(j1, j1, FUN = seq_along)
ind <- cbind(i1, j1)
ind
# i1 j1
#[1,] 1 1
#[2,] 2 1
#[3,] 3 1
#[4,] 1 2
#[5,] 2 2
#[6,] 1 3
A[ind] <- A[ind] + sample(c(-1,1),prob=c(0.5,0.5),
size = nrow(ind), replace= TRUE)

How to write the function to create a diagonal matrix from upper right to lower left in R?

I would like to write one function whose input is a square matrix, and it returns a square matrix whose numbers from the upper right corner down to lower left corner are preserved and other numbers are zero.
For example
suppose A is a 4*4 matrix in the following.(sorry I do not know how to type the matrix expression)
[1,2,3,4]
[5,6,7,8]
[9,10,11,12]
[13,14,15,16]
How can I write a function in R without any loops to transform the matrix into this?
[0,0,0,4]
[0,0,7,0]
[0,10,0,0]
[13,0,0,0]

This feels like a gymnastics exercise...
xy <- matrix(1:16, ncol = 4, byrow = TRUE)
xy <- apply(xy, MARGIN = 1, rev)
xy[lower.tri(xy)] <- 0
xy[upper.tri(xy)] <- 0
t(apply(xy, MARGIN = 1, rev))
[,1] [,2] [,3] [,4]
[1,] 0 0 0 4
[2,] 0 0 7 0
[3,] 0 10 0 0
[4,] 13 0 0 0

Here is another option.
mat <- matrix(1:16, 4, byrow = TRUE)
idx <- cbind(seq_len(nrow(mat)),
ncol(mat):1)
values <- mat[idx]
mat <- matrix(0, nrow = dim(mat)[1], ncol = dim(mat)[2])
mat[idx] <- values
mat
# [,1] [,2] [,3] [,4]
#[1,] 0 0 0 4
#[2,] 0 0 7 0
#[3,] 0 10 0 0
#[4,] 13 0 0 0

A non-apply solution using some maths to generate the indices stealing xy from #Roman
xy <- matrix(1:16, ncol = 4, byrow = TRUE)
ind <- nrow(xy)
xy[setdiff(1:length(xy), seq(ind, by = ind -1, length.out = ind))] <- 0
xy
# [,1] [,2] [,3] [,4]
#[1,] 0 0 0 4
#[2,] 0 0 7 0
#[3,] 0 10 0 0
#[4,] 13 0 0 0
Trying it on 5 X 5 matrix
xy <- matrix(1:25, 5, byrow = TRUE)
ind <- nrow(xy)
xy[setdiff(1:length(xy), seq(ind, by = ind -1, length.out = ind))] <- 0
xy
# [,1] [,2] [,3] [,4] [,5]
#[1,] 0 0 0 0 5
#[2,] 0 0 0 9 0
#[3,] 0 0 13 0 0
#[4,] 0 17 0 0 0
#[5,] 21 0 0 0 0

This answer takes a slightly different approach than the other answers. Instead of trying to zero out everything except for the diagonal, we can just build the diagonal by itself:
m <- matrix(rep(0,16), nrow = 4, byrow = TRUE)
for (i in 0:15) {
row <- floor(i / 4)
col <- i %% 4
if (i == 3 + (row*3)) {
m[row+1, col+1] <- i+1
}
}
m
[,1] [,2] [,3] [,4]
[1,] 0 0 0 4
[2,] 0 0 7 0
[3,] 0 10 0 0
[4,] 13 0 0 0

I just thought about a way to reverse the original diag function from base R.
You can see it by just typing diag in the console.
Here the highlighted change I made in my diag_reverse:
y <- x[((m - 1L):0L * (dim(x)[1L])) + (1L:m)] # m is min(dim(x))
And here's the complete function (I kept all the code except that one line):
diag_reverse <- function (x = 1, nrow, ncol, names = TRUE)
{
if (is.matrix(x)) {
if (nargs() > 1L && (nargs() > 2L || any(names(match.call()) %in%
c("nrow", "ncol"))))
stop("'nrow' or 'ncol' cannot be specified when 'x' is a matrix")
if ((m <- min(dim(x))) == 0L)
return(vector(typeof(x), 0L))
y <- x[((m - 1L):0L * (dim(x)[1L])) + (1L:m)] # HERE I made the change
if (names) {
nms <- dimnames(x)
if (is.list(nms) && !any(vapply(nms, is.null, NA)) &&
identical((nm <- nms[[1L]][seq_len(m)]), nms[[2L]][seq_len(m)]))
names(y) <- nm
}
return(y)
}
if (is.array(x) && length(dim(x)) != 1L)
stop("'x' is an array, but not one-dimensional.")
if (missing(x))
n <- nrow
else if (length(x) == 1L && nargs() == 1L) {
n <- as.integer(x)
x <- 1
}
else n <- length(x)
if (!missing(nrow))
n <- nrow
if (missing(ncol))
ncol <- n
.Internal(diag(x, n, ncol))
}
Then we can call it:
m <- matrix(1:16,nrow=4,ncol=4,byrow = T)
diag_reverse(m)
#[1] 4 7 10 13
I'll test it on other matrices to see if it gives always the correct answer.

The apply family are really just loops with a bow tie.
Here is a way to do it without apply. With some input checking and should work on any size matrix.
off_diag = function(X)
{
if(!is.matrix(X)) stop('Argument is not a matrix')
n <- nrow(X)
if(ncol(X) != n) stop('Matrix is not square')
if(n<2) return(X)
Y <- X * c(0,rep(rep(c(0,1),c(n-2,1)),n),rep(0,n-1))
return(Y)
}
Now it can handle numeric vectors, character vectors and NAs.
mat <- matrix(1:16, 4, byrow = TRUE)
off_diag(mat)
# [,1] [,2] [,3] [,4]
# [1,] 0 0 0 4
# [2,] 0 0 7 0
# [3,] 0 10 0 0
# [4,] 13 0 0 0
Edit: improvement
I realised my function will fail if there are NAs since NA*0 is NA, additionally it will not work on characters, but doesn't check the matrix has mode as numeric. So instead I use the same setup to make a logical vector
minor_diag = function(X)
{
if(!is.matrix(X)) stop('Argument is not a matrix')
n <- nrow(X)
if(ncol(X) != n) stop('Matrix is not square')
if(n<2) return(X)
index = c(TRUE,rep(rep(c(TRUE,FALSE),c(n-2,1)),n),rep(TRUE,n-1))
X[index]=0
return(X)
}
mat <- matrix(letters[1:16], 4, byrow = TRUE)
minor_diag(mat)
## [,1] [,2] [,3] [,4]
## [1,] "0" "0" "0" "d"
## [2,] "0" "0" "g" "0"
## [3,] "0" "j" "0" "0"
## [4,] "m" "0" "0" "0"
minor_diag(matrix(NA,2,2))
## [,1] [,2]
## [1,] 0 NA
## [2,] NA 0

A one liner without loops
#setup
n <- 5
A <- matrix(1:(n^2), n)
#solution
diag(diag(A[n:1,]))[n:1,]

strange matrix result from if else loop

The code below to fill a matrix with 1 if the vertex is adjacent to another vertex and 0 otherwise. I used this function for comparison but the resulted matrix is strange !!
R
library(igraph)
#prepare random data
random<-matrix(c(1,2,2,3,3,4),ncol=2,byrow=TRUE)
graph<-graph.data.frame(random, directed = FALSE)
v1<-c()
v2<-c()
for (edge in 1:length(E(graph))){
ver1<-ends(graph = graph, es = edge)[1]
v1[edge]<-ver1
ver2<-ends(graph = graph, es = edge)[2]
v2[edge]<-ver2
}
v1
[1] "1" "2" "3"
#Construct the matrix
n1<-matrix(,nrow=length(v1), ncol=length(V(graph)))
for(i in 1:length(v1)){
for(j in 1:length(V(graph))){
are_adjacent(graph, v1[i], V(graph)[j])
if(TRUE){
n1[i,j]<-1
}
else{
n1[i,j]<-0
}
}
}
n1
[,1] [,2] [,3] [,4]
[1,] 1 1 1 1
[2,] 1 1 1 1
[3,] 1 1 1 1
While the resulted matrix should be:
n1
[,1] [,2] [,3] [,4]
[1,] 0 1 0 0
[2,] 1 0 1 0
[3,] 0 1 0 1
since 1 is adjacent only to 2, 2 is adjacent to 1 & 3, 3 is adjacent to 2 & 4, 4 is adjacent only to 3
Thanks in advance

The error is your if statement:
Try this:
n1<-matrix(,nrow=length(v1), ncol=length(V(graph)))
for(i in 1:length(v1)){
for(j in 1:length(V(graph))){
adjacent_test <- are_adjacent(graph, v1[i], V(graph)[j])
if(adjacent_test == TRUE){
n1[i,j]<-1
}
else{
n1[i,j]<-0
}
}
}

Match list to rows of matrix in R

"a" is a list and "b" is a matrix.
a<-list(matrix(c(0,2,0,1,0,2,0,0,1,0,0,0,0,0,2,2),4),
matrix(c(0,1,0,0,0,1,1,0,0,0,0,0),3),
matrix(c(0,0,0,0,2,0,1,0,0,0,0,0,2,0,2,1,0,1,1,0),5))
b<-matrix(c(2,2,1,1,1,2,1,2,1,1,2,1,1,1,1,1,1,2,2,2,1,2,1,1),6)
> a
[[1]]
[,1] [,2] [,3] [,4]
[1,] 0 0 1 0
[2,] 2 2 0 0
[3,] 0 0 0 2
[4,] 1 0 0 2
[[2]]
[,1] [,2] [,3] [,4]
[1,] 0 0 1 0
[2,] 1 0 0 0
[3,] 0 1 0 0
[[3]]
[,1] [,2] [,3] [,4]
[1,] 0 0 0 1
[2,] 0 1 0 0
[3,] 0 0 2 1
[4,] 0 0 0 1
[5,] 2 0 2 0
> b
[,1] [,2] [,3] [,4]
[1,] 2 1 1 2
[2,] 2 2 1 2
[3,] 1 1 1 1
[4,] 1 1 1 2
[5,] 1 2 1 1
[6,] 2 1 2 1
There are 3 objects in list "a". I want to test whether all the non-zero elements in each object in the list "a" match with the corresponding position of the same row in matrix "b". If matched, output the matched row number of b.
For example, the second object is
[[2]]
[,1] [,2] [,3] [,4]
[1,] 0 0 1 0
[2,] 1 0 0 0
[3,] 0 1 0 0
We can see the non-zero number in the 1st row is 1, and it locates in the third place of the row, it can match the 1-5 rows of matrix "b", the non-zero number in the 2nd row is 1, and it locates in the first place of this row, it can match the 3-5 rows of matrix "b", the non-zero number in the 3rd row is 1, and it locates in the second place of this row, it can match the 3-4 rows of matrix "b". so only the 3rd or 4th row of Matrix "b" can match all the rows in this object, so the output result is "3 4".
My attempting code is as follows:
temp<-Map(function(y) t(y), Map(function(a)
apply(a,1,function(x){
apply(b,1, function(y) identical(x[x!=0],y[x!=0]))}),a))
lapply(temp, function(a) which(apply(a,2,prod)==1))
The result is as follows:
[[1]]
integer(0)
[[2]]
[1] 3 4
[[3]]
[1] 6
It is right. but I wonder whether there is more quick code to handle this question?

Having a few columns and trying to take advantage of columns with > 1 unique values or no non-zero values to reduce computations:
ff = function(a, b)
{
i = seq_len(nrow(b)) #starting candidate matches
for(j in seq_len(ncol(a))) {
aj = a[, j]
nzaj = aj[aj != 0L]
if(!length(nzaj)) next #if all(a[, j] == 0) save some operations
if(sum(tabulate(nzaj) > 0L) > 1L) return(integer()) #if no unique values in a column break looping
i = i[b[i, j] == nzaj[[1L]]] #update candidate matches
}
return(i)
}
lapply(a, function(x) ff(x, b))
#[[1]]
#integer(0)
#
#[[2]]
#[1] 3 4
#
#[[3]]
#[1] 6
With data of your actual size:
set.seed(911)
a2 = replicate(300L, matrix(sample(0:3, 20 * 5, TRUE, c(0.97, 0.01, 0.01, 0.01)), 20, 5), simplify = FALSE)
b2 = matrix(sample(1:3, 15 * 5, TRUE), 15, 5)
identical(OP(a2, b2), lapply(a2, function(x) ff(x, b2)))
#[1] TRUE
microbenchmark::microbenchmark(OP(a2, b2), lapply(a2, function(x) ff(x, b2)), times = 50)
#Unit: milliseconds
# expr min lq mean median uq max neval cld
# OP(a2, b2) 686.961815 730.840732 760.029859 753.790094 785.310056 863.04577 50 b
# lapply(a2, function(x) ff(x, b2)) 8.110542 8.450888 9.381802 8.949924 9.872826 15.51568 50 a
OP is:
OP = function (a, b)
{
temp = Map(function(y) t(y), Map(function(a) apply(a, 1,
function(x) {
apply(b, 1, function(y) identical(x[x != 0], y[x !=
0]))
}), a))
lapply(temp, function(x) which(apply(x, 2, prod) == 1))
}

Your explanations of what you want and what your possible matrices look like are really not clear. From what I can deduce, you want to match the row number in b that matches the unique non-zero number in each column of a matrix in a. If so, here's a simpler option:
lapply(a, function(x){ # loop across the matrices in a
x[x == 0] <- NA # replace 0s with NA
which(apply(b, 1, function(y){ # loop across the rows of b, trying to match
all(y == colMeans(x, na.rm = TRUE)) # the rows of b with the colmeans of x
}))
})
# [[1]]
# [1] 2
#
# [[2]]
# [1] 5
#
# [[3]]
# [1] 6

Running Map reduces the dimensions of the matrices

Say I have three lists:
l_zero
[[1]]
[,1] [,2]
[1,] 0 0
[2,] 0 0
[[2]]
[,1] [,2]
[1,] 0 0
[2,] 0 0
l_ind <- list(matrix(c(1,1), ncol = 2), matrix(c(1,1,1,2), ncol = 2))
l_ind
[[1]]
[,1] [,2]
[1,] 1 1
[[2]]
[,1] [,2]
[1,] 1 1
[2,] 1 2
l_val <- list(5, c(4, 7))
l_val
[[1]]
[1] 5
[[2]]
[1] 4 7
I would like to run Map over the three lists with the goal of replacing in l_zero the zeros with the coordinates in l_ind with the values from l_val.
My attempt gives me the following:
Map(function(l_zero, l_ind, l_val) l_zero[l_ind] <- l_val, l_zero = l_zero, l_ind = l_ind, l_val = l_val)
[[1]]
[1] 5
[[2]]
[1] 4 7
As you can see, the original dimensions of the matrices are reduced, but I would like to keep the dimensions of the matrices and just replace the values with the coordinates in l_ind. I tried l_zero[l_ind, drop = FALSE], but that didn't help either.
Can someone help me with this?

Here's a bit simpler method, The [<- replacement function can be used in Map()'s function argument. It takes three arguments, in order.
Map("[<-", l_zero, l_ind, l_val)
# [[1]]
# [,1] [,2]
# [1,] 5 0
# [2,] 0 0
#
# [[2]]
# [,1] [,2]
# [1,] 4 7
# [2,] 0 0

You need to return the modified value from your mapped function (see return(l_zero) below).
l_zero <- replicate(2,matrix(0,2,2),simplify=FALSE)
l_ind <- list(matrix(c(1,1), ncol = 2), matrix(c(1,1,1,2), ncol = 2))
l_val <- list(5, c(4, 7))
ff <- function(l_zero, l_ind, l_val) {
l_zero[l_ind] <- l_val
return(l_zero)
}
Map(ff, l_zero = l_zero, l_ind = l_ind, l_val = l_val)
Results:
## [[1]]
## [,1] [,2]
## [1,] 5 0
## [2,] 0 0
##
## [[2]]
## [,1] [,2]
## [1,] 4 7
## [2,] 0 0

Resources