Reverting to revision 1880
[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, 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                 result <- evaluateMxObject(rowAlgebraName, flatJob, labelsData)
208                 if (nrow(result) != 1) {
209                         msg <- paste("The rowAlgebra with name", 
210                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
211                                 "does not evaluate to a row vector")
212                         stop(msg, call. = FALSE)                        
213                 }
214                 if (is.na(.Object@data)) {
215                         msg <- paste("The MxRowObjective objective function",
216                                 "does not have a dataset associated with it in model",
217                                 omxQuotes(model@name))
218                         stop(msg, call.=FALSE)          
219                 }
220                 mxDataObject <- flatJob@datasets[[.Object@data]]
221
222                 # Create the row results
223                 rows <- nrow(mxDataObject@observed)
224                 cols <- ncol(result)
225                 if (is.na(rowResultsName)) {
226                         rowResultsName <- imxIdentifier(model@name, imxUntitledName())
227                 }
228                 rowResults <- job[[rowResultsName]]
229                 if (!is.null(rowResults)) {
230                         msg <- paste("The rowResults cannot have name", 
231                                 omxQuotes(simplifyName(rowResultsName, model@name)), 
232                                 "because this entity already exists in the model")
233                         stop(msg, call. = FALSE)
234                 }
235                 rowResults <- mxMatrix('Full', nrow = rows, ncol = cols)
236                 job[[rowResultsName]] <- rowResults
237                 flatJob[[rowResultsName]] <- rowResults
238                 pair <- imxReverseIdentifier(model, rowResultsName)
239                 if (model@name == pair[[1]]) {
240                         job[[.Object@name]]@rowResults <- pair[[2]]
241                 } else {
242                         job[[.Object@name]]@rowResults <- rowResultsName
243                 }
244
245                 # Locate the reduce algebra
246                 reduceAlgebra <- job[[reduceAlgebraName]]
247                 if (is.null(reduceAlgebra)) {
248                         msg <- paste("The reduceAlgebra with name", 
249                                 omxQuotes(simplifyName(reduceAlgebraName, model@name)), 
250                                 "is not defined in the model")
251                         stop(msg, call. = FALSE)
252                 }
253                 job@.newobjects <- TRUE
254                 job@.newobjective <- FALSE
255                 job@.newtree <- FALSE
256                 return(list(job, flatJob))
257         }
258 )
259
260 setMethod("genericObjInitialMatrix", "MxRowObjective",
261         function(.Object, flatModel) {
262                 reduceAlgebraName <- .Object@reduceAlgebra
263                 labelsData <- imxGenerateLabels(flatModel)
264                 result <- evaluateMxObject(reduceAlgebraName, flatModel, labelsData)
265                 return(result)
266         }
267 )
268
269 checkStringArgument <- function(arg, name) {
270         if (single.na(arg)) {
271                 arg <- as.character(NA) 
272         } else if (length(unlist(strsplit(arg, imxSeparatorChar, fixed = TRUE))) > 1) {
273                 stop(paste("the", omxQuotes(name), "argument cannot contain the", 
274                         omxQuotes(imxSeparatorChar), 
275                         "character"))
276         }
277         if (!(is.vector(arg) && 
278                 (typeof(arg) == 'character') && 
279                 (length(arg) == 1))) {
280                 stop("the", omxQuotes(name), "argument is not a string")
281         }
282         return(arg)
283 }
284
285 mxRowObjective <- function(rowAlgebra, reduceAlgebra, dimnames, rowResults = "rowResults", 
286         filteredDataRow = "filteredDataRow", existenceVector = "existenceVector") {
287         if (missing(rowAlgebra) || typeof(rowAlgebra) != "character") {
288                 stop("the 'rowAlgebra' argument is not a string (the name of the row-by-row algebra)")
289         }
290         if (missing(reduceAlgebra) || typeof(reduceAlgebra) != "character") {
291                 stop("the 'reduceAlgebra' argument is not a string (the name of the reduction algebra)")
292         }
293         if (missing(dimnames) || typeof(dimnames) != "character") {
294                 stop("the 'dimnames' argument is not a string (the column names from the data set)")
295         }
296         if (any(is.na(dimnames))) {
297                 stop("NA values are not allowed for 'dimnames' vector")
298         }
299         rowResults <- checkStringArgument(rowResults, "rowResults")
300         filteredDataRow <- checkStringArgument(filteredDataRow, "filteredDataRow")
301         existenceVector <- checkStringArgument(existenceVector, "existenceVector")
302         return(new("MxRowObjective", rowAlgebra, rowResults, filteredDataRow, existenceVector, reduceAlgebra, dimnames))
303 }
304
305 printSlot <- function(object, slotName) {
306         val <- slot(object, slotName)
307         if (single.na(val)) {
308                 msg <- paste('@', slotName, ' : NA \n', sep = '')
309         } else {
310                 msg <- paste('@', slotName, ' : ',omxQuotes(val), '\n', sep = '')
311         }
312         cat(msg)
313 }
314
315 displayRowObjective <- function(objective) {
316         cat("MxRowObjective", omxQuotes(objective@name), '\n')
317         cat("@rowAlgebra :", omxQuotes(objective@rowAlgebra), '\n')
318         printSlot(objective, "rowResults")
319         printSlot(objective, "filteredDataRow")
320         printSlot(objective, "existenceVector")
321         printSlot(objective, "reduceAlgebra")
322         if (length(objective@result) == 0) {
323                 cat("@result: (not yet computed) ")
324         } else {
325                 cat("@result:\n")
326         }
327         print(objective@result)
328         invisible(objective)
329 }
330
331
332 setMethod("print", "MxRowObjective", function(x,...) { 
333         displayRowObjective(x) 
334 })
335
336 setMethod("show", "MxRowObjective", function(object) { 
337         displayRowObjective(object) 
338 })