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
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
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
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.
A one liner without loops
#setup
n <- 5
A <- matrix(1:(n^2), n)
#solution
diag(diag(A[n:1,]))[n:1,]
