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