Reverting to revision 1880
[openmx:openmx.git] / R / MxModel.R
1 #
2 #   Copyright 2007-2010 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",
18         representation = representation(
19                 name = "character",
20                 matrices = "list",
21                 algebras = "list",
22                 constraints = "list",
23                 intervals = "list",
24                 latentVars = "character",
25                 manifestVars = "character",
26                 data = "MxData",
27                 submodels = "list",
28                 objective = "MxObjective",
29                 independent = "logical",
30                 options = "list",
31                 output = "list",
32                 runstate = "list",
33                 .forcesequential = "logical",
34                 .newobjects = "logical",
35                 .newobjective = "logical",
36                 .newtree = "logical",
37         .resetdata = "logical"
38 ))
39
40 imxModelTypes[['default']] <- "MxModel"
41
42 setMethod("initialize", "MxModel",
43         function(.Object, name = character()) {
44                 .Object@name <- name
45                 .Object@latentVars <- character()
46                 .Object@manifestVars <- character()
47                 .Object@matrices <- list()
48                 .Object@algebras <- list()
49                 .Object@constraints <- list()
50                 .Object@data <- NULL
51                 .Object@submodels <- list()
52                 .Object@objective <- NULL
53                 .Object@independent <- FALSE
54                 .Object@options <- list()
55                 .Object@output <- list()
56                 .Object@runstate <- list()
57                 .Object@.newobjects <- FALSE
58                 .Object@.newobjective <- FALSE
59                 .Object@.newtree <- FALSE
60                 .Object@.resetdata <- FALSE
61                 .Object <- imxInitModel(.Object)
62                 return(.Object)
63         }
64 )
65
66 # Begin declaration of generics
67
68 setGeneric("imxInitModel", function(model) {
69         return(standardGeneric("imxInitModel")) } )
70
71 setGeneric("imxModelBuilder", function(model, lst, name, 
72         manifestVars, latentVars, remove, independent) {
73         return(standardGeneric("imxModelBuilder")) } )
74
75 setGeneric("imxTypeName", function(model) { 
76         return(standardGeneric("imxTypeName")) 
77 })
78
79 setGeneric("imxVerifyModel", function(model) {
80     return(standardGeneric("imxVerifyModel"))
81 })
82
83 # End declaration of generics
84
85 generateParentNames <- function(model) {
86         retval <- generateLocalNames(model)
87         if (length(model@submodels) > 0) {
88                 retval <- union(retval, names(model@submodels))
89                 childNames <- unlist(lapply(model@submodels, generateChildNames))
90                 retval <- union(retval, childNames)
91         }
92         return(retval)
93 }
94
95 generateChildNames <- function(model) {
96         retval <- generateLocalNames(model)     
97         if (!is.null(retval)) {
98                 retval <- paste(model@name, retval, sep = ".")
99         }
100         if (length(model@submodels) > 0) {
101                 retval <- union(retval, names(model@submodels))
102                 childNames <- unlist(lapply(model@submodels, generateChildNames))
103                 retval <- union(retval, childNames)
104         }
105         return(retval)
106 }
107
108 generateLocalNames <- function(model) {
109         matrices <- names(model@matrices)
110         algebras <- names(model@algebras)
111         constraints <- names(model@constraints)
112         retval <- union(matrices, algebras)
113         retval <- union(retval, constraints)
114         if (!is.null(model@objective)) {
115                 retval <- union(retval, model@objective@name)
116         }
117         if (!is.null(model@data)) {
118                 retval <- union(retval, model@data@name)
119         }
120         return(retval)
121 }
122
123 setMethod("names", "MxModel",
124         function(x) {
125                 generateParentNames(x)
126         }
127 )
128
129 setMethod("[[", "MxModel",
130         function(x, i, j, ..., drop = FALSE) {
131                 return(imxExtractMethod(x, i))
132         }
133 )
134
135 setReplaceMethod("[[", "MxModel",
136         function(x, i, j, value) {
137                 return(imxReplaceMethod(x, i, value))
138         }
139 )
140
141 setMethod("$", "MxModel",
142         function(x, name) {
143                 return(imxExtractMethod(x, name))
144         }
145 )
146
147 setReplaceMethod("$", "MxModel",
148         function(x, name, value) {
149                 return(imxReplaceMethod(x, name, value))
150         }
151 )
152
153 imxExtractMethod <- function(model, index) {
154         if (is.null(index)) {
155                 return(NULL)
156     }
157         if (!(length(index) == 1 && is.character(index))) {
158                 msg <- paste("The argument to the '$' or '['",
159                         "operator applied on a MxModel object",
160                         "must be a single character string")
161                 stop(msg, call. = FALSE)
162         }
163         return(namespaceSearch(model, index))
164 }
165
166 imxReplaceMethod <- function(model, index, value) {
167         return(namespaceSearchReplace(model, index, value))
168 }
169
170 imxSameType <- function(a, b) {
171         return( (is(a, "MxModel") && is(b, "MxModel")) ||
172                         (is(a, "MxMatrix") && is(b, "MxMatrix")) ||
173                         (is(a, "MxAlgebra") && is(b, "MxAlgebra")) ||
174                         (is(a, "MxObjective") && is(b, "MxObjective")) ||
175                         (is(a, "MxConstraint") && is(b, "MxConstraint")) ||
176                         (is(a, "MxData") && is(b, "MxData")))
177 }
178
179 mxModel <- function(model = NA, ..., manifestVars = NA, latentVars = NA,
180         remove = FALSE, independent = NA, type = NA, name = NA) {
181         retval <- firstArgument(model, name)
182         first <- retval[[1]]
183         model <- retval[[2]]
184         name  <- retval[[3]]
185         model <- typeArgument(model, type)
186         lst <- c(first, list(...))
187         lst <- unlist(lst)
188         model <- imxModelBuilder(model, lst, name, manifestVars,
189                 latentVars, remove, independent)
190         return(model)
191 }
192
193 firstArgument <- function(model, name) {
194         first <- NULL
195         defaultType <- imxModelTypes[[getOption("mxDefaultType")]]
196         if (is(model, "MxModel")) {
197         } else {
198                 if (single.na(model)) {
199                 } else if (typeof(model) == "character") {
200                         name <- model
201                 } else if (isS4(model)) {
202                         first <- model
203                 } else {
204                         first <- list(model)
205                 }
206                 if (length(name) > 0 && is.na(name)) {
207                         name <- imxUntitledName()
208                 }
209                 imxVerifyName(name, -1)
210                 model <- new(defaultType, name)
211         }
212         return(list(first, model, name))
213 }
214
215 typeArgument <- function(model, type) {
216         if (!is.na(type)) {
217                 if (is.null(imxModelTypes[[type]])) {
218                         stop(paste("The model type", omxQuotes(type), 
219                                 "is not in the the list of acceptable types:",
220                                 omxQuotes(names(imxModelTypes))), call. = FALSE)
221                 }
222                 typename <- imxModelTypes[[type]]
223                 class(model) <- typename
224                 model <- imxInitModel(model)
225         }
226         return(model)
227 }
228
229 imxGenericModelBuilder <- function(model, lst, name, 
230         manifestVars, latentVars, remove, independent) {
231         model <- variablesArgument(model, manifestVars, latentVars, remove)
232         model <- listArgument(model, lst, remove)
233         model <- independentArgument(model, independent)
234         model <- nameArgument(model, name)
235         return(model)
236 }
237
238 variablesArgument <- function(model, manifestVars, latentVars, remove) {
239         if (single.na(manifestVars)) {
240                 manifestVars <- character()
241         }
242         if (single.na(latentVars)) {
243                 latentVars <- character()
244         }
245         if (remove == TRUE) {
246                 model <- modelRemoveVariables(model, latentVars, manifestVars)
247         } else if (length(manifestVars) + length(latentVars) > 0) {
248                 latentVars <- as.character(latentVars)
249                 manifestVars <- as.character(manifestVars)
250                 checkVariables(model, latentVars, manifestVars)
251                 model <- modelAddVariables(model, latentVars, manifestVars)
252         }
253         return(model)
254 }
255
256 listArgument <- function(model, lst, remove) {
257         if(remove == TRUE) {
258                 model <- modelRemoveEntries(model, lst)
259         } else {
260                 model <- modelAddEntries(model, lst)
261         }
262         return(model)
263 }
264
265 independentArgument <- function(model, independent) {
266         if(!is.na(independent)) {
267                 model@independent <- independent
268         }
269         return(model)
270 }
271
272 nameArgument <- function(model, name) {
273         if(!is.na(name)) {
274                 model@name <- name
275         }
276         return(model)
277 }
278
279 checkVariables <- function(model, latentVars, manifestVars) {
280         common <- intersect(latentVars, manifestVars)
281         if (length(common) > 0) {
282                 stop(paste("The following variables cannot",
283                         "be both latent and manifest:",
284                         omxQuotes(common)), call. = FALSE)
285         }
286         common <- intersect(model@latentVars, manifestVars)
287         if (length(common) > 0) {
288                 stop(paste("The following variables cannot",
289                         "be both latent and manifest:",
290                         omxQuotes(common)), call. = FALSE)
291         }
292         common <- intersect(model@manifestVars, latentVars)
293         if (length(common) > 0) {
294                 stop(paste("The following variables cannot",
295                         "be both latent and manifest",
296                         omxQuotes(common)), call. = FALSE)
297         }
298         if (any(is.na(latentVars))) {
299                 stop("NA is not allowed as a latent variable", call. = FALSE)
300         }
301         if (any(is.na(manifestVars))) {
302                 stop("NA is not allowed as a manifest variable", call. = FALSE)
303         }
304         if (length(unique(latentVars)) != length(latentVars)) {
305                 stop("The latent variables list contains duplicate elements",
306                         call. = FALSE)
307         }
308         if (length(unique(manifestVars)) != length(manifestVars)) {
309                 stop("The manifest variables list contains duplicate elements",
310
311                         call. = FALSE)
312         }
313 }
314
315 # Begin implementation of generics
316
317 setMethod("imxModelBuilder", "MxModel", imxGenericModelBuilder)
318
319 setMethod("imxInitModel", "MxModel", function(model) { 
320         return(model)
321 })
322
323 setMethod("imxTypeName", "MxModel", function(model) { 
324         return("default")
325 })
326
327 setMethod("imxVerifyModel", "MxModel", function(model) {
328     return(TRUE)
329 })
330
331 # End implementation of generics
332
333 modelAddVariables <- function(model, latent, manifest) {
334         model@latentVars   <- union(model@latentVars, latent)
335         model@manifestVars <- union(model@manifestVars, manifest)
336         return(model)
337 }
338
339 modelRemoveVariables <- function(model, latent, manifest) {
340         model@latentVars <- setdiff(model@latentVars, latent)
341         model@manifestVars <- setdiff(model@manifestVars, manifest)
342         return(model)
343 }
344         
345 modelAddEntries <- function(model, entries) {
346         if (length(entries) == 0) {
347                 return(model)
348         }
349         tuple <- modelModifyFilter(model, entries, "add")
350         namedEntities <- tuple[[1]]
351         bounds        <- tuple[[2]]
352         intervals     <- tuple[[3]]
353         intervals     <- expandIntervals(intervals)
354         names(intervals) <- sapply(intervals, slot, "reference")
355         if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {
356                 model <- addSingleNamedEntity(model, namedEntities[[i]])
357         }
358         model <- modelAddBounds(model, bounds)
359         model <- modelAddIntervals(model, intervals)
360         return(model)
361 }
362
363 modelRemoveEntries <- function(model, entries) {
364         if (length(entries) == 0) {
365                 return(model)
366         }
367         tuple <- modelModifyFilter(model, entries, "remove")
368         namedEntities <- tuple[[1]]
369         bounds        <- tuple[[2]]
370         intervals     <- tuple[[3]]
371         intervals     <- expandIntervals(intervals)     
372         names(intervals) <- sapply(intervals, slot, "reference")
373         if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {
374                 model <- removeSingleNamedEntity(model, namedEntities[[i]])
375         }
376         model <- modelRemoveBounds(model, bounds)
377         model <- modelRemoveIntervals(model, intervals)
378         return(model)
379 }
380
381 actionCorrespondingPredicate <- c('add' = 'into', 'remove' = 'from')
382
383 modelModifyFilter <- function(model, entries, action) {
384         boundsFilter <- sapply(entries, is, "MxBounds")
385         intervalFilter <- sapply(entries, is, "MxInterval")
386         namedEntityFilter <- sapply(entries, function(x) {"name" %in% slotNames(x)})
387         characterFilter <- sapply(entries, is.character)
388         pathFilter <- sapply(entries, is, "MxPath")
389         unknownFilter <- !(boundsFilter | namedEntityFilter | intervalFilter | characterFilter)
390         if (any(pathFilter)) {
391                 stop(paste("The model type of model",
392                         omxQuotes(model@name), "does not recognize paths."),
393                         call. = FALSE)
394         }
395         if (any(unknownFilter)) {
396                 stop(paste("Cannot", action, "the following item(s)", 
397                         actionCorrespondingPredicate[[action]], "the model:", 
398                         omxQuotes(entries[unknownFilter])), call. = FALSE)
399         }
400         if (any(namedEntityFilter) && action == 'remove') {
401                 stop(paste("Cannot use named entities when remove = TRUE.",
402                         "Instead give the name of the entity when removing it.",
403                         "See http://openmx.psyc.virginia.edu/wiki/mxmodel-help#Remove_an_object_from_a_model"))
404         }
405         if (any(characterFilter) && action == 'add') {
406                 stop(paste("Cannot use character vectors when remove = FALSE.",
407                         "Instead supply the named entity to the mxModel() function:",
408                         omxQuotes(entries[characterFilter])))
409         }
410         if (identical(action, 'add')) {
411                 return(list(entries[namedEntityFilter], entries[boundsFilter], entries[intervalFilter]))
412         } else if (identical(action, 'remove')) {
413                 return(list(entries[characterFilter], entries[boundsFilter], entries[intervalFilter]))
414         } else {
415                 stop(paste("Internal error, unidentified action:", omxQuotes(action)))
416         }
417 }
418
419 addSingleNamedEntity <- function(model, entity) {
420         if (model@name == entity@name) {
421                 stop(paste("You cannot insert an entity named",
422                         omxQuotes(entity@name), "into a model named",
423                         omxQuotes(model@name)), call. = FALSE)
424         }
425         model[[entity@name]] <- entity
426         return(model)
427 }
428
429 removeSingleNamedEntity <- function(model, name) {
430         model[[name]] <- NULL
431         return(model)
432 }
433
434 setMethod("imxVerifyModel", "MxModel",
435     function(model) {
436         if (length(model@submodels) > 0) {
437                 return(all(sapply(model@submodels, imxVerifyModel)))
438         }
439         return(TRUE)
440     }
441 )