Performance improvements to mxRun() frontend
[openmx:openmx.git] / R / MxModelFunctions.R
1 #
2 #   Copyright 2007-2012 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@objectives))        
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 parameterDependencyList <- function(pList, flatModel, dependencies) {
47         if (length(pList) == 2) {
48                 retval <- list(pList[[1]], pList[[2]], integer())
49                 return(retval)
50         }
51         locations <- pList[3:length(pList)]
52         deps <- lapply(locations, findDependencies, flatModel, dependencies)
53         depnames <- Reduce(union, deps, character())
54         depnumbers <- sapply(depnames, doLocateIndex, flatModel, flatModel@name, USE.NAMES=FALSE)
55         depnumbers <- as.integer(depnumbers)
56         retval <- list(pList[[1]], pList[[2]], depnumbers)
57         return(append(retval, locations))
58 }
59
60 generateParameterList <- function(flatModel, dependencies) {
61         result <- list()
62         if (length(flatModel@matrices) == 0) {
63                 return(result)
64         }
65         for(i in 1:length(flatModel@matrices)) {
66                 matrix <- flatModel@matrices[[i]]
67                 result <- generateParameterListHelper(
68                         matrix, result, i - 1L)
69         }
70         result <- lapply(result, parameterDependencyList, flatModel, dependencies)
71         return(result)
72 }
73
74 generateDefinitionList <- function(flatModel, dependencies) {
75         result <- list()
76         defLocations <- generateDefinitionLocations(flatModel@datasets)
77         if (length(flatModel@matrices) == 0) {
78                 return(result)
79         }
80         for(i in 1:length(flatModel@matrices)) {
81                 result <- generateDefinitionListHelper(
82                         flatModel@matrices[[i]], 
83                         result, defLocations, i - 1L)
84         }
85         result <- lapply(result, parameterDependencyList, flatModel, dependencies)
86         return(result)
87 }
88
89 generateValueList <- function(mList, pList) {
90         mList <- lapply(mList, function(x) { x[[1]] })
91         retval <- vector()
92         if (length(pList) == 0) {
93                 return(retval)
94         }
95         for(i in 1:length(pList)) {
96                 parameter <- pList[[i]]
97                 parameter <- parameter[4:length(parameter)] # Remove (min, max, dependencies)
98                 if (length(parameter) > 1) {
99                         values <- sapply(parameter, generateValueHelper, mList)
100                         if (!all(values == values[[1]])) {
101                                 warning(paste('Parameter',i,'has multiple start values.',
102                                         'Selecting', values[[1]]))
103                         }
104                         retval[i] <- values[[1]]
105                 } else {
106                         retval[i] <- generateValueHelper(parameter[[1]], mList)
107                 }
108     }
109         return(retval)  
110 }
111
112 generateValueHelper <- function(triple, mList) {
113         mat <- triple[1] + 1
114         row <- triple[2] + 1
115         col <- triple[3] + 1
116         return(mList[[mat]][row,col])
117 }
118
119 getObjectiveIndex <- function(flatModel) {
120         objective <- flatModel@objective
121         if(is.null(objective)) {
122                 return(NULL)
123         } else {
124                 return(imxLocateIndex(flatModel, objective@name, flatModel@name))
125         }
126 }
127
128 imxUpdateModelValues <- function(model, flatModel, pList, values) {
129         if(length(pList) != length(values)) {
130                 stop(paste("This model has", length(pList), 
131                         "parameters, but you have given me", length(values),
132                         "values"))
133         }
134         if (length(pList) == 0) {
135                 return(model)
136         }
137         for(i in 1:length(pList)) {
138                 parameters <- pList[[i]]
139                 parameters <- parameters[4:length(parameters)] # Remove min, max, and dependencies
140                 model <- updateModelValuesHelper(parameters, values[[i]], flatModel, model)
141     }
142         return(model)
143 }
144
145 updateModelValuesHelper <- function(triples, value, flatModel, model) {
146         for(i in 1:length(triples)) {
147                 triple <- triples[[i]]
148                 mat <- triple[1] + 1
149                 row <- triple[2] + 1
150                 col <- triple[3] + 1
151                 name <- flatModel@matrices[[mat]]@name
152                 model[[name]]@values[row,col] <- value
153         }
154         return(model)
155 }
156
157 removeTail <- function(lst, tailSize) {
158     newEnd <- length(lst) - tailSize
159     if (newEnd == 0) {
160         return(list())
161     } else {
162         return(lst[1 : newEnd])
163     }
164 }
165
166 updateModelMatrices <- function(model, flatModel, values) {
167         mList <- names(flatModel@matrices)
168         if (length(mList) != length(values)) {
169                 stop(paste("This model has", length(mList), 
170                         "matrices, but the backend has returned", length(values),
171                         "values"))
172         }
173         if (length(values) == 0) {
174                 return(model)
175         }
176         model <- updateModelEntitiesHelper(mList, values, model)
177         return(model)
178 }
179
180
181 updateModelAlgebras <- function(model, flatModel, values) {
182         aNames <- names(flatModel@algebras)
183         oNames <- names(flatModel@objectives)
184         aList <- append(aNames, oNames)
185         if(length(aList) != length(values)) {
186                 stop(paste("This model has", length(aList), 
187                         "algebras, but the backend has returned", length(values),
188                         "values"))
189         }
190         if (length(aList) == 0) {
191                 return(model)
192         }
193         model <- updateModelEntitiesHelper(aList, values, model)
194         return(model)
195 }
196
197
198 updateModelEntitiesHelper <- function(entNames, values, model) {
199         modelNameMapping <- sapply(entNames, getModelNameString)
200         modelNames <- unique(modelNameMapping)
201         for(j in 1:length(modelNames)) {
202                 nextName <- modelNames[[j]]
203                 selectEnt <- entNames[modelNameMapping == nextName]
204                 selectVal <- values[modelNameMapping == nextName]
205                 submodel <- model[[nextName]]
206                 for(i in 1:length(selectEnt)) {
207                         name <- selectEnt[[i]]
208                         candidate <- submodel[[name]]
209                         value <- selectVal[[i]]
210                         if (!is.null(candidate) && (length(value) > 0)
211                                 && !is.nan(value)) {
212                                 if (is(candidate,"MxAlgebra") || is(candidate,"MxObjective")) {
213                                         if (is(candidate, "MxAlgebra")) {
214                                                 dimnames(value) <- dimnames(candidate)
215                                                 candidate@result <- value
216                                         } else {
217                                                 candidate <- objectiveReadAttributes(candidate, value)
218                                         }
219                                 } else if(is(candidate, "MxMatrix")) {
220                                         dimnames(value) <- dimnames(candidate)
221                                         candidate@values <- value
222                                 }
223                         }
224                         submodel[[name]] <- candidate
225                 }
226                 model[[nextName]] <- submodel
227         }
228         return(model)
229 }
230
231 imxLocateIndex <- function(model, name, referant) {
232         if (is.na(name)) { return(as.integer(name)) }
233         mNames <- names(model@matrices)
234         aNames <- names(model@algebras)
235         oNames <- names(model@objectives)
236         dNames <- names(model@datasets)         
237         matrixNumber <- match(name, mNames)
238         algebraNumber <- match(name, append(aNames, oNames))
239         dataNumber <- match(name, dNames)
240         if (is.na(matrixNumber) && is.na(algebraNumber) && is.na(dataNumber)) {
241                 msg <- paste("The reference", omxQuotes(name),
242                         "does not exist.  It is used by the named entity",
243                         omxQuotes(referant),".")
244                 stop(msg, call.=FALSE)
245         } else if (!is.na(matrixNumber)) {
246                 return(- matrixNumber)
247         } else if (!is.na(dataNumber)) {
248                 return(dataNumber - 1L)
249         } else {
250                 return(algebraNumber - 1L)
251         }
252 }
253
254 imxPreprocessModel <- function(model) {
255         model@matrices <- lapply(model@matrices, findSquareBrackets)
256         model@submodels <- lapply(model@submodels, imxPreprocessModel)
257         return(model)
258 }
259
260
261 imxCheckMatrices <- function(model) {
262         matrices <- model@matrices
263         lapply(matrices, imxVerifyMatrix)
264         submodels <- imxDependentModels(model)
265         lapply(submodels, imxCheckMatrices)
266 }