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