Implemented MxData object, but now SimpleCovariance
[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 #setMethod("$", "MxModel",
137 #       function(x, name) {
138 #               return(omxExtractMethod(x, name))
139 #       }
140 #)
141 #
142 #setReplaceMethod("$", "MxModel",
143 #       function(x, name, value) {
144 #               return(omxReplaceMethod(x, name, value))
145 #       }
146 #)\r
147
148 omxSameType <- function(a, b) {
149         return( (is(a, "MxModel") && is(b, "MxModel")) ||
150                         (is(a, "MxMatrix") && is(b, "MxMatrix")) ||
151                         (is(a, "MxAlgebra") && is(b, "MxAlgebra")) ||
152                         (is(a, "MxObjective") && is(b, "MxObjective")) ||
153                         (is(a, "MxConstraint") && is(b, "MxConstraint")) ||
154                         (is(a, "MxData") && is(b, "MxData")) ||
155                         (is(a, "MxBounds") && is(b, "MxBounds")))
156 }
157 \r
158 setGeneric("omxAddEntries", function(.Object, entries) {\r
159         return(standardGeneric("omxAddEntries")) } )\r
160 \r
161 setGeneric("omxRemoveEntries", function(.Object, entries) {\r
162         return(standardGeneric("omxRemoveEntries")) } ) \r
163         \r
164 froms <- function(lst) {
165   retval <- lapply(lst, function(x) { return(x$from) } )\r
166   return(retval)\r
167 }       \r
168 \r
169 tos <- function(lst) {
170   retval <- lapply(lst, function(x) { return(x$to) } )\r
171   return(retval)\r
172 }       \r
173 \r
174 omxMappend <- function(...) {\r
175     args <- list(...)\r
176         return(mappendHelper(args, list()))\r
177 }\r
178 \r
179 mappendHelper <- function(lst, result) {\r
180         if (length(lst) == 0) {\r
181                 return(result)\r
182         } else if (length(lst) == 1) {
183                 len <- length(result)
184                 addition <- lst[[1]]
185                 if (is.list(addition)) {
186                         result <- append(result, addition)
187                 } else {
188                         result[[len + 1]] <- addition
189                 }
190                 return(result)\r
191         } else {
192                 len <- length(result)
193                 addition <- lst[[1]]
194                 if (is.list(addition)) {
195                         result <- append(result, addition)
196                 } else {
197                         result[[len + 1]] <- addition
198                 }
199                 return(mappendHelper(lst[2:length(lst)], result))\r
200         }
201 }\r
202 \r
203 omxModel <- function(model = NA, ..., name = NA, manifestVars = NA,
204         latentVars = NA, remove = FALSE, independent = NA) {
205     first <- NULL
206         if(typeof(model) != "S4" && is.na(model)) {\r
207                 model <- new("MxModel") \r
208         } else if (typeof(model) == "character") {
209                 model <- new("MxModel", name = model)
210         } else if(!is(model, "MxModel")) {
211                 first <- model
212                 model <- new("MxModel")
213         }\r
214         lst <- list(...)
215         lst <- append(lst, first)
216         if(remove == TRUE) {\r
217                 model <- omxRemoveEntries(model, mappendHelper(lst, list()))\r
218                 if ( length(manifestVars) > 1 || !is.na(manifestVars) ) {\r
219                         model@manifestVars <- setdiff(model@manifestVars, manifestVars)\r
220                 }\r
221                 if ( length(latentVars) > 1 || !is.na(latentVars) ) {\r
222                         model@latentVars <- setdiff(model@latentVars, latentVars)\r
223                 }                               \r
224         } else {\r
225                 model <- omxAddEntries(model, mappendHelper(lst, list()))\r
226                 if ( length(manifestVars) > 1 || !is.na(manifestVars) ) {\r
227                         tmp <- append(model@manifestVars, manifestVars)\r
228                         model@manifestVars <- unique(tmp)\r
229                 }\r
230                 if (length(latentVars) > 1 || !is.na(latentVars)) {\r
231                         tmp <- append(model@latentVars, latentVars)\r
232                         model@latentVars <- unique(tmp)\r
233                 }               \r
234         }
235         if(!is.na(independent)) {
236                 model@independent <- independent
237         }
238         if(!is.na(name)) {
239                 model@name <- name
240         }                       \r
241         return(model)\r
242 }\r
243 \r
244 omxAddFilter <- function(entries, paths, namedEntities) {\r
245         if (length(entries) == 0) {\r
246                 return(list(paths, namedEntities))\r
247         }\r
248         head <- entries[[1]]
249         pLength <- length(paths)
250         nLength <- length(namedEntities)
251         if (is.null(head)) {
252         } else if(omxIsPath(head)) {
253                 paths[[pLength + 1]] <- head
254         } else if(isS4(head) && ("name" %in% slotNames(head))) {
255                 namedEntities[[nLength + 1]] <- head
256         } else {\r
257                 stop("Add method accepts only paths or named entities")\r
258         }\r
259         return(omxAddFilter(entries[-1], paths, namedEntities))\r
260 }\r
261
262 omxRemoveFilter <- function(entries, paths, names) {\r
263         if (length(entries) == 0) {\r
264                 return(list(paths, names))\r
265         }\r
266         head <- entries[[1]]
267         pLength <- length(paths)
268         nLength <- length(names)
269         if (is.null(head)) {
270         } else if(omxIsPath(head)) {
271                 paths[[pLength + 1]] <- head
272         } else if(is.character(head) && (length(head) == 1)) {
273                 names[[nLength + 1]] <- head
274         } else {\r
275                 stop("Remove method accepts only paths or names")\r
276         }\r
277         return(omxRemoveFilter(entries[-1], paths, names))\r
278 }
279         \r
280 setMethod("omxAddEntries", "MxModel", \r
281         function(.Object, entries) {\r
282                 if (length(entries) < 1) {\r
283                         return(.Object)\r
284                 }
285                 tuple <- omxAddFilter(entries, list(), list())\r
286                 paths         <- tuple[[1]]
287                 namedEntities <- tuple[[2]]
288                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
289                         stop("The \'from\' field or the \'to\' field contains an NA")\r
290                 }\r
291                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
292                         .Object <- omxAddSinglePath(.Object, paths[[i]])\r
293                 }\r
294                 if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {\r
295                         .Object <- omxAddSingleNamedEntity(.Object, namedEntities[[i]])\r
296                 }\r
297                 return(.Object)\r
298         }\r
299 )\r
300 \r
301 setMethod("omxRemoveEntries", "MxModel", \r
302         function(.Object, entries) {\r
303                 if (length(entries) < 1) {\r
304                         return(.Object)\r
305                 }\r
306                 tuple <- omxRemoveFilter(entries, list(), list())
307                 paths <- tuple[[1]]
308                 names <- tuple[[2]]
309                 if (any(is.na(froms(paths))) || any(is.na(tos(paths)))) {\r
310                         stop("The \'from\' field or the \'to\' field contains an NA")\r
311                 }               \r
312                 if (length(paths) > 0) for(i in 1:length(paths)) {\r
313                         .Object <- omxRemoveSinglePath(.Object, paths[[i]])\r
314                 }\r
315                 if (length(names) > 0) for(i in 1:length(names)) {\r
316                         .Object <- omxRemoveSingleNamedEntity(.Object, names[[i]])\r
317                 }\r
318                 return(.Object)\r
319         }\r
320 )
321
322 omxAddSingleNamedEntity <- function(.Object, entity) {
323         .Object[[entity@name]] <- entity
324         return(.Object)
325 }
326
327 \r
328 omxAddSinglePath <- function(.Object, path) {\r
329         if (nrow(.Object@paths) > 0) {\r
330                 fromExists <- (.Object@paths['from'] == path[['from']])\r
331                 toExists <- (.Object@paths['to'] == path[['to']])\r
332                 replace <- any(fromExists & toExists, na.rm=TRUE)\r
333                 morfExists <- (.Object@paths['from'] == path[['to']])\r
334                 otExists <- (.Object@paths['to'] == path[['from']])\r
335                 oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
336                 if (oppositeExists) {\r
337                         newArrow <- !is.null(path[['arrows']])\r
338                         oldArrow <- !is.null(.Object@paths[morfExists & otExists,'arrows'])\r
339                         if (oldArrow && .Object@paths[morfExists & otExists,'arrows'] == 2) {\r
340                                         fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
341                                         toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
342                                         fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
343                                         .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
344                                         .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
345                                         .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
346                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
347                                         toExists <- (.Object@paths['to'] == path[['to']])\r
348                                         replace <- TRUE\r
349                         } else if (newArrow && path[['arrows']] == 2) {\r
350                                         tmp <- path[['from']]\r
351                                         path[['from']] <- path[['to']]\r
352                                         path[['to']] <- tmp\r
353                                         fromExists <- (.Object@paths['from'] == path[['from']])\r
354                                         toExists <- (.Object@paths['to'] == path[['to']])\r
355                                         replace <- TRUE\r
356                         }\r
357                 }\r
358                 if (replace) {\r
359                         ids <- names(path)                      \r
360                         for(i in 1:length(path)) {\r
361                                 id <- ids[[i]]\r
362                                 .Object@paths[fromExists & toExists,id] <- path[[id]]\r
363                         }\r
364                 } else {\r
365                         .Object@paths <- merge(.Object@paths, \r
366                                 data.frame(path, stringsAsFactors = FALSE), all=TRUE)\r
367                 }\r
368         } else {\r
369                 .Object@paths <- data.frame(path, stringsAsFactors = FALSE)\r
370         }\r
371         fromExists <- (.Object@paths['from'] == path[['from']])\r
372         toExists <- (.Object@paths['to'] == path[['to']])\r
373         field <- .Object@paths[fromExists & toExists, 'arrows']\r
374         if (!is.null(field) && !is.na(field)  \r
375                         && (field == 2) \r
376                         && (path[['from']] > path[['to']])) {\r
377                 fromTemp <- as.vector(.Object@paths[morfExists & otExists,'from'])\r
378                 toTemp <- as.vector(.Object@paths[morfExists & otExists,'to'])\r
379                 fUnique <- lapply(.Object@paths['from'], paste, collapse='')[[1]]\r
380                 .Object@paths[morfExists & otExists, 'from'] <- fUnique\r
381                 .Object@paths[.Object@paths['from'] == fUnique, 'to'] <- fromTemp\r
382                 .Object@paths[.Object@paths['from'] == fUnique, 'from'] <- toTemp\r
383         }       \r
384         return(.Object)\r
385 }\r
386 \r
387 omxRemoveSinglePath <- function(.Object, path) {\r
388         if (nrow(.Object@paths) > 0) {\r
389                 .Object@paths <- subset(.Object@paths, to != path[['to']] | from != path[['from']])\r
390                 if (nrow(.Object@paths) > 0) {          \r
391                         morfExists <- (.Object@paths['from'] == path[['to']])\r
392                         otExists <- (.Object@paths['to'] == path[['from']])\r
393                         oppositeExists <- any(morfExists & otExists, na.rm=TRUE)\r
394                         if (oppositeExists) {\r
395                                 check1 <- !is.null(path[['arrows']]) && path[['arrows']] == 2\r
396                                 check2 <- !is.null(.Object@paths[morfExists & otExists,'arrows']) &&\r
397                                                         .Object@paths[morfExists & otExists,'arrows'] == 2\r
398                                 if (check1 || check2) {\r
399                                         .Object@paths <- subset(.Object@paths, \r
400                                                 to != path[['from']] | from != path[['to']])\r
401                                 }\r
402                         }\r
403                 }               \r
404         }               \r
405         return(.Object)\r
406 }\r
407
408 omxRemoveSingleNamedEntity <- function(.Object, name) {
409         .Object[[name]] <- NULL
410         return(.Object)
411 }
412
413 omxQuotes <- function(name) {
414         listTerms <- sapply(name, function(x) {paste("'", x, "'", sep = '')} )
415         return(paste(listTerms, collapse=', '))
416 }
417
418 omxDisplayModel <- function(model) {
419         cat("MxModel", omxQuotes(model@name), '\n')
420         cat("matrices :", omxQuotes(names(model@matrices)), '\n')
421         cat("algebras :", omxQuotes(names(model@algebras)), '\n')
422         cat("constraints :", omxQuotes(names(model@constraints)), '\n')
423         cat("bounds :", omxQuotes(names(model@bounds)), '\n')
424         if (length(model@paths) > 0) {
425                 cat("latentVars :", model@latentVars, '\n')
426                 cat("manifestVars :", model@manifestVars, '\n')
427                 cat("paths :", nrow(model@paths), "paths", '\n')
428         }
429         data <- model@data
430         if (is.null(data)) {
431                 cat("data : NULL\n")
432         } else {
433                 cat("data :", omxQuotes(data@name), 
434                         "matrix has dim ", nrow(data@matrix), 
435                         "x", ncol(data@matrix))
436                 if(is.na(data@vector)) {
437                         cat("; vector is NA")
438                 } else {
439                         cat("; vector has length ", length(data@vector))
440                 }
441                 cat("; data type is", data@type, '\n')
442         }
443         cat("submodels :", omxQuotes(names(model@submodels)), '\n')
444         objective <- model@objective
445         if (is.null(objective)) {
446                 objectiveType <- "NULL"
447                 objectiveName <- ""
448         } else {
449                 objectiveType <- class(objective)[[1]]
450                 objectiveName <- omxQuotes(objective@name)
451         }
452         cat("objective :", objectiveType, objectiveName, '\n')
453         cat("independent :", model@independent, '\n')
454         cat("output :", length(model@output) > 0, '\n')
455 }
456
457 setMethod("print", "MxModel", function(x,...) { omxDisplayModel(x) })
458 setMethod("show", "MxModel", function(object) { omxDisplayModel(object) })
459 \r
460 mxModel <- function(model = NA, ..., 
461         manifestVars = NA, latentVars = NA, 
462         remove = FALSE, independent = NA, name = NA) {\r
463                 omxModel(model, ..., name = name, 
464                 manifestVars = manifestVars, 
465                 latentVars = latentVars,
466                 remove = remove, 
467                 independent = independent)\r
468 }\r
469 \r