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