R chol and positive semi-definite matrix - r

I have the following matrix:
j <- matrix(c(1,1,.5,1,1,.5,.5,.5,1), nrow=3, ncol=3)
Which is positive semi-definite, because all of the eigenvalues are >= 0.
Source: https://math.stackexchange.com/questions/40849/how-to-check-if-a-symmetric-4-times4-matrix-is-positive-semi-definite
> eigen(j, symmetric = TRUE)
$values
[1] 2.3660254 0.6339746 0.0000000
$vectors
[,1] [,2] [,3]
[1,] -0.6279630 -0.3250576 7.071068e-01
[2,] -0.6279630 -0.3250576 -7.071068e-01
[3,] -0.4597008 0.8880738 -1.942890e-15
However, the cholesky decomposition fails...
> chol(j)
Error in chol.default(j) :
the leading minor of order 2 is not positive definite
I also adapted some code from the internet...
cholesky_matrix <- function(A){
# http://rosettacode.org/wiki/Cholesky_decomposition#C
L <- matrix(0,nrow=nrow(A),ncol=ncol(A))
colnames(L) <- colnames(A)
rownames(L) <- rownames(A)
m <- ncol(L)
for(i in 1:m){
for(j in 1:i){
s <- 0
if(j > 1){
for(k in 1:(j-1)){
s <- s + L[i,k]*L[j,k]
}
}
if(i == j){
L[i,j] <- sqrt(A[i,i] - s)
} else {
L[i,j] <- (1 / L[j,j])*(A[i,j] - s)
}
}
}
return(L)
}
Which also "fails" with NaNs.
> cholesky_matrix(j)
[,1] [,2] [,3]
[1,] 1.0 0 0
[2,] 1.0 0 0
[3,] 0.5 NaN NaN
Does anyone have any idea what is going on? Why is my decomposition failing?

The eigenvalues of your matrix are
> eigen(j)
$values
[1] 2.366025e+00 6.339746e-01 4.440892e-16
the last of which is effectively zero, within the limits of numerical precision. Per ?chol:
Compute the Choleski factorization of a real symmetric positive-definite square matrix.
(emphasis mine)
That said, you can still get the decomposition by setting pivot=TRUE, which is able to handle semi-definiteness:
> chol(j, pivot=TRUE)
[,1] [,2] [,3]
[1,] 1 0.5000000 1
[2,] 0 0.8660254 0
[3,] 0 0.0000000 0
attr(,"pivot")
[1] 1 3 2
attr(,"rank")
[1] 2
Warning message:
In chol.default(j, pivot = TRUE) :
the matrix is either rank-deficient or indefinite

Related

Crout LU decomposition in R

Just wondering if anybody would share an implementation of the Crout algorithm for a LU decomposition (A = L * U) in R. There's a lu function in pracma library but uses Doolite instead.
> A
[,1] [,2] [,3]
[1,] -10 30 50
[2,] -6 16 22
[3,] -2 1 -5
> lu(A)
$L
[,1] [,2] [,3]
[1,] 1.0 0.0 0
[2,] 0.6 1.0 0
[3,] 0.2 2.5 1
$U
[,1] [,2] [,3]
[1,] -10 30 50
[2,] 0 -2 -8
[3,] 0 0 5
Whereas for the Crout algorithm you'd get something like this instead:
$L
[,1] [,2] [,3]
[1,] -10 0 0
[2,] -6 -2 0
[3,] -2 -5 5
$U
[,1] [,2] [,3]
[1,] 1 -3 -5
[2,] 0 1 4
[3,] 0 0 1
I've been googling for something like that for a while but didn't found any working implementation in R.
Thanks!
It is not difficult to convert some MATLAB code to an R implementation:
LUcrout <- function(A) {
n <- nrow(A)
L <- matrix(0, n, n); U <- matrix(0, n, n)
for (i in 1:n) {
L[i, 1] <- A[i, 1]
U[i, i] <- 1
}
for (j in 2:n) {
U[1, j] <- A[1, j] / L[1, 1]
}
for (i in 2:n) {
for (j in 2:i) {
L[i, j] <- A[i, j] - L[i, 1:(j-1)] %*% U[1:(j-1), j]
}
if (i < n) {
for (j in ((i+1):n)) {
U[i, j] = (A[i, j] - L[i, 1:(i-1)] %*% U[1:(i-1), j]) / L[i, i]
}
}
}
return(list(L = L, U = U))
}
Applied to your matrix A example it returns
A = matrix(c(-10, 30, 50,
-6, 16, 22,
-2, 1, -5), 3, 3, byrow = TRUE)
> LUcrout(A)
$L
[,1] [,2] [,3]
[1,] -10 0 0
[2,] -6 -2 0
[3,] -2 -5 5
$U
[,1] [,2] [,3]
[1,] 1 -3 -5
[2,] 0 1 4
[3,] 0 0 1
which is not the same as what you suggested, but is identical to what MATLAB returns (see the 'Crout-matrix-decomposition' page on Wikipedia).
LU decompositions are not unique. Which advantages does the Crout algorithm have in your opinion?
Take the Doolittle decomposition of A transpose, swap L and U and take their transposes.

