Allow ComputeIterate to test maximum absolute change
[openmx:openmx.git] / R / MxRun.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 mxRun <- function(model, ..., intervals = FALSE, silent = FALSE, 
17                 suppressWarnings = FALSE, unsafe = FALSE,
18                 checkpoint = FALSE, useSocket = FALSE, onlyFrontend = FALSE, 
19                 useOptimizer = TRUE){
20         if(!silent) cat("Running", model@name, "\n")
21         frontendStart <- Sys.time()
22         garbageArguments <- list(...)
23         if (length(garbageArguments) > 0) {
24                 stop("mxRun does not accept values for the '...' argument")
25         }
26         runHelper(model, frontendStart, intervals,
27                 silent, suppressWarnings, unsafe,
28                 checkpoint, useSocket, onlyFrontend, useOptimizer)
29 }
30
31 runHelper <- function(model, frontendStart, 
32                 intervals, silent, suppressWarnings, 
33                 unsafe, checkpoint, useSocket, onlyFrontend, useOptimizer, parentData = NULL) {
34
35         model <- imxPreprocessModel(model)
36         model <- eliminateObjectiveFunctions(model)
37         imxCheckMatrices(model)
38         imxVerifyModel(model)
39         model <- processParentData(model, parentData)
40         if (modelIsHollow(model)) {
41                 independents <- getAllIndependents(model)
42                 indepTimeStart <- Sys.time()
43             independents <- omxLapply(independents, runHelper,
44                 frontendStart = frontendStart, 
45                 intervals = intervals, silent = silent, 
46                 suppressWarnings = suppressWarnings, unsafe = unsafe,
47                 checkpoint = checkpoint, useSocket = useSocket,
48                 onlyFrontend = onlyFrontend, useOptimizer = useOptimizer, parentData = model@data)
49                 indepTimeStop <- Sys.time()
50                 indepElapsed <- indepTimeStop - indepTimeStart
51                 return(processHollowModel(model, independents, 
52                         frontendStart, indepElapsed))
53         }
54
55         dataList <- generateDataList(model)
56         dshare <- shareData(model)
57         independents <- getAllIndependents(dshare)
58         indepTimeStart <- Sys.time()
59         independents <- omxLapply(independents, mxRun, 
60                 intervals = intervals, silent = silent, 
61                 suppressWarnings = suppressWarnings, unsafe = unsafe,
62                 checkpoint = checkpoint, useSocket = useSocket,
63                 onlyFrontend = onlyFrontend, useOptimizer = useOptimizer)
64         indepTimeStop <- Sys.time()
65         indepElapsed <- indepTimeStop - indepTimeStart
66         if (modelIsHollow(model)) {
67                 return(processHollowModel(model, independents, 
68                         dataList, frontendStart, indepElapsed))
69         }
70         frozen <- lapply(independents, imxFreezeModel)
71         model <- imxReplaceModels(model, frozen)
72         namespace <- imxGenerateNamespace(model)
73         flatModel <- imxFlattenModel(model, namespace)  
74         omxCheckNamespace(model, namespace)
75         convertArguments <- imxCheckVariables(flatModel, namespace)
76         freeVarGroups <- buildFreeVarGroupList(flatModel)
77         flatModel <- constraintsToAlgebras(flatModel)
78         flatModel <- convertAlgebras(flatModel, convertArguments)
79         defVars <- generateDefinitionList(flatModel, list())
80         model <- expectationFunctionAddEntities(model, flatModel, labelsData)
81         model <- convertDatasets(model, defVars, model@options)
82         flatModel@datasets <- collectDatasets(model)
83         labelsData <- imxGenerateLabels(model)
84
85         model <- fitFunctionAddEntities(model, flatModel, labelsData)
86
87         if (model@.newobjects) {
88                 namespace <- imxGenerateNamespace(model)
89                 flatModel <- imxFlattenModel(model, namespace)
90                 labelsData <- imxGenerateLabels(model)
91         }
92
93         flatModel <- expectationFunctionConvertEntities(flatModel, namespace, labelsData)
94
95         if (model@.newobjects) {
96                 convertArguments <- imxCheckVariables(flatModel, namespace)
97                 flatModel <- constraintsToAlgebras(flatModel)
98                 flatModel <- convertAlgebras(flatModel, convertArguments)
99         }
100
101         dependencies <- cycleDetection(flatModel)
102         dependencies <- transitiveClosure(flatModel, dependencies)
103         flatModel <- populateDefInitialValues(flatModel)
104         flatModel <- checkEvaluation(model, flatModel)
105         flatModel <- generateParameterList(flatModel, dependencies, freeVarGroups)
106         matrices <- generateMatrixList(flatModel)
107         algebras <- generateAlgebraList(flatModel)
108         defVars <- generateDefinitionList(flatModel, dependencies)              
109         expectations <- convertExpectationFunctions(flatModel, model, labelsData, defVars, dependencies)
110         fitfunctions <- convertFitFunctions(flatModel, model, labelsData, defVars, dependencies)
111         data <- flatModel@datasets
112         numAlgebras <- length(algebras)
113         algebras <- append(algebras, fitfunctions)
114         constraints <- convertConstraints(flatModel)
115         parameters <- flatModel@parameters
116         numParam <- length(parameters)
117         intervalList <- generateIntervalList(flatModel, intervals, model@name, parameters, labelsData)
118         communication <- generateCommunicationList(model@name, checkpoint, useSocket, model@options)
119
120         useOptimizer <- useOptimizer && imxPPML.Check.UseOptimizer(model@options$UsePPML)
121         options <- generateOptionsList(model, numParam, constraints, useOptimizer)
122         
123         compute <- NULL
124         computes <- list()
125         if (!is.null(model@fitfunction) && is.null(model@compute)) {
126                 # horrible hack, sorry
127                 fitNum <- match(flatModel@fitfunction@name, names(flatModel@fitfunctions)) - 1L + numAlgebras
128                 if (!useOptimizer || numParam == 0) {
129                         computes <- list(mxComputeOnce(what=fitNum, fit=TRUE))
130                 } else {
131                         if (options[["Calculate Hessian"]] == "No") {
132                                 computes <- list(mxComputeGradientDescent(type="Quasi-Newton",
133                                                                           fitfunction=fitNum))
134                         } else {
135                                 want.se <- options[["Standard Errors"]] == "Yes"
136                                 steps <- list(mxComputeGradientDescent(fitfunction=fitNum, type="Quasi-Newton"),
137                                               mxComputeEstimatedHessian(fitfunction=fitNum, want.se=want.se))
138                                 computes <- list(mxComputeSequence(steps))
139                         }
140                 }
141                 flatModel@computes <- computes          
142                 compute <- 0L
143         } else {
144                 if (!is.null(flatModel@compute)) {
145                         compute <- imxLocateIndex(flatModel, flatModel@compute@name, flatModel@name)
146                 }
147         }
148
149         computes <- convertComputes(flatModel, model)
150         
151         frontendStop <- Sys.time()
152         frontendElapsed <- (frontendStop - frontendStart) - indepElapsed
153         if (onlyFrontend) return(model)
154         output <- .Call(omxBackend, compute,
155                         constraints, matrices, parameters,
156                         algebras, expectations, computes,
157                         data, intervalList, communication, options, PACKAGE = "OpenMx")
158         backendStop <- Sys.time()
159         backendElapsed <- backendStop - frontendStop
160         model <- updateModelMatrices(model, flatModel, output$matrices)
161         model <- updateModelAlgebras(model, flatModel, output$algebras)
162         model <- updateModelExpectations(model, flatModel, output$expectations)
163         independents <- lapply(independents, undoDataShare, dataList)
164         model <- imxReplaceModels(model, independents)
165         model <- resetDataSortingFlags(model)
166         model@output <- nameOptimizerOutput(suppressWarnings, flatModel,
167                 names(matrices), names(algebras),
168                 names(parameters), names(intervalList), output)
169
170         model <- populateRunStateInformation(model, parameters, matrices, fitfunctions,
171                                              collectExpectations(model, namespace, NULL),
172                                              data, flatModel@constraints, independents, defVars)
173         frontendStop <- Sys.time()
174         frontendElapsed <- frontendElapsed + (frontendStop - backendStop)
175         model@output <- calculateTiming(model@output, frontendElapsed,
176                 backendElapsed, indepElapsed, frontendStop, independents)
177         processErrorConditions(model, unsafe, suppressWarnings)
178         return(model)           
179 }
180