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