Allow ComputeIterate to test maximum absolute change
[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            id = "integer",
19            "VIRTUAL"),
20          contains = "MxBaseNamed")
21
22 setClassUnion("MxCompute", c("NULL", "MxBaseCompute"))
23
24 setGeneric("convertForBackend",
25         function(.Object, flatModel, model) {
26                 return(standardGeneric("convertForBackend"))
27         })
28
29 setGeneric("assignId",
30         function(.Object, id) {
31                 return(standardGeneric("assignId"))
32         })
33
34 setMethod("assignId", signature("MxBaseCompute"),
35         function(.Object, id) {
36                 .Object@id <- id
37                 .Object
38         })
39
40 setGeneric("getFreeVarGroup",
41         function(.Object) {
42                 return(standardGeneric("getFreeVarGroup"))
43         })
44
45 setMethod("getFreeVarGroup", signature("MxBaseCompute"),
46         function(.Object) {
47                 list()
48         })
49
50 #----------------------------------------------------
51
52 setClass(Class = "MxComputeOperation",
53          contains = "MxBaseCompute",
54          representation = representation(
55            free.set = "MxOptionalChar"))
56
57 setMethod("qualifyNames", signature("MxComputeOperation"),
58         function(.Object, modelname, namespace) {
59                 .Object@name <- imxIdentifier(modelname, .Object@name)
60                 .Object@free.set <- imxConvertIdentifier(.Object@free.set, modelname, namespace)
61                 .Object
62         })
63
64 setMethod("getFreeVarGroup", signature("MxComputeOperation"),
65         function(.Object) {
66                 if (length(.Object@free.set)) {
67                         list(.Object@id, .Object@free.set)
68                 } else {
69                         list()
70                 }
71         })
72
73 setMethod("convertForBackend", signature("MxComputeOperation"),
74         function(.Object, flatModel, model) {
75                 name <- .Object@name
76                 .Object
77         })
78
79 #----------------------------------------------------
80
81 setClass(Class = "MxComputeOnce",
82          contains = "MxComputeOperation",
83          representation = representation(
84            what = "MxCharOrNumber",
85            verbose = "integer",
86            context = "character",
87            maxAbsChange = "logical",
88            fit = "logical",
89            gradient = "logical",
90            hessian = "logical",
91            ihessian = "logical"))
92
93 setMethod("qualifyNames", signature("MxComputeOnce"),
94         function(.Object, modelname, namespace) {
95                 .Object <- callNextMethod();
96                 for (sl in c('what')) {
97                         slot(.Object, sl) <- imxConvertIdentifier(slot(.Object, sl), modelname, namespace)
98                 }
99                 .Object
100         })
101
102 setMethod("convertForBackend", signature("MxComputeOnce"),
103         function(.Object, flatModel, model) {
104                 .Object <- callNextMethod();
105                 name <- .Object@name
106                 if (any(!is.integer(.Object@what))) {
107                         expNum <- match(.Object@what, names(flatModel@expectations))
108                         algNum <- match(.Object@what, append(names(flatModel@algebras),
109                                                              names(flatModel@fitfunctions)))
110                         if (any(is.na(expNum)) && any(is.na(algNum))) {
111                                 stop("Can only apply MxComputeOnce to MxAlgebra or MxExpectation")
112                         }
113                         if (!any(is.na(expNum))) {
114                                         # Usually negative numbers indicate matrices; not here
115                                 .Object@what <- - expNum
116                         } else {
117                                 if (any(algNum > length(flatModel@algebras)) && length(algNum) > 1) {
118                                         stop("MxComputeOnce cannot evaluate more than 1 fit function")
119                                 }
120                                 .Object@what <- algNum - 1L
121                         }
122                 }
123                 if (length(.Object@what) == 0) warning("MxComputeOnce with nothing will have no effect")
124                 if (all(.Object@what >= 0) && !.Object@maxAbsChange && !.Object@fit && !.Object@gradient &&
125                             !.Object@hessian && !.Object@ihessian) {
126                         warning("MxComputeOnce with no action")
127                 }
128                 .Object
129         })
130
131 setMethod("initialize", "MxComputeOnce",
132           function(.Object, what, free.set, context, maxAbsChange, fit, gradient, hessian, ihessian, verbose) {
133                   .Object@name <- 'compute'
134                   .Object@what <- what
135                   .Object@verbose = verbose
136                   .Object@free.set <- free.set
137                   .Object@context <- context
138                   .Object@maxAbsChange <- maxAbsChange
139                   .Object@fit <- fit
140                   .Object@gradient <- gradient
141                   .Object@hessian <- hessian
142                   .Object@ihessian <- ihessian
143                   .Object
144           })
145
146 mxComputeOnce <- function(what, free.set=NULL, context=character(0),
147                           maxAbsChange=FALSE, fit=FALSE, gradient=FALSE,
148                           hessian=FALSE, ihessian=FALSE, verbose=0L) {
149         new("MxComputeOnce", what, free.set, context, maxAbsChange, fit, gradient, hessian, ihessian, verbose)
150 }
151
152 #----------------------------------------------------
153
154 setClass(Class = "MxComputeGradientDescent",
155          contains = "MxComputeOperation",
156          representation = representation(
157            useGradient = "MxOptionalLogical",
158            fitfunction = "MxCharOrNumber",
159            engine = "character",
160            verbose = "integer"))
161
162 setMethod("qualifyNames", signature("MxComputeGradientDescent"),
163         function(.Object, modelname, namespace) {
164                 .Object <- callNextMethod();
165                 for (sl in c('fitfunction')) {
166                         slot(.Object, sl) <- imxConvertIdentifier(slot(.Object, sl), modelname, namespace)
167                 }
168                 .Object
169         })
170
171 setMethod("convertForBackend", signature("MxComputeGradientDescent"),
172         function(.Object, flatModel, model) {
173                 .Object <- callNextMethod();
174                 name <- .Object@name
175                 if (is.character(.Object@fitfunction)) {
176                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
177                 }
178                 .Object
179         })
180
181 setMethod("initialize", "MxComputeGradientDescent",
182           function(.Object, free.set, engine, fit, useGradient, verbose) {
183                   .Object@name <- 'compute'
184                   .Object@free.set <- free.set
185                   .Object@fitfunction <- fit
186                   .Object@engine <- engine
187                   .Object@useGradient <- useGradient
188                   .Object@verbose <- verbose
189                   .Object
190           })
191
192 mxComputeGradientDescent <- function(type=NULL, free.set=NULL, useGradient=NULL,
193                                      engine=NULL, fitfunction='fitfunction', verbose=0L) {
194 # What to do with 'type'?
195 #       if (length(type) != 1) stop("Specific 1 compute type")
196
197         if (missing(engine)) {
198                 engine <- Sys.getenv("IMX_OPT_ENGINE")
199                 if (!nchar(engine)) engine <- "NPSOL"
200         }
201
202         new("MxComputeGradientDescent", free.set, engine, fitfunction, useGradient, verbose)
203 }
204
205 #----------------------------------------------------
206
207 setClass(Class = "MxComputeNewtonRaphson",
208          contains = "MxComputeOperation",
209          representation = representation(
210            fitfunction = "MxCharOrNumber",
211            maxIter = "integer",
212            tolerance = "numeric",
213            verbose = "integer",
214            carefully = "logical"))
215
216 setMethod("qualifyNames", signature("MxComputeNewtonRaphson"),
217         function(.Object, modelname, namespace) {
218                 .Object <- callNextMethod();
219                 for (sl in c('fitfunction')) {
220                         slot(.Object, sl) <- imxConvertIdentifier(slot(.Object, sl), modelname, namespace)
221                 }
222                 .Object
223         })
224
225 setMethod("convertForBackend", signature("MxComputeNewtonRaphson"),
226         function(.Object, flatModel, model) {
227                 .Object <- callNextMethod();
228                 name <- .Object@name
229                 if (is.character(.Object@fitfunction)) {
230                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
231                 }
232                 .Object
233         })
234
235 setMethod("initialize", "MxComputeNewtonRaphson",
236           function(.Object, free.set, fit, maxIter, tolerance, verbose, carefully) {
237                   .Object@name <- 'compute'
238                   .Object@free.set <- free.set
239                   .Object@fitfunction <- fit
240                   .Object@maxIter <- maxIter
241                   .Object@tolerance <- tolerance
242                   .Object@verbose <- verbose
243                   .Object@carefully <- carefully
244                   .Object
245           })
246
247 mxComputeNewtonRaphson <- function(type, free.set=NULL,
248                                    fitfunction='fitfunction', maxIter = 100L, tolerance=1e-7,
249                                    verbose=0L, carefully=FALSE) {
250
251         new("MxComputeNewtonRaphson", free.set, fitfunction, maxIter, tolerance, verbose, carefully)
252 }
253
254 #----------------------------------------------------
255
256 setClass(Class = "MxComputeSteps",
257          contains = "MxBaseCompute",
258          representation = representation(
259            steps = "list"))
260
261 setMethod("getFreeVarGroup", signature("MxComputeSteps"),
262         function(.Object) {
263                 result <- list()
264                 for (step in .Object@steps) {
265                         got <- getFreeVarGroup(step)
266                         if (length(got)) result <- append(result, got)
267                 }
268                 result
269         })
270
271 setMethod("assignId", signature("MxComputeSteps"),
272         function(.Object, id) {
273                 steps <- .Object@steps
274                 for (sx in 1:length(steps)) {
275                         steps[[sx]] <- assignId(steps[[sx]], id)
276                         id <- steps[[sx]]@id + 1L
277                 }
278                 .Object@steps <- steps
279                 .Object@id <- id
280                 .Object
281         })
282
283 setMethod("qualifyNames", signature("MxComputeSteps"),
284         function(.Object, modelname, namespace) {
285                 .Object@name <- imxIdentifier(modelname, .Object@name)
286                 .Object@steps <- lapply(.Object@steps, function (c) qualifyNames(c, modelname, namespace))
287                 .Object
288         })
289
290 setMethod("convertForBackend", signature("MxComputeSteps"),
291         function(.Object, flatModel, model) {
292                 .Object@steps <- lapply(.Object@steps, function (c) convertForBackend(c, flatModel, model))
293                 .Object
294         })
295
296 #----------------------------------------------------
297
298 setClass(Class = "MxComputeIterate",
299          contains = "MxComputeSteps",
300          representation = representation(
301            maxIter = "integer",
302            tolerance = "numeric",
303            verbose = "integer"))
304
305 setMethod("initialize", "MxComputeIterate",
306           function(.Object, steps, maxIter, tolerance, verbose) {
307                   .Object@name <- 'compute'
308                   .Object@steps <- steps
309                   .Object@maxIter <- maxIter
310                   .Object@tolerance <- tolerance
311                   .Object@verbose <- verbose
312                   .Object
313           })
314
315 mxComputeIterate <- function(steps, maxIter=500L, tolerance=1e-4, verbose=0L) {
316         new("MxComputeIterate", steps=steps, maxIter=maxIter, tolerance=tolerance, verbose)
317 }
318
319 displayMxComputeIterate <- function(opt) {
320         cat(class(opt), omxQuotes(opt@name), '\n')
321         cat("@tolerance :", omxQuotes(opt@tolerance), '\n')
322         cat("@maxIter :", omxQuotes(opt@maxIter), '\n')
323         for (step in 1:length(opt@steps)) {
324                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
325         }
326         invisible(opt)
327 }
328
329 setMethod("print", "MxComputeIterate", function(x, ...) displayMxComputeIterate(x))
330 setMethod("show",  "MxComputeIterate", function(object) displayMxComputeIterate(object))
331
332 #----------------------------------------------------
333
334 setClass(Class = "MxComputeEstimatedHessian",
335          contains = "MxComputeOperation",
336          representation = representation(
337            fitfunction = "MxCharOrNumber",
338            se = "logical"))
339
340 setMethod("qualifyNames", signature("MxComputeEstimatedHessian"),
341         function(.Object, modelname, namespace) {
342                 .Object <- callNextMethod();
343                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
344                 .Object
345         })
346
347 setMethod("convertForBackend", signature("MxComputeEstimatedHessian"),
348         function(.Object, flatModel, model) {
349                 .Object <- callNextMethod();
350                 name <- .Object@name
351                 if (is.character(.Object@fitfunction)) {
352                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
353                 }
354                 .Object
355         })
356
357 setMethod("initialize", "MxComputeEstimatedHessian",
358           function(.Object, free.set, fit, want.se) {
359                   .Object@name <- 'compute'
360                   .Object@free.set <- free.set
361                   .Object@fitfunction <- fit
362                   .Object@se <- want.se
363                   .Object
364           })
365
366 mxComputeEstimatedHessian <- function(free.set=NULL, fitfunction='fitfunction', want.se=TRUE) {
367         new("MxComputeEstimatedHessian", free.set, fitfunction, want.se)
368 }
369
370 #----------------------------------------------------
371
372 setClass(Class = "MxComputeSequence",
373          contains = "MxComputeSteps")
374
375 setMethod("initialize", "MxComputeSequence",
376           function(.Object, steps) {
377                   .Object@name <- 'compute'
378                   .Object@steps <- steps
379                   .Object
380           })
381
382 mxComputeSequence <- function(steps) {
383         new("MxComputeSequence", steps=steps)
384 }
385
386 displayMxComputeSequence <- function(opt) {
387         cat(class(opt), omxQuotes(opt@name), '\n')
388         for (step in 1:length(opt@steps)) {
389                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
390         }
391         invisible(opt)
392 }
393
394 setMethod("print", "MxComputeSequence", function(x, ...) displayMxComputeSequence(x))
395 setMethod("show",  "MxComputeSequence", function(object) displayMxComputeSequence(object))
396
397 #----------------------------------------------------
398
399 displayMxComputeOperation <- function(opt) {
400         cat(class(opt), omxQuotes(opt@name), '\n')
401         cat("@id :", opt@id, '\n')
402         cat("@free.set :", omxQuotes(opt@free.set), '\n')
403         invisible(opt)
404 }
405
406 setMethod("print", "MxComputeOperation", function(x, ...) displayMxComputeOperation(x))
407 setMethod("show",  "MxComputeOperation", function(object) displayMxComputeOperation(object))
408
409 displayMxComputeGradientDescent <- function(opt) {
410         cat("@type :", omxQuotes(opt@type), '\n')
411         cat("@engine :", omxQuotes(opt@engine), '\n')
412         cat("@fitfunction :", omxQuotes(opt@fitfunction), '\n')
413         invisible(opt)
414 }
415
416 setMethod("print", "MxComputeGradientDescent",
417           function(x, ...) { callNextMethod(); displayMxComputeGradientDescent(x) })
418 setMethod("show",  "MxComputeGradientDescent",
419           function(object) { callNextMethod(); displayMxComputeGradientDescent(object) })
420
421 convertComputes <- function(flatModel, model) {
422         retval <- lapply(flatModel@computes, function(opt) {
423                 convertForBackend(opt, flatModel, model)
424         })
425         retval
426 }