Updated copyright to 2013 for R/ demo/ models/passing and src/ folders, and also...
[openmx:openmx.git] / R / MxFitFunction.R
1 #
2 #   Copyright 2007-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
17 #
18 # The virtual base class for all fit functions
19 #
20 setClass(Class = "MxBaseFitFunction", 
21         representation = representation(
22                 name = "character",
23         info = "list",
24                 dependencies = "integer",
25                 expectation = "integer",
26                 result = "matrix", "VIRTUAL"))
27
28 setClassUnion("MxFitFunction", c("NULL", "MxBaseFitFunction"))
29
30 setGeneric("genericFitDependencies",
31         function(.Object, flatModel, dependencies) {
32         return(standardGeneric("genericFitDependencies"))
33 })
34
35 setGeneric("genericFitFunNamespace", 
36         function(.Object, modelname, namespace) {
37         return(standardGeneric("genericFitFunNamespace"))
38 })
39
40 setGeneric("genericFitRename",
41         function(.Object, oldname, newname) {
42         return(standardGeneric("genericFitRename"))
43 })
44
45 setGeneric("genericFitInitialMatrix",
46         function(.Object, flatModel) {
47         return(standardGeneric("genericFitInitialMatrix"))
48 })
49
50 setGeneric("genericFitNewEntities",
51         function(.Object) {
52         return(standardGeneric("genericFitNewEntities"))
53 })
54
55
56 setGeneric("genericFitFunConvert", 
57         function(.Object, flatModel, model, labelsData, defVars, dependencies) {
58         return(standardGeneric("genericFitFunConvert")) 
59 })
60
61 setMethod("genericFitInitialMatrix", "MxBaseFitFunction",
62         function(.Object, flatModel) {
63                 return(matrix(as.double(NA), 1, 1))
64 })
65
66 setMethod("genericFitInitialMatrix", "NULL",
67         function(.Object, flatModel) {
68                 return(NULL)
69 })
70
71 ##' Add dependencies
72 ##'
73 ##' If there is an expectation, then the fitfunction should always
74 ##' depend on it. Hence, subclasses that implement this method must
75 ##' ignore the passed-in dependencies and use "dependencies <-
76 ##' callNextMethod()" instead.
77 ##'
78 ##' @param .Object
79 ##' @param flatModel
80 ##' @param dependencies accumulated dependency relationships
81
82 setMethod("genericFitDependencies", "MxBaseFitFunction",
83         function(.Object, flatModel, dependencies) {
84         name <- .Object@name
85         modelname <- imxReverseIdentifier(model, .Object@name)[[1]]
86         expectName <- paste(modelname, "expectation", sep=".")
87         if (!is.null(flatModel[[expectName]])) {
88             dependencies <- imxAddDependency(expectName, .Object@name, dependencies)
89         }
90                 return(dependencies)
91 })
92
93 setMethod("genericFitDependencies", "NULL",
94         function(.Object, flatModel, dependencies) {
95                 return(dependencies)
96 })
97
98 setMethod("genericFitRename", "MxBaseFitFunction",
99         function(.Object, oldname, newname) {
100                 return(.Object)
101 })
102
103 setMethod("genericFitRename", "NULL",
104         function(.Object, oldname, newname) {
105                 return(NULL)
106 })
107
108 setMethod("genericFitNewEntities", "MxBaseFitFunction",
109         function(.Object) {
110                 return(NULL)
111 })
112
113 setGeneric("genericFitConvertEntities",
114         function(.Object, flatModel, namespace, labelsData) {
115         return(standardGeneric("genericFitConvertEntities"))
116 })
117
118 setGeneric("genericFitAddEntities",
119         function(.Object, job, flatJob, labelsData) {
120         return(standardGeneric("genericFitAddEntities"))
121 })
122
123 setMethod("genericFitConvertEntities", "MxBaseFitFunction",
124         function(.Object, flatModel, namespace, labelsData) {
125                 return(flatModel)
126 })
127
128 setMethod("genericFitConvertEntities", "NULL",
129         function(.Object, flatModel, namespace, labelsData) {
130                 return(flatModel)
131 })
132
133 setMethod("genericFitAddEntities", "MxBaseFitFunction",
134         function(.Object, job, flatJob, labelsData) {
135                 return(job)
136 })
137
138 setMethod("genericFitAddEntities", "NULL",
139         function(.Object, job, flatJob, labelsData) {
140                 return(job)
141 })
142
143 fitFunctionAddEntities <- function(model, flatModel, labelsData) {
144
145         fitfunctions <- flatModel@fitfunctions
146
147         if (length(fitfunctions) == 0) {
148                 return(model)
149         }
150
151         for(i in 1:length(fitfunctions)) {
152                 model <- genericFitAddEntities(fitfunctions[[i]], model, flatModel, labelsData)
153         }
154
155         return(model)
156 }
157
158 fitFunctionModifyEntities <- function(flatModel, namespace, labelsData) {
159
160         fitfunctions <- flatModel@fitfunctions
161
162         if (length(fitfunctions) == 0) {
163                 return(flatModel)
164         }
165
166         for(i in 1:length(fitfunctions)) {
167                 flatModel <- genericFitConvertEntities(fitfunctions[[i]], flatModel, namespace, labelsData)
168         }
169
170         return(flatModel)
171 }
172
173 convertFitFunctions <- function(flatModel, model, labelsData, defVars, dependencies) {
174         retval <- lapply(flatModel@fitfunctions, genericFitFunConvert, 
175                 flatModel, model, labelsData, defVars, dependencies)
176         return(retval)
177 }
178
179 fitFunctionReadAttributes <- function(fitFunction, values) {
180         attr <- attributes(values)
181         attributes(values) <- list('dim' = attr$dim)
182
183                 dimnames(values) <- dimnames(fitFunction)
184         attr$dim <- NULL
185
186                 fitFunction@result <- values
187         fitFunction@info <- attr
188                 return(fitFunction)
189 }