Performance improvements to front end.
[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("genericObjAddEntities", "MxRowObjective",
154         function(.Object, job, flatJob, labelsData) {
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                 job@.newobjects <- TRUE
162
163                 # Create the filtered data row
164                 filteredDataRow <- flatJob[[filteredDataRowName]]
165                 if (!is.null(filteredDataRow)) {
166                         msg <- paste("The filteredDataRow cannot have name", 
167                                 omxQuotes(filteredDataRowName), 
168                                 "because this entity already exists in the model")
169                         stop(msg, call. = FALSE)
170                 }
171                 filteredDataRow <- mxMatrix('Full', nrow = 1, ncol = length(dimnames))
172                 job[[filteredDataRowName]] <- filteredDataRow
173                 flatJob[[filteredDataRowName]] <- filteredDataRow
174
175                 # Create the existence vector
176                 if (!is.na(existenceVectorName)) {
177                         existenceVector <- job[[existenceVectorName]]
178                         if (!is.null(existenceVector)) {
179                                 msg <- paste("The existenceVector cannot have name", 
180                                         omxQuotes(existenceVectorName), 
181                                         "because this entity already exists in the model")
182                                 stop(msg, call. = FALSE)
183                         }
184                         existenceVector <- mxMatrix('Full', nrow = 1, ncol = length(dimnames), values = 1)
185                         job[[existenceVectorName]] <- existenceVector
186                         flatJob[[existenceVectorName]] <- existenceVector
187                 }
188
189                 # Locate the row algebra
190                 rowAlgebra <- job[[rowAlgebraName]]
191                 if (is.null(rowAlgebra)) {
192                         msg <- paste("The rowAlgebra with name", 
193                                 omxQuotes(rowAlgebraName), 
194                                 "is not defined in the model")
195                         stop(msg, call. = FALSE)
196                 }
197                 tuple <- evaluateMxObject(rowAlgebraName, flatJob, labelsData, new.env(parent = emptyenv()))
198                 result <- tuple[[1]]
199                 if (nrow(result) != 1) {
200                         msg <- paste("The rowAlgebra with name", 
201                                 omxQuotes(rowAlgebraName), 
202                                 "does not evaluate to a row vector")
203                         stop(msg, call. = FALSE)                        
204                 }
205                 if (is.na(.Object@data)) {
206                         msg <- paste("The MxRowObjective objective function",
207                                 "does not have a dataset associated with it in model",
208                                 omxQuotes(model@name))
209                         stop(msg, call.=FALSE)          
210                 }
211                 mxDataObject <- flatJob@datasets[[.Object@data]]
212
213                 # Create the row results
214                 rows <- nrow(mxDataObject@observed)
215                 cols <- ncol(result)
216                 rowResults <- job[[rowResultsName]]
217                 if (!is.null(rowResults)) {
218                         msg <- paste("The rowResults cannot have name", 
219                                 omxQuotes(rowResultsName), 
220                                 "because this entity already exists in the model")
221                         stop(msg, call. = FALSE)
222                 }
223                 rowResults <- mxMatrix('Full', nrow = rows, ncol = cols)
224                 job[[rowResultsName]] <- rowResults
225
226                 # Locate the reduce algebra
227                 reduceAlgebra <- job[[reduceAlgebraName]]
228                 if (is.null(reduceAlgebra)) {
229                         msg <- paste("The reduceAlgebra with name", 
230                                 omxQuotes(reduceAlgebraName), 
231                                 "is not defined in the model")
232                         stop(msg, call. = FALSE)
233                 }
234                 return(job)
235         }
236 )
237
238 setMethod("genericObjInitialMatrix", "MxRowObjective",
239         function(.Object, flatModel) {
240                 reduceAlgebraName <- .Object@reduceAlgebra
241                 labelsData <- imxGenerateLabels(flatModel)
242                 tuple <- evaluateMxObject(reduceAlgebraName, flatModel, labelsData, new.env(parent = emptyenv()))
243                 result <- tuple[[1]]
244                 return(result)
245         }
246 )
247
248 checkStringArgument <- function(arg, name) {
249         if (single.na(arg)) {
250                 arg <- as.character(NA) 
251         } else if (length(unlist(strsplit(arg, imxSeparatorChar, fixed = TRUE))) > 1) {
252                 stop(paste("the", omxQuotes(name), "argument cannot contain the", 
253                         omxQuotes(imxSeparatorChar), 
254                         "character"))
255         }
256         if (!(is.vector(arg) && 
257                 (typeof(arg) == 'character') && 
258                 (length(arg) == 1))) {
259                 stop("the", omxQuotes(name), "argument is not a string")
260         }
261         return(arg)
262 }
263
264 mxRowObjective <- function(rowAlgebra, reduceAlgebra, dimnames, rowResults = "rowResults", 
265         filteredDataRow = "filteredDataRow", existenceVector = "existenceVector") {
266         if (missing(rowAlgebra) || typeof(rowAlgebra) != "character") {
267                 stop("the 'rowAlgebra' argument is not a string (the name of the row-by-row algebra)")
268         }
269         if (missing(reduceAlgebra) || typeof(reduceAlgebra) != "character") {
270                 stop("the 'reduceAlgebra' argument is not a string (the name of the reduction algebra)")
271         }
272         if (missing(dimnames) || typeof(dimnames) != "character") {
273                 stop("the 'dimnames' argument is not a string (the column names from the data set)")
274         }
275         if (any(is.na(dimnames))) {
276                 stop("NA values are not allowed for 'dimnames' vector")
277         }
278         rowResults <- checkStringArgument(rowResults, "rowResults")
279         filteredDataRow <- checkStringArgument(filteredDataRow, "filteredDataRow")
280         existenceVector <- checkStringArgument(existenceVector, "existenceVector")
281         return(new("MxRowObjective", rowAlgebra, rowResults, filteredDataRow, existenceVector, reduceAlgebra, dimnames))
282 }
283
284 printSlot <- function(object, slotName) {
285         val <- slot(object, slotName)
286         if (single.na(val)) {
287                 msg <- paste('@', slotName, ' : NA \n', sep = '')
288         } else {
289                 msg <- paste('@', slotName, ' : ',omxQuotes(val), '\n', sep = '')
290         }
291         cat(msg)
292 }
293
294 displayRowObjective <- function(objective) {
295         cat("MxRowObjective", omxQuotes(objective@name), '\n')
296         cat("@rowAlgebra :", omxQuotes(objective@rowAlgebra), '\n')
297         printSlot(objective, "rowResults")
298         printSlot(objective, "filteredDataRow")
299         printSlot(objective, "existenceVector")
300         printSlot(objective, "reduceAlgebra")
301         if (length(objective@result) == 0) {
302                 cat("@result: (not yet computed) ")
303         } else {
304                 cat("@result:\n")
305         }
306         print(objective@result)
307         invisible(objective)
308 }
309
310
311 setMethod("print", "MxRowObjective", function(x,...) { 
312         displayRowObjective(x) 
313 })
314
315 setMethod("show", "MxRowObjective", function(object) { 
316         displayRowObjective(object) 
317 })