CODEWITHSUNDEEP
r
Song Calderone Zhang
Song Calderone Zhang

Reputation: 421

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]

Upvotes: 3

Views: 940

Answers (7)

user160623
user160623

Reputation: 316

A one liner without loops

#setup
n <- 5
A <- matrix(1:(n^2), n)

#solution
diag(diag(A[n:1,]))[n:1,]

Upvotes: 1

markus
markus

Reputation: 26373

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

Upvotes: 3

Aaron Hayman
Aaron Hayman

Reputation: 525

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

Upvotes: 1

RLave
RLave

Reputation: 8374

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.

Upvotes: 1

Tim Biegeleisen
Tim Biegeleisen

Reputation: 522815

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

Upvotes: 1

Ronak Shah
Ronak Shah

Reputation: 389355

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

Upvotes: 2

Roman Luštrik
Roman Luštrik

Reputation: 70653

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

Upvotes: 6

Related Questions