1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
|
##' Create/extract 'reverse'-diagonal matrix or off-diagonal elements
##' @title Create/extract 'reverse'-diagonal matrix or off-diagonal elements
##' @aliases revdiag revdiag<- offdiag offdiag<-
##' @usage
##' revdiag(x,...)
##' offdiag(x,type=0,...)
##'
##' revdiag(x,...) <- value
##' offdiag(x,type=0,...) <- value
##' @param x vector
##' @param value For the assignment function the values to put in the diagonal
##' @param type 0: upper and lower triangular, 1: upper triangular, 2: lower triangular, 3: upper triangular + diagonal, 4: lower triangular + diagonal
##' @param \dots additional arguments to lower level functions
##' @author Klaus K. Holst
##' @export
revdiag <- function(x,...) {
if (NCOL(x)==1) {
res <- matrix(0,length(x),length(x))
revdiag(res) <- x
return(res)
}
n <- max(ncol(x),nrow(x))
x[cbind(rev(seq(n)),seq(n))]
}
##' @export
"revdiag<-" <- function(x,...,value) {
n <- max(ncol(x),nrow(x))
x[cbind(rev(seq(n)),seq(n))] <- value
x
}
##' @export
offdiag <- function(x,type=0,...) {
##if (NCOL(x)==1) return(NULL)
if (type%in%c(1,3)) {
ii <- which(upper.tri(x,diag=(type==3)))
} else if (type%in%c(2,4)) {
ii <- which(lower.tri(x,diag=(type==4)))
} else {
ii <- c(which(lower.tri(x,diag=FALSE)),which(upper.tri(x,diag=FALSE)))
}
res <- x[ii]
class(res) <- c("offdiag",class(res))
attributes(res) <-
c(attributes(res),list(type=type,dimension=dim(x),index=ii,nam=dimnames(x)))
return(res)
}
##' @export
"offdiag<-" <- function(x,type=0,...,value) {
if (type%in%c(1,3)) {
ii <- which(upper.tri(x,diag=(type==3)))
} else if (type%in%c(2,4)) {
ii <- which(lower.tri(x,diag=(type==4)))
} else {
ii <- c(which(lower.tri(x,diag=FALSE)),which(upper.tri(x,diag=FALSE)))
}
x[ii] <- value
return(x)
}
##' @export
print.offdiag <- function(x,...) {
## type <- attr(x,"type")
nn <- attr(x,"dimension")
M <- matrix(NA,nn[1],nn[2])
M[attr(x,"index")] <- x
dimnames(M) <- attr(x,"nam")
print(M,na.print="",...)
}
|
