Implemented mxRename function. Another refactoring has changed trailing newline...
[openmx:openmx.git] / R / MxModelFunctions.R
1 #\r
2 #   Copyright 2007-2010 The OpenMx Project\r
3 #\r
4 #   Licensed under the Apache License, Version 2.0 (the "License");\r
5 #   you may not use this file except in compliance with the License.\r
6 #   You may obtain a copy of the License at\r
7\r
8 #        http://www.apache.org/licenses/LICENSE-2.0\r
9\r
10 #   Unless required by applicable law or agreed to in writing, software\r
11 #   distributed under the License is distributed on an "AS IS" BASIS,\r
12 #   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.\r
13 #   See the License for the specific language governing permissions and\r
14 #   limitations under the License.\r
15 \r
16 \r
17 generateMatrixList <- function(model) {\r
18         matvalues <- lapply(model@matrices, generateMatrixValuesHelper)\r
19         matnames  <- names(model@matrices)\r
20         names(matvalues) <- matnames\r
21         references <- generateMatrixReferences(model)\r
22         retval <- mapply(function(x,y) { c(list(x), y) }, \r
23                         matvalues, references, SIMPLIFY = FALSE)\r
24         return(retval)\r
25 }\r
26 \r
27 generateAlgebraList <- function(model) {\r
28         mNames <- names(model@matrices)\r
29         aNames <- names(model@algebras)\r
30         oNames <- names(model@objectives)\r
31         retval <- lapply(model@algebras, generateAlgebraHelper, \r
32                 mNames, append(aNames, oNames))\r
33     return(retval)\r
34 }\r
35 \r
36 generateParameterList <- function(flatModel) {\r
37         result <- list()\r
38         if (length(flatModel@matrices) == 0) {\r
39                 return(result)\r
40         }\r
41         for(i in 1:length(flatModel@matrices)) {\r
42                 matrix <- flatModel@matrices[[i]]\r
43                 result <- generateParameterListHelper(\r
44                         matrix, result, i - 1L)\r
45         }\r
46         return(result)\r
47 }\r
48 \r
49 generateDefinitionList <- function(flatModel) {\r
50         result <- list()\r
51         defLocations <- generateDefinitionLocations(flatModel@datasets)\r
52         if (length(flatModel@matrices) == 0) {\r
53                 return(result)\r
54         }\r
55         for(i in 1:length(flatModel@matrices)) {\r
56                 result <- generateDefinitionListHelper(\r
57                         flatModel@matrices[[i]], \r
58                         result, defLocations, i - 1L)\r
59         }       \r
60         return(result)\r
61 }\r
62 \r
63 generateValueList <- function(mList, pList) {\r
64         mList <- lapply(mList, function(x) { x[[1]] })\r
65         retval <- vector()\r
66         if (length(pList) == 0) {\r
67                 return(retval)\r
68         }\r
69         for(i in 1:length(pList)) {\r
70                 parameter <- pList[[i]]\r
71                 parameter <- parameter[3:length(parameter)] # Remove (min, max) bounds\r
72                 if (length(parameter) > 1) {\r
73                         values <- sapply(parameter, generateValueHelper, mList)\r
74                         if (!all(values == values[[1]])) {\r
75                                 warning(paste('Parameter',i,'has multiple start values.',\r
76                                         'Selecting', values[[1]]))\r
77                         }\r
78                         retval[i] <- values[[1]]\r
79                 } else {\r
80                         retval[i] <- generateValueHelper(parameter[[1]], mList)\r
81                 }\r
82     }\r
83         return(retval)  \r
84 }\r
85 \r
86 generateValueHelper <- function(triple, mList) {\r
87         mat <- triple[1] + 1\r
88         row <- triple[2] + 1\r
89         col <- triple[3] + 1\r
90         return(mList[[mat]][row,col])\r
91 }\r
92 \r
93 getObjectiveIndex <- function(flatModel) {\r
94         objective <- flatModel@objective\r
95         if(is.null(objective)) {\r
96                 return(NULL)\r
97         } else {\r
98                 return(omxLocateIndex(flatModel, objective@name, flatModel@name))\r
99         }\r
100 }\r
101 \r
102 omxUpdateModelValues <- function(model, flatModel, pList, values) {\r
103         if(length(pList) != length(values)) {\r
104                 stop(paste("This model has", length(pList), \r
105                         "parameters, but you have given me", length(values),\r
106                         "values"))\r
107         }\r
108         if (length(pList) == 0) {\r
109                 return(model)\r
110         }\r
111         for(i in 1:length(pList)) {\r
112                 parameters <- pList[[i]]\r
113                 parameters <- parameters[3:length(parameters)] # Remove (min, max) bounds\r
114                 model <- updateModelValuesHelper(parameters, values[[i]], flatModel, model)\r
115     }\r
116         return(model)\r
117 }\r
118 \r
119 updateModelValuesHelper <- function(triples, value, flatModel, model) {\r
120         for(i in 1:length(triples)) {\r
121                 triple <- triples[[i]]\r
122                 mat <- triple[1] + 1\r
123                 row <- triple[2] + 1\r
124                 col <- triple[3] + 1\r
125                 name <- flatModel@matrices[[mat]]@name\r
126                 model[[name]]@values[row,col] <- value\r
127         }\r
128         return(model)\r
129 }\r
130 \r
131 removeTail <- function(lst, tailSize) {\r
132     newEnd <- length(lst) - tailSize\r
133     if (newEnd == 0) {\r
134         return(list())\r
135     } else {\r
136         return(lst[1 : newEnd])\r
137     }\r
138 }\r
139 \r
140 updateModelMatrices <- function(model, flatModel, values) {\r
141     flatModel@matrices <- removeTail(flatModel@matrices, length(flatModel@constMatrices))\r
142     flatModel@matrices <- removeTail(flatModel@matrices, length(flatModel@freeMatrices))\r
143     flatModel@matrices <- removeTail(flatModel@matrices, length(flatModel@outsideMatrices))\r
144     values <- removeTail(values, length(flatModel@constMatrices))    \r
145     values <- removeTail(values, length(flatModel@freeMatrices))\r
146     values <- removeTail(values, length(flatModel@outsideMatrices))    \r
147         mList <- names(flatModel@matrices)\r
148         if (length(mList) != length(values)) {\r
149                 stop(paste("This model has", length(mList), \r
150                         "matrices, but you have given me", length(values),\r
151                         "values"))\r
152         }\r
153         if (length(mList) == 0) {\r
154                 return(model)\r
155         }       \r
156         model <- updateModelMatricesHelper(mList, values, model)\r
157         return(model)\r
158 }\r
159 \r
160 \r
161 updateModelAlgebras <- function(model, flatModel, values) {\r
162         aNames <- names(flatModel@algebras)\r
163         oNames <- names(flatModel@objectives)\r
164         aList <- append(aNames, oNames)\r
165         if(length(aList) != length(values)) {\r
166                 stop(paste("This model has", length(aList), \r
167                         "algebras, but you have given me", length(values),\r
168                         "values"))\r
169         }\r
170         if (length(aList) == 0) {\r
171                 return(model)\r
172         }       \r
173         model <- updateModelAlgebrasHelper(aList, values, model)\r
174         return(model)\r
175 }\r
176 \r
177 updateModelMatricesHelper <- function(mList, values, model) {\r
178         for(i in 1:length(mList)) {\r
179                 name <- mList[[i]]\r
180                 dimnames(values[[i]]) <- dimnames(model[[name]])\r
181                 model[[name]]@values <- values[[i]]\r
182         }\r
183         return(model)\r
184 }\r
185 \r
186 updateModelAlgebrasHelper <- function(aList, values, model) {\r
187         for(i in 1:length(aList)) {\r
188                 name <- aList[[i]]\r
189                 candidate <- model[[name]]\r
190                 if (!is.null(candidate) && (length(values[[i]]) > 0) \r
191                         && !is.nan(values[[i]]) && \r
192                         (is(candidate,"MxAlgebra") || (is(candidate,"MxObjective")))) {\r
193                         model[[name]]@result <- as.matrix(values[[i]])\r
194                         if (is(candidate, "MxAlgebra")) {\r
195                                 dimnames(model[[name]]@result) <- dimnames(model[[name]])\r
196                         }\r
197                 }\r
198         }\r
199         return(model)\r
200 }\r
201 \r
202 omxLocateIndex <- function(model, name, referant) {\r
203         if (is.na(name)) { return(as.integer(name)) }\r
204         mNames <- names(model@matrices)\r
205         aNames <- names(model@algebras)\r
206         oNames <- names(model@objectives)\r
207         dNames <- names(model@datasets)         \r
208         matrixNumber <- match(name, mNames)\r
209         algebraNumber <- match(name, append(aNames, oNames))\r
210         dataNumber <- match(name, dNames)\r
211         if (is.na(matrixNumber) && is.na(algebraNumber) && is.na(dataNumber)) {\r
212                 msg <- paste("The reference", omxQuotes(name),\r
213                         "does not exist.  It is used by the named entity",\r
214                         omxQuotes(referant),".")\r
215                 stop(msg, call.=FALSE)\r
216         } else if (!is.na(matrixNumber)) {\r
217                 return(- matrixNumber)\r
218         } else if (!is.na(dataNumber)) {\r
219                 return(dataNumber - 1L)\r
220         } else {\r
221                 return(algebraNumber - 1L)\r
222         }\r
223 }\r
224 \r
225 omxCheckMatrices <- function(model) {\r
226         matrices <- model@matrices\r
227         lapply(matrices, omxVerifyMatrix)\r
228         submodels <- omxDependentModels(model)\r
229         if(length(submodels) > 0) {\r
230                 omxLapply(submodels, omxCheckMatrices)\r
231         }\r
232 }