Switch to C++
[openmx:openmx.git] / src / omxNPSOLSpecific.cpp
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 #include <ctype.h>
18 #include <R.h>
19 #include <Rinternals.h>
20 #include <Rdefines.h>
21
22 #include "omxState.h"
23 #include "omxGlobalState.h"
24 #include "omxNPSOLSpecific.h"
25 #include "omxOptimizer.h"
26 #include "omxMatrix.h"
27 #include "npsolWrap.h"
28 #include "omxImportFrontendState.h"
29
30 /* NPSOL-specific globals */
31 const double NPSOL_BIGBND = 1e20;
32 const double NEG_INF = -2e20;
33 const double INF = 2e20;
34
35 const char* anonMatrix = "anonymous matrix";
36
37 #ifdef  __cplusplus
38 extern "C" {
39 #endif
40
41 /* NPSOL-related functions */
42 extern void F77_SUB(npsol)(int *n, int *nclin, int *ncnln, int *ldA, int *ldJ, int *ldR, double *A,
43                             double *bl, double *bu, void* funcon, void* funobj, int *inform, int *iter, 
44                             int *istate, double *c, double *cJac, double *clambda, double *f, double *g, double *R,
45                             double *x, int *iw, int *leniw, double *w, int *lenw);
46 extern void F77_SUB(npoptn)(char* string, int length);
47
48 #ifdef  __cplusplus
49 }
50 #endif
51
52 /****** Objective Function *********/
53 void F77_SUB(npsolObjectiveFunction)
54         (       int* mode, int* n, double* x,
55                 double* f, double* g, int* nstate )
56 {
57         unsigned short int checkpointNow = FALSE;
58
59         if(OMX_DEBUG) {Rprintf("Starting Objective Run.\n");}
60
61         if(*mode == 1) {
62                 omxSetMajorIteration(globalState, globalState->majorIteration + 1);
63                 omxSetMinorIteration(globalState, 0);
64                 checkpointNow = TRUE;                                   // Only checkpoint at major iterations.
65         } else omxSetMinorIteration(globalState, globalState->minorIteration + 1);
66
67         omxMatrix* fitMatrix = globalState->fitMatrix;
68         omxResetStatus(globalState);                                            // Clear Error State recursively
69         /* Interruptible? */
70         R_CheckUserInterrupt();
71     /* This allows for abitrary repopulation of the free parameters.
72      * Typically, the default is for repopulateFun to be NULL,
73      * and then handleFreeVarList is invoked */
74
75         if (fitMatrix->fitFunction->repopulateFun != NULL) {
76                 fitMatrix->fitFunction->repopulateFun(fitMatrix->fitFunction, x, *n);
77         } else {
78                 handleFreeVarList(globalState, x, *n);
79         }
80
81         if (*mode > 0 && globalState->analyticGradients && globalState->currentInterval < 0) {
82                 omxFitFunctionCompute(fitMatrix->fitFunction, FF_COMPUTE_FIT|FF_COMPUTE_GRADIENT, g);
83         } else {
84                 omxFitFunctionCompute(fitMatrix->fitFunction, FF_COMPUTE_FIT, NULL);
85         }
86
87         omxExamineFitOutput(globalState, fitMatrix, mode);
88
89         if(globalState->statusCode <= -1) {             // At some point, we'll add others
90                 if(OMX_DEBUG) {
91                         Rprintf("Error status reported.\n");
92                 }
93                 *mode = -1;
94         }
95
96         *f = fitMatrix->data[0];
97         if(OMX_VERBOSE) {
98                 Rprintf("Fit function value is: %f, Mode is %d.\n", fitMatrix->data[0], *mode);
99         }
100
101         if(OMX_DEBUG) { Rprintf("-======================================================-\n"); }
102
103         if(checkpointNow && globalState->numCheckpoints != 0) { // If it's a new major iteration
104                 omxSaveCheckpoint(globalState, x, f, FALSE);            // Check about saving a checkpoint
105         }
106
107 }
108
109 /* Objective function for confidence interval limit finding. 
110  * Replaces the standard objective function when finding confidence intervals. */
111 void F77_SUB(npsolLimitObjectiveFunction)
112         (       int* mode, int* n, double* x, double* f, double* g, int* nstate ) {
113                 
114                 if(OMX_VERBOSE) Rprintf("Calculating interval %d, %s boundary:", globalState->currentInterval, (globalState->intervalList[globalState->currentInterval].calcLower?"lower":"upper"));
115
116                 F77_CALL(npsolObjectiveFunction)(mode, n, x, f, g, nstate);     // Standard objective function call
117
118                 omxConfidenceInterval *oCI = &(globalState->intervalList[globalState->currentInterval]);
119                 
120                 omxRecompute(oCI->matrix);
121                 
122                 double CIElement = omxMatrixElement(oCI->matrix, oCI->row, oCI->col);
123
124                 if(OMX_DEBUG) {
125                         Rprintf("Finding Confidence Interval Likelihoods: lbound is %f, ubound is %f, estimate likelihood is %f, and element current value is %f.\n",
126                                 oCI->lbound, oCI->ubound, *f, CIElement);
127                 }
128
129                 /* Catch boundary-passing condition */
130                 if(isnan(CIElement) || isinf(CIElement)) {
131                         omxRaiseError(globalState, -1, 
132                                 "Confidence interval is in a range that is currently incalculable. Add constraints to keep the value in the region where it can be calculated.");
133                         *mode = -1;
134                         return;
135                 }
136
137                 if(oCI->calcLower) {
138                         double diff = oCI->lbound - *f;         // Offset - likelihood
139                         *f = diff * diff + CIElement;
140                                 // Minimize element for lower bound.
141                 } else {
142                         double diff = oCI->ubound - *f;                 // Offset - likelihood
143                         *f = diff * diff - CIElement;
144                                 // Maximize element for upper bound.
145                 }
146
147                 if(OMX_DEBUG) {
148                         Rprintf("Interval fit function in previous iteration was calculated to be %f.\n", *f);
149                 }
150 }
151
152 /* (Non)Linear Constraint Functions */
153 void F77_SUB(npsolConstraintFunction)
154         (       int *mode, int *ncnln, int *n,
155                 int *ldJ, int *needc, double *x,
156                 double *c, double *cJac, int *nstate)
157 {
158
159         if(OMX_DEBUG) { Rprintf("Constraint function called.\n");}
160
161         if(*mode==1) {
162                 if(OMX_DEBUG) {
163                         Rprintf("But only gradients requested.  Returning.\n");
164                         Rprintf("-=====================================================-\n");
165                 }
166
167                 return;
168         }
169
170         int j, k, l = 0;
171
172         handleFreeVarList(globalState, x, *n);
173
174         for(j = 0; j < globalState->numConstraints; j++) {
175                 omxRecompute(globalState->conList[j].result);
176                 if(OMX_VERBOSE) { omxPrint(globalState->conList[j].result, "Constraint evaluates as:"); }
177                 for(k = 0; k < globalState->conList[j].size; k++){
178                         c[l++] = globalState->conList[j].result->data[k];
179                 }
180         }
181
182         if(OMX_DEBUG) { Rprintf("-=======================================================-\n"); }
183
184         return;
185
186 }
187
188 void omxInvokeNPSOL(double *f, double *x, double *g, double *R, int disableOptimizer) {
189  
190     double *A=NULL, *bl=NULL, *bu=NULL, *c=NULL, *clambda=NULL, *w=NULL; //  *g, *R, *cJac,
191  
192     int k, ldA, ldJ, ldR, inform, iter, leniw, lenw; 
193  
194     double *cJac = NULL;    // Hessian (Approx) and Jacobian
195  
196     int *iw = NULL;
197  
198     int *istate = NULL;                 // Current state of constraints (0 = no, 1 = lower, 2 = upper, 3 = both (equality))
199  
200     int nctotl, nlinwid, nlnwid;    // Helpful side variables.
201  
202     int nclin = globalState->nclin;
203     int ncnln = globalState->ncnln;
204  
205     /* NPSOL Arguments */
206     void (*funcon)(int*, int*, int*, int*, int*, double*, double*, double*, int*);
207  
208     funcon = F77_SUB(npsolConstraintFunction);
209  
210     int n = globalState->numFreeParams;
211  
212     if(n == 0) {            // Special Case for the evaluation-only condition
213  
214         if(OMX_DEBUG) { Rprintf("No free parameters.  Avoiding Optimizer Entirely.\n"); }
215         int mode = 0, nstate = -1;
216         *f = 0;
217         x = NULL;
218         g = NULL;
219  
220         if(globalState->fitMatrix != NULL) {
221             F77_SUB(npsolObjectiveFunction)(&mode, &n, x, f, g, &nstate);
222         };
223         globalState->numIntervals = 0;  // No intervals if there's no free params
224         inform = 0;
225         iter = 0;
226  
227         for(int index = 0; index < globalState->numMats; index++) {
228             omxMarkDirty(globalState->matrixList[index]);
229         }
230         for(int index = 0; index < globalState->numAlgs; index++) {
231             omxMarkDirty(globalState->algebraList[index]);
232         }
233         omxStateNextEvaluation(globalState);    // Advance for a final evaluation.
234  
235     } else {
236  
237         /* Set boundaries and widths. */
238         if(nclin <= 0) {
239             nclin = 0;                  // This should never matter--nclin should always be non-negative.
240             nlinwid = 1;                // For memory allocation purposes, nlinwid > 0
241         } else {                        // nlinwid is  used to calculate ldA, and eventually the size of A.
242             nlinwid = nclin;
243         }
244  
245         if(ncnln <= 0) {
246             ncnln = 0;                  // This should never matter--ncnln should always be non-negative.
247             nlnwid = 1;                 // For memory allocation purposes nlnwid > 0
248         } else {                        // nlnwid is used to calculate ldJ, and eventually the size of J.
249             nlnwid = ncnln;
250         }
251  
252         nctotl = n + nlinwid + nlnwid;
253  
254         leniw = 3 * n + nclin + 2 * ncnln;
255         lenw = 2 * n * n + n * nclin + 2 * n * ncnln + 20 * n + 11 * nclin + 21 * ncnln;
256  
257         ldA = nlinwid;          // NPSOL specifies this should be either 1 or nclin, whichever is greater
258         ldJ = nlnwid;           // NPSOL specifies this should be either 1 or nclin, whichever is greater
259         ldR = n;                // TODO: Test alternative versions of the size of R to see what's best.
260  
261     /* Allocate arrays */
262         A       = (double*) R_alloc (ldA * n, sizeof ( double )  );
263         bl      = (double*) R_alloc ( nctotl, sizeof ( double ) );
264         bu      = (double*) R_alloc (nctotl, sizeof ( double ) );
265         c       = (double*) R_alloc (nlnwid, sizeof ( double ));
266         cJac    = (double*) R_alloc (ldJ * n, sizeof ( double ) );
267         clambda = (double*) R_alloc (nctotl, sizeof ( double )  );
268         w       = (double*) R_alloc (lenw, sizeof ( double ));
269         istate  = (int*) R_alloc (nctotl, sizeof ( int ) );
270         iw      = (int*) R_alloc (leniw, sizeof ( int ));
271  
272         /* Set up actual run */
273  
274         omxSetupBoundsAndConstraints(bl, bu, n, nclin);     
275  
276         /* Initialize Starting Values */
277         if(OMX_VERBOSE) {
278             Rprintf("--------------------------\n");
279             Rprintf("Starting Values (%d) are:\n", n);
280         }
281         for(k = 0; k < n; k++) {
282             if((x[k] == 0.0) && !disableOptimizer) {
283                 x[k] += 0.1;
284                 markFreeVarDependencies(globalState, k);
285             }
286             if(OMX_VERBOSE) { Rprintf("%d: %f\n", k, x[k]); }
287         }
288         if(OMX_DEBUG) {
289             Rprintf("--------------------------\n");
290             Rprintf("Setting up optimizer...");
291         }
292  
293     /*  F77_CALL(npsol)
294         (   int *n,                 -- Number of variables
295             int *nclin,             -- Number of linear constraints
296             int *ncnln,             -- Number of nonlinear constraints
297             int *ldA,               -- Row dimension of A (Linear Constraints)
298             int *ldJ,               -- Row dimension of cJac (Jacobian)
299             int *ldR,               -- Row dimension of R (Hessian)
300             double *A,              -- Linear Constraints Array A (in Column-major order)
301             double *bl,             -- Lower Bounds Array (at least n + nclin + ncnln long)
302             double *bu,             -- Upper Bounds Array (at least n + nclin + ncnln long)
303             function funcon,        -- Nonlinear constraint function
304             function funobj,        -- Objective function
305             int *inform,            -- Used to report state.  Need not be initialized.
306             int *iter,              -- Used to report number of major iterations performed.  Need not be initialized.
307             int *istate,            -- Initial State.  Need not be initialized unless using Warm Start.
308             double *c,              -- Array of length ncnln.  Need not be initialized.  Reports nonlinear constraints at final iteration.
309             double *cJac,           -- Array of Row-length ldJ.  Unused if ncnln = 0. Generally need not be initialized.
310             double *clambda,        -- Array of length n+nclin+ncnln.  Need not be initialized unless using Warm Start. Reports final QP multipliers.
311             double *f,              -- Used to report final objective value.  Need not be initialized.
312             double *g,              -- Array of length n. Used to report final objective gradient.  Need not be initialized.
313             double *R,              -- Array of length ldR.  Need not be intialized unless using Warm Start.
314             double *x,              -- Array of length n.  Contains initial solution estimate.
315             int *iw,                -- Array of length leniw. Need not be initialized.  Provides workspace.
316             int *leniw,             -- Length of iw.  Must be at least 3n + nclin + ncnln.
317             double *w,              -- Array of length lenw. Need not be initialized.  Provides workspace.
318             int *lenw               -- Length of w.  Must be at least 2n^2 + n*nclin + 2*n*ncnln + 20*n + 11*nclin +21*ncnln
319         )
320  
321         bl, bu, istate, and clambda are all length n+nclin+ncnln.
322             First n elements refer to the vars, in order.
323             Next nclin elements refer to bounds on Ax
324             Last ncnln elements refer to bounds on c(x)
325  
326         All arrays must be in column-major order.
327  
328         */
329  
330         if(OMX_DEBUG) {
331             Rprintf("Set.\n");
332         }
333  
334         if (disableOptimizer) {
335             int mode = 0, nstate = -1;      
336             if(globalState->fitMatrix != NULL) {
337                 F77_SUB(npsolObjectiveFunction)(&mode, &n, x, f, g, &nstate);
338             };
339  
340             inform = 0;
341             iter = 0;
342  
343             omxStateNextEvaluation(globalState);    // Advance for a final evaluation.      
344         } else {
345             F77_CALL(npsol)(&n, &nclin, &ncnln, &ldA, &ldJ, &ldR, A, bl, bu, (void*)funcon,
346                             (void*) F77_SUB(npsolObjectiveFunction), &inform, &iter, istate, c, cJac,
347                             clambda, f, g, R, x, iw, &leniw, w, &lenw);
348         }
349         if(OMX_DEBUG) { Rprintf("Final Objective Value is: %f.\n", *f); }
350  
351         omxSaveCheckpoint(globalState, x, f, TRUE);
352  
353         handleFreeVarList(globalState, x, n);
354         
355     } // END OF PERFORM OPTIMIZATION CASE
356  
357     globalState->inform = inform;
358     globalState->iter   = iter;
359  
360 }
361  
362  
363 void omxNPSOLConfidenceIntervals(double *f, double *x, double *g, double *R, int ciMaxIterations) {
364  
365     double *A=NULL, *bl=NULL, *bu=NULL, *c=NULL, *clambda=NULL, *w=NULL; //  *g, *R, *cJac,
366  
367     int ldA, ldJ, ldR, inform, iter, leniw, lenw; 
368  
369     double *cJac = NULL;    // Hessian (Approx) and Jacobian
370  
371     int *iw = NULL;
372  
373     int *istate = NULL;                 // Current state of constraints (0 = no, 1 = lower, 2 = upper, 3 = both (equality))
374  
375     int nctotl, nlinwid, nlnwid;    // Helpful side variables.
376  
377     int n = globalState->numFreeParams;
378     inform = globalState->inform;
379  
380     /* NPSOL Arguments */
381     void (*funcon)(int*, int*, int*, int*, int*, double*, double*, double*, int*);
382  
383     funcon = F77_SUB(npsolConstraintFunction);
384  
385     int nclin = globalState->nclin;
386     int ncnln = globalState->ncnln;
387  
388     /* Set boundaries and widths. */
389     if(nclin <= 0) {
390         nclin = 0;                  // This should never matter--nclin should always be non-negative.
391         nlinwid = 1;                // For memory allocation purposes, nlinwid > 0
392     } else {                        // nlinwid is  used to calculate ldA, and eventually the size of A.
393         nlinwid = nclin;
394     }
395  
396     if(ncnln <= 0) {
397         ncnln = 0;                  // This should never matter--ncnln should always be non-negative.
398         nlnwid = 1;                 // For memory allocation purposes nlnwid > 0
399     } else {                        // nlnwid is used to calculate ldJ, and eventually the size of J.
400         nlnwid = ncnln;
401     }
402  
403     nctotl = n + nlinwid + nlnwid;
404  
405     leniw = 3 * n + nclin + 2 * ncnln;
406     lenw = 2 * n * n + n * nclin + 2 * n * ncnln + 20 * n + 11 * nclin + 21 * ncnln;
407  
408     ldA = nlinwid;          // NPSOL specifies this should be either 1 or nclin, whichever is greater
409     ldJ = nlnwid;           // NPSOL specifies this should be either 1 or nclin, whichever is greater
410     ldR = n;                // TODO: Test alternative versions of the size of R to see what's best.
411  
412     /* Allocate arrays */
413     A       = (double*) R_alloc (ldA * n, sizeof ( double )  );
414     bl      = (double*) R_alloc ( nctotl, sizeof ( double ) );
415     bu      = (double*) R_alloc (nctotl, sizeof ( double ) );
416     c       = (double*) R_alloc (nlnwid, sizeof ( double ));
417     cJac    = (double*) R_alloc (ldJ * n, sizeof ( double ) );
418     clambda = (double*) R_alloc (nctotl, sizeof ( double )  );
419     w       = (double*) R_alloc (lenw, sizeof ( double ));
420     istate  = (int*) R_alloc (nctotl, sizeof ( int ) );
421     iw      = (int*) R_alloc (leniw, sizeof ( int ));
422  
423  
424     omxSetupBoundsAndConstraints(bl, bu, n, nclin);     
425  
426     if(inform == 0 || inform == 1 || inform == 6) {
427         if(OMX_DEBUG) { Rprintf("Calculating likelihood-based confidence intervals.\n"); }
428         globalState->optimizerState = (omxOptimizerState*) R_alloc(1, sizeof(omxOptimizerState));
429         for(int i = 0; i < globalState->numIntervals; i++) {
430
431                         omxConfidenceInterval *currentCI = &(globalState->intervalList[i]);
432
433                         int msgLength = 45;
434  
435                         if (currentCI->matrix->name == NULL) {
436                                 msgLength += strlen(anonMatrix);
437                         } else {
438                                 msgLength += strlen(currentCI->matrix->name);
439                         }
440             
441                         char *message = Calloc(msgLength, char);
442  
443                         if (currentCI->matrix->name == NULL) {
444                                 sprintf(message, "%s[%d, %d] begin lower interval",
445                                         anonMatrix, currentCI->row + 1, currentCI->col + 1);
446                         } else {
447                                 sprintf(message, "%s[%d, %d] begin lower interval",
448                                         currentCI->matrix->name, currentCI->row + 1, currentCI->col + 1);
449                         }
450  
451                         omxWriteCheckpointMessage(globalState, message);
452  
453             memcpy(x, globalState->optimalValues, n * sizeof(double)); // Reset to previous optimum
454             globalState->currentInterval = i;
455
456             currentCI->lbound += globalState->optimum;          // Convert from offsets to targets
457             currentCI->ubound += globalState->optimum;          // Convert from offsets to targets
458  
459             /* Set up for the lower bound */
460             inform = -1;
461             // Number of times to keep trying.
462             int cycles = ciMaxIterations;
463             double value = INF;
464             double objDiff = 1.e-4;     // TODO : Use function precision to determine CI jitter?
465             while(inform != 0 && cycles > 0) {
466                 /* Find lower limit */
467                 currentCI->calcLower = TRUE;
468                 F77_CALL(npsol)(&n, &nclin, &ncnln, &ldA, &ldJ, &ldR, A, bl, bu, (void*)funcon,
469                     (void*) F77_SUB(npsolLimitObjectiveFunction), &inform, &iter, istate, c, cJac,
470                     clambda, f, g, R, x, iw, &leniw, w, &lenw);
471  
472                 currentCI->lCode = inform;
473                 if(*f < value) {
474                     currentCI->min = omxMatrixElement(currentCI->matrix, currentCI->row, currentCI->col);
475                     value = *f;
476                                         omxSaveCheckpoint(globalState, x, f, TRUE);
477                 }
478  
479                 if(inform != 0 && OMX_DEBUG) {
480                     Rprintf("Calculation of lower interval %d failed: Bad inform value of %d\n",
481                             i, inform);
482                 }
483                 cycles--;
484                 if(inform != 0) {
485                     unsigned int jitter = TRUE;
486                     for(int j = 0; j < n; j++) {
487                         if(fabs(x[j] - globalState->optimalValues[j]) > objDiff) {
488                             jitter = FALSE;
489                             break;
490                         }
491                     }
492                     if(jitter) {
493                         for(int j = 0; j < n; j++) {
494                             x[j] = globalState->optimalValues[j] + objDiff;
495                         }
496                     }
497                 }
498             }
499  
500             if(OMX_DEBUG) { Rprintf("Found lower bound %d.  Seeking upper.\n", i); }
501             // TODO: Repopulate original optimizer state in between CI calculations
502
503                         if (currentCI->matrix->name == NULL) {
504                                 sprintf(message, "%s[%d, %d] begin upper interval", 
505                                         anonMatrix, currentCI->row + 1, currentCI->col + 1);
506                         } else {
507                                 sprintf(message, "%s[%d, %d] begin upper interval",
508                                         currentCI->matrix->name, currentCI->row + 1, currentCI->col + 1);
509                         }
510  
511                         omxWriteCheckpointMessage(globalState, message);
512  
513                         Free(message);
514  
515             memcpy(x, globalState->optimalValues, n * sizeof(double));
516  
517             /* Reset for the upper bound */
518             value = INF;
519             inform = -1;
520             cycles = ciMaxIterations;
521  
522             while(inform != 0 && cycles >= 0) {
523                 /* Find upper limit */
524                 currentCI->calcLower = FALSE;
525                 F77_CALL(npsol)(&n, &nclin, &ncnln, &ldA, &ldJ, &ldR, A, bl, bu, (void*)funcon,
526                                     (void*) F77_SUB(npsolLimitObjectiveFunction), &inform, &iter, istate, c, cJac,
527                                     clambda, f, g, R, x, iw, &leniw, w, &lenw);
528  
529                 currentCI->uCode = inform;
530                 if(*f < value) {
531                     currentCI->max = omxMatrixElement(currentCI->matrix, currentCI->row, currentCI->col);
532                     value = *f;
533                                         omxSaveCheckpoint(globalState, x, f, TRUE);
534                 }
535  
536                 if(inform != 0 && OMX_DEBUG) {
537                     Rprintf("Calculation of upper interval %d failed: Bad inform value of %d\n",
538                             i, inform);
539                 }
540                 cycles--;
541                 if(inform != 0) {
542                     unsigned int jitter = TRUE;
543                     for(int j = 0; j < n; j++) {
544                         if(fabs(x[j] - globalState->optimalValues[j]) > objDiff){
545                             jitter = FALSE;
546                             break;
547                         }
548                     }
549                     if(jitter) {
550                         for(int j = 0; j < n; j++) {
551                             x[j] = globalState->optimalValues[j] + objDiff;
552                         }
553                     }
554                 }
555             }
556             if(OMX_DEBUG) {Rprintf("Found Upper bound %d.\n", i);}
557         }
558     } else {
559         // Improper code. No intervals calculated.
560         // TODO: Throw a warning, allow force()
561         warning("Not calculating confidence intervals because of error status.");
562         if(OMX_DEBUG) {
563             Rprintf("Calculation of all intervals failed: Bad inform value of %d", inform);
564         }
565     }
566 }
567  
568 static void
569 friendlyStringToLogical(const char *key, const char *str, int *out)
570 {
571         int understood = FALSE;
572         int newVal;
573         if (matchCaseInsensitive(str, "Yes")) {
574                 understood = TRUE;
575                 newVal = 1;
576         } else if (matchCaseInsensitive(str, "No")) {
577                 understood = TRUE;
578                 newVal = 0;
579         } else if (isdigit(str[0]) && (atoi(str) == 1 || atoi(str) == 0)) {
580                 understood = TRUE;
581                 newVal = atoi(str);
582         }
583         if (!understood) {
584                 warning("Expecting 'Yes' or 'No' for '%s' but got '%s', ignoring", key, str);
585                 return;
586         }
587         if(OMX_DEBUG) { Rprintf("%s=%d\n", key, newVal); }
588         *out = newVal;
589 }
590
591 void omxSetNPSOLOpts(SEXP options, int *numHessians, int *calculateStdErrors, 
592         int *ciMaxIterations, int *disableOptimizer, int *numThreads,
593         int *analyticGradients, int numFreeParams) {
594
595                 char optionCharArray[250] = "";                 // For setting options
596                 int numOptions = length(options);
597                 SEXP optionNames;
598                 PROTECT(optionNames = GET_NAMES(options));
599                 for(int i = 0; i < numOptions; i++) {
600                         const char *nextOptionName = CHAR(STRING_ELT(optionNames, i));
601                         const char *nextOptionValue = STRING_VALUE(VECTOR_ELT(options, i));
602                         if(matchCaseInsensitive(nextOptionName, "Calculate Hessian")) {
603                                 if(OMX_DEBUG) { Rprintf("Found hessian option... Value: %s. ", nextOptionValue);};
604                                 if(!matchCaseInsensitive(nextOptionValue, "No")) {
605                                         if(OMX_DEBUG) { Rprintf("Enabling explicit hessian calculation.\n");}
606                                         if (numFreeParams > 0) {
607                                                 *numHessians = 1;
608                                         }
609                                 }
610                         } else if(matchCaseInsensitive(nextOptionName, "Standard Errors")) {
611                                 friendlyStringToLogical(nextOptionName, nextOptionValue, calculateStdErrors);
612                                 if (*calculateStdErrors == TRUE && numFreeParams > 0) {
613                                         *numHessians = 1;
614                                 }
615                         } else if(matchCaseInsensitive(nextOptionName, "CI Max Iterations")) {
616                                 int newvalue = atoi(nextOptionValue);
617                                 if (newvalue > 0) *ciMaxIterations = newvalue;
618                         } else if(matchCaseInsensitive(nextOptionName, "useOptimizer")) {
619                                 if(OMX_DEBUG) { Rprintf("Found useOptimizer option...");};      
620                                 if(matchCaseInsensitive(nextOptionValue, "No")) {
621                                         if(OMX_DEBUG) { Rprintf("Disabling optimization.\n");}
622                                         *disableOptimizer = 1;
623                                 }
624                         } else if(matchCaseInsensitive(nextOptionName, "Analytic Gradients")) {
625                                 friendlyStringToLogical(nextOptionName, nextOptionValue, analyticGradients);
626                         } else if(matchCaseInsensitive(nextOptionName, "Number of Threads")) {
627                                 *numThreads = atoi(nextOptionValue);
628                                 if(OMX_DEBUG) { Rprintf("Found Number of Threads option (# = %d)...\n", *numThreads);};
629                         } else {
630                                 sprintf(optionCharArray, "%s %s", nextOptionName, nextOptionValue);
631                                 F77_CALL(npoptn)(optionCharArray, strlen(optionCharArray));
632                                 if(OMX_DEBUG) { Rprintf("Option %s \n", optionCharArray); }
633                         }
634                 }
635                 UNPROTECT(1); // optionNames
636 }
637