Write a trackable R function that mimics LAPACK's dgetrf for LU factorization

There is no LU factorization function in R core. Although such factorization is a step of solve, it is not made explicitly available as a stand-alone function. Can we write an R function for this? It needs mimic LAPACK routine dgetrf. Matrix package has an lu function which is good, but it would be better if we could write a trackable R function, that can
factorize the matrix till a certain column / row and return the intermediate result;
continue the factorization from an intermediate result to another column / row or to the end.
This function would be useful for both educational and debugging purpose. The benefit for education is evident as we can illustrate the factorization / Gaussian elimination column by column. For debugging use, here are two examples.
In Inconsistent results between LU decomposition in R and Python, it is asked why LU factorization in R and Python gives different result. We can clearly see that both software return identical 1st pivot and 2nd pivot, but not the 3rd. So there must be something interesting when the factorization proceeds to the 3rd row / column. It would be good if we could retrieve that temporary result for an investigation.
In Can I stably invert a Vandermonde matrix with many small values in R? LU factorization is unstable for this type of matrix. In my answer, a 3 x 3 matrix is given for an example. I would expect solve to produce an error complaining U[3, 3] = 0, but running solve for a few times I find that solve is sometimes successful. So for a numerical investigation, I would like to know what happens when the factorization proceeds to the 2nd column / row.
Since the function is to be written in pure R code, it is expected to be slow for a moderate to big matrix. But performance is not an issue, as for education and debugging we only use a small matrix.
A little introduction to dgetrf
LAPACK's dgetrf computes LU factorization with row pivoting: A = PLU. On exit of the factorization,
L is a unit lower triangular matrix, stored in the lower triangular part of A;
U is an upper triangular matrix, stored in the upper triangular part of A;
P is a row permutation matrix stored as a separate permutation index vector.
Unless a pivot is exactly zero (not up to some tolerance), factorization should proceed.
What I start with
It is not challenging to write a LU factorization with neither row pivoting nor "pause / continue" option:
LU <- function (A) {
## check dimension
n <- dim(A)
if (n[1] != n[2]) stop("'A' must be a square matrix")
n <- n[1]
## Gaussian elimination
for (j in 1:(n - 1)) {
ind <- (j + 1):n
## check if the pivot is EXACTLY 0
piv <- A[j, j]
if (piv == 0) stop(sprintf("system is exactly singular: U[%d, %d] = 0", j, j))
l <- A[ind, j] / piv
## update `L` factor
A[ind, j] <- l
## update `U` factor by Gaussian elimination
A[ind, ind] <- A[ind, ind] - tcrossprod(l, A[j, ind])
}
A
}
This is shown to give correct result when pivoting is not required:
A <- structure(c(0.923065107548609, 0.922819485189393, 0.277002309216186,
0.532856695353985, 0.481061384081841, 0.0952619954477996,
0.261916425777599, 0.433514681644738, 0.677919807843864,
0.771985625848174, 0.705952850636095, 0.873727774480358,
0.28782021952793, 0.863347264472395, 0.627262107795104,
0.187472499441355), .Dim = c(4L, 4L))
oo <- LU(A)
oo
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.9997339 -0.3856714 0.09424621 0.5756036
#[3,] 0.3000897 -0.3048058 0.53124291 0.7163376
#[4,] 0.5772688 -0.4040044 0.97970570 -0.4479307
L <- diag(4)
low <- lower.tri(L)
L[low] <- oo[low]
L
# [,1] [,2] [,3] [,4]
#[1,] 1.0000000 0.0000000 0.0000000 0
#[2,] 0.9997339 1.0000000 0.0000000 0
#[3,] 0.3000897 -0.3048058 1.0000000 0
#[4,] 0.5772688 -0.4040044 0.9797057 1
U <- oo
U[low] <- 0
U
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.0000000 -0.3856714 0.09424621 0.5756036
#[3,] 0.0000000 0.0000000 0.53124291 0.7163376
#[4,] 0.0000000 0.0000000 0.00000000 -0.4479307
Comparison with lu from Matrix package:
library(Matrix)
rr <- expand(lu(A))
rr
#$L
#4 x 4 Matrix of class "dtrMatrix" (unitriangular)
# [,1] [,2] [,3] [,4]
#[1,] 1.0000000 . . .
#[2,] 0.9997339 1.0000000 . .
#[3,] 0.3000897 -0.3048058 1.0000000 .
#[4,] 0.5772688 -0.4040044 0.9797057 1.0000000
#
#$U
#4 x 4 Matrix of class "dtrMatrix"
# [,1] [,2] [,3] [,4]
#[1,] 0.92306511 0.48106138 0.67791981 0.28782022
#[2,] . -0.38567138 0.09424621 0.57560363
#[3,] . . 0.53124291 0.71633755
#[4,] . . . -0.44793070
#
#$P
#4 x 4 sparse Matrix of class "pMatrix"
#
#[1,] | . . .
#[2,] . | . .
#[3,] . . | .
#[4,] . . . |
Now consider a permuted A:
B <- A[c(4, 3, 1, 2), ]
LU(B)
# [,1] [,2] [,3] [,4]
#[1,] 0.5328567 0.43351468 0.8737278 0.1874725
#[2,] 0.5198439 0.03655646 0.2517508 0.5298057
#[3,] 1.7322952 -7.38348421 1.0231633 3.8748743
#[4,] 1.7318343 -17.93154011 3.6876940 -4.2504433
The result is different from LU(A). However, since Matrix::lu performs row pivoting, the result of lu(B) only differs from lu(A) in the permutation matrix:
expand(lu(B))$P
#4 x 4 sparse Matrix of class "pMatrix"
#
#[1,] . . . |
#[2,] . . | .
#[3,] | . . .
#[4,] . | . .
Let's add those features one by one.
with row pivoting
This is not too difficult.
Suppose A is n x n. Initialize a permutation index vector pivot <- 1:n. At the j-th column we scan A[j:n, j] for the maximum absolute value. Suppose it is A[m, j]. If m > j we do a row exchange A[m, ] <-> A[j, ]. Meanwhile we do a permutation pivot[j] <-> pivot[m]. After pivoting, the elimination is as same as that for a factorization without pivoting, so we could reuse the code of function LU.
LUP <- function (A) {
## check dimension
n <- dim(A)
if (n[1] != n[2]) stop("'A' must be a square matrix")
n <- n[1]
## LU factorization from the beginning to the end
from <- 1
to <- (n - 1)
pivot <- 1:n
## Gaussian elimination
for (j in from:to) {
## select pivot
m <- which.max(abs(A[j:n, j]))
## A[j - 1 + m, j] is the pivot
if (m > 1L) {
## row exchange
tmp <- A[j, ]; A[j, ] <- A[j - 1 + m, ]; A[j - 1 + m, ] <- tmp
tmp <- pivot[j]; pivot[j] <- pivot[j - 1 + m]; pivot[j - 1 + m] <- tmp
}
ind <- (j + 1):n
## check if the pivot is EXACTLY 0
piv <- A[j, j]
if (piv == 0) {
stop(sprintf("system is exactly singular: U[%d, %d] = 0", j, j))
}
l <- A[ind, j] / piv
## update `L` factor
A[ind, j] <- l
## update `U` factor by Gaussian elimination
A[ind, ind] <- A[ind, ind] - tcrossprod(l, A[j, ind])
}
## add `pivot` as an attribute and return `A`
structure(A, pivot = pivot)
}
Trying matrix B in the question, LUP(B) is as same as LU(A) with an additional permutation index vector.
oo <- LUP(B)
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.9997339 -0.3856714 0.09424621 0.5756036
#[3,] 0.3000897 -0.3048058 0.53124291 0.7163376
#[4,] 0.5772688 -0.4040044 0.97970570 -0.4479307
#attr(,"pivot")
#[1] 3 4 2 1
Here is a utility function to extract L, U, P:
exLUP <- function (LUPftr) {
L <- diag(1, nrow(LUPftr), ncol(LUPftr))
low <- lower.tri(L)
L[low] <- LUPftr[low]
U <- LUPftr[1:nrow(LUPftr), ] ## use "[" to drop attributes
U[low] <- 0
list(L = L, U = U, P = attr(LUPftr, "pivot"))
}
rr <- exLUP(oo)
#$L
# [,1] [,2] [,3] [,4]
#[1,] 1.0000000 0.0000000 0.0000000 0
#[2,] 0.9997339 1.0000000 0.0000000 0
#[3,] 0.3000897 -0.3048058 1.0000000 0
#[4,] 0.5772688 -0.4040044 0.9797057 1
#
#$U
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.0000000 -0.3856714 0.09424621 0.5756036
#[3,] 0.0000000 0.0000000 0.53124291 0.7163376
#[4,] 0.0000000 0.0000000 0.00000000 -0.4479307
#
#$P
#[1] 3 4 2 1
Note that the permutation index returned is really for PA = LU (probably the most used in textbooks):
all.equal( B[rr$P, ], with(rr, L %*% U) )
#[1] TRUE
To get the permutation index as returned by LAPACK, i.e., the one in A = PLU, do order(rr$P).
all.equal( B, with(rr, (L %*% U)[order(P), ]) )
#[1] TRUE
"pause / continue" option
Adding "pause / continue" feature is a bit tricky, as we need some way to record where an incomplete factorization stops so that we can pick it up from there later.
Suppose we are to enhance function LUP to a new one LUP2. Consider adding an argument to. The factorization will stop when it has done with A[to, to] and is going to work with A[to + 1, to + 1]. We can store this to, as well as the temporary pivot vector, as attributes to A and return. Later when we pass this temporary result back to LUP2, it need first check whether these attributes exist. If so it knows where it should start; otherwise it just starts right from the beginning.
LUP2 <- function (A, to = NULL) {
## check dimension
n <- dim(A)
if (n[1] != n[2]) stop("'A' must be a square matrix")
n <- n[1]
## ensure that "to" has a valid value
## if it is not provided, set it to (n - 1) so that we complete factorization of `A`
## if provided, it can not be larger than (n - 1); otherwise it is reset to (n - 1)
if (is.null(to)) to <- n - 1L
else if (to > n - 1L) {
warning(sprintf("provided 'to' too big; reset to maximum possible value: %d", n - 1L))
to <- n - 1L
}
## is `A` an intermediate result of a previous, unfinished LU factorization?
## if YES, it should have a "to" attribute, telling where the previous factorization stopped
## if NO, a new factorization starting from `A[1, 1]` is performed
from <- attr(A, "to")
if (!is.null(from)) {
## so we continue factorization, but need to make sure there is work to do
from <- from + 1L
if (from >= n) {
warning("LU factorization of is already completed; return input as it is")
return(A)
}
if (from > to) {
stop(sprintf("please provide a bigger 'to' between %d and %d", from, n - 1L))
}
## extract "pivot"
pivot <- attr(A, "pivot")
} else {
## we start a new factorization
from <- 1
pivot <- 1:n
}
## LU factorization from `A[from, from]` to `A[to, to]`
## the following code reuses function `LUP`'s code
for (j in from:to) {
## select pivot
m <- which.max(abs(A[j:n, j]))
## A[j - 1 + m, j] is the pivot
if (m > 1L) {
## row exchange
tmp <- A[j, ]; A[j, ] <- A[j - 1 + m, ]; A[j - 1 + m, ] <- tmp
tmp <- pivot[j]; pivot[j] <- pivot[j - 1 + m]; pivot[j - 1 + m] <- tmp
}
ind <- (j + 1):n
## check if the pivot is EXACTLY 0
piv <- A[j, j]
if (piv == 0) {
stop(sprintf("system is exactly singular: U[%d, %d] = 0", j, j))
}
l <- A[ind, j] / piv
## update `L` factor
A[ind, j] <- l
## update `U` factor by Gaussian elimination
A[ind, ind] <- A[ind, ind] - tcrossprod(l, A[j, ind])
}
## update attributes of `A` and return `A`
structure(A, to = to, pivot = pivot)
}
Try with matrix B in the question. Let's say we want to stop the factorization after it has processed 2 columns / rows.
oo <- LUP2(B, 2)
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.9997339 -0.3856714 0.09424621 0.5756036
#[3,] 0.5772688 -0.4040044 0.52046170 0.2538693
#[4,] 0.3000897 -0.3048058 0.53124291 0.7163376
#attr(,"to")
#[1] 2
#attr(,"pivot")
#[1] 3 4 1 2
Since factorization is not complete, the U factor is not an upper triangular. Here is a helper function to extract it.
## usable for all functions: `LU`, `LUP` and `LUP2`
## for `LUP2` the attribute "to" is used;
## for other two we can simply zero the lower triangular of `A`
getU <- function (A) {
attr(A, "pivot") <- NULL
to <- attr(A, "to")
if (is.null(to)) {
A[lower.tri(A)] <- 0
} else {
n <- nrow(A)
len <- (n - 1):(n - to)
zero_ind <- sequence(len)
offset <- seq.int(1L, by = n + 1L, length = to)
zero_ind <- zero_ind + rep.int(offset, len)
A[zero_ind] <- 0
}
A
}
getU(oo)
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.0000000 -0.3856714 0.09424621 0.5756036
#[3,] 0.0000000 0.0000000 0.52046170 0.2538693
#[4,] 0.0000000 0.0000000 0.53124291 0.7163376
#attr(,"to")
#[1] 2
Now we can continue factorization:
LUP2(oo, 1)
#Error in LUP2(oo, 1) : please provide a bigger 'to' between 3 and 3
Oops, we have wrongly passed an infeasible value to = 1 to LUP2, because the temporary result has already processed 2 columns / rows and it can not undo it. The function tells us that we can only move forward and set to to any integers between 3 and 3. If we pass in a value larger than 3, a warning will be generated and to is reset to the maximum possible value.
oo <- LUP2(oo, 10)
#Warning message:
#In LUP2(oo, 10) :
# provided 'to' too big; reset to maximum possible value: 3
And we have the U factor
getU(oo)
# [,1] [,2] [,3] [,4]
#[1,] 0.9230651 0.4810614 0.67791981 0.2878202
#[2,] 0.0000000 -0.3856714 0.09424621 0.5756036
#[3,] 0.0000000 0.0000000 0.53124291 0.7163376
#[4,] 0.0000000 0.0000000 0.00000000 -0.4479307
#attr(,"to")
#[1] 3
The oo is now a complete factorization result. What if we still ask LUP2 to update it?
## without providing "to", it defaults to factorize till the end
oo <- LUP2(oo)
#Warning message:
#In LUP2(oo) :
# LU factorization is already completed; return input as it is
It tells you that nothing further can be done and return the input as it is.
Finally let's try a singular square matrix.
## this 4 x 4 matrix has rank 1
S <- tcrossprod(1:4, 2:5)
LUP2(S)
#Error in LUP2(S) : system is exactly singular: U[2, 2] = 0
## traceback
LUP2(S, to = 1)
# [,1] [,2] [,3] [,4]
#[1,] 8.00 12 16 20
#[2,] 0.50 0 0 0
#[3,] 0.75 0 0 0
#[4,] 0.25 0 0 0
#attr(,"to")
#[1] 1
#attr(,"pivot")
#[1] 4 2 3 1

