Remove most instances of setFinalReturns
[openmx:openmx.git] / R / MxModelFunctions.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
17 generateMatrixList <- function(model) {
18         matvalues <- lapply(model@matrices, generateMatrixValuesHelper)
19         matnames  <- names(model@matrices)
20         names(matvalues) <- matnames
21         references <- generateMatrixReferences(model)
22         retval <- mapply(function(x,y) { c(list(x), y) }, 
23                         matvalues, references, SIMPLIFY = FALSE)
24         return(retval)
25 }
26
27 generateAlgebraList <- function(model) {
28         mNames <- names(model@matrices)
29         aNames <- append(names(model@algebras), names(model@fitfunctions))      
30         mNumbers <- as.list(as.integer(-1 : (-length(mNames))))
31         aNumbers <- as.list(as.integer(0 : (length(aNames) - 1)))
32         names(mNumbers) <- mNames
33         names(aNumbers) <- aNames
34         retval <- lapply(model@algebras, generateAlgebraHelper, 
35                 mNumbers, aNumbers)
36     return(retval)
37 }
38
39 findDependencies <- function(triple, flatModel, dependencies) {
40         mNames <- names(flatModel@matrices)
41         matrixNum <- triple[[1]] + 1
42         matrixName <- mNames[[matrixNum]]
43         return(dependencies[[matrixName]])      
44 }
45
46         
47 isExpectation <- function(name) {
48         return(length(grep("expectation", name, fixed=TRUE)) > 0)
49 }
50
51 parameterDependencyList <- function(pList, flatModel, dependencies, freeGroupNames) {
52         if (length(pList) == 3) {
53                 return(retval)
54         }
55         pList[[3]] <- match(pList[[3]], freeGroupNames) - 1L
56         locations <- pList[4:length(pList)]
57         deps <- lapply(locations, findDependencies, flatModel, dependencies)
58         depnames <- Reduce(union, deps, character())
59         depnames <- Filter(Negate(isExpectation), depnames)
60         depnumbers <- sapply(depnames, doLocateIndex, flatModel, flatModel@name, USE.NAMES=FALSE)
61         depnumbers <- as.integer(depnumbers)
62         retval <- append(pList[1:3], list(depnumbers))
63         append(retval, locations)
64 }
65
66 generateFreeVarGroups <- function(flatModel) {
67         mList <- flatModel@matrices
68         if (length(mList) == 0) {
69                 return(list())
70         }
71         free.group <- sapply(mList, slot, 'free.group')
72         if (is.list(free.group) || any(nchar(free.group) == 0)) {
73                 stop(paste("Invalid free.group name", omxQuotes(free.group)))
74         }
75         flatModel@freeGroupNames <- append(setdiff(unique(free.group), "default"), "default", after=0)
76         flatModel
77 }
78
79 generateParameterList <- function(flatModel, dependencies) {
80         mList <- flatModel@matrices
81         pList <- list()
82         for(i in 1:length(mList)) {
83                 matrix <- mList[[i]]
84                 pList <- generateParameterListHelper(matrix, pList, i - 1L)
85         }
86         pList <- lapply(pList, parameterDependencyList, flatModel, dependencies,
87                         flatModel@freeGroupNames)
88
89         if (length(pList)) for(i in 1:length(pList)) {
90                 original <- pList[[i]]
91                 svalues <- original[5:length(original)]
92                 svalue <- NA
93                 if (length(svalues) > 1) {
94                         values <- sapply(svalues, generateValueHelper, mList)
95                         if (!all(values == values[[1]])) {
96                                 warning(paste('Parameter',i,'has multiple start values.',
97                                               'Selecting', values[[1]]))
98                         }
99                         svalue <- values[[1]]
100                 } else {
101                         svalue <- generateValueHelper(svalues[[1]], mList)
102                 }
103                 pList[[i]] <- c(original, svalue)
104         }
105         flatModel@parameters <- pList
106         flatModel
107 }
108
109 definitionDependencyList <- function(pList, flatModel, dependencies) {
110         if (length(pList) == 2) {
111                 retval <- list(pList[[1]], pList[[2]], integer())
112                 return(retval)
113         }
114         locations <- pList[3:length(pList)]
115         deps <- lapply(locations, findDependencies, flatModel, dependencies)
116         depnames <- Reduce(union, deps, character())
117         depnames <- Filter(Negate(isExpectation), depnames)
118         depnumbers <- sapply(depnames, doLocateIndex, flatModel, flatModel@name, USE.NAMES=FALSE)
119         depnumbers <- as.integer(depnumbers)
120         retval <- list(pList[[1]], pList[[2]], depnumbers)
121         return(append(retval, locations))
122 }
123
124 generateDefinitionList <- function(flatModel, dependencies) {
125         result <- list()
126         defLocations <- generateDefinitionLocations(flatModel@datasets)
127         if (length(flatModel@matrices) == 0) {
128                 return(result)
129         }
130         for(i in 1:length(flatModel@matrices)) {
131                 result <- generateDefinitionListHelper(
132                         flatModel@matrices[[i]], 
133                         result, defLocations, i - 1L)
134         }
135         result <- lapply(result, definitionDependencyList, flatModel, dependencies)
136         return(result)
137 }
138
139 generateValueHelper <- function(triple, mList) {
140         mat <- triple[1] + 1
141         row <- triple[2] + 1
142         col <- triple[3] + 1
143         val <- mList[[mat]]@values[row,col]
144         if (is.na(val)) {
145                 stop(paste("Starting value in ",names(mList)[[mat]],
146                            "[",row,",",col,"] is missing", sep=""))
147         }
148         return(val)
149 }
150
151 imxUpdateModelValues <- function(model, flatModel, values) {
152         pList <- flatModel@parameters
153         if(length(pList) != length(values)) {
154                 stop(paste("This model has", length(pList), 
155                         "parameters, but you have given me", length(values),
156                         "values"))
157         }
158         if (length(pList) == 0) {
159                 return(model)
160         }
161         for(i in 1:length(pList)) {
162                 parameters <- pList[[i]]
163                 parameters <- parameters[5:(length(parameters)-1)]
164                 model <- updateModelValuesHelper(parameters, values[[i]], flatModel, model)
165     }
166         return(model)
167 }
168
169 updateModelValuesHelper <- function(triples, value, flatModel, model) {
170         for(i in 1:length(triples)) {
171                 triple <- triples[[i]]
172                 mat <- triple[1] + 1
173                 row <- triple[2] + 1
174                 col <- triple[3] + 1
175                 name <- flatModel@matrices[[mat]]@name
176                 model[[name]]@values[row,col] <- value
177         }
178         return(model)
179 }
180
181 removeTail <- function(lst, tailSize) {
182     newEnd <- length(lst) - tailSize
183     if (newEnd == 0) {
184         return(list())
185     } else {
186         return(lst[1 : newEnd])
187     }
188 }
189
190 updateModelMatrices <- function(model, flatModel, values) {
191         mList <- names(flatModel@matrices)
192         if (length(mList) != length(values)) {
193                 stop(paste("This model has", length(mList), 
194                         "matrices, but the backend has returned", length(values),
195                         "values"))
196         }
197         if (length(values) == 0) {
198                 return(model)
199         }
200         model <- updateModelEntitiesHelper(mList, values, model)
201         return(model)
202 }
203
204
205 updateModelAlgebras <- function(model, flatModel, values) {
206         aNames <- names(flatModel@algebras)
207         oNames <- names(flatModel@fitfunctions)
208         aList <- append(aNames, oNames)
209         if(length(aList) != length(values)) {
210                 stop(paste("This model has", length(aList), 
211                         "algebras, but the backend has returned", length(values),
212                         "values"))
213         }
214         if (length(aList) == 0) {
215                 return(model)
216         }
217         model <- updateModelEntitiesHelper(aList, values, model)
218         return(model)
219 }
220
221 updateModelExpectations <- function(model, flatModel, values) {
222         eNames <- names(flatModel@expectations)
223         if (length(eNames) != length(values)) {
224                 stop(paste("This model has", length(eNames),
225                            "expectations, but the backend has returned", length(values),
226                            "values"))
227         }
228         if (length(eNames) == 0) return(model)
229         updateModelEntitiesHelper(eNames, values, model)
230 }
231
232 updateModelEntitiesTargetModel <- function(model, entNames, values, modelNameMapping) {
233     nextName <- model@name
234     selectEnt <- entNames[modelNameMapping == nextName]
235     selectVal <- values[modelNameMapping == nextName]
236     if (length(selectEnt) > 0) {
237                 for(i in 1:length(selectEnt)) {
238                         name <- selectEnt[[i]]
239                         candidate <- model[[name]]
240                         value <- selectVal[[i]]
241                         if (!is.null(candidate) && (length(value) > 0)
242                                 && !is.nan(value)) {
243                                 if (is(candidate, "MxAlgebra")) {
244                                         dimnames(value) <- dimnames(candidate)
245                                         candidate@result <- value
246                                 } else if (is(candidate,"MxFitFunction")) {
247                                         candidate@result <- as.matrix(value[1,1])
248                                         attr <- attributes(value)
249                                         attr$dim <- NULL
250                                         candidate@info <- attr
251                                 } else if(is(candidate, "MxMatrix")) {
252                                         dimnames(value) <- dimnames(candidate)
253                                         candidate@values <- value
254                                 } else if (is(candidate, "MxExpectation")) {
255                                         for (sl in names(attributes(value))) {
256                                                 slot(candidate, sl) <- attr(value, sl)
257                                         }
258                                 }
259                                 model[[name]] <- candidate
260                         }
261                 }
262         }
263     if (length(model@submodels) > 0) {
264         model@submodels <- lapply(model@submodels, 
265             updateModelEntitiesTargetModel, entNames, values, modelNameMapping)
266     }
267         return(model)
268 }
269
270 updateModelEntitiesHelper <- function(entNames, values, model) {
271     modelNameMapping <- sapply(entNames, getModelNameString)
272     model <- updateModelEntitiesTargetModel(model, entNames, 
273                 values, modelNameMapping)
274     return(model)
275 }
276
277 imxLocateIndex <- function(model, name, referant) {
278         if (length(name) == 0) return(name)
279         if (is.na(name)) { return(as.integer(name)) }
280         mNames <- names(model@matrices)
281         aNames <- names(model@algebras)
282         fNames <- names(model@fitfunctions)
283         eNames <- names(model@expectations)
284         oNames <- names(model@computes)
285         dNames <- names(model@datasets)         
286         matrixNumber <- match(name, mNames)
287         algebraNumber <- match(name, append(aNames, fNames))
288         dataNumber <- match(name, dNames)
289         expectationNumber <- match(name, eNames)
290         computeNumber <- match(name, oNames)
291         if (is.na(matrixNumber) && is.na(algebraNumber) 
292                 && is.na(dataNumber) && is.na(expectationNumber) &&
293             is.na(computeNumber)) {
294                 msg <- paste("The reference", omxQuotes(name),
295                         "does not exist.  It is used by the named entity",
296                         omxQuotes(referant),".")
297                 stop(msg, call.=FALSE)
298         } else if (!is.na(matrixNumber)) {
299                 return(- matrixNumber)
300         } else if (!is.na(dataNumber)) {
301                 return(dataNumber - 1L)
302         } else if (!is.na(expectationNumber)) {
303                 return(expectationNumber - 1L)
304         } else if (!is.na(computeNumber)) {
305                 return(computeNumber - 1L)
306         } else {
307                 return(algebraNumber - 1L)
308         }
309 }
310
311 imxPreprocessModel <- function(model) {
312         model@matrices <- lapply(model@matrices, findSquareBrackets)
313         model@submodels <- lapply(model@submodels, imxPreprocessModel)
314         return(model)
315 }
316
317
318 imxCheckMatrices <- function(model) {
319         matrices <- model@matrices
320         lapply(matrices, imxVerifyMatrix)
321         submodels <- imxDependentModels(model)
322         lapply(submodels, imxCheckMatrices)
323 }