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