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