Added license information to R source files.
[openmx:openmx.git] / R / MxSparseMatrix.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 = "MxSparseMatrix",\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", "MxSparseMatrix",\r
33         function(.Object, data = NA, nrow = 1, ncol = 1, dimnames = NULL) {\r
34                 if (is.matrix(data)) {\r
35                         tdata <- t(data)\r
36                         nonZero <- (data != 0) | is.na(data)\r
37                         rowMatrix <- t(row(data) * nonZero)\r
38                         colMatrix <- t(col(data) * nonZero)\r
39                         rowVector <- as.vector(rowMatrix)\r
40                         colVector <- as.vector(colMatrix)\r
41                         .Object@dataVector <- tdata[tdata != 0]\r
42                         .Object@rowVector <- rowVector[rowVector > 0]\r
43                         .Object@colVector <- colVector[colVector > 0]\r
44                         .Object@nrow <- nrow(data)\r
45                         .Object@ncol <- ncol(data)\r
46                 } else {\r
47                         .Object@nrow <- nrow\r
48                         .Object@ncol <- ncol\r
49             }\r
50             if (!is.null(dimnames)) {\r
51                     .Object@dimNames <- dimnames\r
52                 }\r
53                 return(.Object)\r
54         }\r
55 )                                       \r
56 \r
57 setMethod("print", "MxSparseMatrix", function(x,...) { \r
58   args <- list(...)\r
59   use.quotes <- args[['use.quotes']]\r
60   if (is.null(use.quotes)) {\r
61     use.quotes <- FALSE\r
62   }\r
63   omxDisplayMxSparseMatrix(x, use.quotes) \r
64 })\r
65 \r
66 setMethod("show", "MxSparseMatrix", function(object) { \r
67   omxDisplayMxSparseMatrix(object, FALSE) \r
68 })\r
69 \r
70 omxDisplayMxSparseMatrix <- function(mxMatrix, use.quotes) {\r
71    matrix <- as.matrix(mxMatrix)\r
72    if (use.quotes) {\r
73       matrix <- apply(matrix, c(1,2), function(x) {
74     if(is.na(x)) {return('NA')}\r
75         else if(x == '0') {return('0')}\r
76         else {return(omxQuotes(x))}\r
77       })\r
78       print(matrix, quote = FALSE)\r
79    } else {\r
80       print(matrix)\r
81    }\r
82\r
83 \r
84 setMethod("t", "MxSparseMatrix",                \r
85         function(x) {\r
86             return(new("MxSparseMatrix", data=t(as.matrix(x))))\r
87         }\r
88 )\r
89 \r
90 setMethod("nnzero", "MxSparseMatrix",\r
91         function(x, na.counted = NA) {\r
92                 return(length(x@rowVector))\r
93         }\r
94 )\r
95                 \r
96 setMethod("as.matrix", "MxSparseMatrix",\r
97         function(x, ...) {\r
98                 result <- matrix(0, nrow(x), ncol(x))\r
99                 result[x@rowVector + (x@colVector - 1)*nrow(x)] <- x@dataVector\r
100                 return(result)\r
101         }\r
102 )\r
103 \r
104 setMethod("nrow", "MxSparseMatrix",\r
105         function(x) {\r
106             return(x@nrow)\r
107         }\r
108 )\r
109 \r
110 setMethod("ncol", "MxSparseMatrix",\r
111         function(x) {\r
112             return(x@ncol)\r
113         }\r
114 )\r
115 \r
116 \r
117 \r
118 setMethod("[", "MxSparseMatrix",\r
119         function(x, i, j, ..., drop = FALSE) {\r
120         if (is.character(i)) {\r
121                 if(length(x@dimNames) == 0) {\r
122                         stop("no 'dimnames' attribute for array")\r
123                 } else {\r
124                         rownames <- x@dimNames[[1]]\r
125                         i <- match(i, rownames) \r
126                 }\r
127         }\r
128         if (is.character(j)) {\r
129                 if(length(x@dimNames) == 0) {                                   stop("no 'dimnames' attribute for array")\r
130                 } else {\r
131                         colnames <- x@dimNames[[2]]\r
132                         j <- match(j, colnames) \r
133                 }\r
134         }                               \r
135             if (i > x@nrow || j > x@ncol) {\r
136                 stop("subscript out of bounds")\r
137             } else if (length(x@rowVector) == 0) {\r
138                         return(0)\r
139         } else {\r
140                         ubound <- findInterval(i, x@rowVector)\r
141                         if ((ubound > 0) && x@rowVector[ubound] == i) {\r
142                                 lbound <- findInterval(i - 1, x@rowVector) + 1\r
143                                 index <- findInterval(j, x@colVector[lbound:ubound])\r
144                                 offset <- index + lbound - 1\r
145                                 if (offset > 0 && x@colVector[offset] == j) {\r
146                                         return(x@dataVector[offset])\r
147                                 }\r
148                         } \r
149                 }\r
150                 return(0)\r
151     }\r
152 )\r
153 \r
154 setReplaceMethod("[", "MxSparseMatrix", \r
155         function(x, i, j, value) {\r
156         if (is.character(i)) {\r
157                 if(length(x@dimNames) == 0) {\r
158                         stop("no 'dimnames' attribute for array")\r
159                 } else {\r
160                         rownames <- x@dimNames[[1]]\r
161                         i <- match(i, rownames) \r
162                 }\r
163         }\r
164         if (is.character(j)) {\r
165                 if(length(x@dimNames) == 0) {\r
166                         stop("no 'dimnames' attribute for array")\r
167                 } else {\r
168                         colnames <- x@dimNames[[2]]\r
169                         j <- match(j, colnames) \r
170                 }\r
171         }               \r
172             if (i > x@nrow || j > x@ncol) {\r
173                 stop("subscript out of bounds")      \r
174         } else if (length(x@rowVector) == 0) {\r
175                         x@rowVector <- c(i)\r
176                         x@colVector <- c(j)\r
177                         x@dataVector <- c(value)\r
178         } else {\r
179                         ubound <- findInterval(i, x@rowVector)\r
180                         if ((ubound > 0) && x@rowVector[ubound] == i) {\r
181                                 lbound <- findInterval(i - 1, x@rowVector) + 1\r
182                                 index <- findInterval(j, x@colVector[lbound:ubound])\r
183                                 offset <- index + lbound - 1\r
184                                 if (offset > 0 && x@colVector[offset] == j) {\r
185                                     if (!is.na(value) && value == 0) {\r
186                                            x@rowVector <- x@rowVector[-offset]\r
187                                        x@colVector <- x@colVector[-offset]\r
188                                        x@dataVector <- x@dataVector[-offset]\r
189                                     } else {\r
190                                            x@rowVector[offset] <- i\r
191                                            x@colVector[offset] <- j\r
192                                            x@dataVector[offset] <- value\r
193                                     }\r
194                                 } else if (is.na(value) || value != 0) {\r
195                                         x@rowVector <- append(x@rowVector, i, after = offset)\r
196                                         x@colVector <- append(x@colVector, j, after = offset)\r
197                                         x@dataVector <- append(x@dataVector, value, after = offset)\r
198                                 }\r
199                         } else if (is.na(value) || value != 0) {\r
200                                 x@rowVector <- append(x@rowVector, i, after = ubound)\r
201                                 x@colVector <- append(x@colVector, j, after = ubound)\r
202                                 x@dataVector <- append(x@dataVector, value, after = ubound)\r
203                         }\r
204                 }\r
205                 return(x)\r
206     }\r
207 )\r