Implemented mxEval() caching system
[openmx:openmx.git] / R / MxRowObjective.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 setClass(Class = "MxRowObjective",
18         representation = representation(
19                 rowAlgebra = "MxCharOrNumber",
20                 rowResults = "MxCharOrNumber",
21                 filteredDataRow = "MxCharOrNumber",
22                 existenceVector = "MxCharOrNumber",
23                 reduceAlgebra = "MxCharOrNumber",
24                 definitionVars = "list",
25                 dims = "character",
26                 dataColumns = "numeric"),
27         contains = "MxBaseObjective")
28
29 setMethod("initialize", "MxRowObjective",
30         function(.Object, rowAlgebra, rowResults, filteredDataRow, 
31                 existenceVector, reduceAlgebra, dims,
32                 data = as.integer(NA), definitionVars = list(), name = 'objective') {
33                 .Object@name <- name
34                 .Object@rowAlgebra <- rowAlgebra
35                 .Object@rowResults <- rowResults
36                 .Object@reduceAlgebra <- reduceAlgebra
37                 .Object@filteredDataRow <- filteredDataRow
38                 .Object@existenceVector <- existenceVector
39                 .Object@data <- data
40                 .Object@definitionVars <- definitionVars
41                 .Object@dims <- dims
42                 return(.Object)
43         }
44 )
45
46 setMethod("genericObjNewEntities", signature("MxRowObjective"),
47         function(.Object) {
48                 if (is.na(.Object@rowResults) && is.na(.Object@filteredDataRow) && is.na(.Object@existenceVector)) {
49                         return(NULL)
50                 } else {
51                         a <- .Object@rowResults
52                         b <- .Object@filteredDataRow
53                         c <- .Object@existenceVector
54                         retval <- c(a, b, c)
55                         retval <- as.character(na.omit(retval))
56                         return(retval)
57                 }
58         }
59 )
60
61 setMethod("genericObjDependencies", signature("MxRowObjective"),
62         function(.Object, dependencies) {
63         sources <- c(.Object@reduceAlgebra)
64         sources <- sources[!is.na(sources)]
65         if (length(sources) > 0) {
66                 dependencies <- imxAddDependency(sources, .Object@name, dependencies)
67         }
68         return(dependencies)
69 })
70
71
72 setMethod("genericObjFunNamespace", signature("MxRowObjective"), 
73         function(.Object, modelname, namespace) {
74                 .Object@name <- imxIdentifier(modelname, .Object@name)
75                 .Object@rowAlgebra <- imxConvertIdentifier(.Object@rowAlgebra, 
76                         modelname, namespace)
77                 .Object@rowResults <- imxConvertIdentifier(.Object@rowResults,
78                         modelname, namespace)
79                 .Object@filteredDataRow <- imxConvertIdentifier(.Object@filteredDataRow, 
80                         modelname, namespace)
81                 .Object@existenceVector <- imxConvertIdentifier(.Object@existenceVector, 
82                         modelname, namespace)
83                 .Object@reduceAlgebra <- imxConvertIdentifier(.Object@reduceAlgebra, 
84                         modelname, namespace)
85                 .Object@data <- imxConvertIdentifier(.Object@data, 
86                         modelname, namespace)
87                 return(.Object)
88 })
89
90 setMethod("genericObjRename", signature("MxRowObjective"),
91         function(.Object, oldname, newname) {
92                 .Object@rowAlgebra <- renameReference(.Object@rowAlgebra, oldname, newname)
93                 .Object@reduceAlgebra <- renameReference(.Object@reduceAlgebra, oldname, newname)
94                 .Object@data <- renameReference(.Object@data, oldname, newname)
95                 return(.Object)
96 })
97
98 setMethod("genericObjFunConvert", signature("MxRowObjective"), 
99         function(.Object, flatModel, model, defVars) {
100                 modelname <- imxReverseIdentifier(model, .Object@name)[[1]]
101                 name <- .Object@name
102                 dataName <- .Object@data 
103                 if(is.na(dataName)) {
104                         msg <- paste("The MxRowObjective objective function",
105                                 "does not have a dataset associated with it in model",
106                                 omxQuotes(modelname))
107                         stop(msg, call. = FALSE)
108                 }
109                 mxDataObject <- flatModel@datasets[[dataName]]
110                 if (mxDataObject@type != 'raw') {
111                         msg <- paste("The dataset associated with the MxRowObjective objective", 
112                                 "in model", omxQuotes(modelname), "is not raw data.")
113                         stop(msg, call. = FALSE)
114                 }
115                 .Object@definitionVars <- imxFilterDefinitionVariables(defVars, dataName)
116                 .Object@rowAlgebra <- imxLocateIndex(flatModel, .Object@rowAlgebra, name)
117                 .Object@rowResults <- imxLocateIndex(flatModel, .Object@rowResults, name)
118                 .Object@filteredDataRow <- imxLocateIndex(flatModel, .Object@filteredDataRow, name)
119                 .Object@existenceVector <- imxLocateIndex(flatModel, .Object@existenceVector, name)
120                 .Object@reduceAlgebra <- imxLocateIndex(flatModel, .Object@reduceAlgebra, name)
121                 .Object@data <- imxLocateIndex(flatModel, dataName, name)
122                 .Object@dataColumns <- generateRowDataColumns(flatModel, .Object@dims, dataName)
123                 if (length(mxDataObject@observed) == 0) {
124                         .Object@data <- as.integer(NA)
125                 }
126                 return(.Object)
127 })
128
129 generateRowDataColumns <- function(flatModel, expectedNames, dataName) {
130         retval <- c()
131         dataColumnNames <- dimnames(flatModel@datasets[[dataName]]@observed)[[2]]
132         for(i in 1:length(expectedNames)) {
133                 targetName <- expectedNames[[i]]
134                 index <- match(targetName, dataColumnNames)
135                 if(is.na(index)) {
136                         msg <- paste("The column name", omxQuotes(targetName),
137                                 "in the expected covariance matrix",
138                                 "of the FIML objective function in model",
139                                 omxQuotes(flatModel@name),
140                                 "cannot be found in the column names of the data.")
141                         stop(msg, call. = FALSE)
142                 }
143                 retval[[i]] <- index - 1
144         }
145         return(retval)
146 }
147
148 setMethod("genericObjModelConvert", "MxRowObjective",
149         function(.Object, job, model, namespace, labelsData, flatJob) {
150                 rowAlgebraName <- .Object@rowAlgebra
151                 rowResultsName <- .Object@rowResults
152                 filteredDataRowName <- .Object@filteredDataRow
153                 existenceVectorName <- .Object@existenceVector
154                 reduceAlgebraName <- .Object@reduceAlgebra
155                 dimnames <- .Object@dims
156
157                 # Create the filtered data row
158                 if (is.na(filteredDataRowName)) {
159                         filteredDataRowName <- imxIdentifier(model@name, imxUntitledName())
160                 }
161                 filteredDataRow <- job[[filteredDataRowName]]
162                 if (!is.null(filteredDataRow)) {
163                         msg <- paste("The filteredDataRow cannot have name", 
164                                 omxQuotes(simplifyName(filteredDataRowName, model@name)), 
165                                 "because this entity already exists in the model")
166                         stop(msg, call. = FALSE)
167                 }
168                 filteredDataRow <- mxMatrix('Full', nrow = 1, ncol = length(dimnames))
169                 job[[filteredDataRowName]] <- filteredDataRow
170                 flatJob[[filteredDataRowName]] <- filteredDataRow
171                 pair <- imxReverseIdentifier(model, filteredDataRowName)
172                 if (model@name == pair[[1]]) {
173                         job[[.Object@name]]@filteredDataRow <- pair[[2]]
174                 } else {
175                         job[[.Object@name]]@filteredDataRow <- filteredDataRowName
176                 }
177
178                 # Create the existence vector
179                 if (!is.na(existenceVectorName)) {
180                         existenceVector <- job[[existenceVectorName]]
181                         if (!is.null(existenceVector)) {
182                                 msg <- paste("The existenceVector cannot have name", 
183                                         omxQuotes(simplifyName(existenceVectorName, model@name)), 
184                                         "because this entity already exists in the model")
185                                 stop(msg, call. = FALSE)
186                         }
187                         existenceVector <- mxMatrix('Full', nrow = 1, ncol = length(dimnames), values = 1)
188                         job[[existenceVectorName]] <- existenceVector
189                         flatJob[[existenceVectorName]] <- existenceVector
190                         pair <- imxReverseIdentifier(model, existenceVectorName)
191                         if (model@name == pair[[1]]) {
192                                 job[[.Object@name]]@existenceVector <- pair[[2]]
193                         } else {
194                                 job[[.Object@name]]@existenceVector <- existenceVectorName
195                         }
196                 }
197
198                 # Locate the row algebra
199                 rowAlgebra <- job[[rowAlgebraName]]
200                 if (is.null(rowAlgebra)) {
201                         msg <- paste("The rowAlgebra with name", 
202                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
203                                 "is not defined in the model")
204                         stop(msg, call. = FALSE)
205                 }
206                 labelsData <- imxGenerateLabels(job)
207                 tuple <- evaluateMxObject(rowAlgebraName, flatJob, labelsData, list())
208                 result <- tuple[[1]]
209                 if (nrow(result) != 1) {
210                         msg <- paste("The rowAlgebra with name", 
211                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
212                                 "does not evaluate to a row vector")
213                         stop(msg, call. = FALSE)                        
214                 }
215                 if (is.na(.Object@data)) {
216                         msg <- paste("The MxRowObjective objective function",
217                                 "does not have a dataset associated with it in model",
218                                 omxQuotes(model@name))
219                         stop(msg, call.=FALSE)          
220                 }
221                 mxDataObject <- flatJob@datasets[[.Object@data]]
222
223                 # Create the row results
224                 rows <- nrow(mxDataObject@observed)
225                 cols <- ncol(result)
226                 if (is.na(rowResultsName)) {
227                         rowResultsName <- imxIdentifier(model@name, imxUntitledName())
228                 }
229                 rowResults <- job[[rowResultsName]]
230                 if (!is.null(rowResults)) {
231                         msg <- paste("The rowResults cannot have name", 
232                                 omxQuotes(simplifyName(rowResultsName, model@name)), 
233                                 "because this entity already exists in the model")
234                         stop(msg, call. = FALSE)
235                 }
236                 rowResults <- mxMatrix('Full', nrow = rows, ncol = cols)
237                 job[[rowResultsName]] <- rowResults
238                 flatJob[[rowResultsName]] <- rowResults
239                 pair <- imxReverseIdentifier(model, rowResultsName)
240                 if (model@name == pair[[1]]) {
241                         job[[.Object@name]]@rowResults <- pair[[2]]
242                 } else {
243                         job[[.Object@name]]@rowResults <- rowResultsName
244                 }
245
246                 # Locate the reduce algebra
247                 reduceAlgebra <- job[[reduceAlgebraName]]
248                 if (is.null(reduceAlgebra)) {
249                         msg <- paste("The reduceAlgebra with name", 
250                                 omxQuotes(simplifyName(reduceAlgebraName, model@name)), 
251                                 "is not defined in the model")
252                         stop(msg, call. = FALSE)
253                 }
254                 job@.newobjects <- TRUE
255                 job@.newobjective <- FALSE
256                 job@.newtree <- FALSE
257                 return(list(job, flatJob))
258         }
259 )
260
261 setMethod("genericObjInitialMatrix", "MxRowObjective",
262         function(.Object, flatModel) {
263                 reduceAlgebraName <- .Object@reduceAlgebra
264                 labelsData <- imxGenerateLabels(flatModel)
265                 tuple <- evaluateMxObject(reduceAlgebraName, flatModel, labelsData, list())
266                 result <- tuple[[1]]
267                 return(result)
268         }
269 )
270
271 checkStringArgument <- function(arg, name) {
272         if (single.na(arg)) {
273                 arg <- as.character(NA) 
274         } else if (length(unlist(strsplit(arg, imxSeparatorChar, fixed = TRUE))) > 1) {
275                 stop(paste("the", omxQuotes(name), "argument cannot contain the", 
276                         omxQuotes(imxSeparatorChar), 
277                         "character"))
278         }
279         if (!(is.vector(arg) && 
280                 (typeof(arg) == 'character') && 
281                 (length(arg) == 1))) {
282                 stop("the", omxQuotes(name), "argument is not a string")
283         }
284         return(arg)
285 }
286
287 mxRowObjective <- function(rowAlgebra, reduceAlgebra, dimnames, rowResults = "rowResults", 
288         filteredDataRow = "filteredDataRow", existenceVector = "existenceVector") {
289         if (missing(rowAlgebra) || typeof(rowAlgebra) != "character") {
290                 stop("the 'rowAlgebra' argument is not a string (the name of the row-by-row algebra)")
291         }
292         if (missing(reduceAlgebra) || typeof(reduceAlgebra) != "character") {
293                 stop("the 'reduceAlgebra' argument is not a string (the name of the reduction algebra)")
294         }
295         if (missing(dimnames) || typeof(dimnames) != "character") {
296                 stop("the 'dimnames' argument is not a string (the column names from the data set)")
297         }
298         if (any(is.na(dimnames))) {
299                 stop("NA values are not allowed for 'dimnames' vector")
300         }
301         rowResults <- checkStringArgument(rowResults, "rowResults")
302         filteredDataRow <- checkStringArgument(filteredDataRow, "filteredDataRow")
303         existenceVector <- checkStringArgument(existenceVector, "existenceVector")
304         return(new("MxRowObjective", rowAlgebra, rowResults, filteredDataRow, existenceVector, reduceAlgebra, dimnames))
305 }
306
307 printSlot <- function(object, slotName) {
308         val <- slot(object, slotName)
309         if (single.na(val)) {
310                 msg <- paste('@', slotName, ' : NA \n', sep = '')
311         } else {
312                 msg <- paste('@', slotName, ' : ',omxQuotes(val), '\n', sep = '')
313         }
314         cat(msg)
315 }
316
317 displayRowObjective <- function(objective) {
318         cat("MxRowObjective", omxQuotes(objective@name), '\n')
319         cat("@rowAlgebra :", omxQuotes(objective@rowAlgebra), '\n')
320         printSlot(objective, "rowResults")
321         printSlot(objective, "filteredDataRow")
322         printSlot(objective, "existenceVector")
323         printSlot(objective, "reduceAlgebra")
324         if (length(objective@result) == 0) {
325                 cat("@result: (not yet computed) ")
326         } else {
327                 cat("@result:\n")
328         }
329         print(objective@result)
330         invisible(objective)
331 }
332
333
334 setMethod("print", "MxRowObjective", function(x,...) { 
335         displayRowObjective(x) 
336 })
337
338 setMethod("show", "MxRowObjective", function(object) { 
339         displayRowObjective(object) 
340 })