Implemented new protocol in frontend for MxRowObjective type.
[openmx:openmx.git] / R / MxRowObjective.R
1 #
2 #   Copyright 2007-2010 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, 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                         existenceVectorName <- imxIdentifier(model@name, imxUntitledName())
181                 }
182                 existenceVector <- job[[existenceVectorName]]
183                 if (!is.null(existenceVector)) {
184                         msg <- paste("The existenceVector cannot have name", 
185                                 omxQuotes(simplifyName(existenceVectorName, model@name)), 
186                                 "because this entity already exists in the model")
187                         stop(msg, call. = FALSE)
188                 }
189                 existenceVector <- mxMatrix('Full', nrow = 1, ncol = length(dimnames), values = 1)
190                 job[[existenceVectorName]] <- existenceVector
191                 flatJob[[existenceVectorName]] <- existenceVector
192                 pair <- imxReverseIdentifier(model, existenceVectorName)
193                 if (model@name == pair[[1]]) {
194                         job[[.Object@name]]@existenceVector <- pair[[2]]
195                 } else {
196                         job[[.Object@name]]@existenceVector <- existenceVectorName
197                 }
198
199                 # Locate the row algebra
200                 rowAlgebra <- job[[rowAlgebraName]]
201                 if (is.null(rowAlgebra)) {
202                         msg <- paste("The rowAlgebra with name", 
203                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
204                                 "is not defined in the model")
205                         stop(msg, call. = FALSE)
206                 }
207                 labelsData <- imxGenerateLabels(job)
208                 result <- evaluateMxObject(rowAlgebraName, flatJob, labelsData)
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                 if (is.na(reduceAlgebraName)) {
248                         reduceAlgebraName <- imxUntitledName()
249                         reduceAlgebra <- eval(substitute(mxAlgebra(x, reduceAlgebraName), 
250                                 list(x = quote(as.symbol(rowResultsName)))))
251                         job[[model@name]][[reduceAlgebraName]] <- reduceAlgebra
252                         job[[.Object@name]]@reduceAlgebra <- reduceAlgebraName
253                         reduceAlgebraName <- imxIdentifier(model@name, reduceAlgebraName)
254                 }
255                 reduceAlgebra <- job[[reduceAlgebraName]]
256                 if (is.null(reduceAlgebra)) {
257                         msg <- paste("The reduceAlgebra with name", 
258                                 omxQuotes(simplifyName(reduceAlgebraName, model@name)), 
259                                 "is not defined in the model")
260                         stop(msg, call. = FALSE)
261                 }
262                 job@.newobjects <- TRUE
263                 job@.newobjective <- FALSE
264                 job@.newtree <- FALSE
265                 return(job)
266         }
267 )
268
269 setMethod("genericObjInitialMatrix", "MxRowObjective",
270         function(.Object, flatModel) {
271                 reduceAlgebraName <- .Object@reduceAlgebra
272                 labelsData <- imxGenerateLabels(flatModel)
273                 result <- evaluateMxObject(reduceAlgebraName, flatModel, labelsData)
274                 return(result)
275         }
276 )
277
278 checkStringArgument <- function(arg, name) {
279         if (single.na(arg)) {
280                 arg <- as.character(NA) 
281         } else if (length(unlist(strsplit(arg, imxSeparatorChar, fixed = TRUE))) > 1) {
282                 stop(paste("the", omxQuotes(name), "argument cannot contain the", 
283                         omxQuotes(imxSeparatorChar), 
284                         "character"))
285         }
286         if (!(is.vector(arg) && 
287                 (typeof(arg) == 'character') && 
288                 (length(arg) == 1))) {
289                 stop("the", omxQuotes(name), "argument is not a string")
290         }
291         return(arg)
292 }
293
294 mxRowObjective <- function(rowAlgebra, dimnames, rowResults = NA, filteredDataRow = NA, existenceVector = NA, reduceAlgebra = NA) {
295         if (missing(rowAlgebra) || typeof(rowAlgebra) != "character") {
296                 stop("the 'rowAlgebra' argument is not a string (the name of the row-by-row algebra)")
297         }
298         if (missing(dimnames) || typeof(dimnames) != "character") {
299                 stop("the 'dimnames' argument is not a string (the column names from the data set)")
300         }
301         if (any(is.na(dimnames))) {
302                 stop("NA values are not allowed for 'dimnames' vector")
303         }
304         rowResults <- checkStringArgument(rowResults, "rowResults")
305         filteredDataRow <- checkStringArgument(filteredDataRow, "filteredDataRow")
306         existenceVector <- checkStringArgument(existenceVector, "existenceVector")
307         if (single.na(reduceAlgebra)) {
308                 reduceAlgebra <- as.character(NA)
309         }
310         if (!(is.vector(reduceAlgebra) && 
311                 (typeof(reduceAlgebra) == 'character') && 
312                 (length(reduceAlgebra) == 1))) {
313                 stop("the 'reduceAlgebra' argument is not a string (the name of the reduction algebra)")
314         }
315         return(new("MxRowObjective", rowAlgebra, rowResults, filteredDataRow, existenceVector, reduceAlgebra, dimnames))
316 }
317
318 printSlot <- function(object, slotName) {
319         val <- slot(object, slotName)
320         if (single.na(val)) {
321                 msg <- paste('@', slotName, ' : NA \n', sep = '')
322         } else {
323                 msg <- paste('@', slotName, ' : ',omxQuotes(val), '\n', sep = '')
324         }
325         cat(msg)
326 }
327
328 displayRowObjective <- function(objective) {
329         cat("MxRowObjective", omxQuotes(objective@name), '\n')
330         cat("@rowAlgebra :", omxQuotes(objective@rowAlgebra), '\n')
331         printSlot(objective, "rowResults")
332         printSlot(objective, "filteredDataRow")
333         printSlot(objective, "existenceVector")
334         printSlot(objective, "reduceAlgebra")
335         if (length(objective@result) == 0) {
336                 cat("@result: (not yet computed) ")
337         } else {
338                 cat("@result:\n")
339         }
340         print(objective@result)
341         invisible(objective)
342 }
343
344
345 setMethod("print", "MxRowObjective", function(x,...) { 
346         displayRowObjective(x) 
347 })
348
349 setMethod("show", "MxRowObjective", function(object) { 
350         displayRowObjective(object) 
351 })