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