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