Как написать функцию для создания диагональной матрицы из верхнего правого нижнего левого в R?

Question

Я хотел бы написать одну функцию, чьи входные данные являются квадратной матрицей, и она возвращает квадратную матрицу, чьи числа от верхнего правого угла до нижнего левого угла сохраняются, а другие числа равны нулю.

Дляпример предположим, что A - это матрица 4 * 4 в следующем (извините, я не знаю, как набрать выражение матрицы)

[1,2,3,4]
[5,6,7,8]
[9,10,11,12]
[13,14,15,16]

Как я могу написать функцию в R без каких-либо циклов для преобразования матрицыв это?

[0,0,0,4]
[0,0,7,0]
[0,10,0,0]
[13,0,0,0]

Answer 1

Я только что подумал о том, как изменить diag оригинальную функцию *1001* R.

. Чтобы увидеть это, просто наберите diag в консоли.

Здесьвыделенное изменение, которое я сделал в моем diag_reverse:

y <- x[((m - 1L):0L * (dim(x)[1L])) + (1L:m)] # m is min(dim(x))

И вот полная функция (я сохранил весь код, кроме одной строки):

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))
} 

Тогда мы можем вызватьit:

m <- matrix(1:16,nrow=4,ncol=4,byrow = T)

diag_reverse(m)
#[1]  4  7 10 13

Я протестирую его на других матрицах, чтобы увидеть, дает ли он всегда правильный ответ.

Answer 2

Семейство apply - это просто петли с галстуком-бабочкой.

Вот способ сделать это без apply.С некоторой проверкой ввода и должен работать на матрице любого размера.

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)
}

Теперь он может обрабатывать числовые векторы, векторы символов и NA.

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

Редактировать: улучшение

Я понял, что моя функция не будет работать, если есть NA с, поскольку NA*0 равно NA, кроме того, он не будет работать с символами, но не проверяет, что матрица имеет режим как числовой.Поэтому вместо этого я использую ту же настройку, чтобы создать логический вектор

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

Answer 3

Этот ответ имеет несколько иной подход, чем другие ответы.Вместо того, чтобы пытаться обнулить все, кроме диагонали, мы можем просто построить диагональ отдельно:

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

Answer 4

Неприменимое решение, использующее некоторые математические вычисления для генерации индексов кражи xy из @ 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

---

Пример использования матрицы 5 X 5

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

Answer 5

Вот еще один вариант.

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

Answer 6

Это похоже на гимнастическое упражнение ...

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