Free parameter groups
[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 setMethod("qualifyNames", signature("MxBaseCompute"),
29         function(.Object, modelname, namespace) {
30                 .Object@name <- imxIdentifier(modelname, .Object@name)
31                 .Object@fitfunction <- imxConvertIdentifier(.Object@fitfunction, modelname, namespace)
32                 .Object
33         })
34
35 setMethod("convertForBackend", signature("MxBaseCompute"),
36         function(.Object, flatModel, model) {
37                 name <- .Object@name
38                 if (is.character(.Object@fitfunction)) {
39                         .Object@fitfunction <- imxLocateIndex(flatModel, .Object@fitfunction, name)
40                 }
41                 fg <- match(.Object@free.group, flatModel@freeGroupNames)
42                 if (is.na(fg)) {
43                         stop(paste("Cannot find free group", .Object@free.group,
44                                    "in list of free groups:",
45                                    omxQuotes(flatModel@freeGroupNames)))
46                 } else {
47                         .Object@free.group <- fg - 1L
48                 }
49                 .Object
50         })
51
52 setClass(Class = "MxComputeOperation",
53          contains = "MxBaseCompute",
54          representation = representation(
55            free.group = "MxCharOrNumber",
56            fitfunction = "MxCharOrNumber"))
57
58 setClass(Class = "MxComputeOnce",
59          contains = "MxComputeOperation")
60
61 setClass(Class = "MxComputeGradientDescent",
62          contains = "MxComputeOperation",
63          representation = representation(
64            type = "character",
65            engine = "character"))
66
67 setClass(Class = "MxComputeSequence",
68          contains = "MxBaseCompute",
69          representation = representation(
70            steps = "list"))
71
72 setClass(Class = "MxComputeEstimatedHessian",
73          contains = "MxComputeOperation",
74          representation = representation(
75            se = "logical"))
76
77 setMethod("initialize", "MxComputeOnce",
78           function(.Object, free.group, fit) {
79                   .Object@name <- 'compute'
80                   .Object@free.group <- free.group
81                   .Object@fitfunction <- fit
82                   .Object
83           })
84
85 mxComputeOnce <- function(free.group='default', fitfunction='fitfunction') {
86         new("MxComputeOnce", free.group, fitfunction)
87 }
88
89 setMethod("initialize", "MxComputeSequence",
90           function(.Object, steps) {
91                   .Object@name <- 'compute'
92                   .Object@steps <- steps
93                   .Object
94           })
95
96 setMethod("qualifyNames", signature("MxComputeSequence"),
97         function(.Object, modelname, namespace) {
98                 .Object@name <- imxIdentifier(modelname, .Object@name)
99                 .Object@steps <- lapply(.Object@steps, function (c) qualifyNames(c, modelname, namespace))
100                 .Object
101         })
102
103 setMethod("convertForBackend", signature("MxComputeSequence"),
104         function(.Object, flatModel, model) {
105                 .Object@steps <- lapply(.Object@steps, function (c) convertForBackend(c, flatModel, model))
106                 .Object
107         })
108
109 mxComputeSequence <- function(steps) {
110         new("MxComputeSequence", steps=steps)
111 }
112
113 setMethod("initialize", "MxComputeEstimatedHessian",
114           function(.Object, free.group, fit, want.se) {
115                   .Object@name <- 'compute'
116                   .Object@free.group <- free.group
117                   .Object@fitfunction <- fit
118                   .Object@se <- want.se
119                   .Object
120           })
121
122 mxComputeEstimatedHessian <- function(free.group='default', fitfunction='fitfunction', want.se=TRUE) {
123         new("MxComputeEstimatedHessian", free.group, fitfunction, want.se)
124 }
125
126 setMethod("initialize", "MxComputeGradientDescent",
127           function(.Object, free.group, type, engine, fit) {
128                   .Object@name <- 'compute'
129                   .Object@free.group <- free.group
130                   .Object@fitfunction <- fit
131                   .Object@type <- type
132                   .Object@engine <- engine
133                   .Object
134           })
135
136 mxComputeGradientDescent <- function(type, free.group='default',
137                                      engine=NULL, fitfunction='fitfunction') {
138 #       if (length(type) != 1) stop("Specific 1 compute type")
139
140         if (is.null(type)) type <- as.character(NA)
141         if (is.null(engine)) engine <- as.character(NA)
142
143         new("MxComputeGradientDescent", free.group, type, engine, fitfunction)
144 }
145
146 displayMxComputeSequence <- function(opt) {
147         cat(class(opt), omxQuotes(opt@name), '\n')
148         for (step in 1:length(opt@steps)) {
149                 cat("[[", step, "]] :", class(opt@steps[[step]]), '\n')
150         }
151         invisible(opt)
152 }
153
154 setMethod("print", "MxComputeSequence", function(x, ...) displayMxComputeSequence(x))
155 setMethod("show",  "MxComputeSequence", function(object) displayMxComputeSequence(object))
156
157 displayMxComputeOperation <- function(opt) {
158         cat(class(opt), omxQuotes(opt@name), '\n')
159         cat("@free.group :", omxQuotes(opt@free.group), '\n')
160         cat("@fitfunction :", omxQuotes(opt@fitfunction), '\n')
161         invisible(opt)
162 }
163
164 setMethod("print", "MxComputeOperation", function(x, ...) displayMxComputeOperation(x))
165 setMethod("show",  "MxComputeOperation", function(object) displayMxComputeOperation(object))
166
167 displayMxComputeGradientDescent <- function(opt) {
168         cat("@type :", omxQuotes(opt@type), '\n')
169         cat("@engine :", omxQuotes(opt@engine), '\n')
170         invisible(opt)
171 }
172
173 setMethod("print", "MxComputeGradientDescent",
174           function(x, ...) { callNextMethod(); displayMxComputeGradientDescent(x) })
175 setMethod("show",  "MxComputeGradientDescent",
176           function(object) { callNextMethod(); displayMxComputeGradientDescent(object) })
177
178 convertComputes <- function(flatModel, model) {
179         retval <- lapply(flatModel@computes, function(opt) {
180                 convertForBackend(opt, flatModel, model)
181         })
182         retval
183 }