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