Allow more than 1 algebra/expectation in MxComputeOnce
[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 = "MxComputeOnce",
58          contains = "MxComputeOperation",
59          representation = representation(
60            what = "MxCharOrNumber",
61            context = "character",
62            gradient = "logical",
63            hessian = "logical"))
64
65 setMethod("qualifyNames", signature("MxComputeOnce"),
66         function(.Object, modelname, namespace) {
67                 .Object@name <- imxIdentifier(modelname, .Object@name)
68                 .Object@what <- imxConvertIdentifier(.Object@what, modelname, namespace)
69                 .Object
70         })
71
72 setMethod("convertForBackend", signature("MxComputeOnce"),
73         function(.Object, flatModel, model) {
74                 .Object <- callNextMethod();
75                 name <- .Object@name
76                 if (any(!is.integer(.Object@what))) {
77                         expNum <- match(.Object@what, names(flatModel@expectations))
78                         algNum <- match(.Object@what, append(names(flatModel@algebras),
79                                                              names(flatModel@fitfunctions)))
80                         if (any(is.na(expNum)) && any(is.na(algNum))) {
81                                 stop("Can only apply MxComputeOnce to MxAlgebra or MxExpectation")
82                         }
83                         if (!any(is.na(expNum))) {
84                                         # Usually negative numbers indicate matrices; not here
85                                 .Object@what <- - expNum
86                         } else {
87                                 if (any(algNum > length(flatModel@algebras)) && length(algNum) > 1) {
88                                         stop("MxComputeOnce cannot evaluate more than 1 fit function")
89                                 }
90                                 .Object@what <- algNum - 1L
91                         }
92                 }
93                 if (length(.Object@what) == 0) warning("MxComputeOnce with nothing will have no effect")
94                 .Object
95         })
96
97 setMethod("initialize", "MxComputeOnce",
98           function(.Object, what, free.group, context, gradient, hessian) {
99                   .Object@name <- 'compute'
100                   .Object@what <- what
101                   .Object@free.group <- free.group
102                   .Object@context <- context
103                   .Object@gradient <- gradient
104                   .Object@hessian <- hessian
105                   .Object
106           })
107
108 mxComputeOnce <- function(what, free.group='default', context=character(0), gradient=FALSE, hessian=FALSE) {
109         new("MxComputeOnce", what, free.group, context, gradient, hessian)
110 }
111
112 #----------------------------------------------------
113
114 setClass(Class = "MxComputeGradientDescent",
115          contains = "MxComputeOperation",
116          representation = representation(
117            fitfunction = "MxCharOrNumber",
118            engine = "character"))
119
120 setMethod("qualifyNames", signature("MxComputeGradientDescent"),
121         function(.Object, modelname, namespace) {
122                 .Object@name <- imxIdentifier(modelname, .Object@name)
123                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
124                 .Object
125         })
126
127 setMethod("convertForBackend", signature("MxComputeGradientDescent"),
128         function(.Object, flatModel, model) {
129                 .Object <- callNextMethod();
130                 name <- .Object@name
131                 if (is.character(.Object@fitfunction)) {
132                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
133                 }
134                 .Object
135         })
136
137 setMethod("initialize", "MxComputeGradientDescent",
138           function(.Object, free.group, engine, fit) {
139                   .Object@name <- 'compute'
140                   .Object@free.group <- free.group
141                   .Object@fitfunction <- fit
142                   .Object@engine <- engine
143                   .Object
144           })
145
146 mxComputeGradientDescent <- function(type, free.group='default',
147                                      engine=NULL, fitfunction='fitfunction') {
148 # What to do with 'type'?
149 #       if (length(type) != 1) stop("Specific 1 compute type")
150
151         if (is.null(engine)) engine <- as.character(NA)
152
153         new("MxComputeGradientDescent", free.group, engine, fitfunction)
154 }
155
156 #----------------------------------------------------
157
158 setClass(Class = "MxComputeNewtonRaphson",
159          contains = "MxComputeOperation",
160          representation = representation(
161            fitfunction = "MxCharOrNumber",
162            maxIter = "integer",
163            tolerance = "numeric"))
164
165 setMethod("qualifyNames", signature("MxComputeNewtonRaphson"),
166         function(.Object, modelname, namespace) {
167                 .Object@name <- imxIdentifier(modelname, .Object@name)
168                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
169                 .Object
170         })
171
172 setMethod("convertForBackend", signature("MxComputeNewtonRaphson"),
173         function(.Object, flatModel, model) {
174                 .Object <- callNextMethod();
175                 name <- .Object@name
176                 if (is.character(.Object@fitfunction)) {
177                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
178                 }
179                 .Object
180         })
181
182 setMethod("initialize", "MxComputeNewtonRaphson",
183           function(.Object, free.group, fit, maxIter, tolerance) {
184                   .Object@name <- 'compute'
185                   .Object@free.group <- free.group
186                   .Object@fitfunction <- fit
187                   .Object@maxIter <- maxIter
188                   .Object@tolerance <- tolerance
189                   .Object
190           })
191
192 mxComputeNewtonRaphson <- function(type, free.group='default',
193                                    fitfunction='fitfunction', maxIter = 500L, tolerance=1e-7) {
194
195         new("MxComputeNewtonRaphson", free.group, fitfunction, maxIter, tolerance)
196 }
197
198 #----------------------------------------------------
199
200 setClass(Class = "MxComputeIterate",
201          contains = "MxBaseCompute",
202          representation = representation(
203            steps = "list",
204            maxIter = "integer",
205            tolerance = "numeric",
206            verbose = "logical"))
207
208 setMethod("initialize", "MxComputeIterate",
209           function(.Object, steps, maxIter, tolerance, verbose) {
210                   .Object@name <- 'compute'
211                   .Object@steps <- steps
212                   .Object@maxIter <- maxIter
213                   .Object@tolerance <- tolerance
214                   .Object@verbose <- verbose
215                   .Object
216           })
217
218 setMethod("qualifyNames", signature("MxComputeIterate"),
219         function(.Object, modelname, namespace) {
220                 .Object@name <- imxIdentifier(modelname, .Object@name)
221                 .Object@steps <- lapply(.Object@steps, function (c) qualifyNames(c, modelname, namespace))
222                 .Object
223         })
224
225 setMethod("convertForBackend", signature("MxComputeIterate"),
226         function(.Object, flatModel, model) {
227                 .Object@steps <- lapply(.Object@steps, function (c) convertForBackend(c, flatModel, model))
228                 .Object
229         })
230
231 mxComputeIterate <- function(steps, maxIter=500L, tolerance=1e-4, verbose=FALSE) {
232         new("MxComputeIterate", steps=steps, maxIter=maxIter, tolerance=tolerance, verbose)
233 }
234
235 displayMxComputeIterate <- function(opt) {
236         cat(class(opt), omxQuotes(opt@name), '\n')
237         cat("@tolerance :", omxQuotes(opt@tolerance), '\n')
238         cat("@maxIter :", omxQuotes(opt@maxIter), '\n')
239         for (step in 1:length(opt@steps)) {
240                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
241         }
242         invisible(opt)
243 }
244
245 setMethod("print", "MxComputeIterate", function(x, ...) displayMxComputeIterate(x))
246 setMethod("show",  "MxComputeIterate", function(object) displayMxComputeIterate(object))
247
248 #----------------------------------------------------
249
250 setClass(Class = "MxComputeEstimatedHessian",
251          contains = "MxComputeOperation",
252          representation = representation(
253            fitfunction = "MxCharOrNumber",
254            se = "logical"))
255
256 setMethod("qualifyNames", signature("MxComputeEstimatedHessian"),
257         function(.Object, modelname, namespace) {
258                 .Object@name <- imxIdentifier(modelname, .Object@name)
259                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
260                 .Object
261         })
262
263 setMethod("convertForBackend", signature("MxComputeEstimatedHessian"),
264         function(.Object, flatModel, model) {
265                 .Object <- callNextMethod();
266                 name <- .Object@name
267                 if (is.character(.Object@fitfunction)) {
268                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
269                 }
270                 .Object
271         })
272
273 setMethod("initialize", "MxComputeEstimatedHessian",
274           function(.Object, free.group, fit, want.se) {
275                   .Object@name <- 'compute'
276                   .Object@free.group <- free.group
277                   .Object@fitfunction <- fit
278                   .Object@se <- want.se
279                   .Object
280           })
281
282 mxComputeEstimatedHessian <- function(free.group='default', fitfunction='fitfunction', want.se=TRUE) {
283         new("MxComputeEstimatedHessian", free.group, fitfunction, want.se)
284 }
285
286 #----------------------------------------------------
287
288 setClass(Class = "MxComputeSequence",
289          contains = "MxBaseCompute",
290          representation = representation(
291            steps = "list"))
292
293 setMethod("initialize", "MxComputeSequence",
294           function(.Object, steps) {
295                   .Object@name <- 'compute'
296                   .Object@steps <- steps
297                   .Object
298           })
299
300 setMethod("qualifyNames", signature("MxComputeSequence"),
301         function(.Object, modelname, namespace) {
302                 .Object@name <- imxIdentifier(modelname, .Object@name)
303                 .Object@steps <- lapply(.Object@steps, function (c) qualifyNames(c, modelname, namespace))
304                 .Object
305         })
306
307 setMethod("convertForBackend", signature("MxComputeSequence"),
308         function(.Object, flatModel, model) {
309                 .Object@steps <- lapply(.Object@steps, function (c) convertForBackend(c, flatModel, model))
310                 .Object
311         })
312
313 mxComputeSequence <- function(steps) {
314         new("MxComputeSequence", steps=steps)
315 }
316
317 displayMxComputeSequence <- function(opt) {
318         cat(class(opt), omxQuotes(opt@name), '\n')
319         for (step in 1:length(opt@steps)) {
320                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
321         }
322         invisible(opt)
323 }
324
325 setMethod("print", "MxComputeSequence", function(x, ...) displayMxComputeSequence(x))
326 setMethod("show",  "MxComputeSequence", function(object) displayMxComputeSequence(object))
327
328 #----------------------------------------------------
329
330 displayMxComputeOperation <- function(opt) {
331         cat(class(opt), omxQuotes(opt@name), '\n')
332         cat("@free.group :", omxQuotes(opt@free.group), '\n')
333         invisible(opt)
334 }
335
336 setMethod("print", "MxComputeOperation", function(x, ...) displayMxComputeOperation(x))
337 setMethod("show",  "MxComputeOperation", function(object) displayMxComputeOperation(object))
338
339 displayMxComputeGradientDescent <- function(opt) {
340         cat("@type :", omxQuotes(opt@type), '\n')
341         cat("@engine :", omxQuotes(opt@engine), '\n')
342         cat("@fitfunction :", omxQuotes(opt@fitfunction), '\n')
343         invisible(opt)
344 }
345
346 setMethod("print", "MxComputeGradientDescent",
347           function(x, ...) { callNextMethod(); displayMxComputeGradientDescent(x) })
348 setMethod("show",  "MxComputeGradientDescent",
349           function(object) { callNextMethod(); displayMxComputeGradientDescent(object) })
350
351 convertComputes <- function(flatModel, model) {
352         retval <- lapply(flatModel@computes, function(opt) {
353                 convertForBackend(opt, flatModel, model)
354         })
355         retval
356 }