Enable R_NO_REMAP for a cleaner namespace
[openmx:openmx.git] / src / ComputeGD.cpp
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
17 #include "omxState.h"
18 #include "omxFitFunction.h"
19 #include "omxNPSOLSpecific.h"
20 #include "omxExportBackendState.h"
21 #include "omxCsolnp.h"
22 #include "Compute.h"
23 #include "npsolswitch.h"
24
25 enum OptEngine {
26         OptEngine_NPSOL,
27         OptEngine_CSOLNP
28 };
29
30 class omxComputeGD : public omxCompute {
31         typedef omxCompute super;
32         enum OptEngine engine;
33         omxMatrix *fitMatrix;
34         bool useGradient;
35         int verbose;
36     
37         SEXP intervals, intervalCodes; // move to FitContext? TODO
38         int inform, iter;
39     
40 public:
41         omxComputeGD();
42         virtual void initFromFrontend(SEXP rObj);
43         virtual void computeImpl(FitContext *fc);
44         virtual void reportResults(FitContext *fc, MxRList *slots, MxRList *out);
45         virtual double getOptimizerStatus() { return inform; }  // backward compatibility
46 };
47
48 class omxCompute *newComputeGradientDescent()
49 {
50         return new omxComputeGD();
51 }
52
53 omxComputeGD::omxComputeGD()
54 {
55         intervals = 0;
56         intervalCodes = 0;
57         inform = 0;
58         iter = 0;
59 }
60
61 void omxComputeGD::initFromFrontend(SEXP rObj)
62 {
63         super::initFromFrontend(rObj);
64         fitMatrix = omxNewMatrixFromSlot(rObj, globalState, "fitfunction");
65         setFreeVarGroup(fitMatrix->fitFunction, varGroup);
66         omxCompleteFitFunction(fitMatrix);
67     
68         SEXP slotValue;
69         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("useGradient")));
70         if (Rf_length(slotValue)) {
71                 useGradient = Rf_asLogical(slotValue);
72         } else {
73                 useGradient = Global->analyticGradients;
74         }
75     
76         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("verbose")));
77         verbose = Rf_asInteger(slotValue);
78     
79         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("engine")));
80         const char *engine_name = CHAR(Rf_asChar(slotValue));
81         if (strcmp(engine_name, "CSOLNP")==0) {
82                 engine = OptEngine_CSOLNP;
83         } else if (strcmp(engine_name, "NPSOL")==0) {
84 #if HAS_NPSOL
85                 engine = OptEngine_NPSOL;
86 #else
87                 Rf_error("NPSOL is not available in this build");
88 #endif
89         } else {
90                 Rf_error("MxComputeGradientDescent engine %s unknown", engine_name);
91         }
92 }
93
94 void omxComputeGD::computeImpl(FitContext *fc)
95 {
96     size_t numParam = varGroup->vars.size();
97         if (numParam <= 0) {
98                 Rf_error("Model has no free parameters");
99                 return;
100         }
101     
102         omxFitFunctionCompute(fitMatrix->fitFunction, FF_COMPUTE_PREOPTIMIZE, fc);
103
104         if (fitMatrix->fitFunction && fitMatrix->fitFunction->usesChildModels)
105                 omxFitFunctionCreateChildren(globalState);
106     
107         switch (engine) {
108         case OptEngine_NPSOL:
109 #if HAS_NPSOL
110             omxInvokeNPSOL(fitMatrix, fc, &inform, &iter, useGradient, varGroup, verbose);
111 #endif
112             break;
113         case OptEngine_CSOLNP:
114             omxInvokeCSOLNP(fitMatrix, fc, &inform, &iter, varGroup, verbose);
115             break;
116         default: Rf_error("huh?");
117         }
118     
119         omxFreeChildStates(globalState);
120     
121         if (Global->numIntervals && engine == OptEngine_NPSOL) {
122                 if (!(inform == 0 || inform == 1 || inform == 6)) {
123                         // TODO: allow forcing
124                         Rf_warning("Not calculating confidence intervals because of NPSOL status %d", inform);
125                 } else {
126                         Rf_protect(intervals = Rf_allocMatrix(REALSXP, Global->numIntervals, 2));
127                         Rf_protect(intervalCodes = Rf_allocMatrix(INTSXP, Global->numIntervals, 2));
128 #if HAS_NPSOL
129                         omxNPSOLConfidenceIntervals(fitMatrix, fc);
130 #endif
131                         omxPopulateConfidenceIntervals(intervals, intervalCodes); // TODO move code here
132                 }
133         }
134         
135     else if(Global->numIntervals && engine == OptEngine_CSOLNP) {
136         Rf_protect(intervals = Rf_allocMatrix(REALSXP, Global->numIntervals, 2));
137         Rf_protect(intervalCodes = Rf_allocMatrix(INTSXP, Global->numIntervals, 2));
138         omxCSOLNPConfidenceIntervals(fitMatrix, fc, verbose);
139         omxPopulateConfidenceIntervals(intervals, intervalCodes); // TODO move code here
140     }
141     
142         fc->wanted |= FF_COMPUTE_GRADIENT | FF_COMPUTE_BESTFIT;
143
144         omxMarkDirty(fitMatrix); // not sure why it needs to be dirty
145     /*printf("fc->hess in computeGD\n");
146     printf("%2f", fc->hess[0]); putchar('\n');
147     printf("%2f", fc->hess[1]); putchar('\n');
148     printf("%2f", fc->hess[2]); putchar('\n');
149     */
150 }
151
152 void omxComputeGD::reportResults(FitContext *fc, MxRList *slots, MxRList *out)
153 {
154         omxPopulateFitFunction(fitMatrix, out);
155     
156     /*printf("fc->hess in computeGD:report results\n");
157     printf("%2f", fc->hess[0]); putchar('\n');
158     printf("%2f", fc->hess[1]); putchar('\n');
159     printf("%2f", fc->hess[2]); putchar('\n');
160 */
161         size_t numFree = varGroup->vars.size();
162     
163         SEXP hessian;
164         Rf_protect(hessian = Rf_allocMatrix(REALSXP, numFree, numFree));
165     
166         memcpy(REAL(hessian), fc->hess, sizeof(double) * numFree * numFree);
167     
168         out->push_back(std::make_pair(Rf_mkChar("hessianCholesky"), hessian));
169     
170         if (intervals && intervalCodes) {
171                 out->push_back(std::make_pair(Rf_mkChar("confidenceIntervals"), intervals));
172                 out->push_back(std::make_pair(Rf_mkChar("confidenceIntervalCodes"), intervalCodes));
173         }
174     
175         SEXP code, iterations;
176     
177         Rf_protect(code = Rf_allocVector(REALSXP,1));
178         REAL(code)[0] = inform;
179         out->push_back(std::make_pair(Rf_mkChar("npsol.code"), code));
180     
181         Rf_protect(iterations = Rf_allocVector(REALSXP,1));
182         REAL(iterations)[0] = iter;
183         out->push_back(std::make_pair(Rf_mkChar("npsol.iterations"), iterations));
184         out->push_back(std::make_pair(Rf_mkChar("iterations"), iterations)); // backward compatibility
185 }