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