Added more tests to AlgebraCompute.R, and now some algebra
[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 generateMatrixList <- function(mxModel) {
18         matvalues <- lapply(mxModel@matrices, generateMatrixValuesHelper)
19         matnames  <- names(mxModel@matrices)
20         names(matvalues) <- matnames
21         references <- generateMatrixReferences(mxModel)
22         retval <- mapply(function(x,y) { c(list(x), y) }, 
23                         matvalues, references, SIMPLIFY = FALSE)
24         return(retval)
25 }
26
27 generateSimpleMatrixList <- function(mxModel) {
28         retval <- generateMatrixList(mxModel)
29         retval <- lapply(retval, function(x) { 
30                 c(list(as.matrix(x[[1]])), x[-1]) }) 
31         return(retval)
32 }
33
34 generateAlgebraList <- function(mxModel) {
35         mNames <- names(mxModel@matrices)
36         aNames <- names(mxModel@algebras)
37         oNames <- names(mxModel@objectives)
38         retval <- lapply(mxModel@algebras, generateAlgebraHelper, 
39                 mNames, append(aNames, oNames))
40     return(retval)
41 }
42
43 generateParameterList <- function(flatModel) {
44         result <- list()
45         if (length(flatModel@matrices) == 0) {
46                 return(result)
47         }
48         for(i in 1:length(flatModel@matrices)) {
49                 matrix <- flatModel@matrices[[i]]
50                 result <- generateParameterListHelper(
51                         matrix, result, i - 1)
52         }
53         return(result)
54 }
55
56 generateDefinitionList <- function(flatModel) {
57         result <- list()
58         defLocations <- generateDefinitionLocations(flatModel@datasets)
59         if (length(flatModel@matrices) == 0) {
60                 return(result)
61         }
62         for(i in 1:length(flatModel@matrices)) {
63                 result <- generateDefinitionListHelper(
64                         flatModel@matrices[[i]], 
65                         result, defLocations, i - 1)
66         }       
67         return(result)
68 }
69
70 generateValueList <- function(mxModel, mList, pList) {
71         mList <- lapply(mList, function(x) { x[[1]] })
72         retval <- vector()
73         if (length(pList) == 0) {
74                 return(retval)
75         }
76         for(i in 1:length(pList)) {
77                 parameter <- pList[[i]]
78                 parameter <- parameter[3:length(parameter)] # Remove (min, max) bounds
79                 if (length(parameter) > 1) {
80                         values <- sapply(parameter, generateValueHelper, mList)
81                         if (!all(values == values[[1]])) {
82                                 warning(paste('Parameter',i,'has multiple start values.',
83                                         'Selecting', values[[1]]))
84                         }
85                         retval[i] <- values[[1]]
86                 } else {
87                         retval[i] <- generateValueHelper(parameter[[1]], mList)
88                 }
89     }
90         return(retval)  
91 }
92
93 generateValueHelper <- function(triple, mList) {
94         mat <- triple[1] + 1
95         row <- triple[2] + 1
96         col <- triple[3] + 1
97         return(mList[[mat]][row,col])
98 }
99
100 convertObjectives <- function(flatModel, definitions) {
101         retval <- lapply(flatModel@objectives, function(x) {
102                 omxObjFunConvert(x, flatModel, definitions)
103         })
104         return(retval)
105 }
106
107 getObjectiveIndex <- function(flatModel) {
108         objective <- flatModel@objective
109         if(is.null(objective)) {
110                 return(NULL)
111         } else {
112                 return(omxLocateIndex(flatModel, objective@name, flatModel@name))
113         }
114 }
115
116 updateModelValues <- function(model, flatModel, pList, values) {
117         if(length(pList) != length(values)) {
118                 stop(paste("This model has", length(pList), 
119                         "parameters, but you have given me", length(values),
120                         "values"))
121         }
122         if (length(pList) == 0) {
123                 return(model)
124         }
125         for(i in 1:length(pList)) {
126                 parameters <- pList[[i]]
127                 parameters <- parameters[3:length(parameters)] # Remove (min, max) bounds
128                 model <- updateModelValuesHelper(parameters, values[[i]], flatModel, model)
129     }
130         return(model)
131 }
132
133 updateModelValuesHelper <- function(triples, value, flatModel, model) {
134         for(i in 1:length(triples)) {
135                 triple <- triples[[i]]
136                 mat <- triple[1] + 1
137                 row <- triple[2] + 1
138                 col <- triple[3] + 1
139                 name <- flatModel@matrices[[mat]]@name
140                 model[[name]]@values[row,col] <- value
141         }
142         return(model)
143 }
144
145 updateModelMatrices <- function(model, flatModel, values) {
146         mList <- names(flatModel@matrices)
147         if (length(mList) != length(values)) {
148                 stop(paste("This model has", length(mList), 
149                         "matrices, but you have given me", length(values),
150                         "values"))
151         }
152         if (length(mList) == 0) {
153                 return(model)
154         }       
155         model <- updateModelMatricesHelper(mList, values, model)
156         return(model)
157 }
158
159
160 updateModelAlgebras <- function(model, flatModel, values) {
161         aNames <- names(flatModel@algebras)
162         oNames <- names(flatModel@objectives)
163         aList <- append(aNames, oNames)
164         if(length(aList) != length(values)) {
165                 stop(paste("This model has", length(aList), 
166                         "algebras, but you have given me", length(values),
167                         "values"))
168         }
169         if (length(aList) == 0) {
170                 return(model)
171         }       
172         model <- updateModelAlgebrasHelper(aList, values, model)
173         return(model)
174 }
175
176 updateModelMatricesHelper <- function(mList, values, model) {
177         for(i in 1:length(mList)) {
178                 name <- mList[[i]]
179                 model[[name]]@values <- values[[i]]
180         }
181         return(model)
182 }
183
184 updateModelAlgebrasHelper <- function(aList, values, model) {
185         for(i in 1:length(aList)) {
186                 name <- aList[[i]]
187                 candidate <- model[[name]]
188                 if (!is.null(candidate) && (length(values[[i]]) > 0) 
189                         && !is.nan(values[[i]]) && 
190                         (is(candidate,"MxAlgebra") || (is(candidate,"MxObjective")))) {
191                         model[[name]]@result <- as.matrix(values[[i]])
192                 }
193         }
194         return(model)
195 }
196
197 omxLocateIndex <- function(model, name, referant) {
198         mNames <- names(model@matrices)
199         aNames <- names(model@algebras)
200         oNames <- names(model@objectives)
201         dNames <- names(model@datasets)         
202         matrixNumber <- match(name, mNames)
203         algebraNumber <- match(name, append(aNames, oNames))
204         dataNumber <- match(name, dNames)
205         if (is.na(matrixNumber) && is.na(algebraNumber) && is.na(dataNumber)) {
206                 msg <- paste("The reference", omxQuotes(name),
207                         "does not exist.  It is used by the named entity",
208                         omxQuotes(referant),".")
209                 stop(msg, call.=FALSE)
210         } else if (!is.na(matrixNumber)) {
211                 return(- matrixNumber)
212         } else if (!is.na(dataNumber)) {
213                 return(dataNumber - 1)
214         } else {
215                 return(algebraNumber - 1)
216         }
217 }
218
219 omxCheckMatrices <- function(model) {
220         matrices <- model@matrices
221         lapply(matrices, omxVerifyMatrix)
222         if (length(model@submodels) > 0) {
223                 for(i in 1:length(model@submodels)) {
224                         submodel <- model@submodels[[i]]
225                         if(submodel@independent == FALSE) {
226                                 omxCheckMatrices(submodel)
227                         }
228                 }
229         }
230 }