Added more documentation. Switched the order of arguments
[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 = matrix(0, 0, 0), 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     first <- NULL
165         if(is.null(model)) {\r
166                 model <- new("MxModel") \r
167         } else if (typeof(model) == "character") {
168                 model <- new("MxModel", name = model)
169         } else if(!is(model, "MxModel")) {
170                 first <- model
171             model <- new("MxModel")
172         }\r
173         lst <- list(...)
174     lst <- append(lst, first)
175         if(class(model)[[1]] != "MxModel") {\r
176                 stop("First argument is not an MxModel object")\r
177         }\r
178         if(remove == TRUE) {\r
179                 model <- omxRemoveEntries(model, mappendHelper(lst, list()))\r
180                 if ( !is.null(manifestVars) ) {\r
181                         model@manifestVars <- setdiff(model@manifestVars, manifestVars)\r
182                 }\r
183                 if ( !is.null(latentVars) ) {\r
184                         model@latentVars <- setdiff(model@latentVars, latentVars)\r
185                 }                               \r
186         } else {\r
187                 model <- omxAddEntries(model, mappendHelper(lst, list()))\r
188                 if ( !is.null(manifestVars) ) {\r
189                         tmp <- append(model@manifestVars, manifestVars)\r
190                         model@manifestVars <- unique(tmp)\r
191                 }\r
192                 if ( !is.null(latentVars) ) {\r
193                         tmp <- append(model@latentVars, latentVars)\r
194                         model@latentVars <- unique(tmp)\r
195                 }               \r
196         }
197         if(!is.null(independent)) {
198                 model@independent <- independent
199         }
200         if(!is.null(name)) {
201                 model@name <- name
202         }                       \r
203         return(model)\r
204 }\r
205 \r
206 filterEntries <- function(entries, paths, namedEntities, 
207         objectives, data) {\r
208         if (length(entries) == 0) {\r
209                 return(list(paths, namedEntities,
210                         objectives, data))\r
211         }\r
212         head <- entries[[1]]
213         pLength   <- length(paths)
214         nLength   <- length(namedEntities)
215         oLength   <- length(objectives)
216         dLength   <- length(data)
217         if (is.null(head)) {
218     } else if (is(head, "MxObjective")) {
219         objectives[[oLength + 1]] <- head
220     } else if (is(head, "MxData")) {
221                 data[[dLength + 1]] <- head
222         } else if(omxIsPath(head)) {
223                 paths[[pLength + 1]] <- head
224         } else if(isS4(head) && ("name" %in% slotNames(head))) {
225                 namedEntities[[nLength + 1]] <- head
226         } else {\r
227                 stop(paste("Unknown object:", head))\r
228         }\r
229         return(filterEntries(entries[-1], paths, namedEntities, 
230                 objectives, data))\r
231 }\r
232         \r
233 setMethod("omxAddEntries", "MxModel", \r
234         function(.Object, entries) {\r
235                 if (length(entries) < 1) {\r
236                         return(.Object)\r
237                 }
238                 tuple <- filterEntries(entries, list(), list(), list(), list())\r
239                 paths         <- tuple[[1]]
240                 namedEntities <- tuple[[2]]
241                 objectives    <- tuple[[3]]
242                 data          <- tuple[[4]]
243                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
244                         stop("The \'from\' field or the \'to\' field contains an NA")\r
245                 }\r
246                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
247                         .Object <- omxAddSinglePath(.Object, paths[[i]])\r
248                 }\r
249                 if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {\r
250                         .Object <- omxAddSingleNamedEntity(.Object, namedEntities[[i]])\r
251                 }\r
252                 if (length(objectives) > 0) .Object <- omxAddObjectives(.Object, objectives)
253                 if (length(data) > 0) .Object <- omxAddData(.Object, data)\r
254                 return(.Object)\r
255         }\r
256 )\r
257 \r
258 setMethod("omxRemoveEntries", "MxModel", \r
259         function(.Object, entries) {\r
260                 if (length(entries) < 1) {\r
261                         return(.Object)\r
262                 }\r
263                 tuple <- filterEntries(entries, list(), list(), list(), list())
264                 paths         <- tuple[[1]]
265                 namedEntities <- tuple[[2]]
266                 objectives    <- tuple[[3]]
267                 data          <- tuple[[4]]
268                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
269                         stop("The \'from\' field or the \'to\' field contains an NA")\r
270                 }               \r
271                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
272                         .Object <- omxRemoveSinglePath(.Object, paths[[i]])\r
273                 }\r
274                 if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {\r
275                         .Object <- omxRemoveSingleNamedEntity(.Object, namedEntities[[i]])\r
276                 }\r
277                 if (length(objectives) > 0) {
278                         .Object@objective <- NULL
279                 }
280                 if (length(data) > 0) {
281                         .Object@data <- NULL
282                 }\r
283                 return(.Object)\r
284         }\r
285 )
286
287 omxAddSingleNamedEntity <- function(.Object, entity) {
288         .Object[[entity@name]] <- entity
289         return(.Object)
290 }
291
292 \r
293 omxAddSinglePath <- function(.Object, path) {\r
294         if (nrow(.Object@paths) > 0) {\r
295                 fromExists <- (.Object@paths['from'] == path[['from']])\r
296                 toExists <- (.Object@paths['to'] == path[['to']])\r
297                 replace <- any(fromExists & toExists, na.rm=TRUE)\r
298                 morfExists <- (.Object@paths['from'] == path[['to']])\r
299                 otExists <- (.Object@paths['to'] == path[['from']])\r
300                 oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
301                 if (oppositeExists) {\r
302                         newArrow <- !is.null(path[['arrows']])\r
303                         oldArrow <- !is.null(.Object@paths[morfExists & otExists,'arrows'])\r
304                         if (oldArrow && .Object@paths[morfExists & otExists,'arrows'] == 2) {\r
305                                         fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
306                                         toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
307                                         fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
308                                         .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
309                                         .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
310                                         .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
311                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
312                                         toExists <- (.Object@paths['to'] == path[['to']])\r
313                                         replace <- TRUE\r
314                         } else if (newArrow && path[['arrows']] == 2) {\r
315                                         tmp <- path[['from']]\r
316                                         path[['from']] <- path[['to']]\r
317                                         path[['to']] <- tmp\r
318                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
319                                         toExists <- (.Object@paths['to'] == path[['to']])\r
320                                         replace <- TRUE\r
321                         }\r
322                 }\r
323                 if (replace) {\r
324                         ids <- names(path)                      \r
325                         for(i in 1:length(path)) {\r
326                                 id <- ids[[i]]\r
327                                 .Object@paths[fromExists & toExists,id] <- path[[id]]\r
328                         }\r
329                 } else {\r
330                         .Object@paths <- merge(.Object@paths, \r
331                                 data.frame(path, stringsAsFactors = FALSE), all=TRUE)\r
332                 }\r
333         } else {\r
334                 .Object@paths <- data.frame(path, stringsAsFactors = FALSE)\r
335         }\r
336         fromExists <- (.Object@paths['from'] == path[['from']])\r
337         toExists <- (.Object@paths['to'] == path[['to']])\r
338         field <- .Object@paths[fromExists & toExists, 'arrows']\r
339         if (!is.null(field) && !is.na(field)  \r
340                         && (field == 2) \r
341                         && (path[['from']] > path[['to']])) {\r
342                 fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
343                 toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
344                 fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
345                 .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
346                 .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
347                 .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
348         }       \r
349         return(.Object)\r
350 }\r
351 \r
352 omxRemoveSinglePath <- function(.Object, path) {\r
353         if (nrow(.Object@paths) > 0) {\r
354                 .Object@paths <- subset(.Object@paths, to != path[['to']] | from != path[['from']])\r
355                 if (nrow(.Object@paths) > 0) {          \r
356                         morfExists <- (.Object@paths['from'] == path[['to']])\r
357                         otExists <- (.Object@paths['to'] == path[['from']])\r
358                         oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
359                         if (oppositeExists) {\r
360                                 check1 <- !is.null(path[['arrows']]) && path[['arrows']] == 2\r
361                                 check2 <- !is.null(.Object@paths[morfExists & otExists,'arrows']) &&\r
362                                                         .Object@paths[morfExists & otExists,'arrows'] == 2\r
363                                 if (check1 || check2) {\r
364                                         .Object@paths <- subset(.Object@paths, \r
365                                                 to != path[['from']] | from != path[['to']])\r
366                                 }\r
367                         }\r
368                 }               \r
369         }               \r
370         return(.Object)\r
371 }\r
372
373 omxRemoveSingleNamedEntity <- function(.Object, entity) {
374         .Object[[entity@name]] <- NULL
375         return(.Object)
376 }
377
378 omxAddObjectives <- function(.Object, objectives) {
379         if (length(objectives) > 1) {
380                 warning("Multiple objective functions were specified; the first one will be used")
381         }
382         objective <- objectives[[1]]
383         .Object[[objective@name]] <- objective
384         return(.Object)
385 }
386
387 omxAddData <- function(.Object, dataset) {
388         if (length(dataset) > 1) {
389                 warning("Multiple datasets were specified; the first one will be used")
390         }
391         data <- dataset[[1]]
392         .Object@data <- data
393         return(.Object)
394 }
395
396 omxQuotes <- function(name) {
397         listTerms <- sapply(name, function(x) {paste("'", x, "'", sep = '')} )
398         return(paste(listTerms, collapse=', '))
399 }
400
401 omxDisplayModel <- function(model) {
402         cat("MxModel", omxQuotes(model@name), '\n')
403         cat("matrices :", omxQuotes(names(model@matrices)), '\n')
404         cat("algebras :", omxQuotes(names(model@algebras)), '\n')
405         cat("constraints :", omxQuotes(names(model@constraints)), '\n')
406         cat("bounds :", omxQuotes(names(model@bounds)), '\n')
407         if (length(model@paths) > 0) {
408                 cat("latentVars :", model@latentVars, '\n')
409                 cat("manifestVars :", model@manifestVars, '\n')
410                 cat("paths :", nrow(model@paths), "paths", '\n')
411         }
412         if (is.null(model@data)) {
413                 cat("data : NULL\n")
414         } else {
415                 cat("data :", nrow(model@data), "x", ncol(model@data), '\n')
416         }
417         cat("submodels :", omxQuotes(names(model@submodels)), '\n')
418         objective <- model@objective
419         if (is.null(objective)) {
420                 objectiveType <- "NULL"
421                 objectiveName <- ""
422         } else {
423                 objectiveType <- class(objective)[[1]]
424                 objectiveName <- omxQuotes(objective@name)
425         }
426         cat("objective :", objectiveType, objectiveName, '\n')
427         cat("independent :", model@independent, '\n')
428         cat("output :", length(model@output) > 0, '\n')
429 }
430
431 setMethod("print", "MxModel", function(x,...) { omxDisplayModel(x) })
432 setMethod("show", "MxModel", function(object) { omxDisplayModel(object) })
433 \r
434 mxModel <- function(model = NULL, ..., 
435         manifestVars = NULL,latentVars = NULL, 
436         remove = FALSE, independent = NULL, name = NULL) {\r
437                 omxModel(model, ..., name = name, 
438                 manifestVars = manifestVars, 
439                 latentVars = latentVars,
440                 remove = remove, 
441                 independent = independent)\r
442 }\r
443 \r