Merging three-matrix branch into the trunk.
[openmx:openmx.git] / R / MxModel.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 = "MxModel",\r
18         representation = representation(
19                 name = "character",
20                 matrices = "list",
21                 algebras = "list",
22                 constraints = "list",
23                 bounds = "list",\r
24                 paths = "data.frame",\r
25                 latentVars = "character",\r
26                 manifestVars = "character",\r
27                 data = "MxData",
28                 submodels = "list",
29                 objective = "MxObjective",
30                 independent = "logical",
31                 output = "list"
32 ))
33 \r
34 setMethod("initialize", "MxModel",\r
35         function(.Object, name = omxUntitledName(), paths = list(), 
36                 latentVars = character(), manifestVars = character(), 
37                 matrices = list(), algebras = list(), 
38                 constraints = list(), bounds = list(),
39                 data = NULL, submodels = list(), 
40                 objective = NULL, independent = FALSE) {\r
41                 if (length(paths) > 0) {\r
42                         .Object <- mxAddPath(.Object, paths)\r
43                 }
44                 .Object@name <- name\r
45                 .Object@latentVars <- latentVars\r
46                 .Object@manifestVars <- manifestVars\r
47                 .Object@matrices <- matrices\r
48                 .Object@algebras <- algebras
49                 .Object@constraints <- constraints
50                 .Object@bounds <- bounds\r
51                 .Object@data <- data
52                 .Object@submodels <- submodels
53                 .Object@objective <- objective
54                 .Object@independent <- independent
55                 .Object@output <- list()\r
56                 return(.Object)\r
57         }\r
58 )\r
59
60 omxExtractMethod <- function(model, index) {
61         first <- model@matrices[[index]]
62         second <- model@algebras[[index]]
63         third <- model@submodels[[index]]
64         fourth <- model@constraints[[index]]
65         fifth <- model@bounds[[index]]
66         if (!is.null(model@objective) && index == model@objective@name) {
67                 return(model@objective)
68         } else if (!is.null(model@data) && index == model@data@name) {
69                 return(model@data)
70         } else if (!is.null(first)) {
71                 return(first)
72         } else if (!is.null(second)) {
73                 return(second)
74         } else if (!is.null(third)) {
75                 return(third)
76         } else if (!is.null(fourth)) {
77                 return(fourth)
78         } else {
79                 return(fifth)
80         }       
81 }
82
83 omxReplaceMethod <- function(model, index, value) {
84         current <- model[[index]]
85         if (is.null(current) && is.null(value)) {
86                 return(model)
87         }
88         if(index == model@name) {
89                 stop(paste(omxQuotes(index), 
90                         "is already used as the name of the model"))
91         }
92         if(!is.null(current) && !is.null(value) && 
93                         !omxSameType(current, value)) {
94                 stop(paste("There already exists an object", 
95                                 omxQuotes(index), 
96                                 "in this model of different type"))
97         }
98         if(!is.null(value)) {
99                 value@name <- index
100                 test <- value
101         } else {
102                 test <- current
103         }
104         if (is(test,"MxMatrix")) {
105                 model@matrices[[index]] <- value
106         } else if (is(test,"MxAlgebra")) {
107                 model@algebras[[index]] <- value
108         } else if (is(test,"MxModel")) {
109                 model@submodels[[index]] <- value       
110         } else if (is(test,"MxObjective")) {
111                 model@objective <- value
112         } else if (is(test,"MxData")) {
113                 model@data <- value
114         } else if (is(test,"MxConstraint")) {
115                 model@constraints[[index]] <- value
116         } else if (is(test,"MxBounds")) {
117                 model@bounds[[index]] <- value
118         } else {
119                 stop("Unknown type of value", value)
120         }
121         return(model)
122 }
123 \r
124 setMethod("[[", "MxModel",\r
125         function(x, i, j, ..., drop = FALSE) {\r
126                 return(omxExtractMethod(x, i))\r
127         }\r
128 )
129 \r
130 setReplaceMethod("[[", "MxModel",\r
131         function(x, i, j, value) {
132                 return(omxReplaceMethod(x, i, value))
133         }\r
134 )
135
136 omxSameType <- function(a, b) {
137         return( (is(a, "MxModel") && is(b, "MxModel")) ||
138                         (is(a, "MxMatrix") && is(b, "MxMatrix")) ||
139                         (is(a, "MxAlgebra") && is(b, "MxAlgebra")) ||
140                         (is(a, "MxObjective") && is(b, "MxObjective")) ||
141                         (is(a, "MxConstraint") && is(b, "MxConstraint")) ||
142                         (is(a, "MxData") && is(b, "MxData")) ||
143                         (is(a, "MxBounds") && is(b, "MxBounds")))
144 }
145 \r
146 setGeneric("omxAddEntries", function(.Object, entries) {\r
147         return(standardGeneric("omxAddEntries")) } )\r
148 \r
149 setGeneric("omxRemoveEntries", function(.Object, entries) {\r
150         return(standardGeneric("omxRemoveEntries")) } ) \r
151         \r
152 froms <- function(lst) {
153   retval <- lapply(lst, function(x) { return(x$from) } )\r
154   return(retval)\r
155 }       \r
156 \r
157 tos <- function(lst) {
158   retval <- lapply(lst, function(x) { return(x$to) } )\r
159   return(retval)\r
160 }       \r
161 \r
162 omxMappend <- function(...) {\r
163     args <- list(...)\r
164         return(mappendHelper(args, list()))\r
165 }\r
166 \r
167 mappendHelper <- function(lst, result) {\r
168         if (length(lst) == 0) {\r
169                 return(result)\r
170         } else if (length(lst) == 1) {
171                 len <- length(result)
172                 addition <- lst[[1]]
173                 if (is.list(addition)) {
174                         result <- append(result, addition)
175                 } else {
176                         result[[len + 1]] <- addition
177                 }
178                 return(result)\r
179         } else {
180                 len <- length(result)
181                 addition <- lst[[1]]
182                 if (is.list(addition)) {
183                         result <- append(result, addition)
184                 } else {
185                         result[[len + 1]] <- addition
186                 }
187                 return(mappendHelper(lst[2:length(lst)], result))\r
188         }
189 }\r
190 \r
191 omxModel <- function(model = NA, ..., name = NA, manifestVars = NA,
192         latentVars = NA, remove = FALSE, independent = NA) {
193     first <- NULL
194         if(typeof(model) != "S4" && is.na(model)) {\r
195                 model <- new("MxModel") \r
196         } else if (typeof(model) == "character") {
197                 model <- new("MxModel", name = model)
198         } else if(!is(model, "MxModel")) {
199                 if(isS4(model)) {
200                         first <- model
201                 } else {
202                         first <- list(model)
203                 }
204                 model <- new("MxModel")
205         }\r
206         lst <- list(...)
207         lst <- append(lst, first)
208         if(remove == TRUE) {\r
209                 model <- omxRemoveEntries(model, mappendHelper(lst, list()))\r
210                 if ( length(manifestVars) > 1 || !is.na(manifestVars) ) {\r
211                         model@manifestVars <- setdiff(model@manifestVars, manifestVars)\r
212                 }\r
213                 if ( length(latentVars) > 1 || !is.na(latentVars) ) {\r
214                         model@latentVars <- setdiff(model@latentVars, latentVars)\r
215                 }                               \r
216         } else {\r
217                 model <- omxAddEntries(model, mappendHelper(lst, list()))\r
218                 if ( length(manifestVars) > 1 || !is.na(manifestVars) ) {\r
219                         tmp <- append(model@manifestVars, manifestVars)\r
220                         model@manifestVars <- unique(tmp)\r
221                 }\r
222                 if (length(latentVars) > 1 || !is.na(latentVars)) {\r
223                         tmp <- append(model@latentVars, latentVars)\r
224                         model@latentVars <- unique(tmp)\r
225                 }               \r
226         }
227         if(!is.na(independent)) {
228                 model@independent <- independent
229         }
230         if(!is.na(name)) {
231                 model@name <- name
232         }                       \r
233         return(model)\r
234 }\r
235 \r
236 omxAddFilter <- function(entries, paths, namedEntities) {\r
237         if (length(entries) == 0) {\r
238                 return(list(paths, namedEntities))\r
239         }\r
240         head <- entries[[1]]
241         pLength <- length(paths)
242         nLength <- length(namedEntities)
243         if (is.null(head)) {
244         } else if(omxIsPath(head)) {
245                 paths[[pLength + 1]] <- head
246         } else if(isS4(head) && ("name" %in% slotNames(head))) {
247                 namedEntities[[nLength + 1]] <- head
248         } else {\r
249                 stop("Add method accepts only paths or named entities")\r
250         }\r
251         return(omxAddFilter(entries[-1], paths, namedEntities))\r
252 }\r
253
254 omxRemoveFilter <- function(entries, paths, names) {\r
255         if (length(entries) == 0) {\r
256                 return(list(paths, names))\r
257         }\r
258         head <- entries[[1]]
259         pLength <- length(paths)
260         nLength <- length(names)
261         if (is.null(head)) {
262         } else if(omxIsPath(head)) {
263                 paths[[pLength + 1]] <- head
264         } else if(is.character(head) && (length(head) == 1)) {
265                 names[[nLength + 1]] <- head
266         } else {\r
267                 stop("Remove method accepts only paths or names")\r
268         }\r
269         return(omxRemoveFilter(entries[-1], paths, names))\r
270 }
271         \r
272 setMethod("omxAddEntries", "MxModel", \r
273         function(.Object, entries) {\r
274                 if (length(entries) < 1) {\r
275                         return(.Object)\r
276                 }
277                 tuple <- omxAddFilter(entries, list(), list())\r
278                 paths         <- tuple[[1]]
279                 namedEntities <- tuple[[2]]
280                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
281                         stop("The \'from\' field or the \'to\' field contains an NA")\r
282                 }\r
283                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
284                         .Object <- omxAddSinglePath(.Object, paths[[i]])\r
285                 }\r
286                 if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {\r
287                         .Object <- omxAddSingleNamedEntity(.Object, namedEntities[[i]])\r
288                 }\r
289                 return(.Object)\r
290         }\r
291 )\r
292 \r
293 setMethod("omxRemoveEntries", "MxModel", \r
294         function(.Object, entries) {\r
295                 if (length(entries) < 1) {\r
296                         return(.Object)\r
297                 }\r
298                 tuple <- omxRemoveFilter(entries, list(), list())
299                 paths <- tuple[[1]]
300                 names <- tuple[[2]]
301                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
302                         stop("The \'from\' field or the \'to\' field contains an NA")\r
303                 }               \r
304                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
305                         .Object <- omxRemoveSinglePath(.Object, paths[[i]])\r
306                 }\r
307                 if (length(names) > 0) for(i in 1:length(names)) {\r
308                         .Object <- omxRemoveSingleNamedEntity(.Object, names[[i]])\r
309                 }\r
310                 return(.Object)\r
311         }\r
312 )
313
314 omxAddSingleNamedEntity <- function(.Object, entity) {
315         .Object[[entity@name]] <- entity
316         return(.Object)
317 }
318
319 \r
320 omxAddSinglePath <- function(.Object, path) {\r
321         if (nrow(.Object@paths) > 0) {\r
322                 fromExists <- (.Object@paths['from'] == path[['from']])\r
323                 toExists <- (.Object@paths['to'] == path[['to']])\r
324                 replace <- any(fromExists & toExists, na.rm=TRUE)\r
325                 morfExists <- (.Object@paths['from'] == path[['to']])\r
326                 otExists <- (.Object@paths['to'] == path[['from']])\r
327                 oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
328                 if (oppositeExists) {\r
329                         newArrow <- !is.null(path[['arrows']])\r
330                         oldArrow <- !is.null(.Object@paths[morfExists & otExists,'arrows'])\r
331                         if (oldArrow && .Object@paths[morfExists & otExists,'arrows'] == 2) {\r
332                                         fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
333                                         toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
334                                         fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
335                                         .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
336                                         .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
337                                         .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
338                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
339                                         toExists <- (.Object@paths['to'] == path[['to']])\r
340                                         replace <- TRUE\r
341                         } else if (newArrow && path[['arrows']] == 2) {\r
342                                         tmp <- path[['from']]\r
343                                         path[['from']] <- path[['to']]\r
344                                         path[['to']] <- tmp\r
345                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
346                                         toExists <- (.Object@paths['to'] == path[['to']])\r
347                                         replace <- TRUE\r
348                         }\r
349                 }\r
350                 if (replace) {\r
351                         ids <- names(path)                      \r
352                         for(i in 1:length(path)) {\r
353                                 id <- ids[[i]]\r
354                                 .Object@paths[fromExists & toExists,id] <- path[[id]]\r
355                         }\r
356                 } else {\r
357                         .Object@paths <- merge(.Object@paths, \r
358                                 data.frame(path, stringsAsFactors = FALSE), all=TRUE)\r
359                 }\r
360         } else {\r
361                 .Object@paths <- data.frame(path, stringsAsFactors = FALSE)\r
362         }\r
363         fromExists <- (.Object@paths['from'] == path[['from']])\r
364         toExists <- (.Object@paths['to'] == path[['to']])\r
365         field <- .Object@paths[fromExists & toExists, 'arrows']\r
366         if (!is.null(field) && !is.na(field)  \r
367                         && (field == 2) \r
368                         && (path[['from']] > path[['to']])) {\r
369                 fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
370                 toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
371                 fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
372                 .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
373                 .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
374                 .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
375         }       \r
376         return(.Object)\r
377 }\r
378 \r
379 omxRemoveSinglePath <- function(.Object, path) {\r
380         if (nrow(.Object@paths) > 0) {\r
381                 .Object@paths <- subset(.Object@paths, to != path[['to']] | from != path[['from']])\r
382                 if (nrow(.Object@paths) > 0) {          \r
383                         morfExists <- (.Object@paths['from'] == path[['to']])\r
384                         otExists <- (.Object@paths['to'] == path[['from']])\r
385                         oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
386                         if (oppositeExists) {\r
387                                 check1 <- !is.null(path[['arrows']]) && path[['arrows']] == 2\r
388                                 check2 <- !is.null(.Object@paths[morfExists & otExists,'arrows']) &&\r
389                                                         .Object@paths[morfExists & otExists,'arrows'] == 2\r
390                                 if (check1 || check2) {\r
391                                         .Object@paths <- subset(.Object@paths, \r
392                                                 to != path[['from']] | from != path[['to']])\r
393                                 }\r
394                         }\r
395                 }               \r
396         }               \r
397         return(.Object)\r
398 }\r
399
400 omxRemoveSingleNamedEntity <- function(.Object, name) {
401         .Object[[name]] <- NULL
402         return(.Object)
403 }
404
405 \r
406 mxModel <- function(model = NA, ..., 
407         manifestVars = NA, latentVars = NA, 
408         remove = FALSE, independent = NA, name = NA) {\r
409                 omxModel(model, ..., name = name, 
410                 manifestVars = manifestVars, 
411                 latentVars = latentVars,
412                 remove = remove, 
413                 independent = independent)\r
414 }