Eigen() in R: How to return non-normalized eigenvectors [duplicate]

#eigen values and vectors
a <- matrix(c(2, -1, -1, 2), 2)
eigen(a)
I am trying to find eigenvalues and eigenvectors in R. Function eigen works for eigenvalues but there are errors in eigenvectors values. Is there any way to fix that?
Some paper work tells you
the eigenvector for eigenvalue 3 is (-s, s) for any non-zero real value s;
the eigenvector for eigenvalue 1 is (t, t) for any non-zero real value t.
Scaling eigenvectors to unit-length gives
s = ± sqrt(0.5) = ±0.7071068
t = ± sqrt(0.5) = ±0.7071068
Scaling is good because if the matrix is real symmetric, the matrix of eigenvectors is orthonormal, so that its inverse is its transpose. Taking your real symmetric matrix a for example:
a <- matrix(c(2, -1, -1, 2), 2)
# [,1] [,2]
#[1,] 2 -1
#[2,] -1 2
E <- eigen(a)
d <- E[[1]]
#[1] 3 1
u <- E[[2]]
# [,1] [,2]
#[1,] -0.7071068 -0.7071068
#[2,] 0.7071068 -0.7071068
u %*% diag(d) %*% solve(u) ## don't do this stupid computation in practice
# [,1] [,2]
#[1,] 2 -1
#[2,] -1 2
u %*% diag(d) %*% t(u) ## don't do this stupid computation in practice
# [,1] [,2]
#[1,] 2 -1
#[2,] -1 2
crossprod(u)
# [,1] [,2]
#[1,] 1 0
#[2,] 0 1
tcrossprod(u)
# [,1] [,2]
#[1,] 1 0
#[2,] 0 1
How to find eigenvectors using textbook method
The textbook method is to solve the homogenous system: (A - λI)x = 0 for the Null Space basis. The NullSpace function in my this answer would be helpful.
## your matrix
a <- matrix(c(2, -1, -1, 2), 2)
## knowing that eigenvalues are 3 and 1
## eigenvector for eigenvalue 3
NullSpace(a - diag(3, nrow(a)))
# [,1]
#[1,] -1
#[2,] 1
## eigenvector for eigenvalue 1
NullSpace(a - diag(1, nrow(a)))
# [,1]
#[1,] 1
#[2,] 1
As you can see, they are not "normalized". By contrasts, pracma::nullspace gives "normalized" eigenvectors, so you get something consistent with the output of eigen (up to possible sign flipping):
library(pracma)
nullspace(a - diag(3, nrow(a)))
# [,1]
#[1,] -0.7071068
#[2,] 0.7071068
nullspace(a - diag(1, nrow(a)))
# [,1]
#[1,] 0.7071068
#[2,] 0.7071068

