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