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