Initial commit of MxRowObjective.R
[openmx:openmx.git] / R / MxRowObjective.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 setClass(Class = "MxRowObjective",\r
18         representation = representation(\r
19                 rowAlgebra = "MxCharOrNumber",\r
20                 rowResults = "MxCharOrNumber",\r
21                 reduceAlgebra = "MxCharOrNumber",\r
22                 definitionVars = "list"),\r
23         contains = "MxBaseObjective")\r
24 \r
25 setMethod("initialize", "MxRowObjective",\r
26         function(.Object, rowAlgebra, rowResults, reduceAlgebra,\r
27                 data = as.integer(NA), definitionVars = list(), name = 'objective') {\r
28                 .Object@name <- name\r
29                 .Object@rowAlgebra <- rowAlgebra\r
30                 .Object@rowResults <- rowResults\r
31                 .Object@reduceAlgebra <- reduceAlgebra          \r
32                 .Object@data <- data\r
33                 .Object@definitionVars <- definitionVars
34                 return(.Object)\r
35         }\r
36 )
37
38 setMethod("omxObjDependencies", signature("MxRowObjective"),
39         function(.Object, dependencies) {
40         sources <- c(.Object@reduceAlgebra)
41         sources <- sources[!is.na(sources)]
42         if (length(sources) > 0) {\r
43                 dependencies <- omxAddDependency(sources, .Object@name, dependencies)
44         }\r
45         return(dependencies)
46 })
47 \r
48 \r
49 setMethod("omxObjFunNamespace", signature("MxRowObjective"), \r
50         function(.Object, modelname, namespace) {\r
51                 .Object@name <- omxIdentifier(modelname, .Object@name)\r
52                 .Object@rowAlgebra <- omxConvertIdentifier(.Object@rowAlgebra, \r
53                         modelname, namespace)\r
54                 .Object@rowResults <- omxConvertIdentifier(.Object@rowResults, \r
55                         modelname, namespace)\r
56                 .Object@reduceAlgebra <- omxConvertIdentifier(.Object@reduceAlgebra, \r
57                         modelname, namespace)\r
58                 .Object@data <- omxConvertIdentifier(.Object@data, \r
59                         modelname, namespace)\r
60                 return(.Object)\r
61 })\r
62 \r
63 setMethod("omxObjFunConvert", signature("MxRowObjective"), \r
64         function(.Object, flatModel, model) {
65                 modelname <- omxReverseIdentifier(model, .Object@name)[[1]]\r
66                 name <- .Object@name\r
67                 if(is.na(.Object@data)) {\r
68                         msg <- paste("The MxRowObjective objective function",\r
69                                 "does not have a dataset associated with it in model",\r
70                                 omxQuotes(modelname))\r
71                         stop(msg, call.=FALSE)\r
72                 }\r
73                 mxDataObject <- flatModel@datasets[[.Object@data]]\r
74                 if (mxDataObject@type != 'raw') {\r
75                         msg <- paste("The dataset associated with the MxRowObjective objective", \r
76                                 "in model", omxQuotes(modelname), "is not raw data.")\r
77                         stop(msg, call.=FALSE)\r
78                 }\r
79                 .Object@rowAlgebra <- omxLocateIndex(flatModel, .Object@rowAlgebra, name)\r
80                 .Object@rowResults <- omxLocateIndex(flatModel, .Object@rowResults, name)\r
81                 .Object@reduceAlgebra <- omxLocateIndex(flatModel, .Object@reduceAlgebra, name)\r
82                 .Object@definitionVars <- generateDefinitionList(flatModel)\r
83                 if (length(mxDataObject@observed) == 0) {\r
84                         .Object@data <- as.integer(NA)\r
85                 }\r
86                 return(.Object)\r
87 })
88
89 setMethod("omxObjModelConvert", "MxRowObjective",
90         function(.Object, job, model, flatJob) {
91                 rowAlgebraName <- .Object@rowAlgebra\r
92                 rowResultsName <- .Object@rowResults\r
93                 reduceAlgebraName <- .Object@reduceAlgebra\r
94                 rowAlgebra <- job[[rowAlgebraName]]\r
95                 if (is.null(rowAlgebra)) {\r
96                         msg <- paste("The rowAlgebra with name", \r
97                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), \r
98                                 "is not defined in the model")\r
99                         stop(msg, call. = FALSE)\r
100                 }\r
101                 labelsData <- omxGenerateLabels(job)            \r
102                 result <- tryCatch(eval(computeSymbol(as.symbol(rowAlgebraName), flatJob, labelsData)), \r
103                         error = function(x) {\r
104                                 stop(paste("The entity", \r
105                                         omxQuotes(simplifyName(rowAlgebraName, model@name)), \r
106                                         "in model", omxQuotes(model@name), \r
107                                         "generated the error message:",\r
108                                         x$message), call. = FALSE)\r
109                 })\r
110                 if (nrow(result) != 1) {\r
111                         msg <- paste("The rowAlgebra with name", \r
112                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), \r
113                                 "does not evaluate to a row vector")\r
114                         stop(msg, call. = FALSE)                        \r
115                 }\r
116                 if (is.na(.Object@data)) {\r
117                         msg <- paste("The MxRowObjective objective function",\r
118                                 "does not have a dataset associated with it in model",\r
119                                 omxQuotes(model@name))\r
120                         stop(msg, call.=FALSE)          \r
121                 }\r
122                 mxDataObject <- flatJob@datasets[[.Object@data]]                \r
123                 rows <- nrow(mxDataObject@observed)\r
124                 cols <- ncol(result)\r
125                 if (is.na(rowResultsName)) {\r
126                         rowResultsName <- omxUntitledName()                     \r
127                 }\r
128                 rowResults <- job[[model@name]][[rowResultsName]]\r
129                 if (!is.null(rowResults)) {\r
130                         msg <- paste("The rowResults cannot have name", \r
131                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), \r
132                                 "because this entity already exists in the model")\r
133                         stop(msg, call. = FALSE)\r
134                 }\r
135                 rowResults <- mxMatrix('Full', nrow = rows, ncol = cols, name = rowResultsName)\r
136                 job[[model@name]][[rowResultsName]] <- rowResults\r
137                 job[[.Object@name]]@rowResults <- rowResultsName\r
138                 if (is.na(reduceAlgebraName)) {\r
139                         reduceAlgebraName <- omxUntitledName()\r
140                         reduceAlgebra <- eval(substitute(mxAlgebra(x, reduceAlgebraName), \r
141                                 list(x = as.symbol(rowResultsName))))\r
142                         job[[model@name]][[reduceAlgebraName]] <- reduceAlgebra         \r
143                         job[[.Object@name]]@reduceAlgebra <- reduceAlgebraName\r
144                         reduceAlgebraName <- omxIdentifier(model@name, reduceAlgebraName)\r
145                 }\r
146                 reduceAlgebra <- job[[reduceAlgebraName]]\r
147                 if (is.null(reduceAlgebra)) {\r
148                         msg <- paste("The reduceAlgebra with name", \r
149                                 omxQuotes(simplifyName(reduceAlgebraName, model@name)), \r
150                                 "is not defined in the model")\r
151                         stop(msg, call. = FALSE)\r
152                 }\r
153                 return(job)
154         }
155 )
156 \r\r
157 setMethod("omxObjInitialMatrix", "MxRowObjective",\r
158         function(.Object, flatModel) {\r
159                 reduceAlgebraName <- .Object@reduceAlgebra\r
160                 labelsData <- omxGenerateLabels(flatModel)              \r
161                 result <- tryCatch(eval(computeSymbol(as.symbol(reduceAlgebraName), flatModel, labelsData)), \r
162                         error = function(x) {\r
163                                 stop(paste("The entity", \r
164                                         omxQuotes(simplifyName(reduceAlgebraName, flatModel@name)), \r
165                                         "in model", omxQuotes(flatModel@name), \r
166                                         "generated the error message:",\r
167                                         x$message), call. = FALSE)\r
168                 })\r
169                 return(result)\r
170         }\r
171 )\r
172
173 mxRowObjective <- function(rowAlgebra, rowResults = NA, reduceAlgebra = NA) {\r
174         if (missing(rowAlgebra) || typeof(rowAlgebra) != "character") {\r
175                 stop("the 'rowAlgebra' argument is not a string (the name of the row-by-row algebra)")\r
176         }\r
177         if (single.na(rowResults)) {\r
178                 rowResults <- as.character(NA)  \r
179         } else if (length(unlist(strsplit(rowResults, omxSeparatorChar, fixed = TRUE))) > 1) {\r
180                 stop(paste("the 'rowResults' argument cannot contain the", \r
181                         omxQuotes(omxSeparatorChar), \r
182                         "character"))\r
183         }\r
184         if (!(is.vector(rowResults) && \r
185                 (typeof(rowResults) == 'character') && \r
186                 (length(rowResults) == 1))) {\r
187                 stop("the 'rowResults' argument is not a string (the name for the results matrix)")\r
188         }\r
189         if (single.na(reduceAlgebra)) {\r
190                 reduceAlgebra <- as.character(NA)       \r
191         }\r
192         if (!(is.vector(reduceAlgebra) && \r
193                 (typeof(reduceAlgebra) == 'character') && \r
194                 (length(reduceAlgebra) == 1))) {\r
195                 stop("the 'reduceAlgebra' argument is not a string (the name of the reduction algebra)")\r
196         }\r
197         return(new("MxRowObjective", rowAlgebra, rowResults, reduceAlgebra))\r
198 }\r
199 \r
200 displayRowObjective <- function(objective) {\r
201         cat("MxRowObjective", omxQuotes(objective@name), '\n')\r
202         cat("@rowAlgebra :", omxQuotes(objective@rowAlgebra), '\n')\r
203         if (single.na(objective@rowResults)) {\r
204                 cat("@rowResults : NA \n")\r
205         } else {\r
206                 cat("@rowResults :", omxQuotes(objective@rowResults), '\n')     \r
207         }\r
208         if (single.na(objective@reduceAlgebra)) {\r
209                 cat("@reduceAlgebra : NA \n")\r
210         } else {\r
211                 cat("@reduceAlgebra :", omxQuotes(objective@reduceAlgebra), '\n')       \r
212         }       \r
213         if (length(objective@result) == 0) {\r
214                 cat("@result: (not yet computed) ")\r
215         } else {\r
216                 cat("@result:\n")\r
217         }\r
218         print(objective@result)\r
219         invisible(objective)\r
220 }\r
221 \r
222 \r
223 setMethod("print", "MxRowObjective", function(x,...) { \r
224         displayRowObjective(x) \r
225 })\r
226 \r
227 setMethod("show", "MxRowObjective", function(object) { \r
228         displayRowObjective(object) \r
229 })\r