Added 'excludeself' argument to mxPath() function.
[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                 .estimation="logical",
34                 .postEstimation="logical"
35 ))
36
37 omxModelTypes[['raw']] <- "MxModel"
38
39 setMethod("initialize", "MxModel",
40         function(.Object, name = character()) {
41                 .Object@name <- name
42                 .Object@latentVars <- character()
43                 .Object@manifestVars <- character()
44                 .Object@matrices <- list()
45                 .Object@algebras <- list()
46                 .Object@constraints <- list()
47                 .Object@data <- NULL
48                 .Object@submodels <- list()
49                 .Object@objective <- NULL
50                 .Object@independent <- FALSE
51                 .Object@options <- list()
52                 .Object@output <- list()
53                 .Object@runstate <- list()
54                 .Object@.estimation <- FALSE
55                 .Object@.postEstimation <- FALSE
56                 .Object <- omxInitModel(.Object)
57                 return(.Object)
58         }
59 )
60
61 # Begin declaration of generics
62
63 setGeneric("omxInitModel", function(model) {
64         return(standardGeneric("omxInitModel")) } )
65
66 setGeneric("omxModelBuilder", function(model, lst, name, 
67         manifestVars, latentVars, remove, independent) {
68         return(standardGeneric("omxModelBuilder")) } )
69
70 setGeneric("omxTypeName", function(model) { 
71         return(standardGeneric("omxTypeName")) 
72 })
73
74 setGeneric("omxVerifyModel", function(model) {
75     return(standardGeneric("omxVerifyModel"))
76 })
77
78 # End declaration of generics
79
80 generateParentNames <- function(model) {
81         retval <- generateLocalNames(model)
82         if (length(model@submodels) > 0) {
83                 retval <- union(retval, names(model@submodels))
84                 childNames <- unlist(lapply(model@submodels, generateChildNames))
85                 retval <- union(retval, childNames)
86         }
87         return(retval)
88 }
89
90 generateChildNames <- function(model) {
91         retval <- generateLocalNames(model)     
92         if (!is.null(retval)) {
93                 retval <- paste(model@name, retval, sep = ".")
94         }
95         if (length(model@submodels) > 0) {
96                 retval <- union(retval, names(model@submodels))
97                 childNames <- unlist(lapply(model@submodels, generateChildNames))
98                 retval <- union(retval, childNames)
99         }
100         return(retval)
101 }
102
103 generateLocalNames <- function(model) {
104         matrices <- names(model@matrices)
105         algebras <- names(model@algebras)
106         constraints <- names(model@constraints)
107         retval <- union(matrices, algebras)
108         retval <- union(retval, constraints)
109         if (!is.null(model@objective)) {
110                 retval <- union(retval, model@objective@name)
111         }
112         if (!is.null(model@data)) {
113                 retval <- union(retval, model@data@name)
114         }
115         return(retval)
116 }
117
118 setMethod("names", "MxModel",
119         function(x) {
120                 generateParentNames(x)
121         }
122 )
123
124 setMethod("[[", "MxModel",
125         function(x, i, j, ..., drop = FALSE) {
126                 return(omxExtractMethod(x, i))
127         }
128 )
129
130 setReplaceMethod("[[", "MxModel",
131         function(x, i, j, value) {
132                 return(omxReplaceMethod(x, i, value))
133         }
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 )
147
148 omxExtractMethod <- function(model, index) {
149         return(namespaceSearch(model, index))
150 }
151
152 omxReplaceMethod <- function(model, index, value) {
153         return(namespaceSearchReplace(model, index, value))
154 }
155
156 omxSameType <- function(a, b) {
157         return( (is(a, "MxModel") && is(b, "MxModel")) ||
158                         (is(a, "MxMatrix") && is(b, "MxMatrix")) ||
159                         (is(a, "MxAlgebra") && is(b, "MxAlgebra")) ||
160                         (is(a, "MxObjective") && is(b, "MxObjective")) ||
161                         (is(a, "MxConstraint") && is(b, "MxConstraint")) ||
162                         (is(a, "MxData") && is(b, "MxData")))
163 }
164
165 mxModel <- function(model = NA, ..., manifestVars = NA, latentVars = NA,
166         remove = FALSE, independent = NA, type = NA, name = NA) {
167         retval <- firstArgument(model, name)
168         first <- retval[[1]]
169         model <- retval[[2]]
170         name  <- retval[[3]]
171         model <- typeArgument(model, type)
172         lst <- c(first, list(...))
173         lst <- unlist(lst)
174         model <- omxModelBuilder(model, lst, name, manifestVars,
175                 latentVars, remove, independent)
176         return(model)
177 }
178
179 firstArgument <- function(model, name) {
180         first <- NULL
181         defaultType <- omxModelTypes[[getOption("mxDefaultType")]]
182         if (is(model, "MxModel")) {
183         } else {
184                 if (single.na(model)) {
185                 } else if (typeof(model) == "character") {
186                         name <- model
187                 } else if (isS4(model)) {
188                         first <- model
189                 } else {
190                         first <- list(model)
191                 }
192                 if (length(name) > 0 && is.na(name)) {
193                         name <- omxUntitledName()
194                 }
195                 omxVerifyName(name, -1)
196                 model <- new(defaultType, name)
197         }
198         return(list(first, model, name))
199 }
200
201 typeArgument <- function(model, type) {
202         if (!is.na(type)) {
203                 if (is.null(omxModelTypes[[type]])) {
204                         stop(paste("The model type", omxQuotes(type), 
205                                 "is not in the the list of acceptable types:",
206                                 omxQuotes(names(omxModelTypes))), call. = FALSE)
207                 }
208                 typename <- omxModelTypes[[type]]
209                 class(model) <- typename
210                 model <- omxInitModel(model)
211         }
212         return(model)
213 }
214
215 omxGenericModelBuilder <- function(model, lst, name, 
216         manifestVars, latentVars, remove, independent) {
217         model <- variablesArgument(model, manifestVars, latentVars, remove)
218         model <- listArgument(model, lst, remove)
219         model <- independentArgument(model, independent)
220         model <- nameArgument(model, name)
221         return(model)
222 }
223
224 variablesArgument <- function(model, manifestVars, latentVars, remove) {
225         if (single.na(manifestVars)) {
226                 manifestVars <- character()
227         }
228         if (single.na(latentVars)) {
229                 latentVars <- character()
230         }
231         if (remove == TRUE) {
232                 model <- modelRemoveVariables(model, latentVars, manifestVars)
233         } else if (length(manifestVars) + length(latentVars) > 0) {
234                 latentVars <- as.character(latentVars)
235                 manifestVars <- as.character(manifestVars)
236                 checkVariables(model, latentVars, manifestVars)
237                 model <- modelAddVariables(model, latentVars, manifestVars)
238         }
239         return(model)
240 }
241
242 listArgument <- function(model, lst, remove) {
243         if(remove == TRUE) {
244                 model <- modelRemoveEntries(model, lst)
245         } else {
246                 model <- modelAddEntries(model, lst)
247         }
248         return(model)
249 }
250
251 independentArgument <- function(model, independent) {
252         if(!is.na(independent)) {
253                 model@independent <- independent
254         }
255         return(model)
256 }
257
258 nameArgument <- function(model, name) {
259         if(!is.na(name)) {
260                 model@name <- name
261         }
262         return(model)
263 }
264
265 checkVariables <- function(model, latentVars, manifestVars) {
266         common <- intersect(latentVars, manifestVars)
267         if (length(common) > 0) {
268                 stop(paste("The following variables cannot",
269                         "be both latent and manifest:",
270                         omxQuotes(common)), call. = FALSE)
271         }
272         common <- intersect(model@latentVars, manifestVars)
273         if (length(common) > 0) {
274                 stop(paste("The following variables cannot",
275                         "be both latent and manifest:",
276                         omxQuotes(common)), call. = FALSE)
277         }
278         common <- intersect(model@manifestVars, latentVars)
279         if (length(common) > 0) {
280                 stop(paste("The following variables cannot",
281                         "be both latent and manifest",
282                         omxQuotes(common)), call. = FALSE)
283         }
284         if (any(is.na(latentVars))) {
285                 stop("NA is not allowed as a latent variable", call. = FALSE)
286         }
287         if (any(is.na(manifestVars))) {
288                 stop("NA is not allowed as a manifest variable", call. = FALSE)
289         }
290         if (length(unique(latentVars)) != length(latentVars)) {
291                 stop("The latent variables list contains duplicate elements",
292                         call. = FALSE)
293         }
294         if (length(unique(manifestVars)) != length(manifestVars)) {
295                 stop("The manifest variables list contains duplicate elements",
296
297                         call. = FALSE)
298         }
299 }
300
301 # Begin implementation of generics
302
303 setMethod("omxModelBuilder", "MxModel", omxGenericModelBuilder)
304
305 setMethod("omxInitModel", "MxModel", function(model) { 
306         return(model)
307 })
308
309 setMethod("omxTypeName", "MxModel", function(model) { 
310         return("default")
311 })
312
313 setMethod("omxVerifyModel", "MxModel", function(model) {
314     return(TRUE)
315 })
316
317 # End implementation of generics
318
319 modelAddVariables <- function(model, latent, manifest) {
320         model@latentVars   <- union(model@latentVars, latent)
321         model@manifestVars <- union(model@manifestVars, manifest)
322         return(model)
323 }
324
325 modelRemoveVariables <- function(model, latent, manifest) {
326         model@latentVars <- setdiff(model@latentVars, latent)
327         model@manifestVars <- setdiff(model@manifestVars, manifest)
328         return(model)
329 }
330         
331 modelAddEntries <- function(model, entries) {
332         if (length(entries) == 0) {
333                 return(model)
334         }
335         tuple <- modelModifyFilter(model, entries, "add")
336         namedEntities <- tuple[[1]]
337         bounds        <- tuple[[2]]
338         intervals     <- tuple[[3]]
339         intervals     <- expandIntervals(intervals)
340         names(intervals) <- sapply(intervals, slot, "reference")
341         if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {
342                 model <- addSingleNamedEntity(model, namedEntities[[i]])
343         }
344         model <- modelAddBounds(model, bounds)
345         model <- modelAddIntervals(model, intervals)
346         return(model)
347 }
348
349 modelRemoveEntries <- function(model, entries) {
350         if (length(entries) == 0) {
351                 return(model)
352         }
353         tuple <- modelModifyFilter(model, entries, "remove")
354         namedEntities <- tuple[[1]]
355         bounds        <- tuple[[2]]
356         intervals     <- tuple[[3]]
357         intervals     <- expandIntervals(intervals)     
358         names(intervals) <- sapply(intervals, slot, "reference")
359         if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {
360                 model <- removeSingleNamedEntity(model, namedEntities[[i]])
361         }
362         model <- modelRemoveBounds(model, bounds)
363         model <- modelRemoveIntervals(model, intervals)
364         return(model)
365 }
366
367 modelModifyFilter <- function(model, entries, action) {
368         boundsFilter <- sapply(entries, is, "MxBounds")
369         intervalFilter <- sapply(entries, is, "MxInterval")
370         namedFilter <- sapply(entries, function(x) {"name" %in% slotNames(x)})
371         pathFilter <- sapply(entries, is, "MxPath")
372         unknownFilter <- !(boundsFilter | namedFilter | intervalFilter)
373         if (any(pathFilter)) {
374                 stop(paste("The model type of model",
375                         omxQuotes(model@name), "does not recognize paths."),
376                         call. = FALSE)
377         }
378         if (any(unknownFilter)) {
379                 stop(paste("Cannot", action, "the following item(s) into the model:", 
380                         omxQuotes(entries[unknownFilter])), call. = FALSE)
381         }
382         return(list(entries[namedFilter], entries[boundsFilter], entries[intervalFilter]))
383 }
384
385 addSingleNamedEntity <- function(model, entity) {
386         if (model@name == entity@name) {
387                 stop(paste("You cannot insert an entity named",
388                         omxQuotes(entity@name), "into a model named",
389                         omxQuotes(model@name)), call. = FALSE)
390         }
391         model[[entity@name]] <- entity
392         return(model)
393 }
394
395 removeSingleNamedEntity <- function(model, name) {
396         model[[name]] <- NULL
397         return(model)
398 }
399
400 setMethod("omxVerifyModel", "MxModel",
401     function(model) {
402         if (length(model@submodels) > 0) {
403                 return(all(sapply(model@submodels, omxVerifyModel)))
404         }
405         return(TRUE)
406     }
407 )