Calculate inverse of a non-square matrix in R

I'm pretty new to the R language and trying to find out how you can calculate the inverse of a matrix that isn't square. (non-square? irregular? I'm unsure of the correct terminology).
From my book and a quick google search, (see source), I've found you can use solve(a) to find the inverse of a matrix if a is square.
The matrix I have created is, and from what I understand, not square:
> matX<-matrix(c(rep(1, 8),2,3,4,0,6,4,3,7,-2,-4,3,5,7,8,9,11), nrow=8, ncol=3);
> matX
[,1] [,2] [,3]
[1,] 1 2 -2
[2,] 1 3 -4
[3,] 1 4 3
[4,] 1 0 5
[5,] 1 6 7
[6,] 1 4 8
[7,] 1 3 9
[8,] 1 7 11
>
Is there a function for solving a matrix of this size or will I have to do something to each element? as the solve() function gives this error:
Error in solve.default(matX) : 'a' (8 x 3) must be square
The calculation I'm trying to achieve from the above matrix is: (matX'matX)^-1
Thanks in advance.
ginv ginv in the MASS package will give the generalized inverse of a matrix. Premultiplying the original matrix by it will give the identity:
library(MASS)
inv <- ginv(matX)
# test it out
inv %*% matX
## [,1] [,2] [,3]
## [1,] 1.000000e+00 6.661338e-16 4.440892e-15
## [2,] -8.326673e-17 1.000000e+00 -1.110223e-15
## [3,] 6.938894e-17 8.326673e-17 1.000000e+00
As suggested in the comments this can be displayed in a nicer way using zapsmall:
zapsmall(inv %*% matX)
## [,1] [,2] [,3]
## [1,] 1 0 0
## [2,] 0 1 0
## [3,] 0 0 1
The inverse of matX'matX is now:
tcrossprod(inv)
## [,1] [,2] [,3]
## [1,] 0.513763935 -0.104219636 -0.002371406
## [2,] -0.104219636 0.038700372 -0.007798748
## [3,] -0.002371406 -0.007798748 0.006625269
solve however, if you aim is to calculate the inverse of matX'matX you don't need it in the first place. This does not involve MASS:
solve(crossprod(matX))
## [,1] [,2] [,3]
## [1,] 0.513763935 -0.104219636 -0.002371406
## [2,] -0.104219636 0.038700372 -0.007798748
## [3,] -0.002371406 -0.007798748 0.006625269
svd The svd could also be used and similarly does not require MASS:
with(svd(matX), v %*% diag(1/d^2) %*% t(v))
## [,1] [,2] [,3]
## [1,] 0.513763935 -0.104219636 -0.002371406
## [2,] -0.104219636 0.038700372 -0.007798748
## [3,] -0.002371406 -0.007798748 0.006625269
ADDED some additional info.
You can do what's called a "Moore–Penrose pseudoinverse". Here's a function exp.matthat will do this for you. There is also an example outlining it's use here.
exp.mat():
#The exp.mat function performs can calculate the pseudoinverse of a matrix (EXP=-1)
#and other exponents of matrices, such as square roots (EXP=0.5) or square root of
#its inverse (EXP=-0.5).
#The function arguments are a matrix (MAT), an exponent (EXP), and a tolerance
#level for non-zero singular values.
exp.mat<-function(MAT, EXP, tol=NULL){
MAT <- as.matrix(MAT)
matdim <- dim(MAT)
if(is.null(tol)){
tol=min(1e-7, .Machine$double.eps*max(matdim)*max(MAT))
}
if(matdim[1]>=matdim[2]){
svd1 <- svd(MAT)
keep <- which(svd1$d > tol)
res <- t(svd1$u[,keep]%*%diag(svd1$d[keep]^EXP, nrow=length(keep))%*%t(svd1$v[,keep]))
}
if(matdim[1]<matdim[2]){
svd1 <- svd(t(MAT))
keep <- which(svd1$d > tol)
res <- svd1$u[,keep]%*%diag(svd1$d[keep]^EXP, nrow=length(keep))%*%t(svd1$v[,keep])
}
return(res)
}
example of use:
source("exp.mat.R")
X <- matrix(c(rep(1, 8),2,3,4,0,6,4,3,7,-2,-4,3,5,7,8,9,11), nrow=8, ncol=3)
iX <- exp.mat(X, -1)
zapsmall(iX %*% X) # results in identity matrix
[,1] [,2] [,3]
[1,] 1 0 0
[2,] 0 1 0
[3,] 0 0 1

Adding elements to the diagonal of a matrix that is not square in R

I want to be able to add a value (in my code nug) to the i,j entry of a matrix where i = j (so like a Kronecker delta function). Its very easy to do when the matrix is square (see my code below) however I am not sure how to do it in one line when the matrix is not square
nug = 2
R = tau + diag(nug,nrow(tau))
The above code works when tau is a square matrix but now imagine that tau is not square. How would I add nug to each of the i,j elements of tau where i = j?
m <- matrix(1:6, ncol = 2)
m
[,1] [,2]
[1,] 1 4
[2,] 2 5
[3,] 3 6
diag(m) <- diag(m) + 1:2
m
[,1] [,2]
[1,] 2 4
[2,] 2 7
[3,] 3 6
You can do this :
m[col(m)==row(m)] <- m[col(m)==row(m)] +nug
Using a matrix of zeros to show this:
m <- matrix(rep(0,6), ncol = 2)
> m[col(m)==row(m)] <- m[col(m)==row(m)] +2
> m
[,1] [,2]
[1,] 2 0
[2,] 0 2
[3,] 0 0

Resources