Added license information to R source files.
[openmx:openmx.git] / R / MxSymmetricSparse.R
1 #
2 #   Copyright 2007-2009 The OpenMx Project
3 #
4 #   Licensed under the Apache License, Version 2.0 (the "License");
5 #   you may not use this file except in compliance with the License.
6 #   You may obtain a copy of the License at
7
8 #        http://www.apache.org/licenses/LICENSE-2.0
9
10 #    Unless required by applicable law or agreed to in writing, software
11 #    distributed under the License is distributed on an "AS IS" BASIS,
12 #    WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13 #   See the License for the specific language governing permissions and
14 #   limitations under the License.
15
16
17 setClass(Class = "MxSymmetricSparse",\r
18         representation = representation(\r
19                 rowVector = "vector",\r
20                 colVector = "vector",\r
21                 dataVector = "vector",\r
22                 nrow = "numeric",\r
23                 ncol = "numeric",\r
24                 dimNames = "list"),\r
25         prototype = prototype(\r
26                 rowVector = vector(mode="numeric",0),\r
27                 colVector = vector(mode="numeric",0),\r
28                 dataVector = vector(mode="character",0),\r
29                 dimNames = list(),\r
30                 nrow = 1, ncol = 1))\r
31 \r
32 setMethod("initialize", "MxSymmetricSparse",\r
33         function(.Object, data = NA, nrow = 1, ncol = 1, dimnames = NULL) {\r
34                 if (is.matrix(data)) {\r
35                     test <- all(data == t(data) | is.na(data))\r
36                     if (is.na(test) || !test) {\r
37                                 stop("Input matrix is not symmetric")\r
38                     }\r
39                     data[lower.tri(data)] <- 0\r
40                         tdata <- t(data)\r
41                         nonZero <- (data != 0) | is.na(data)\r
42                         rowMatrix <- t(row(data) * nonZero)\r
43                         colMatrix <- t(col(data) * nonZero)\r
44                         rowVector <- as.vector(rowMatrix)\r
45                         colVector <- as.vector(colMatrix)\r
46                         .Object@dataVector <- tdata[tdata != 0]\r
47                         .Object@rowVector <- rowVector[rowVector > 0]\r
48                         .Object@colVector <- colVector[colVector > 0]\r
49                         .Object@nrow <- nrow(data)\r
50                         .Object@ncol <- ncol(data)\r
51                 } else {\r
52                         .Object@nrow <- nrow\r
53                         .Object@ncol <- ncol\r
54             }\r
55             if (!is.null(dimnames)) {\r
56                 .Object@dimNames <- dimnames\r
57             }\r
58                 return(.Object)\r
59         }\r
60 )\r
61 \r
62 setMethod("print", "MxSymmetricSparse", function(x,...) { \r
63   args <- list(...)\r
64   use.quotes <- args[['use.quotes']]\r
65   if (is.null(use.quotes)) {\r
66     use.quotes <- FALSE\r
67   }\r
68   omxDisplayMxSymmetricSparse(x, use.quotes) \r
69 })\r
70 \r
71 setMethod("show", "MxSymmetricSparse", function(object) { \r
72   omxDisplayMxSymmetricSparse(object, FALSE) \r
73 })\r
74 \r
75 omxDisplayMxSymmetricSparse <- function(mxMatrix, use.quotes) {\r
76    matrix <- as.matrix(mxMatrix)\r
77    if (use.quotes) {\r
78       matrix <- apply(matrix, c(1,2), function(x) {
79     if(is.na(x)) {return('NA')}\r
80         else if(x == '0') {return('0')}\r
81         else {return(omxQuotes(x))}\r
82       })\r
83       print(matrix, quote = FALSE)\r
84    } else {\r
85       print(matrix)\r
86    }\r
87\r
88 \r
89 setMethod("t",  "MxSymmetricSparse",            \r
90         function(x) {\r
91                 return(x)\r
92         }\r
93 )\r
94 \r
95 setMethod("nnzero", "MxSymmetricSparse",\r
96         function(x, na.counted = NA) {\r
97             duplicates <- sum(x@rowVector == x@colVector)           \r
98                 return(length(x@rowVector) * 2 - duplicates)\r
99         }\r
100 )\r
101                 \r
102 setMethod("as.matrix",  "MxSymmetricSparse",\r
103         function(x, ...) {\r
104                 result <- matrix(0, nrow(x), ncol(x))\r
105                 result[x@rowVector + (x@colVector - 1)*nrow(x)] <- x@dataVector\r
106                 result[x@colVector + (x@rowVector - 1)*ncol(x)] <- x@dataVector         \r
107                 return(result)\r
108         }\r
109 )\r
110 \r
111 setMethod("nrow", "MxSymmetricSparse",\r
112         function(x) {\r
113             return(x@nrow)\r
114         }\r
115 )\r
116 \r
117 setMethod("ncol", "MxSymmetricSparse",\r
118         function(x) {\r
119                 return(x@ncol)\r
120         }\r
121 )\r
122 \r
123 \r
124 \r
125 setMethod("[", "MxSymmetricSparse",\r
126         function(x, i, j, ..., drop = FALSE) {\r
127         if (is.character(i)) {\r
128                 if(length(x@dimNames) == 0) {\r
129                         stop("no 'dimnames' attribute for array")\r
130                 } else {\r
131                         rownames <- x@dimNames[[1]]\r
132                         i <- match(i, rownames) \r
133                 }\r
134         }\r
135         if (is.character(j)) {\r
136                 if(length(x@dimNames) == 0) {                                   stop("no 'dimnames' attribute for array")\r
137                 } else {\r
138                         colnames <- x@dimNames[[2]]\r
139                         j <- match(j, colnames) \r
140                 }\r
141         }                                                               \r
142             if (i > x@nrow || j > x@ncol) {\r
143                 stop("subscript out of bounds")         \r
144                 } else if (length(x@rowVector) == 0) {\r
145                         return(0)\r
146         } else {\r
147                 if (i > j) {\r
148                         tmp <- i\r
149                             i <- j\r
150                             j <- tmp                            \r
151                 }\r
152                         ubound <- findInterval(i, x@rowVector)\r
153                         if ((ubound > 0) && x@rowVector[ubound] == i) {\r
154                                 lbound <- findInterval(i - 1, x@rowVector) + 1\r
155                                 index <- findInterval(j, x@colVector[lbound:ubound])\r
156                                 offset <- index + lbound - 1\r
157                                 if (offset > 0 && x@colVector[offset] == j) {\r
158                                         return(x@dataVector[offset])\r
159                                 }\r
160                         } \r
161                 }\r
162                 return(0)\r
163     }\r
164 )\r
165 \r
166 setReplaceMethod("[", "MxSymmetricSparse", \r
167         function(x, i, j, value) {\r
168         if (is.character(i)) {\r
169                 if(length(x@dimNames) == 0) {\r
170                         stop("no 'dimnames' attribute for array")\r
171                 } else {\r
172                         rownames <- x@dimNames[[1]]\r
173                         i <- match(i, rownames) \r
174                 }\r
175         }\r
176         if (is.character(j)) {\r
177                 if(length(x@dimNames) == 0) {                                   stop("no 'dimnames' attribute for array")\r
178                 } else {\r
179                         colnames <- x@dimNames[[2]]\r
180                         j <- match(j, colnames) \r
181                 }\r
182         }               \r
183             if (i > x@nrow || j > x@ncol) {\r
184                 stop("subscript out of bounds")         \r
185             } else if (i > j) {\r
186                         tmp <- i\r
187                             i <- j\r
188                             j <- tmp                            \r
189         }       \r
190                 if (length(x@rowVector) == 0) {\r
191                         x@rowVector <- c(i)\r
192                         x@colVector <- c(j)\r
193                         x@dataVector <- c(value)\r
194         } else {\r
195                         ubound <- findInterval(i, x@rowVector)\r
196                         if ((ubound > 0) && x@rowVector[ubound] == i) {\r
197                                 lbound <- findInterval(i - 1, x@rowVector) + 1\r
198                                 index <- findInterval(j, x@colVector[lbound:ubound])\r
199                                 offset <- index + lbound - 1\r
200                                 if (offset > 0 && x@colVector[offset] == j) {\r
201                                     if (!is.na(value) && value == 0) {\r
202                                            x@rowVector <- x@rowVector[-offset]\r
203                                        x@colVector <- x@colVector[-offset]\r
204                                        x@dataVector <- x@dataVector[-offset]\r
205                                     } else {\r
206                                            x@rowVector[offset] <- i\r
207                                            x@colVector[offset] <- j\r
208                                            x@dataVector[offset] <- value\r
209                                     }\r
210                                 } else if (is.na(value) || value != 0) {\r
211                                         x@rowVector <- append(x@rowVector, i, after = offset)\r
212                                         x@colVector <- append(x@colVector, j, after = offset)\r
213                                         x@dataVector <- append(x@dataVector, value, after = offset)\r
214                                 }\r
215                         } else if (is.na(value) || value != 0) {\r
216                                 x@rowVector <- append(x@rowVector, i, after = ubound)\r
217                                 x@colVector <- append(x@colVector, j, after = ubound)\r
218                                 x@dataVector <- append(x@dataVector, value, after = ubound)\r
219                         }\r
220                 }\r
221                 return(x)\r
222     }\r
223 )\r