Minor changes to single.na predicate and replaced some "=" statements with "<-" state...
[openmx:openmx.git] / R / MxModel.R
1 setClass(Class = "MxModel",\r
2         representation = representation(\r
3                 matrices = "list",\r
4                 algebras = "list",\r
5                 paths = "data.frame",\r
6                 latentVars = "character",\r
7                 manifestVars = "character",\r
8                 data = "data.frame"))\r
9                 \r
10 setMethod("initialize", "MxModel",\r
11         function(.Object, paths = list(), latentVars = character(),\r
12                 manifestVars = character(), matrices = list(), \r
13                 algebras = list(), data = data.frame()) {\r
14                 if (length(paths) > 0) {\r
15                         .Object <- mxAddPath(.Object, paths)\r
16                 }\r
17                 .Object@latentVars <- latentVars\r
18                 .Object@manifestVars <- manifestVars\r
19                 .Object@matrices <- matrices\r
20                 .Object@algebras <- algebras\r
21                 .Object@data <- data\r
22                 return(.Object)\r
23         }\r
24 )\r
25 \r
26 setMethod("[[", "MxModel",\r
27         function(x, i, j, ..., drop = FALSE) {\r
28                 first <- x@matrices[[i]]\r
29                 second <- x@algebras[[i]]\r
30                 if (is.null(first)) {\r
31                         return(second)\r
32                 } else {\r
33                         return(first)\r
34                 }       \r
35         }\r
36 )\r
37 \r
38 setReplaceMethod("[[", "MxModel",\r
39         function(x, i, j, value) {\r
40                 if (is(value,"MxMatrix")) {\r
41                         if (!is.null(x@algebras[[i]])) {\r
42                                 stop(paste(i, "is already an MxAlgebra object"))\r
43                         }\r
44                         value@name <- i\r
45                         x@matrices[[i]] <- value\r
46                 } else if (is(value,"MxAlgebra")) {\r
47                         if (!is.null(x@matrices[[i]])) {\r
48                                 stop(paste(i, "is already an MxMatrix object"))\r
49                         }\r
50                         x@algebras[[i]] <- value                \r
51                 } else {\r
52                         stop(paste("Unknown type of value", value))\r
53                 }\r
54                 return(x)\r
55         }\r
56 )\r
57 \r
58 setGeneric("omxAddEntries", function(.Object, entries) {\r
59         return(standardGeneric("omxAddEntries")) } )\r
60 \r
61 setGeneric("omxRemoveEntries", function(.Object, entries) {\r
62         return(standardGeneric("omxRemoveEntries")) } ) \r
63         \r
64 froms <- function(lst) {\r
65   retval <- lapply(lst, function(x) { return(x$from) } )\r
66   return(retval)\r
67 }       \r
68 \r
69 tos <- function(lst) {\r
70   retval <- lapply(lst, function(x) { return(x$to) } )\r
71   return(retval)\r
72 }       \r
73 \r
74 omxMappend <- function(...) {\r
75     args <- list(...)\r
76         return(mappendHelper(args, list()))\r
77 }\r
78 \r
79 mappendHelper <- function(lst, result) {\r
80         if (length(lst) == 0) {\r
81                 return(result)\r
82         } else if (length(lst) == 1) {\r
83                 return(append(result,lst[[1]]))\r
84         } else {\r
85                 return(mappendHelper(lst[2:length(lst)], append(result, lst[[1]])))\r
86         }\r
87 }\r
88 \r
89 omxModel <- function(model=NULL, ..., remove=FALSE, manifestVars=NULL, latentVars=NULL) {\r
90         if(is.null(model)) {\r
91                 model <- new("MxModel") \r
92         }\r
93         lst <- list(...)\r
94         if(class(model)[[1]] != "MxModel") {\r
95                 stop("First argument is not an MxModel object")\r
96         }\r
97         if(remove == TRUE) {\r
98                 model <- omxRemoveEntries(model, mappendHelper(lst, list()))\r
99                 if ( !is.null(manifestVars) ) {\r
100                         model@manifestVars <- setdiff(model@manifestVars, manifestVars)\r
101                 }\r
102                 if ( !is.null(latentVars) ) {\r
103                         model@latentVars <- setdiff(model@latentVars, latentVars)\r
104                 }                               \r
105         } else {\r
106                 model <- omxAddEntries(model, mappendHelper(lst, list()))\r
107                 if ( !is.null(manifestVars) ) {\r
108                         tmp <- append(model@manifestVars, manifestVars)\r
109                         model@manifestVars <- unique(tmp)\r
110                 }\r
111                 if ( !is.null(latentVars) ) {\r
112                         tmp <- append(model@latentVars, latentVars)\r
113                         model@latentVars <- unique(tmp)\r
114                 }               \r
115         }\r
116         return(model)\r
117 }\r
118 \r
119 filterEntries <- function(entries, paths, matrices, algebras) {\r
120         if (length(entries) == 0) {\r
121                 return(list(paths, matrices, algebras))\r
122         }\r
123         head <- entries[[1]]\r
124         if (is(head, "MxMatrix")) {\r
125                 matrices <- append(matrices, head)\r
126         } else if (is(head, "MxAlgebra")) {\r
127                 algebras <- append(algebras, head)\r
128         } else if (omxIsPath(head)) {\r
129                 paths <- append(paths, head)\r
130         } else {\r
131                 stop(paste("Unkown object:", head))\r
132         }\r
133         return(filterEntries(entries[-1], paths, matrices, algebras))\r
134 }\r
135         \r
136 setMethod("omxAddEntries", "MxModel", \r
137         function(.Object, entries) {\r
138                 if (length(entries) < 1) {\r
139                         return(.Object)\r
140                 }\r
141                 threeTuple <- filterEntries(entries, list(), list(), list())\r
142                 paths <- threeTuple[[1]]\r
143                 matrices <- threeTuple[[2]]\r
144                 algebras <- threeTuple[[3]]\r
145                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
146                         stop("The \'from\' field or the \'to\' field contains an NA")\r
147                 }\r
148                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
149                         .Object <- omxAddSinglePath(.Object, paths[[i]])\r
150                 }\r
151                 if (length(matrices) > 0) for(i in 1:length(matrices)) {\r
152                         .Object <- omxAddSingleMatrix(.Object, matrices[[i]])\r
153                 }\r
154                 if (length(algebras) > 0) for(i in 1:length(algebras)) {\r
155                         .Object <- omxAddSingleAlgebra(.Object, algebras[[i]])\r
156                 }\r
157                 return(.Object)\r
158         }\r
159 )\r
160 \r
161 setMethod("omxRemoveEntries", "MxModel", \r
162         function(.Object, entries) {\r
163                 if (length(entries) < 1) {\r
164                         return(.Object)\r
165                 }\r
166                 threeTuple <- filterEntries(entries, list(), list(), list())\r
167                 paths <- threeTuple[[1]]\r
168                 matrices <- threeTuple[[2]]\r
169                 algebras <- threeTuple[[3]]             \r
170                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
171                         stop("The \'from\' field or the \'to\' field contains an NA")\r
172                 }               \r
173                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
174                         .Object <- omxRemoveSinglePath(.Object, paths[[i]])\r
175                 }\r
176                 if (length(matrices) > 0) for(i in 1:length(matrices)) {\r
177                         .Object <- omxRemoveSingleMatrix(.Object, matrices[[i]])\r
178                 }\r
179                 if (length(algebras) > 0) for(i in 1:length(algebras)) {\r
180                         .Object <- omxRemoveSingleAlgebra(.Object, algebras[[i]])\r
181                 }\r
182                 return(.Object)\r
183         }\r
184 )\r
185 \r
186 omxAddSingleMatrix <- function(.Object, matrix) {\r
187         .Object[[matrix@name]] <- matrix\r
188         return(.Object)\r
189 }\r
190 \r
191 omxAddSingleAlgebra <- function(.Object, algebra) {\r
192         .Object[[algebra@name]] <- algebra\r
193         return(.Object)\r
194 }\r
195 \r
196 omxAddSinglePath <- function(.Object, path) {\r
197         if (nrow(.Object@paths) > 0) {\r
198                 fromExists <- (.Object@paths['from'] == path[['from']])\r
199                 toExists <- (.Object@paths['to'] == path[['to']])\r
200                 replace <- any(fromExists & toExists, na.rm=TRUE)\r
201                 morfExists <- (.Object@paths['from'] == path[['to']])\r
202                 otExists <- (.Object@paths['to'] == path[['from']])\r
203                 oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
204                 if (oppositeExists) {\r
205                         newArrow <- !is.null(path[['arrows']])\r
206                         oldArrow <- !is.null(.Object@paths[morfExists & otExists,'arrows'])\r
207                         if (oldArrow && .Object@paths[morfExists & otExists,'arrows'] == 2) {\r
208                                         fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
209                                         toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
210                                         fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
211                                         .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
212                                         .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
213                                         .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
214                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
215                                         toExists <- (.Object@paths['to'] == path[['to']])\r
216                                         replace <- TRUE\r
217                         } else if (newArrow && path[['arrows']] == 2) {\r
218                                         tmp <- path[['from']]\r
219                                         path[['from']] <- path[['to']]\r
220                                         path[['to']] <- tmp\r
221                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
222                                         toExists <- (.Object@paths['to'] == path[['to']])\r
223                                         replace <- TRUE\r
224                         }\r
225                 }\r
226                 if (replace) {\r
227                         ids <- names(path)                      \r
228                         for(i in 1:length(path)) {\r
229                                 id <- ids[[i]]\r
230                                 .Object@paths[fromExists & toExists,id] <- path[[id]]\r
231                         }\r
232                 } else {\r
233                         .Object@paths <- merge(.Object@paths, \r
234                                 data.frame(path, stringsAsFactors = FALSE), all=TRUE)\r
235                 }\r
236         } else {\r
237                 .Object@paths <- data.frame(path, stringsAsFactors = FALSE)\r
238         }\r
239         fromExists <- (.Object@paths['from'] == path[['from']])\r
240         toExists <- (.Object@paths['to'] == path[['to']])\r
241         field <- .Object@paths[fromExists & toExists, 'arrows']\r
242         if (!is.null(field) && !is.na(field)  \r
243                         && (field == 2) \r
244                         && (path[['from']] > path[['to']])) {\r
245                 fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
246                 toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
247                 fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
248                 .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
249                 .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
250                 .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
251         }       \r
252         return(.Object)\r
253 }\r
254 \r
255 omxRemoveSinglePath <- function(.Object, path) {\r
256         if (nrow(.Object@paths) > 0) {\r
257                 .Object@paths <- subset(.Object@paths, to != path[['to']] | from != path[['from']])\r
258                 if (nrow(.Object@paths) > 0) {          \r
259                         morfExists <- (.Object@paths['from'] == path[['to']])\r
260                         otExists <- (.Object@paths['to'] == path[['from']])\r
261                         oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
262                         if (oppositeExists) {\r
263                                 check1 <- !is.null(path[['arrows']]) && path[['arrows']] == 2\r
264                                 check2 <- !is.null(.Object@paths[morfExists & otExists,'arrows']) &&\r
265                                                         .Object@paths[morfExists & otExists,'arrows'] == 2\r
266                                 if (check1 || check2) {\r
267                                         .Object@paths <- subset(.Object@paths, \r
268                                                 to != path[['from']] | from != path[['to']])\r
269                                 }\r
270                         }\r
271                 }               \r
272         }               \r
273         return(.Object)\r
274 }\r
275 \r
276 omxRemoveSingleMatrix <- function(.Object, matrix) {\r
277         .Object[[matrix@name]] <- NULL\r
278         return(.Object)\r
279 }\r
280 \r
281 omxRemoveSingleAlgebra <- function(.Object, algebra) {\r
282         .Object[[algebra@name]] <- NULL\r
283         return(.Object)\r
284 }\r
285 \r
286 mxModel <- function(model = NULL, ..., remove = FALSE, manifestVars = NULL, latentVars = NULL) {\r
287         omxModel(model, ..., remove = remove, manifestVars = manifestVars, latentVars = latentVars)\r
288 }\r
289 \r