Add verbose option to omxComputeIterate
[openmx:openmx.git] / R / MxCompute.R
1 #
2 #   Copyright 2013 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 setClass(Class = "MxBaseCompute", 
17          representation = representation(
18            "VIRTUAL"),
19          contains = "MxBaseNamed")
20
21 setClassUnion("MxCompute", c("NULL", "MxBaseCompute"))
22
23 setGeneric("convertForBackend",
24         function(.Object, flatModel, model) {
25                 return(standardGeneric("convertForBackend"))
26         })
27
28 #----------------------------------------------------
29
30 setClass(Class = "MxComputeOperation",
31          contains = "MxBaseCompute",
32          representation = representation(
33            free.group = "MxCharOrNumber"))
34
35 setMethod("qualifyNames", signature("MxComputeOperation"),
36         function(.Object, modelname, namespace) {
37                 .Object@name <- imxIdentifier(modelname, .Object@name)
38                 .Object
39         })
40
41 setMethod("convertForBackend", signature("MxComputeOperation"),
42         function(.Object, flatModel, model) {
43                 name <- .Object@name
44                 fg <- match(.Object@free.group, flatModel@freeGroupNames)
45                 if (is.na(fg)) {
46                         stop(paste("Cannot find free group", .Object@free.group,
47                                    "in list of free groups:",
48                                    omxQuotes(flatModel@freeGroupNames)))
49                 } else {
50                         .Object@free.group <- fg - 1L
51                 }
52                 .Object
53         })
54
55 #----------------------------------------------------
56
57 setClass(Class = "MxComputeAssign",  # good name? or ComputeCopy?
58          contains = "MxComputeOperation",
59          representation = representation(
60            from = "MxCharOrNumber",
61            to = "MxCharOrNumber"))
62
63 setMethod("initialize", "MxComputeAssign",
64           function(.Object, from, to, free.group) {
65                   .Object@name <- 'compute'
66                   .Object@from <- from
67                   .Object@to <- to
68                   .Object@free.group <- free.group
69                   .Object
70           })
71
72 setMethod("qualifyNames", signature("MxComputeAssign"),
73         function(.Object, modelname, namespace) {
74                 .Object <- callNextMethod();
75                 .Object@from <- imxIdentifier(modelname, .Object@from)
76                 .Object@to <- imxIdentifier(modelname, .Object@to)
77                 .Object
78         })
79
80 setMethod("convertForBackend", signature("MxComputeAssign"),
81         function(.Object, flatModel, model) {
82                 .Object <- callNextMethod();
83                 name <- .Object@name
84                 for (sl in c('from', 'to')) {
85                         mat <- match(slot(.Object, sl), names(flatModel@matrices))
86                         if (any(is.na(mat))) {
87                                 stop(paste("MxComputeAssign: cannot find",
88                                            omxQuotes(slot(.Object, sl)[is.na(mat)]),
89                                            "mentioned in slot '", sl, "'"))
90                         }
91                         slot(.Object, sl) <- -mat
92                 }
93                 .Object
94         })
95
96 mxComputeAssign <- function(from, to, free.group="default") {
97         if (length(from) != length(to)) {
98                 stop("Arguments 'from' and 'to' must be the same length")
99         }
100         new("MxComputeAssign", from=from, to=to, free.group=free.group)
101 }
102
103 #----------------------------------------------------
104
105 setClass(Class = "MxComputeOnce",
106          contains = "MxComputeOperation",
107          representation = representation(
108            fitfunction = "MxOptionalCharOrNumber",
109            expectation = "MxOptionalCharOrNumber",
110            context = "character"))
111
112 setMethod("qualifyNames", signature("MxComputeOnce"),
113         function(.Object, modelname, namespace) {
114                 .Object@name <- imxIdentifier(modelname, .Object@name)
115                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
116                 .Object@expectation <- imxConvertIdentifier(.Object@expectation, modelname, namespace)
117                 .Object
118         })
119
120 setMethod("convertForBackend", signature("MxComputeOnce"),
121         function(.Object, flatModel, model) {
122                 .Object <- callNextMethod();
123                 name <- .Object@name
124                 if (is.character(.Object@fitfunction)) {
125                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
126                 }
127                 if (is.character(.Object@expectation)) {
128                         .Object@expectation <- imxLocateIndex(flatModel, .Object@expectation, name)
129                 }
130                 .Object
131         })
132
133 setMethod("initialize", "MxComputeOnce",
134           function(.Object, free.group, fit, expectation, context) {
135                   .Object@name <- 'compute'
136                   .Object@free.group <- free.group
137                   if (!is.null(fit) && !is.null(expectation)) {
138                           stop("Cannot evaluate a fitfunction and expectation simultaneously")
139                   }
140                   .Object@fitfunction <- fit
141                   .Object@expectation <- expectation
142                   .Object@context <- context
143                   .Object
144           })
145
146 mxComputeOnce <- function(free.group='default', fitfunction=NULL, expectation=NULL, context=character(0)) {
147         new("MxComputeOnce", free.group, fitfunction, expectation, context)
148 }
149
150 #----------------------------------------------------
151
152 setClass(Class = "MxComputeGradientDescent",
153          contains = "MxComputeOperation",
154          representation = representation(
155            fitfunction = "MxCharOrNumber",
156            engine = "character"))
157
158 setMethod("qualifyNames", signature("MxComputeGradientDescent"),
159         function(.Object, modelname, namespace) {
160                 .Object@name <- imxIdentifier(modelname, .Object@name)
161                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
162                 .Object
163         })
164
165 setMethod("convertForBackend", signature("MxComputeGradientDescent"),
166         function(.Object, flatModel, model) {
167                 .Object <- callNextMethod();
168                 name <- .Object@name
169                 if (is.character(.Object@fitfunction)) {
170                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
171                 }
172                 .Object
173         })
174
175 setMethod("initialize", "MxComputeGradientDescent",
176           function(.Object, free.group, engine, fit) {
177                   .Object@name <- 'compute'
178                   .Object@free.group <- free.group
179                   .Object@fitfunction <- fit
180                   .Object@engine <- engine
181                   .Object
182           })
183
184 mxComputeGradientDescent <- function(type, free.group='default',
185                                      engine=NULL, fitfunction='fitfunction') {
186 # What to do with 'type'?
187 #       if (length(type) != 1) stop("Specific 1 compute type")
188
189         if (is.null(engine)) engine <- as.character(NA)
190
191         new("MxComputeGradientDescent", free.group, engine, fitfunction)
192 }
193
194 #----------------------------------------------------
195
196 setClass(Class = "MxComputeIterate",
197          contains = "MxBaseCompute",
198          representation = representation(
199            steps = "list",
200            maxIter = "integer",
201            tolerance = "numeric",
202            verbose = "logical"))
203
204 setMethod("initialize", "MxComputeIterate",
205           function(.Object, steps, maxIter, tolerance, verbose) {
206                   .Object@name <- 'compute'
207                   .Object@steps <- steps
208                   .Object@maxIter <- maxIter
209                   .Object@tolerance <- tolerance
210                   .Object@verbose <- verbose
211                   .Object
212           })
213
214 setMethod("qualifyNames", signature("MxComputeIterate"),
215         function(.Object, modelname, namespace) {
216                 .Object@name <- imxIdentifier(modelname, .Object@name)
217                 .Object@steps <- lapply(.Object@steps, function (c) qualifyNames(c, modelname, namespace))
218                 .Object
219         })
220
221 setMethod("convertForBackend", signature("MxComputeIterate"),
222         function(.Object, flatModel, model) {
223                 .Object@steps <- lapply(.Object@steps, function (c) convertForBackend(c, flatModel, model))
224                 .Object
225         })
226
227 mxComputeIterate <- function(steps, maxIter=500L, tolerance=1e-4, verbose=FALSE) {
228         new("MxComputeIterate", steps=steps, maxIter=maxIter, tolerance=tolerance, verbose)
229 }
230
231 displayMxComputeIterate <- function(opt) {
232         cat(class(opt), omxQuotes(opt@name), '\n')
233         cat("@tolerance :", omxQuotes(opt@tolerance), '\n')
234         cat("@maxIter :", omxQuotes(opt@maxIter), '\n')
235         for (step in 1:length(opt@steps)) {
236                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
237         }
238         invisible(opt)
239 }
240
241 setMethod("print", "MxComputeIterate", function(x, ...) displayMxComputeIterate(x))
242 setMethod("show",  "MxComputeIterate", function(object) displayMxComputeIterate(object))
243
244 #----------------------------------------------------
245
246 setClass(Class = "MxComputeEstimatedHessian",
247          contains = "MxComputeOperation",
248          representation = representation(
249            fitfunction = "MxCharOrNumber",
250            se = "logical"))
251
252 setMethod("qualifyNames", signature("MxComputeEstimatedHessian"),
253         function(.Object, modelname, namespace) {
254                 .Object@name <- imxIdentifier(modelname, .Object@name)
255                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
256                 .Object
257         })
258
259 setMethod("convertForBackend", signature("MxComputeEstimatedHessian"),
260         function(.Object, flatModel, model) {
261                 .Object <- callNextMethod();
262                 name <- .Object@name
263                 if (is.character(.Object@fitfunction)) {
264                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
265                 }
266                 .Object
267         })
268
269 setMethod("initialize", "MxComputeEstimatedHessian",
270           function(.Object, free.group, fit, want.se) {
271                   .Object@name <- 'compute'
272                   .Object@free.group <- free.group
273                   .Object@fitfunction <- fit
274                   .Object@se <- want.se
275                   .Object
276           })
277
278 mxComputeEstimatedHessian <- function(free.group='default', fitfunction='fitfunction', want.se=TRUE) {
279         new("MxComputeEstimatedHessian", free.group, fitfunction, want.se)
280 }
281
282 #----------------------------------------------------
283
284 setClass(Class = "MxComputeSequence",
285          contains = "MxBaseCompute",
286          representation = representation(
287            steps = "list"))
288
289 setMethod("initialize", "MxComputeSequence",
290           function(.Object, steps) {
291                   .Object@name <- 'compute'
292                   .Object@steps <- steps
293                   .Object
294           })
295
296 setMethod("qualifyNames", signature("MxComputeSequence"),
297         function(.Object, modelname, namespace) {
298                 .Object@name <- imxIdentifier(modelname, .Object@name)
299                 .Object@steps <- lapply(.Object@steps, function (c) qualifyNames(c, modelname, namespace))
300                 .Object
301         })
302
303 setMethod("convertForBackend", signature("MxComputeSequence"),
304         function(.Object, flatModel, model) {
305                 .Object@steps <- lapply(.Object@steps, function (c) convertForBackend(c, flatModel, model))
306                 .Object
307         })
308
309 mxComputeSequence <- function(steps) {
310         new("MxComputeSequence", steps=steps)
311 }
312
313 displayMxComputeSequence <- function(opt) {
314         cat(class(opt), omxQuotes(opt@name), '\n')
315         for (step in 1:length(opt@steps)) {
316                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
317         }
318         invisible(opt)
319 }
320
321 setMethod("print", "MxComputeSequence", function(x, ...) displayMxComputeSequence(x))
322 setMethod("show",  "MxComputeSequence", function(object) displayMxComputeSequence(object))
323
324 #----------------------------------------------------
325
326 displayMxComputeOperation <- function(opt) {
327         cat(class(opt), omxQuotes(opt@name), '\n')
328         cat("@free.group :", omxQuotes(opt@free.group), '\n')
329         invisible(opt)
330 }
331
332 setMethod("print", "MxComputeOperation", function(x, ...) displayMxComputeOperation(x))
333 setMethod("show",  "MxComputeOperation", function(object) displayMxComputeOperation(object))
334
335 displayMxComputeGradientDescent <- function(opt) {
336         cat("@type :", omxQuotes(opt@type), '\n')
337         cat("@engine :", omxQuotes(opt@engine), '\n')
338         cat("@fitfunction :", omxQuotes(opt@fitfunction), '\n')
339         invisible(opt)
340 }
341
342 setMethod("print", "MxComputeGradientDescent",
343           function(x, ...) { callNextMethod(); displayMxComputeGradientDescent(x) })
344 setMethod("show",  "MxComputeGradientDescent",
345           function(object) { callNextMethod(); displayMxComputeGradientDescent(object) })
346
347 convertComputes <- function(flatModel, model) {
348         retval <- lapply(flatModel@computes, function(opt) {
349                 convertForBackend(opt, flatModel, model)
350         })
351         retval
352 }