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