Enable R_NO_REMAP for a cleaner namespace
[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 "types.h"
30 #include "glue.h"
31 #include "omxOpenmpWrap.h"
32 #include "omxState.h"
33 #include "omxMatrix.h"
34 #include "omxAlgebra.h"
35 #include "omxFitFunction.h"
36 #include "omxExpectation.h"
37 #include "omxNPSOLSpecific.h"
38 #include "omxImportFrontendState.h"
39 #include "omxExportBackendState.h"
40 #include "Compute.h"
41 #include "dmvnorm.h"
42 #include "npsolswitch.h"
43
44 static SEXP has_NPSOL()
45 { return Rf_ScalarLogical(HAS_NPSOL); }
46
47 static R_CallMethodDef callMethods[] = {
48         {"backend", (DL_FUNC) omxBackend, 10},
49         {"callAlgebra", (DL_FUNC) omxCallAlgebra, 3},
50         {"findIdenticalRowsData", (DL_FUNC) findIdenticalRowsData, 5},
51         {"Dmvnorm_wrapper", (DL_FUNC) dmvnorm_wrapper, 3},
52         {"hasNPSOL_wrapper", (DL_FUNC) has_NPSOL, 0},
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                 SEXP 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, p1);
101                 SET_VECTOR_ELT(ans,   lx, p2);
102         }
103         Rf_namesgets(ans, names);
104         return ans;
105 }
106
107 /* Main functions */
108 SEXP omxCallAlgebra2(SEXP matList, SEXP algNum, SEXP) {
109
110         omxManageProtectInsanity protectManager;
111
112         if(OMX_DEBUG) { mxLog("-----------------------------------------------------------------------");}
113         if(OMX_DEBUG) { mxLog("Explicit call to algebra %d.", INTEGER(algNum)[0]);}
114
115         int j,k,l;
116         omxMatrix* algebra;
117         int algebraNum = INTEGER(algNum)[0];
118         SEXP ans, nextMat;
119         char output[MAX_STRING_LEN];
120
121         FitContext::setRFitFunction(NULL);
122         Global = new omxGlobal;
123
124         globalState = new omxState;
125         omxInitState(globalState);
126
127         /* Retrieve All Matrices From the MatList */
128
129         if(OMX_DEBUG) { mxLog("Processing %d matrix(ces).", Rf_length(matList));}
130
131         omxMatrix *args[Rf_length(matList)];
132         for(k = 0; k < Rf_length(matList); k++) {
133                 Rf_protect(nextMat = VECTOR_ELT(matList, k));   // This is the matrix + populations
134                 args[k] = omxNewMatrixFromRPrimitive(nextMat, globalState, 1, - k - 1);
135                 globalState->matrixList.push_back(args[k]);
136                 if(OMX_DEBUG) {
137                         mxLog("Matrix[%d] initialized (%d x %d)",
138                                 k, globalState->matrixList[k]->rows, globalState->matrixList[k]->cols);
139                 }
140         }
141
142         algebra = omxNewAlgebraFromOperatorAndArgs(algebraNum, args, Rf_length(matList), globalState);
143
144         if(algebra==NULL) {
145                 Rf_error(globalState->statusMsg);
146         }
147
148         if(OMX_DEBUG) {mxLog("Completed Algebras and Matrices.  Beginning Initial Compute.");}
149         omxStateNextEvaluation(globalState);
150
151         omxRecompute(algebra);
152
153         Rf_protect(ans = Rf_allocMatrix(REALSXP, algebra->rows, algebra->cols));
154         for(l = 0; l < algebra->rows; l++)
155                 for(j = 0; j < algebra->cols; j++)
156                         REAL(ans)[j * algebra->rows + l] =
157                                 omxMatrixElement(algebra, l, j);
158
159         if(OMX_DEBUG) { mxLog("All Algebras complete."); }
160
161         output[0] = 0;
162         if (isErrorRaised(globalState)) {
163                 strncpy(output, globalState->statusMsg, MAX_STRING_LEN);
164         }
165
166         omxFreeAllMatrixData(algebra);
167         omxFreeState(globalState);
168         delete Global;
169
170         if(output[0]) Rf_error(output);
171
172         return ans;
173 }
174
175 SEXP omxCallAlgebra(SEXP matList, SEXP algNum, SEXP options)
176 {
177         try {
178                 return omxCallAlgebra2(matList, algNum, options);
179         } catch( std::exception& __ex__ ) {
180                 exception_to_try_Rf_error( __ex__ );
181         } catch(...) {
182                 string_to_try_Rf_error( "c++ exception (unknown reason)" );
183         }
184 }
185
186 static void
187 friendlyStringToLogical(const char *key, const char *str, int *out)
188 {
189         int understood = FALSE;
190         int newVal;
191         if (matchCaseInsensitive(str, "Yes")) {
192                 understood = TRUE;
193                 newVal = 1;
194         } else if (matchCaseInsensitive(str, "No")) {
195                 understood = TRUE;
196                 newVal = 0;
197         } else if (isdigit(str[0]) && (atoi(str) == 1 || atoi(str) == 0)) {
198                 understood = TRUE;
199                 newVal = atoi(str);
200         }
201         if (!understood) {
202                 Rf_warning("Expecting 'Yes' or 'No' for '%s' but got '%s', ignoring", key, str);
203                 return;
204         }
205         if(OMX_DEBUG) { mxLog("%s=%d", key, newVal); }
206         *out = newVal;
207 }
208
209 // TODO: make member of omxGlobal class
210 static void readOpts(SEXP options, int *ciMaxIterations, int *numThreads,
211                      int *analyticGradients)
212 {
213                 int numOptions = Rf_length(options);
214                 SEXP optionNames;
215                 Rf_protect(optionNames = Rf_getAttrib(options, R_NamesSymbol));
216                 for(int i = 0; i < numOptions; i++) {
217                         const char *nextOptionName = CHAR(STRING_ELT(optionNames, i));
218                         const char *nextOptionValue = CHAR(Rf_asChar(VECTOR_ELT(options, i)));
219                         if (matchCaseInsensitive(nextOptionName, "CI Max Iterations")) {
220                                 int newvalue = atoi(nextOptionValue);
221                                 if (newvalue > 0) *ciMaxIterations = newvalue;
222                         } else if(matchCaseInsensitive(nextOptionName, "Analytic Gradients")) {
223                                 friendlyStringToLogical(nextOptionName, nextOptionValue, analyticGradients);
224                         } else if(matchCaseInsensitive(nextOptionName, "loglikelihoodScale")) {
225                                 Global->llScale = atof(nextOptionValue);
226                         } else if(matchCaseInsensitive(nextOptionName, "Number of Threads")) {
227                                 *numThreads = atoi(nextOptionValue);
228                                 if (*numThreads < 1) {
229                                         Rf_warning("Computation will be too slow with %d threads; using 1 thread instead", *numThreads);
230                                         *numThreads = 1;
231                                 }
232                         } else {
233                                 // ignore
234                         }
235                 }
236                 Rf_unprotect(1); // optionNames
237 }
238
239 SEXP omxBackend2(SEXP constraints, SEXP matList,
240                  SEXP varList, SEXP algList, SEXP expectList, SEXP computeList,
241                  SEXP data, SEXP intervalList, SEXP checkpointList, SEXP options)
242 {
243         SEXP nextLoc;
244
245         /* Sanity Check and Parse Inputs */
246         /* TODO: Need to find a way to account for nullness in these.  For now, all checking is done on the front-end. */
247 //      if(!isVector(matList)) Rf_error ("matList must be a list");
248 //      if(!isVector(algList)) Rf_error ("algList must be a list");
249
250         omxManageProtectInsanity protectManager;
251
252         FitContext::setRFitFunction(NULL);
253         Global = new omxGlobal;
254
255         /* Create new omxState for current state storage and initialize it. */
256         globalState = new omxState;
257         omxInitState(globalState);
258
259         readOpts(options, &Global->ciMaxIterations, &Global->numThreads, 
260                         &Global->analyticGradients);
261 #if HAS_NPSOL
262         omxSetNPSOLOpts(options);
263 #endif
264
265         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
266         omxProcessMxExpectationEntities(expectList);
267         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
268
269         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
270         omxProcessMxDataEntities(data);
271         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
272     
273         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
274         omxProcessMxMatrixEntities(matList);
275         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
276
277         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
278         std::vector<double> startingValues;
279         omxProcessFreeVarList(varList, &startingValues);
280         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
281
282         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
283         omxProcessMxAlgebraEntities(algList);
284         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
285
286         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
287         omxProcessMxFitFunction(algList);
288         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
289
290         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
291         omxProcessMxComputeEntities(computeList);
292         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
293
294         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
295         omxCompleteMxExpectationEntities();
296         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
297
298         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
299         omxCompleteMxFitFunction(algList);
300         if (isErrorRaised(globalState)) Rf_error(globalState->statusMsg);
301
302         // This is the chance to check for matrix
303         // conformability, etc.  Any Rf_errors encountered should
304         // be reported using R's Rf_error() function, not
305         // omxRaiseErrorf.
306
307         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
308         omxInitialMatrixAlgebraCompute();
309         omxResetStatus(globalState);
310
311         omxCompute *topCompute = NULL;
312         if (Global->computeList.size()) topCompute = Global->computeList[0];
313
314         /* Process Matrix and Algebra Population Function */
315         /*
316           Each matrix is a list containing a matrix and the other matrices/algebras that are
317           populated into it at each iteration.  The first element is already processed, above.
318           The rest of the list will be processed here.
319         */
320         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
321         for(int j = 0; j < Rf_length(matList); j++) {
322                 Rf_protect(nextLoc = VECTOR_ELT(matList, j));           // This is the matrix + populations
323                 omxProcessMatrixPopulationList(globalState->matrixList[j], nextLoc);
324         }
325
326         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
327         omxProcessConstraints(constraints);
328
329         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
330         omxProcessConfidenceIntervals(intervalList);
331
332         omxProcessCheckpointOptions(checkpointList);
333
334         for (size_t vg=0; vg < Global->freeGroup.size(); ++vg) {
335                 Global->freeGroup[vg]->cacheDependencies();
336         }
337
338         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
339         FitContext fc(startingValues);
340
341         if (topCompute && !isErrorRaised(globalState)) {
342                 topCompute->compute(&fc);
343         }
344
345         SEXP evaluations;
346         Rf_protect(evaluations = Rf_allocVector(REALSXP,2));
347
348         REAL(evaluations)[0] = globalState->computeCount;
349
350         if (topCompute && !isErrorRaised(globalState) && globalState->stale) {
351                 fc.copyParamToModel(globalState);
352         }
353
354         MxRList result;
355
356         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
357         omxExportResults(globalState, &result); 
358
359         REAL(evaluations)[1] = globalState->computeCount;
360
361         double optStatus = NA_REAL;
362         if (topCompute && !isErrorRaised(globalState)) {
363                 LocalComputeResult cResult;
364                 topCompute->collectResults(&fc, &cResult, &result);
365                 optStatus = topCompute->getOptimizerStatus();
366
367                 if (cResult.size()) {
368                         SEXP computes;
369                         Rf_protect(computes = Rf_allocVector(VECSXP, cResult.size() * 2));
370                         for (size_t cx=0; cx < cResult.size(); ++cx) {
371                                 std::pair<int, MxRList*> c1 = cResult[cx];
372                                 SET_VECTOR_ELT(computes, cx*2, Rf_ScalarInteger(c1.first));
373                                 SET_VECTOR_ELT(computes, cx*2+1, c1.second->asR());
374                                 delete c1.second;
375                         }
376                         result.push_back(std::make_pair(Rf_mkChar("computes"), computes));
377                 }
378
379                 if (fc.wanted & FF_COMPUTE_FIT) {
380                         result.push_back(std::make_pair(Rf_mkChar("fit"), Rf_ScalarReal(fc.fit)));
381                         result.push_back(std::make_pair(Rf_mkChar("Minus2LogLikelihood"), Rf_ScalarReal(fc.fit)));
382                 }
383                 if (fc.wanted & FF_COMPUTE_BESTFIT) {
384                         result.push_back(std::make_pair(Rf_mkChar("minimum"), Rf_ScalarReal(fc.fit)));
385                 }
386
387                 size_t numFree = Global->freeGroup[FREEVARGROUP_ALL]->vars.size();
388                 if (numFree) {
389                         // move other global reporting here TODO
390
391                         SEXP estimate;
392                         Rf_protect(estimate = Rf_allocVector(REALSXP, numFree));
393                         memcpy(REAL(estimate), fc.est, sizeof(double)*numFree);
394                         result.push_back(std::make_pair(Rf_mkChar("estimate"), estimate));
395
396                         if (fc.wanted & FF_COMPUTE_GRADIENT) {
397                                 SEXP Rgradient;
398                                 Rf_protect(Rgradient = Rf_allocVector(REALSXP, numFree));
399                                 memcpy(REAL(Rgradient), fc.grad, sizeof(double) * numFree);
400                                 result.push_back(std::make_pair(Rf_mkChar("gradient"), Rgradient));
401                         }
402                         if (fc.wanted & FF_COMPUTE_HESSIAN) {
403                                 SEXP Rhessian;
404                                 Rf_protect(Rhessian = Rf_allocMatrix(REALSXP, numFree, numFree));
405                                 memcpy(REAL(Rhessian), fc.hess, sizeof(double) * numFree * numFree);
406                                 result.push_back(std::make_pair(Rf_mkChar("hessian"), Rhessian));
407                         }
408                         if (fc.wanted & FF_COMPUTE_IHESSIAN) {
409                                 SEXP Rihessian;
410                                 Rf_protect(Rihessian = Rf_allocMatrix(REALSXP, numFree, numFree));
411                                 memcpy(REAL(Rihessian), fc.ihess, sizeof(double) * numFree * numFree);
412                                 result.push_back(std::make_pair(Rf_mkChar("ihessian"), Rihessian));
413                         }
414                         if (fc.stderrs) {
415                                 SEXP stdErrors;
416                                 Rf_protect(stdErrors = Rf_allocMatrix(REALSXP, numFree, 1));
417                                 memcpy(REAL(stdErrors), fc.stderrs, sizeof(double) * numFree);
418                                 result.push_back(std::make_pair(Rf_mkChar("standardErrors"), stdErrors));
419                         }
420                         if (fc.wanted & (FF_COMPUTE_HESSIAN | FF_COMPUTE_IHESSIAN)) {
421                                 result.push_back(std::make_pair(Rf_mkChar("infoDefinite"),
422                                                                 Rf_ScalarLogical(fc.infoDefinite)));
423                                 result.push_back(std::make_pair(Rf_mkChar("conditionNumber"),
424                                                                 Rf_ScalarReal(fc.infoCondNum)));
425                         }
426                 }
427         }
428
429         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
430         MxRList backwardCompatStatus;
431         backwardCompatStatus.push_back(std::make_pair(Rf_mkChar("code"), Rf_ScalarReal(optStatus)));
432         backwardCompatStatus.push_back(std::make_pair(Rf_mkChar("status"),
433                                                       Rf_ScalarInteger(-isErrorRaised(globalState))));
434
435         if (isErrorRaised(globalState)) {
436                 SEXP msg;
437                 Rf_protect(msg = Rf_allocVector(STRSXP, 1));
438                 SET_STRING_ELT(msg, 0, Rf_mkChar(globalState->statusMsg));
439                 result.push_back(std::make_pair(Rf_mkChar("error"), msg));
440                 backwardCompatStatus.push_back(std::make_pair(Rf_mkChar("statusMsg"), msg));
441         }
442
443         result.push_back(std::make_pair(Rf_mkChar("status"), backwardCompatStatus.asR()));
444         result.push_back(std::make_pair(Rf_mkChar("evaluations"), evaluations));
445
446         omxFreeState(globalState);
447         delete Global;
448
449         if(OMX_DEBUG) mxLog("Protect depth at line %d: %d", __LINE__, protectManager.getDepth());
450         return result.asR();
451 }
452
453 SEXP omxBackend(SEXP constraints, SEXP matList,
454                 SEXP varList, SEXP algList, SEXP expectList, SEXP computeList,
455                 SEXP data, SEXP intervalList, SEXP checkpointList, SEXP options)
456 {
457         try {
458                 return omxBackend2(constraints, matList,
459                                    varList, algList, expectList, computeList,
460                                    data, intervalList, checkpointList, options);
461         } catch( std::exception& __ex__ ) {
462                 exception_to_try_Rf_error( __ex__ );
463         } catch(...) {
464                 string_to_try_Rf_error( "c++ exception (unknown reason)" );
465         }
466 }
467