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