Revert "Add option to checkpoint every evaluation"
[openmx:openmx.git] / src / glue.cpp
1 /*
2  *  Copyright 2007-2014 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 <stdio.h>
18 #include <sys/types.h>
19 #include <errno.h>
20
21 #define R_NO_REMAP
22 #include <R.h>
23 #include <Rinternals.h>
24 #include <R_ext/Rdynload.h>
25 #include <R_ext/BLAS.h>
26 #include <R_ext/Lapack.h>
27
28 #include "omxDefines.h"
29 #include "glue.h"
30 #include "omxOpenmpWrap.h"
31 #include "omxState.h"
32 #include "omxMatrix.h"
33 #include "omxAlgebra.h"
34 #include "omxFitFunction.h"
35 #include "omxExpectation.h"
36 #include "omxNPSOLSpecific.h"
37 #include "omxImportFrontendState.h"
38 #include "omxExportBackendState.h"
39 #include "Compute.h"
40 #include "dmvnorm.h"
41 #include "npsolswitch.h"
42
43 static SEXP has_NPSOL()
44 { return Rf_ScalarLogical(HAS_NPSOL); }
45
46 static R_CallMethodDef callMethods[] = {
47         {"backend", (DL_FUNC) omxBackend, 10},
48         {"callAlgebra", (DL_FUNC) omxCallAlgebra, 3},
49         {"findIdenticalRowsData", (DL_FUNC) findIdenticalRowsData, 5},
50         {"Dmvnorm_wrapper", (DL_FUNC) dmvnorm_wrapper, 3},
51         {"hasNPSOL_wrapper", (DL_FUNC) has_NPSOL, 0},
52         {"sparseInvert_wrapper", (DL_FUNC) sparseInvert_wrapper, 1},
53         {NULL, NULL, 0}
54 };
55
56 #ifdef  __cplusplus
57 extern "C" {
58 #endif
59
60 void R_init_OpenMx(DllInfo *info) {
61         R_registerRoutines(info, NULL, callMethods, NULL, NULL);
62
63         // There is no code that will change behavior whether openmp
64         // is set for nested or not. I'm just keeping this in case it
65         // makes a difference with older versions of openmp. 2012-12-24 JNP
66 #if defined(_OPENMP) && _OPENMP <= 200505
67         omp_set_nested(0);
68 #endif
69 }
70
71 void R_unload_OpenMx(DllInfo *) {
72         // keep this stub in case we need it
73 }
74
75 #ifdef  __cplusplus
76 }
77 #endif
78
79 void string_to_try_Rf_error( const std::string& str )
80 {
81         Rf_error("%s", str.c_str());
82 }
83
84 void exception_to_try_Rf_error( const std::exception& ex )
85 {
86         string_to_try_Rf_error(ex.what());
87 }
88
89 SEXP MxRList::asR()
90 {
91         // detect duplicate keys? TODO
92         SEXP names, ans;
93         int len = size();
94         Rf_protect(names = Rf_allocVector(STRSXP, len));
95         Rf_protect(ans = Rf_allocVector(VECSXP, len));
96         for (int lx=0; lx < len; ++lx) {
97                 const char *p1 = (*this)[lx].first;
98                 SEXP p2 = (*this)[lx].second;
99                 if (!p1 || !p2) Rf_error("Attempt to return NULL pointer to R");
100                 SET_STRING_ELT(names, lx, Rf_mkChar(p1));
101                 SET_VECTOR_ELT(ans,   lx, p2);
102         }
103         Rf_namesgets(ans, names);
104         return ans;
105 }
106
107 static void
108 friendlyStringToLogical(const char *key, const char *str, int *out)
109 {
110         int understood = FALSE;
111         int newVal;
112         if (matchCaseInsensitive(str, "Yes")) {
113                 understood = TRUE;
114                 newVal = 1;
115         } else if (matchCaseInsensitive(str, "No")) {
116                 understood = TRUE;
117                 newVal = 0;
118         } else if (isdigit(str[0]) && (atoi(str) == 1 || atoi(str) == 0)) {
119                 understood = TRUE;
120                 newVal = atoi(str);
121         }
122         if (!understood) {
123                 Rf_warning("Expecting 'Yes' or 'No' for '%s' but got '%s', ignoring", key, str);
124                 return;
125         }
126         if(OMX_DEBUG) { mxLog("%s=%d", key, newVal); }
127         *out = newVal;
128 }
129
130 // TODO: make member of omxGlobal class
131 static void readOpts(SEXP options, int *ciMaxIterations, int *numThreads,
132                      int *analyticGradients)
133 {
134                 int numOptions = Rf_length(options);
135                 SEXP optionNames;
136                 Rf_protect(optionNames = Rf_getAttrib(options, R_NamesSymbol));
137                 for(int i = 0; i < numOptions; i++) {
138                         const char *nextOptionName = CHAR(STRING_ELT(optionNames, i));
139                         const char *nextOptionValue = CHAR(Rf_asChar(VECTOR_ELT(options, i)));
140                         if (matchCaseInsensitive(nextOptionName, "CI Max Iterations")) {
141                                 int newvalue = atoi(nextOptionValue);
142                                 if (newvalue > 0) *ciMaxIterations = newvalue;
143                         } else if(matchCaseInsensitive(nextOptionName, "Analytic Gradients")) {
144                                 friendlyStringToLogical(nextOptionName, nextOptionValue, analyticGradients);
145                         } else if(matchCaseInsensitive(nextOptionName, "loglikelihoodScale")) {
146                                 Global->llScale = atof(nextOptionValue);
147                         } else if(matchCaseInsensitive(nextOptionName, "Number of Threads")) {
148                                 *numThreads = atoi(nextOptionValue);
149                                 if (*numThreads < 1) {
150                                         Rf_warning("Computation will be too slow with %d threads; using 1 thread instead", *numThreads);
151                                         *numThreads = 1;
152                                 }
153                         } else if(matchCaseInsensitive(nextOptionName, "mvnMaxPointsA")) {
154                                 Global->maxptsa = atof(nextOptionValue);
155                         } else if(matchCaseInsensitive(nextOptionName, "mvnMaxPointsB")) {
156                                 Global->maxptsb = atof(nextOptionValue);
157                         } else if(matchCaseInsensitive(nextOptionName, "mvnMaxPointsC")) {
158                                 Global->maxptsc = atof(nextOptionValue);
159                         } else if(matchCaseInsensitive(nextOptionName, "mvnAbsEps")) {
160                                 Global->absEps = atof(nextOptionValue);
161                         } else if(matchCaseInsensitive(nextOptionName, "mvnRelEps")) {
162                                 Global->relEps = atof(nextOptionValue);
163                         } else if(matchCaseInsensitive(nextOptionName, "maxStackDepth")) {
164                                 Global->maxStackDepth = atoi(nextOptionValue);
165                         } else {
166                                 // ignore
167                         }
168                 }
169                 Rf_unprotect(1); // optionNames
170 }
171
172 /* Main functions */
173 SEXP omxCallAlgebra2(SEXP matList, SEXP algNum, SEXP options) {
174
175         omxManageProtectInsanity protectManager;
176
177         if(OMX_DEBUG) { mxLog("-----------------------------------------------------------------------");}
178         if(OMX_DEBUG) { mxLog("Explicit call to algebra %d.", INTEGER(algNum)[0]);}
179
180         int j,k,l;
181         omxMatrix* algebra;
182         int algebraNum = INTEGER(algNum)[0];
183         SEXP ans, nextMat;
184
185         FitContext::setRFitFunction(NULL);
186         Global = new omxGlobal;
187
188         globalState = new omxState;
189         omxInitState(globalState);
190
191         readOpts(options, &Global->ciMaxIterations, &Global->numThreads, 
192                         &Global->analyticGradients);
193
194         /* Retrieve All Matrices From the MatList */
195
196         if(OMX_DEBUG) { mxLog("Processing %d matrix(ces).", Rf_length(matList));}
197
198         omxMatrix *args[Rf_length(matList)];
199         for(k = 0; k < Rf_length(matList); k++) {
200                 Rf_protect(nextMat = VECTOR_ELT(matList, k));   // This is the matrix + populations
201                 args[k] = omxNewMatrixFromRPrimitive(nextMat, globalState, 1, - k - 1);
202                 globalState->matrixList.push_back(args[k]);
203                 if(OMX_DEBUG) {
204                         mxLog("Matrix[%d] initialized (%d x %d)",
205                                 k, globalState->matrixList[k]->rows, globalState->matrixList[k]->cols);
206                 }
207         }
208
209         algebra = omxNewAlgebraFromOperatorAndArgs(algebraNum, args, Rf_length(matList), globalState);
210
211         if(algebra==NULL) {
212                 Rf_error("Failed to build algebra");
213         }
214
215         if(OMX_DEBUG) {mxLog("Completed Algebras and Matrices.  Beginning Initial Compute.");}
216         omxStateNextEvaluation(globalState);
217
218         omxRecompute(algebra);
219
220         Rf_protect(ans = Rf_allocMatrix(REALSXP, algebra->rows, algebra->cols));
221         for(l = 0; l < algebra->rows; l++)
222                 for(j = 0; j < algebra->cols; j++)
223                         REAL(ans)[j * algebra->rows + l] =
224                                 omxMatrixElement(algebra, l, j);
225
226         if(OMX_DEBUG) { mxLog("All Algebras complete."); }
227
228         const char *bads = Global->getBads();
229
230         omxFreeMatrix(algebra);
231         omxFreeState(globalState);
232         delete Global;
233
234         if (bads) Rf_error(bads);
235
236         return ans;
237 }
238
239 SEXP omxCallAlgebra(SEXP matList, SEXP algNum, SEXP options)
240 {
241         try {
242                 return omxCallAlgebra2(matList, algNum, options);
243         } catch( std::exception& __ex__ ) {
244                 exception_to_try_Rf_error( __ex__ );
245         } catch(...) {
246                 string_to_try_Rf_error( "c++ exception (unknown reason)" );
247         }
248 }
249
250 SEXP omxBackend2(SEXP constraints, SEXP matList,
251                  SEXP varList, SEXP algList, SEXP expectList, SEXP computeList,
252                  SEXP data, SEXP intervalList, SEXP checkpointList, SEXP options)
253 {
254         SEXP nextLoc;
255
256         /* Sanity Check and Parse Inputs */
257         /* TODO: Need to find a way to account for nullness in these.  For now, all checking is done on the front-end. */
258 //      if(!isVector(matList)) Rf_error ("matList must be a list");
259 //      if(!isVector(algList)) Rf_error ("algList must be a list");
260
261         omxManageProtectInsanity protectManager;
262
263         FitContext::setRFitFunction(NULL);
264         Global = new omxGlobal;
265
266         /* Create new omxState for current state storage and initialize it. */
267         globalState = new omxState;
268         omxInitState(globalState);
269
270         readOpts(options, &Global->ciMaxIterations, &Global->numThreads, 
271                         &Global->analyticGradients);
272 #if HAS_NPSOL
273         omxSetNPSOLOpts(options);
274 #endif
275
276         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
277         omxProcessMxExpectationEntities(expectList);
278
279         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
280         omxProcessMxDataEntities(data);
281     
282         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
283         omxProcessMxMatrixEntities(matList);
284
285         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
286         std::vector<double> startingValues;
287         omxProcessFreeVarList(varList, &startingValues);
288
289         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
290         omxProcessMxAlgebraEntities(algList);
291
292         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
293         omxProcessMxFitFunction(algList);
294
295         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
296         omxProcessMxComputeEntities(computeList);
297
298         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
299         omxCompleteMxExpectationEntities();
300
301         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
302         omxCompleteMxFitFunction(algList);
303
304         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
305         omxInitialMatrixAlgebraCompute();
306
307         if (isErrorRaised(NULL)) {
308                 Rf_error(Global->getBads());
309         }
310
311         /*
312         // Fit functions may not have computed anything because want=0.
313         // We shouldn't leave them marked clean because, for example,
314         // ComputeNumericDeriv will see an invalid reference fit value.
315         //
316         // Wait, does dirty/clean make sense for fitfunctions?
317         //
318         for(size_t index = 0; index < globalState->algebraList.size(); ++index) {
319                 omxMatrix *mat = globalState->algebraList[index];
320                 if (mat->fitFunction) omxMarkDirty(mat);
321         }
322         */
323
324         omxCompute *topCompute = NULL;
325         if (Global->computeList.size()) topCompute = Global->computeList[0];
326
327         /* Process Matrix and Algebra Population Function */
328         /*
329           Each matrix is a list containing a matrix and the other matrices/algebras that are
330           populated into it at each iteration.  The first element is already processed, above.
331           The rest of the list will be processed here.
332         */
333         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
334         for(int j = 0; j < Rf_length(matList); j++) {
335                 Rf_protect(nextLoc = VECTOR_ELT(matList, j));           // This is the matrix + populations
336                 globalState->matrixList[j]->omxProcessMatrixPopulationList(nextLoc);
337         }
338
339         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
340         omxProcessConstraints(constraints);
341
342         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
343         omxProcessConfidenceIntervals(intervalList);
344
345         omxProcessCheckpointOptions(checkpointList);
346
347         for (size_t vg=0; vg < Global->freeGroup.size(); ++vg) {
348                 Global->freeGroup[vg]->cacheDependencies();
349         }
350
351         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
352         if (protectManager.getDepth() > Global->maxStackDepth) {
353                 Rf_error("Protection stack too large; report this problem to the OpenMx forum");
354         }
355         FitContext fc(startingValues);
356
357         if (topCompute && !isErrorRaised(globalState)) {
358                 topCompute->compute(&fc);
359         }
360
361         SEXP evaluations;
362         Rf_protect(evaluations = Rf_allocVector(REALSXP,2));
363
364         REAL(evaluations)[0] = globalState->computeCount;
365
366         if (topCompute && !isErrorRaised(globalState) && globalState->stale) {
367                 fc.copyParamToModel(globalState);
368         }
369
370         MxRList result;
371
372         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
373         omxExportResults(globalState, &result); 
374
375         REAL(evaluations)[1] = globalState->computeCount;
376
377         if (topCompute && !isErrorRaised(globalState)) {
378                 LocalComputeResult cResult;
379                 topCompute->collectResults(&fc, &cResult, &result);
380
381                 if (cResult.size()) {
382                         SEXP computes;
383                         Rf_protect(computes = Rf_allocVector(VECSXP, cResult.size() * 2));
384                         for (size_t cx=0; cx < cResult.size(); ++cx) {
385                                 std::pair<int, MxRList*> &c1 = cResult[cx];
386                                 SET_VECTOR_ELT(computes, cx*2, Rf_ScalarInteger(c1.first));
387                                 SET_VECTOR_ELT(computes, cx*2+1, c1.second->asR());
388                                 delete c1.second;
389                         }
390                         result.add("computes", computes);
391                 }
392
393                 if (fc.wanted & FF_COMPUTE_FIT) {
394                         result.add("fit", Rf_ScalarReal(fc.fit));
395                         result.add("Minus2LogLikelihood", Rf_ScalarReal(fc.fit));
396                 }
397                 if (fc.wanted & FF_COMPUTE_BESTFIT) {
398                         result.add("minimum", Rf_ScalarReal(fc.fit));
399                 }
400
401                 size_t numFree = Global->freeGroup[FREEVARGROUP_ALL]->vars.size();
402                 if (numFree) {
403                         // move other global reporting here TODO
404
405                         SEXP estimate;
406                         Rf_protect(estimate = Rf_allocVector(REALSXP, numFree));
407                         memcpy(REAL(estimate), fc.est, sizeof(double)*numFree);
408                         result.add("estimate", estimate);
409
410                         if (fc.stderrs) {
411                                 SEXP stdErrors;
412                                 Rf_protect(stdErrors = Rf_allocMatrix(REALSXP, numFree, 1));
413                                 memcpy(REAL(stdErrors), fc.stderrs, sizeof(double) * numFree);
414                                 result.add("standardErrors", stdErrors);
415                         }
416                         if (fc.wanted & (FF_COMPUTE_HESSIAN | FF_COMPUTE_IHESSIAN)) {
417                                 result.add("infoDefinite", Rf_ScalarLogical(fc.infoDefinite));
418                                 result.add("conditionNumber", Rf_ScalarReal(fc.infoCondNum));
419                         }
420                 }
421         }
422
423         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
424         MxRList backwardCompatStatus;
425         backwardCompatStatus.add("code", Rf_ScalarInteger(fc.inform));
426         backwardCompatStatus.add("status", Rf_ScalarInteger(-isErrorRaised(globalState)));
427
428         if (isErrorRaised(globalState)) {
429                 SEXP msg;
430                 Rf_protect(msg = Rf_allocVector(STRSXP, 1));
431                 SET_STRING_ELT(msg, 0, Rf_mkChar(Global->getBads()));
432                 result.add("error", msg);
433                 backwardCompatStatus.add("statusMsg", msg);
434         }
435
436         result.add("status", backwardCompatStatus.asR());
437         result.add("iterations", Rf_ScalarInteger(fc.iterations));
438         result.add("evaluations", evaluations);
439
440         omxFreeState(globalState);
441         delete Global;
442
443         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
444         return result.asR();
445 }
446
447 SEXP omxBackend(SEXP constraints, SEXP matList,
448                 SEXP varList, SEXP algList, SEXP expectList, SEXP computeList,
449                 SEXP data, SEXP intervalList, SEXP checkpointList, SEXP options)
450 {
451         try {
452                 return omxBackend2(constraints, matList,
453                                    varList, algList, expectList, computeList,
454                                    data, intervalList, checkpointList, options);
455         } catch( std::exception& __ex__ ) {
456                 exception_to_try_Rf_error( __ex__ );
457         } catch(...) {
458                 string_to_try_Rf_error( "c++ exception (unknown reason)" );
459         }
460 }
461