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