Fix infinite loop in objective function transformations
[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                 reduceAlgebra = "MxCharOrNumber",
22                 definitionVars = "list",
23                 dims = "character"),
24         contains = "MxBaseObjective")
25
26 setMethod("initialize", "MxRowObjective",
27         function(.Object, rowAlgebra, rowResults, reduceAlgebra,
28                 data = as.integer(NA), definitionVars = list(), name = 'objective') {
29                 .Object@name <- name
30                 .Object@rowAlgebra <- rowAlgebra
31                 .Object@rowResults <- rowResults
32                 .Object@reduceAlgebra <- reduceAlgebra          
33                 .Object@data <- data
34                 .Object@definitionVars <- definitionVars
35                 .Object@dims <- as.character(NA)
36                 return(.Object)
37         }
38 )
39
40 setMethod("genericObjNewEntities", signature("MxRowObjective"),
41         function(.Object) {
42                 if (is.na(.Object@rowResults)) {
43                         return(NULL)
44                 } else {
45                         return(.Object@rowResults)
46                 }
47         }
48 )
49
50 setMethod("genericObjDependencies", signature("MxRowObjective"),
51         function(.Object, dependencies) {
52         sources <- c(.Object@reduceAlgebra)
53         sources <- sources[!is.na(sources)]
54         if (length(sources) > 0) {
55                 dependencies <- omxAddDependency(sources, .Object@name, dependencies)
56         }
57         return(dependencies)
58 })
59
60
61 setMethod("genericObjFunNamespace", signature("MxRowObjective"), 
62         function(.Object, modelname, namespace) {
63                 .Object@name <- omxIdentifier(modelname, .Object@name)
64                 .Object@rowAlgebra <- omxConvertIdentifier(.Object@rowAlgebra, 
65                         modelname, namespace)
66                 .Object@rowResults <- omxConvertIdentifier(.Object@rowResults, 
67                         modelname, namespace)
68                 .Object@reduceAlgebra <- omxConvertIdentifier(.Object@reduceAlgebra, 
69                         modelname, namespace)
70                 .Object@data <- omxConvertIdentifier(.Object@data, 
71                         modelname, namespace)
72                 return(.Object)
73 })
74
75 setMethod("genericObjRename", signature("MxRowObjective"),
76         function(.Object, oldname, newname) {
77                 .Object@rowAlgebra <- renameReference(.Object@rowAlgebra, oldname, newname)
78                 .Object@reduceAlgebra <- renameReference(.Object@reduceAlgebra, oldname, newname)
79                 .Object@data <- renameReference(.Object@data, oldname, newname)
80                 return(.Object)
81 })
82
83 setMethod("genericObjFunConvert", signature("MxRowObjective"), 
84         function(.Object, flatModel, model, defVars) {
85                 modelname <- omxReverseIdentifier(model, .Object@name)[[1]]
86                 name <- .Object@name
87                 if(is.na(.Object@data)) {
88                         msg <- paste("The MxRowObjective objective function",
89                                 "does not have a dataset associated with it in model",
90                                 omxQuotes(modelname))
91                         stop(msg, call.=FALSE)
92                 }
93                 mxDataObject <- flatModel@datasets[[.Object@data]]
94                 if (mxDataObject@type != 'raw') {
95                         msg <- paste("The dataset associated with the MxRowObjective objective", 
96                                 "in model", omxQuotes(modelname), "is not raw data.")
97                         stop(msg, call.=FALSE)
98                 }
99                 .Object@definitionVars <- omxFilterDefinitionVariables(defVars, .Object@data)
100                 .Object@rowAlgebra <- omxLocateIndex(flatModel, .Object@rowAlgebra, name)
101                 .Object@rowResults <- omxLocateIndex(flatModel, .Object@rowResults, name)
102                 .Object@reduceAlgebra <- omxLocateIndex(flatModel, .Object@reduceAlgebra, name)
103                 .Object@data <- omxLocateIndex(flatModel, .Object@data, name)
104                 if (length(mxDataObject@observed) == 0) {
105                         .Object@data <- as.integer(NA)
106                 }
107                 if (single.na(.Object@dims)) {
108                         .Object@dims <- colnames(mxDataObject@observed)
109                 }
110                 return(.Object)
111 })
112
113 setMethod("genericObjModelConvert", "MxRowObjective",
114         function(.Object, job, model, namespace, flatJob) {
115                 rowAlgebraName <- .Object@rowAlgebra
116                 rowResultsName <- .Object@rowResults
117                 reduceAlgebraName <- .Object@reduceAlgebra
118                 rowAlgebra <- job[[rowAlgebraName]]
119                 if (is.null(rowAlgebra)) {
120                         msg <- paste("The rowAlgebra with name", 
121                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
122                                 "is not defined in the model")
123                         stop(msg, call. = FALSE)
124                 }
125                 labelsData <- omxGenerateLabels(job)
126                 result <- evaluateMxObject(rowAlgebraName, flatJob, labelsData)
127                 if (nrow(result) != 1) {
128                         msg <- paste("The rowAlgebra with name", 
129                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
130                                 "does not evaluate to a row vector")
131                         stop(msg, call. = FALSE)                        
132                 }
133                 if (is.na(.Object@data)) {
134                         msg <- paste("The MxRowObjective objective function",
135                                 "does not have a dataset associated with it in model",
136                                 omxQuotes(model@name))
137                         stop(msg, call.=FALSE)          
138                 }
139                 mxDataObject <- flatJob@datasets[[.Object@data]]                
140                 rows <- nrow(mxDataObject@observed)
141                 cols <- ncol(result)
142                 if (is.na(rowResultsName)) {
143                         rowResultsName <- omxUntitledName()                     
144                 }
145                 rowResults <- job[[model@name]][[rowResultsName]]
146                 if (!is.null(rowResults)) {
147                         msg <- paste("The rowResults cannot have name", 
148                                 omxQuotes(simplifyName(rowAlgebraName, model@name)), 
149                                 "because this entity already exists in the model")
150                         stop(msg, call. = FALSE)
151                 }
152                 rowResults <- mxMatrix('Full', nrow = rows, ncol = cols)
153                 job[[model@name]][[rowResultsName]] <- rowResults
154                 pair <- omxReverseIdentifier(model, rowResultsName)
155                 job[[.Object@name]]@rowResults <- pair[[2]]
156                 if (is.na(reduceAlgebraName)) {
157                         reduceAlgebraName <- omxUntitledName()
158                         reduceAlgebra <- eval(substitute(mxAlgebra(x, reduceAlgebraName), 
159                                 list(x = quote(as.symbol(rowResultsName)))))
160                         job[[model@name]][[reduceAlgebraName]] <- reduceAlgebra         
161                         job[[.Object@name]]@reduceAlgebra <- reduceAlgebraName
162                         reduceAlgebraName <- omxIdentifier(model@name, reduceAlgebraName)
163                 }
164                 reduceAlgebra <- job[[reduceAlgebraName]]
165                 if (is.null(reduceAlgebra)) {
166                         msg <- paste("The reduceAlgebra with name", 
167                                 omxQuotes(simplifyName(reduceAlgebraName, model@name)), 
168                                 "is not defined in the model")
169                         stop(msg, call. = FALSE)
170                 }
171                 job@.newobjects <- TRUE
172                 job@.newobjective <- FALSE
173                 job@.newtree <- FALSE
174                 return(job)
175         }
176 )
177
178 setMethod("genericObjInitialMatrix", "MxRowObjective",
179         function(.Object, flatModel) {
180                 reduceAlgebraName <- .Object@reduceAlgebra
181                 labelsData <- omxGenerateLabels(flatModel)
182                 result <- evaluateMxObject(reduceAlgebraName, flatModel, labelsData)
183                 return(result)
184         }
185 )
186
187 mxRowObjective <- function(rowAlgebra, rowResults = NA, reduceAlgebra = NA) {
188         if (missing(rowAlgebra) || typeof(rowAlgebra) != "character") {
189                 stop("the 'rowAlgebra' argument is not a string (the name of the row-by-row algebra)")
190         }
191         if (single.na(rowResults)) {
192                 rowResults <- as.character(NA)  
193         } else if (length(unlist(strsplit(rowResults, omxSeparatorChar, fixed = TRUE))) > 1) {
194                 stop(paste("the 'rowResults' argument cannot contain the", 
195                         omxQuotes(omxSeparatorChar), 
196                         "character"))
197         }
198         if (!(is.vector(rowResults) && 
199                 (typeof(rowResults) == 'character') && 
200                 (length(rowResults) == 1))) {
201                 stop("the 'rowResults' argument is not a string (the name for the results matrix)")
202         }
203         if (single.na(reduceAlgebra)) {
204                 reduceAlgebra <- as.character(NA)       
205         }
206         if (!(is.vector(reduceAlgebra) && 
207                 (typeof(reduceAlgebra) == 'character') && 
208                 (length(reduceAlgebra) == 1))) {
209                 stop("the 'reduceAlgebra' argument is not a string (the name of the reduction algebra)")
210         }
211         return(new("MxRowObjective", rowAlgebra, rowResults, reduceAlgebra))
212 }
213
214 displayRowObjective <- function(objective) {
215         cat("MxRowObjective", omxQuotes(objective@name), '\n')
216         cat("@rowAlgebra :", omxQuotes(objective@rowAlgebra), '\n')
217         if (single.na(objective@rowResults)) {
218                 cat("@rowResults : NA \n")
219         } else {
220                 cat("@rowResults :", omxQuotes(objective@rowResults), '\n')     
221         }
222         if (single.na(objective@reduceAlgebra)) {
223                 cat("@reduceAlgebra : NA \n")
224         } else {
225                 cat("@reduceAlgebra :", omxQuotes(objective@reduceAlgebra), '\n')       
226         }       
227         if (length(objective@result) == 0) {
228                 cat("@result: (not yet computed) ")
229         } else {
230                 cat("@result:\n")
231         }
232         print(objective@result)
233         invisible(objective)
234 }
235
236
237 setMethod("print", "MxRowObjective", function(x,...) { 
238         displayRowObjective(x) 
239 })
240
241 setMethod("show", "MxRowObjective", function(object) { 
242         displayRowObjective(object) 
243 })