Merging three-matrix branch into the trunk.
[openmx:openmx.git] / R / MxModelFunctions.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 omxGenerateMatrixList <- function(mxModel) {
18         return(lapply(mxModel@matrices, generateMatrixListHelper))
19 }
20
21 omxGenerateSimpleMatrixList <- function(mxModel) {
22         retval <- lapply(mxModel@matrices, generateMatrixListHelper)
23         return(lapply(retval, as.matrix))
24 }
25
26 omxGenerateAlgebraList <- function(mxModel) {
27         mNames <- names(mxModel@matrices)
28         aNames <- names(mxModel@algebras)
29         oNames <- names(mxModel@objectives)
30     retval <- lapply(mxModel@algebras, generateAlgebraHelper, 
31         mNames, append(aNames, oNames))
32     return(retval)
33 }
34
35 omxGenerateParameterList <- function(mxModel, defLocations) {
36         result <- list()
37         if (length(mxModel@matrices) == 0) {
38                 return(result)
39         }
40         for(i in 1:length(mxModel@matrices)) {
41                 result <- omxGenerateParameterListHelper(
42                         mxModel@matrices[[i]], 
43                         mxModel@bounds, result, names(defLocations), i - 1)
44         }       
45         return(result)
46 }
47
48 omxGenerateDefinitionList <- function(mxModel, defLocations) {
49         result <- list()
50         if (length(mxModel@matrices) == 0) {
51                 return(result)
52         }
53         for(i in 1:length(mxModel@matrices)) {
54                 result <- omxGenerateDefinitionListHelper(
55                         mxModel@matrices[[i]], 
56                         mxModel@bounds, result, defLocations, i - 1)
57         }       
58         return(result)
59 }
60
61 omxGenerateValueList <- function(mxModel, defLocations) {
62         mList <- omxGenerateMatrixList(mxModel)
63         pList <- omxGenerateParameterList(mxModel, defLocations)
64         retval <- vector()
65         if (length(pList) == 0) {
66                 return(retval)
67         }
68         for(i in 1:length(pList)) {
69                 parameter <- pList[[i]]
70                 parameter <- parameter[3:length(parameter)] # Remove (min, max) bounds
71                 if (length(parameter) > 1) {
72                         values <- sapply(parameter, generateValueHelper, mList)
73                         if (!all(values == values[[1]])) {
74                                 warning(paste('Parameter',i,'has multiple start values.',
75                                         'Selecting', values[[1]]))
76                         }
77                         retval[i] <- values[[1]]
78                 } else {
79                         retval[i] <- generateValueHelper(parameter[[1]], mList)
80                 }
81     }
82         return(retval)  
83 }
84
85 generateValueHelper <- function(triple, mList) {
86         mat <- triple[1] + 1
87         row <- triple[2] + 1
88         col <- triple[3] + 1
89         return(mList[[mat]][row,col])
90 }
91
92 omxConvertObjectives <- function(flatModel, definitions) {
93         retval <- lapply(flatModel@objectives, function(x) {
94                 omxObjFunConvert(x, flatModel, definitions)
95         })
96         return(retval)
97 }
98
99 omxObjectiveIndex <- function(flatModel) {
100         objective <- flatModel@objective
101         if(is.null(objective)) {
102                 return(NULL)
103         } else {
104                 return(omxLocateIndex(flatModel, objective@name, flatModel@name))
105         }
106 }
107
108 omxUpdateModelValues <- function(treeModel, flatModel, pList, values) {
109         if(length(pList) != length(values)) {
110                 stop(paste("This model has", length(pList), 
111                         "parameters, but you have given me", length(values),
112                         "values"))
113         }
114         if (length(pList) == 0) {
115                 return(treeModel)
116         }
117         for(i in 1:length(pList)) {
118                 parameters <- pList[[i]]
119                 parameters <- parameters[3:length(parameters)] # Remove (min, max) bounds
120                 treeModel <- updateModelValueHelper(
121                         parameters, values[[i]], treeModel, flatModel)
122     }
123         return(treeModel)
124 }
125
126 updateModelValueHelper <- function(triples, value, treeModel, flatModel) {
127         for(i in 1:length(triples)) {
128                 triple <- triples[[i]]
129                 mat <- triple[1] + 1
130                 row <- triple[2] + 1
131                 col <- triple[3] + 1
132                 name <- flatModel@matrices[[mat]]@name
133                 if(!is.null(treeModel[[name]])) {
134                         treeModel[[name]]@values[row,col] <- value
135                 }
136         }
137         treeModel@submodels <- lapply(treeModel@submodels, 
138                 function(x) { updateModelValueHelper(
139                         triples, value, x, flatModel) })
140         return(treeModel)
141 }
142
143 omxUpdateModelAlgebras <- function(treeModel, flatModel, values) {
144         aNames <- names(flatModel@algebras)
145         oNames <- names(flatModel@objectives)
146         aList <- append(aNames, oNames)
147         if(length(aList) != length(values)) {
148                 stop(paste("This model has", length(aList), 
149                         "algebras, but you have given me", length(values),
150                         "values"))
151         }
152         if (length(aList) == 0) {
153                 return(treeModel)
154         }       
155         treeModel <- updateModelAlgebraHelper(aList, values, treeModel)
156         return(treeModel)
157 }
158
159 updateModelAlgebraHelper <- function(aList, values, model) {
160         for(i in 1:length(aList)) {
161                 name <- aList[[i]]
162                 candidate <- model[[name]]
163                 if (!is.null(candidate) && !is.nan(values[[i]]) && 
164                         (is(candidate,"MxAlgebra") || (is(candidate,"MxObjective")))) {
165                         model[[name]]@result <- matrix(values[[i]])
166                 }
167         }
168         model@submodels <- lapply(model@submodels, function(x) {
169                 updateModelAlgebraHelper(aList, values, x)})
170         return(model)
171 }
172
173 omxLocateIndex <- function(model, name, referant) {
174         mNames <- names(model@matrices)
175         aNames <- names(model@algebras)
176         oNames <- names(model@objectives)
177         dNames <- names(model@datasets)         
178         matrixNumber <- match(name, mNames)
179         algebraNumber <- match(name, append(aNames, oNames))
180         dataNumber <- match(name, dNames)
181         if (is.na(matrixNumber) && is.na(algebraNumber) && is.na(dataNumber)) {
182                 msg <- paste("The reference", omxQuotes(name),
183                         "does not exist.  It is used by the named entity",
184                         omxQuotes(referant),".")
185                 stop(msg, call.=FALSE)
186         } else if (!is.na(matrixNumber)) {
187                 return(- matrixNumber)
188         } else if (!is.na(dataNumber)) {
189                 return(dataNumber - 1)
190         } else {
191                 return(algebraNumber - 1)
192         }
193 }
194
195 omxCheckMatrices <- function(model) {
196         matrices <- model@matrices
197         lapply(matrices, omxVerifyMatrix)
198         if (length(model@submodels) > 0) {
199                 for(i in 1:length(model@submodels)) {
200                         submodel <- model@submodels[[i]]
201                         if(submodel@independent == FALSE) {
202                                 omxCheckMatrices(submodel)
203                         }
204                 }
205         }
206 }