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