Centralize definitions of generic class unions
[openmx:openmx.git] / R / MxModel.R
1 #
2 #   Copyright 2007-2013 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 setClass(Class = "MxModel",
17         representation = representation(
18                 name = "character",
19                 matrices = "list",
20                 algebras = "list",
21                 constraints = "list",
22                 intervals = "list",
23                 latentVars = "MxCharOrList",
24                 manifestVars = "MxCharOrList",
25                 data = "MxData",
26                 submodels = "list",
27                 expectation = "MxExpectation",
28                 fitfunction = "MxFitFunction",
29                 independent = "logical",
30                 options = "list",
31                 output = "list",
32                 runstate = "list",
33                 .forcesequential = "logical",
34                 .newobjects = "logical",
35                 .resetdata = "logical"
36 ))
37
38 imxModelTypes[['default']] <- "MxModel"
39
40 setMethod("initialize", "MxModel",
41         function(.Object, name = character()) {
42                 .Object@name <- name
43                 .Object@latentVars <- character()
44                 .Object@manifestVars <- character()
45                 .Object@matrices <- list()
46                 .Object@algebras <- list()
47                 .Object@constraints <- list()
48                 .Object@data <- NULL
49                 .Object@submodels <- list()
50                 .Object@expectation <- NULL
51                 .Object@fitfunction <- NULL
52                 .Object@independent <- FALSE
53                 .Object@options <- list()
54                 .Object@output <- list()
55                 .Object@runstate <- list()
56                 .Object@.newobjects <- FALSE
57                 .Object@.resetdata <- FALSE
58                 .Object <- imxInitModel(.Object)
59                 return(.Object)
60         }
61 )
62
63 # Begin declaration of generics
64
65 setGeneric("imxInitModel", function(model) {
66         return(standardGeneric("imxInitModel")) } )
67
68 setGeneric("imxModelBuilder", function(model, lst, name, 
69         manifestVars, latentVars, lst.call, remove, independent) {
70         return(standardGeneric("imxModelBuilder")) } )
71
72 setGeneric("imxTypeName", function(model) { 
73         return(standardGeneric("imxTypeName")) 
74 })
75
76 setGeneric("imxVerifyModel", function(model) {
77     return(standardGeneric("imxVerifyModel"))
78 })
79
80 # End declaration of generics
81
82 generateParentNames <- function(model) {
83         retval <- generateLocalNames(model)
84         if (length(model@submodels) > 0) {
85                 retval <- union(retval, names(model@submodels))
86                 childNames <- unlist(lapply(model@submodels, generateChildNames))
87                 retval <- union(retval, childNames)
88         }
89         return(retval)
90 }
91
92 generateChildNames <- function(model) {
93         retval <- generateLocalNames(model)     
94         if (!is.null(retval)) {
95                 retval <- paste(model@name, retval, sep = ".")
96         }
97         if (length(model@submodels) > 0) {
98                 retval <- union(retval, names(model@submodels))
99                 childNames <- unlist(lapply(model@submodels, generateChildNames))
100                 retval <- union(retval, childNames)
101         }
102         return(retval)
103 }
104
105 generateLocalNames <- function(model) {
106         matrices <- names(model@matrices)
107         algebras <- names(model@algebras)
108         constraints <- names(model@constraints)
109         retval <- union(matrices, algebras)
110         retval <- union(retval, constraints)
111         if (!is.null(model@fitfunction)) {
112                 retval <- union(retval, model@fitfunction@name)
113         }
114         if (!is.null(model@expectation)) {
115                 retval <- union(retval, model@expectation@name)
116         }
117         if (!is.null(model@data)) {
118                 retval <- union(retval, model@data@name)
119         }
120         return(retval)
121 }
122
123 setMethod("names", "MxModel",
124         function(x) {
125                 generateParentNames(x)
126         }
127 )
128
129 setMethod("[[", "MxModel",
130         function(x, i, j, ..., drop = FALSE) {
131                 return(imxExtractMethod(x, i))
132         }
133 )
134
135 setReplaceMethod("[[", "MxModel",
136         function(x, i, j, value) {
137                 return(imxReplaceMethod(x, i, value))
138         }
139 )
140
141 setMethod("$", "MxModel",
142         function(x, name) {
143                 return(imxExtractMethod(x, name))
144         }
145 )
146
147 setReplaceMethod("$", "MxModel",
148         function(x, name, value) {
149                 return(imxReplaceMethod(x, name, value))
150         }
151 )
152
153 imxExtractMethod <- function(model, index) {
154         if (is.null(index)) {
155                 return(NULL)
156     }
157         if (!(length(index) == 1 && is.character(index))) {
158                 msg <- paste("The argument to the '$' or '['",
159                         "operator applied on a MxModel object",
160                         "must be a single character string")
161                 stop(msg, call. = FALSE)
162         }
163         return(namespaceSearch(model, index))
164 }
165
166 imxReplaceMethod <- function(model, index, value) {
167         return(namespaceSearchReplace(model, index, value))
168 }
169
170 imxSameType <- function(a, b) {
171         return( (is(a, "MxModel") && is(b, "MxModel")) ||
172                         (is(a, "MxMatrix") && is(b, "MxMatrix")) ||
173                         (is(a, "MxAlgebra") && is(b, "MxAlgebra")) ||
174                         (is(a, "MxExpectation") && is(b, "MxExpectation")) ||
175                         (is(a, "MxFitFunction") && is(b, "MxFitFunction")) ||
176                         (is(a, "MxConstraint") && is(b, "MxConstraint")) ||
177                         (is(a, "MxData") && is(b, "MxData")))
178 }
179
180 mxModel <- function(model = NA, ..., manifestVars = NA, latentVars = NA,
181         remove = FALSE, independent = NA, type = NA, name = NA) {
182         func.call <- match.call(expand.dots=FALSE)
183         retval <- firstArgument(model, name)
184         first <- retval[[1]]
185         model <- retval[[2]]
186         name  <- retval[[3]]
187         model <- typeArgument(model, type)
188         lst <- c(first, list(...))
189         lst <- unlist(lst)
190         lst.call <- c(first, func.call[['...']])
191         model <- imxModelBuilder(model, lst, name, manifestVars,
192                 latentVars, lst.call, remove, independent)
193         return(model)
194 }
195
196 firstArgument <- function(model, name) {
197         first <- NULL
198         defaultType <- imxModelTypes[[getOption("mxDefaultType")]]
199         if (is(model, "MxModel")) {
200         } else {
201                 if (single.na(model)) {
202                 } else if (typeof(model) == "character") {
203                         name <- model
204                 } else if (isS4(model)) {
205                         first <- model
206                 } else {
207                         first <- list(model)
208                 }
209                 if (length(name) > 0 && is.na(name)) {
210                         name <- imxUntitledName()
211                 }
212                 imxVerifyName(name, -1)
213                 model <- new(defaultType, name)
214         }
215         return(list(first, model, name))
216 }
217
218 typeArgument <- function(model, type) {
219         if (!is.na(type)) {
220                 if (is.null(imxModelTypes[[type]])) {
221                         stop(paste("The model type", omxQuotes(type), 
222                                 "is not in the the list of acceptable types:",
223                                 omxQuotes(names(imxModelTypes))), call. = FALSE)
224                 }
225                 typename <- imxModelTypes[[type]]
226                 class(model) <- typename
227                 model <- imxInitModel(model)
228         }
229         return(model)
230 }
231
232 imxGenericModelBuilder <- function(model, lst, name, 
233         manifestVars, latentVars, lst.call, remove, independent) {
234         model <- nameArgument(model, name)
235         model <- variablesArgument(model, manifestVars, latentVars, remove)
236         model <- listArgument(model, lst, remove, lst.call)
237         model <- independentArgument(model, independent)
238         return(model)
239 }
240
241 varsToCharacter <- function(vars, vartype) {
242         if (is.list(vars)) {
243                 varnames <- names(vars)
244                 if (length(varnames) == 0) {
245                         return(as.character(vars))      
246                 } else {
247                         result <- pmatch(varnames, imxVariableTypes)
248                         illegal <- which(is.na(result))
249                         if (length(illegal) > 0) {
250                                 if (length(illegal) == 1) {
251                                         ctgMsg <- "category"
252                                 } else {
253                                         ctgMsg <- "categories"
254                                 }
255                                 msg <- paste("In the", vartype, "variables",
256                                         "the", ctgMsg,
257                                         omxQuotes(varnames[illegal]), "did not match",
258                                         "to a valid category or two categories matched",
259                                         "to the same string (see 'imxVariableTypes'",
260                                         "for the list of legal categories)")
261                                 stop(msg, call. = FALSE)
262                         }
263                         varnames <- imxVariableTypes[result]
264                         vars <- lapply(vars, as.character)
265                         names(vars) <- varnames
266                         return(vars)
267                 }
268         } else {
269                 return(as.character(vars))
270         }
271 }
272
273 variablesArgument <- function(model, manifestVars, latentVars, remove) {
274         if (single.na(manifestVars)) {
275                 manifestVars <- character()
276         }
277         if (single.na(latentVars)) {
278                 latentVars <- character()
279         }
280         if (remove == TRUE) {
281                 model <- modelRemoveVariables(model, latentVars, manifestVars)
282         } else if (length(manifestVars) + length(latentVars) > 0) {
283                 latentVars <- varsToCharacter(latentVars, "latent")
284                 manifestVars <- varsToCharacter(manifestVars, "manifest")
285                 checkVariables(model, latentVars, manifestVars)
286                 model <- modelAddVariables(model, latentVars, manifestVars)
287         }
288         return(model)
289 }
290
291 listArgument <- function(model, lst, remove, lst.call) {
292         if(remove == TRUE) {
293                 model <- modelRemoveEntries(model, lst, lst.call)
294         } else {
295                 model <- modelAddEntries(model, lst, lst.call)
296         }
297         return(model)
298 }
299
300 independentArgument <- function(model, independent) {
301         if(!is.na(independent)) {
302                 model@independent <- independent
303         }
304         return(model)
305 }
306
307 nameArgument <- function(model, name) {
308         if(!is.na(name)) {
309                 model@name <- name
310         }
311         return(model)
312 }
313
314 checkVariables <- function(model, latentVars, manifestVars) {
315         latentVars   <- unlist(latentVars, use.names = FALSE)
316         manifestVars <- unlist(manifestVars, use.names = FALSE)
317         modelLatent <- unlist(model@latentVars, use.names = FALSE)
318         modelManifest <- unlist(model@manifestVars, use.names = FALSE)
319         common <- intersect(latentVars, manifestVars)    
320         if (length(common) > 0) {
321                 stop(paste("The following variables cannot",
322                         "be both latent and manifest:",
323                         omxQuotes(common)), call. = FALSE)
324         }
325         common <- intersect(modelLatent, manifestVars)
326         if (length(common) > 0) {
327                 stop(paste("The following variables cannot",
328                         "be both latent and manifest:",
329                         omxQuotes(common)), call. = FALSE)
330         }
331         common <- intersect(modelManifest, latentVars)
332         if (length(common) > 0) {
333                 stop(paste("The following variables cannot",
334                         "be both latent and manifest",
335                         omxQuotes(common)), call. = FALSE)
336         }
337         common <- intersect(modelManifest, manifestVars)
338         if (length(common) > 0) {
339                 stop(paste("The following manifest variables",
340                         "have already been declared",
341                         omxQuotes(common)), call. = FALSE)
342         }
343         common <- intersect(modelLatent, latentVars)
344         if (length(common) > 0) {
345                 stop(paste("The following latent variables",
346                         "have already been declared",
347                         omxQuotes(common)), call. = FALSE)
348         }
349         if (any(is.na(latentVars))) {
350                 stop("NA is not allowed as a latent variable", call. = FALSE)
351         }
352         if (any(is.na(manifestVars))) {
353                 stop("NA is not allowed as a manifest variable", call. = FALSE)
354         }
355         if (length(unique(latentVars)) != length(latentVars)) {
356                 stop(paste("The following variables in the latentVars list are duplicated:", 
357                 omxQuotes(latentVars[duplicated(latentVars)])), call. = FALSE)
358         }
359         if (length(unique(manifestVars)) != length(manifestVars)) {
360                 stop(paste("The following variables in the manifestVars list are duplicated:", 
361                 omxQuotes(manifestVars[duplicated(manifestVars)])), call. = FALSE)
362         }
363 }
364
365 # Begin implementation of generics
366
367 setMethod("imxModelBuilder", "MxModel", imxGenericModelBuilder)
368
369 setMethod("imxInitModel", "MxModel", function(model) { 
370         return(model)
371 })
372
373 setMethod("imxTypeName", "MxModel", function(model) { 
374         return("default")
375 })
376
377 setMethod("imxVerifyModel", "MxModel", function(model) {
378     return(TRUE)
379 })
380
381 # End implementation of generics
382
383 addVariablesHelper <- function(model, vartype, vars) {
384         modelvars <- slot(model, vartype)
385
386         if (length(vars) == 0) {
387                 return(model)
388         } else if (length(modelvars) == 0) {
389                 slot(model, vartype) <- vars
390                 return(model)
391         }
392
393         if (is.list(vars) && !is.list(modelvars)) {
394                 msg <- paste("The", vartype, "variables in",
395                         "the call to mxModel() have been separated",
396                         "into categories, and the existing", vartype,
397                         "variables do not have categories.")
398                 stop(msg, call. = FALSE)
399         } else if (!is.list(vars) && is.list(modelvars)) {
400                 msg <- paste("The", vartype, "variables in",
401                         "the call to mxModel() have not been separated",
402                         "into categories, and the existing", vartype,
403                         "variables do have categories.")
404                 stop(msg, call. = FALSE)
405         }
406
407         if (is.character(vars) && is.character(modelvars)) {
408                 modelvars <- c(modelvars, vars)
409                 slot(model, vartype) <- modelvars
410         } else {
411                 varnames <- names(vars)
412                 offsets <- pmatch(varnames, imxVariableTypes)
413                 for(i in 1:length(vars)) {
414                         currOffset <- offsets[[i]]
415                         currName <- imxVariableTypes[[currOffset]]
416                         modelvars[[currName]] <- c(modelvars[[currName]], vars[[i]])
417                 }
418                 slot(model, vartype) <- modelvars
419         }
420
421         return(model)
422 }
423
424 modelAddVariables <- function(model, latent, manifest) {
425         model <- addVariablesHelper(model, "latentVars", latent)
426         model <- addVariablesHelper(model, "manifestVars", manifest)
427         return(model)
428 }
429
430 modelRemoveVariables <- function(model, latent, manifest) {
431         model@latentVars <- setdiff(model@latentVars, latent)
432         model@manifestVars <- setdiff(model@manifestVars, manifest)
433         return(model)
434 }
435         
436 modelAddEntries <- function(model, entries, lst.call) {
437         if (length(entries) == 0) {
438                 return(model)
439         }
440         tuple <- modelModifyFilter(model, entries, "add", lst.call)
441         namedEntities <- tuple[[1]]
442         bounds        <- tuple[[2]]
443         intervals     <- tuple[[3]]
444         intervals     <- expandIntervals(intervals)
445         names(intervals) <- sapply(intervals, slot, "reference")
446         if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {
447                 model <- addSingleNamedEntity(model, namedEntities[[i]])
448         }
449         model <- modelAddBounds(model, bounds)
450         model <- modelAddIntervals(model, intervals)
451         return(model)
452 }
453
454 modelRemoveEntries <- function(model, entries, lst.call) {
455         if (length(entries) == 0) {
456                 return(model)
457         }
458         tuple <- modelModifyFilter(model, entries, "remove", lst.call)
459         namedEntities <- tuple[[1]]
460         bounds        <- tuple[[2]]
461         intervals     <- tuple[[3]]
462         intervals     <- expandIntervals(intervals)     
463         names(intervals) <- sapply(intervals, slot, "reference")
464         if (length(namedEntities) > 0) for(i in 1:length(namedEntities)) {
465                 model <- removeSingleNamedEntity(model, namedEntities[[i]])
466         }
467         model <- modelRemoveBounds(model, bounds)
468         model <- modelRemoveIntervals(model, intervals)
469         return(model)
470 }
471
472 actionCorrespondingPredicate <- c('add' = 'into', 'remove' = 'from')
473
474 modelModifyFilter <- function(model, entries, action, lst.call) {
475         boundsFilter <- sapply(entries, is, "MxBounds")
476         intervalFilter <- sapply(entries, is, "MxInterval")
477         namedEntityFilter <- sapply(entries, function(x) {"name" %in% slotNames(x)})
478         characterFilter <- sapply(entries, is.character)
479         pathFilter <- sapply(entries, is, "MxPath")
480         unknownFilter <- !(boundsFilter | namedEntityFilter | intervalFilter | characterFilter)
481         if (any(pathFilter)) {
482                 stop(paste("The model type of model",
483                         omxQuotes(model@name), "does not recognize paths."),
484                         call. = FALSE)
485         }
486         if (any(unknownFilter)) {
487                 stop(paste("Cannot", action, "the following item(s)", 
488                         actionCorrespondingPredicate[[action]], "the model:", 
489                         omxQuotes(sapply(lst.call[unknownFilter], deparse))), call. = FALSE)
490         }
491         if (any(namedEntityFilter) && action == 'remove') {
492                 stop(paste("Cannot use named entities when remove = TRUE.",
493                         "Instead give the name of the entity when removing it.",
494                         "See http://openmx.psyc.virginia.edu/wiki/mxmodel-help#Remove_an_object_from_a_model"))
495         }
496         if (any(characterFilter) && action == 'add') {
497                 stop(paste("I don't know what to do with the following strings",
498                         omxQuotes(entries[characterFilter]),
499                         "that have been passed into the function:",
500                         deparse(width.cutoff = 400L, imxLocateFunction("mxModel"))), call. = FALSE)
501         }
502         if (identical(action, 'add')) {
503                 return(list(entries[namedEntityFilter], entries[boundsFilter], entries[intervalFilter]))
504         } else if (identical(action, 'remove')) {
505                 return(list(entries[characterFilter], entries[boundsFilter], entries[intervalFilter]))
506         } else {
507                 stop(paste("Internal error, unidentified action:", omxQuotes(action)))
508         }
509 }
510
511 addSingleNamedEntity <- function(model, entity) {
512         if (!nzchar(entity@name)) {
513                 stop(paste("Entity",
514                         omxQuotes(class(entity)), "in model",
515                         omxQuotes(model@name), "needs a name"), call. = FALSE)
516         }
517         if (model@name == entity@name) {
518                 stop(paste("You cannot insert an entity named",
519                         omxQuotes(entity@name), "into a model named",
520                         omxQuotes(model@name)), call. = FALSE)
521         }
522         model[[entity@name]] <- entity
523         return(model)
524 }
525
526 removeSingleNamedEntity <- function(model, name) {
527         model[[name]] <- NULL
528         return(model)
529 }
530
531 setMethod("imxVerifyModel", "MxModel",
532     function(model) {
533         if (length(model@submodels) > 0) {
534                 return(all(sapply(model@submodels, imxVerifyModel)))
535         }
536         return(TRUE)
537     }
538 )