Fix compile errors
[openmx:openmx.git] / src / omxCsolnp.cpp
1 /*
2  *  Copyright 2007-2012 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 #include "omxState.h"
22 #include "omxNPSOLSpecific.h"
23 #include "omxMatrix.h"
24 #include "npsolWrap.h"
25 #include "omxImportFrontendState.h"
26 #include "subnp.h"
27
28 //#include "matrix.h"
29
30
31 /* NPSOL-related functions */
32 //************************* npsol ****************************//
33 //int solnp(Matrix solPars, double (*solFun)(Matrix),  Matrix solEqB,  Matrix (*solEqBFun)( Matrix),  Matrix (*solEqBStartFun)(Matrix),  Matrix solLB,  Matrix solUB,  Matrix solIneqUB,  Matrix solIneqLB,  Matrix solctrl, bool debugToggle);
34
35 //extern void F77_SUB(npoptn)(char* string, int length);
36
37 static omxMatrix *GLOB_fitMatrix;
38 static FitContext *GLOB_fc;
39
40 Matrix fillMatrix(int cols, int rows, double* array)
41 {
42     Matrix t = new_matrix(cols, rows);
43         int i,j;
44         for(i=0;i<rows;i++){
45                 for(j=0;j<cols;j++) {
46             printf("array is: \n");
47             printf("%2f", array[j]); putchar('\n');
48                         M(t,j,i)=array[j];
49                 }
50         }
51         return t;
52 }
53
54 //****** Objective Function *********//
55 double csolnpObjectiveFunction(Matrix myPars)
56 {
57     printf("myPars inside obj is: \n");
58     print(myPars); putchar('\n');
59     
60         unsigned short int checkpointNow = FALSE;
61     
62         if(OMX_DEBUG) {mxLog("Starting Objective Run.\n");}
63     
64         omxMatrix* fitMatrix = GLOB_fitMatrix;
65     printf("fitMatrix is: \n");
66     printf("%2f", fitMatrix->data[0]); putchar('\n');
67
68         omxResetStatus(globalState);                                            // Clear Error State recursively
69     printf("fitMatrix is: \n");
70     printf("%2f", fitMatrix->data[0]); putchar('\n');
71
72         /* Interruptible? */
73         R_CheckUserInterrupt();
74     /* This allows for abitrary repopulation of the free parameters.
75      * Typically, the default is for repopulateFun to be NULL,
76      * and then handleFreeVarList is invoked */
77     
78         GLOB_fc->copyParamToModel(globalState, myPars.t);
79
80                 omxFitFunctionCompute(fitMatrix->fitFunction, FF_COMPUTE_FIT, NULL);
81                 printf("fitMatrix inside important if is: \n");
82                 printf("%2f", fitMatrix->data[0]); putchar('\n');
83     
84                 int ign = 0; // remove TODO
85                 omxExamineFitOutput(globalState, fitMatrix, &ign);
86     
87     double *ObjectiveValue;
88     double doubleValue = 0.0;
89     ObjectiveValue = &doubleValue;
90         *ObjectiveValue = fitMatrix->data[0];
91         if(OMX_VERBOSE) {
92                 mxLog("Fit function value is: %.32f \n", fitMatrix->data[0]);
93         }
94     
95         if(OMX_DEBUG) { mxLog("-======================================================-\n"); }
96     
97         if(checkpointNow && globalState->numCheckpoints != 0) { // If it's a new major iteration
98                 omxSaveCheckpoint(myPars.t, *ObjectiveValue, FALSE);            // Check about saving a checkpoint
99         }
100     return *ObjectiveValue;
101     
102 }
103
104
105 /* Objective function for confidence interval limit finding.
106  * Replaces the standard objective function when finding confidence intervals. */
107
108 /* (Non)Linear Constraint Functions */
109 Matrix csolnpEqualityFunction(Matrix myPars)
110 {
111         int j, k, eq_n = 0;
112     int l = 0;
113     double EMPTY = -999999.0;
114     Matrix myEqBFun;
115     
116     mxLog("Starting csolnpEqualityFunction.\n");
117     printf("myPars is: \n");
118     print(myPars); putchar('\n');
119
120     GLOB_fc->copyParamToModel(globalState, myPars.t);
121
122     printf("myPars is: \n");
123     print(myPars); putchar('\n');
124         for(j = 0; j < globalState->numConstraints; j++) {
125                 if (globalState->conList[j].opCode == 1)
126         {
127             eq_n += globalState->conList[j].size;
128         }
129     }
130     
131     mxLog("no.of constraints is: %d.\n", globalState->numConstraints);
132     mxLog("neq is: %d.\n", eq_n);
133     
134     if (eq_n == 0)
135     {
136         myEqBFun = fill(1, 1, EMPTY);
137     }
138     else
139     {
140         myEqBFun = fill(eq_n, 1, EMPTY);
141         
142         for(j = 0; j < globalState->numConstraints; j++) {
143             if (globalState->conList[j].opCode == 1)
144             {   printf("result is: \n");
145                 printf("%2f", globalState->conList[j].result->data[0]); putchar('\n');
146                     omxRecompute(globalState->conList[j].result);                printf("%.16f", globalState->conList[j].result->data[0]);putchar('\n');
147                 printf("size is: \n");
148                 printf("%d", globalState->conList[j].size); putchar('\n');}
149                 for(k = 0; k < globalState->conList[j].size; k++){
150                     M(myEqBFun,l,0) = globalState->conList[j].result->data[k];
151                     l = l + 1;
152                 }
153         }
154     }
155     printf("myEqBFun is: \n");
156     print(myEqBFun); putchar('\n');
157     return myEqBFun;
158 }
159
160
161 Matrix csolnpIneqFun(Matrix myPars)
162 {
163         int j, k, ineq_n = 0;
164     int l = 0;
165     double EMPTY = -999999.0;
166     Matrix myIneqFun;
167     
168     mxLog("Starting csolnpIneqFun.\n");
169     GLOB_fc->copyParamToModel(globalState, myPars.t);
170     
171         for(j = 0; j < globalState->numConstraints; j++) {
172                 if ((globalState->conList[j].opCode == 0) || (globalState->conList[j].opCode == 2))
173         {
174             ineq_n += globalState->conList[j].size;
175         }
176     }
177     
178     mxLog("no.of constraints is: %d.\n", globalState->numConstraints);
179     mxLog("ineq_n is: %d.\n", ineq_n);
180     
181     if (ineq_n == 0)
182     {
183         myIneqFun = fill(1, 1, EMPTY);
184     }
185     else
186     {
187         myIneqFun = fill(ineq_n, 1, EMPTY);
188         
189         for(j = 0; j < globalState->numConstraints; j++) {
190             if ((globalState->conList[j].opCode == 0) || globalState->conList[j].opCode == 2)
191             {   omxRecompute(globalState->conList[j].result);}
192             for(k = 0; k < globalState->conList[j].size; k++){
193                 M(myIneqFun,l,0) = globalState->conList[j].result->data[k];
194                 l = l + 1;
195
196             }
197         }
198     }
199     
200     return myIneqFun;
201 }
202
203 void omxInvokeNPSOL(omxMatrix *fitMatrix, FitContext *fc)
204 {
205         GLOB_fitMatrix = fitMatrix;
206         GLOB_fc = fc;
207     
208     double *A=NULL, *bl=NULL, *bu=NULL, *c=NULL, *clambda=NULL, *w=NULL; //  *g, *R, *cJac,
209     
210     int k, ldA, ldJ, ldR, leniw, lenw, eq_n, ineq_n;
211     
212     double *cJac = NULL;    // Hessian (Approx) and Jacobian
213     
214     int *iw = NULL;
215     
216     int *istate = NULL;                 // Current state of constraints (0 = no, 1 = lower, 2 = upper, 3 = both (equality))
217     
218     int nctotl, nlinwid, nlnwid;    // Helpful side variables.
219     
220     int ncnln = globalState->ncnln;
221     int n = int(fc->varGroup->vars.size());
222     
223     double EMPTY = -999999.0;
224     int j;
225     
226    // for(j = 0; j < globalState->numConstraints; j++) {
227    //           if (globalState->conList[j].opCode == 1){ eq_n++;}
228   //  }
229     
230     Matrix solIneqLB;
231     Matrix solIneqUB;
232     Matrix solEqB;
233
234     Matrix myPars = fillMatrix(n, 1, fc->est);
235     
236     double (*solFun)(struct Matrix myPars);
237     solFun = &csolnpObjectiveFunction;
238
239     Matrix (*solEqBFun)(struct Matrix myPars);
240     solEqBFun = &csolnpEqualityFunction;
241     
242     Matrix (*solIneqFun)(struct Matrix myPars);
243     solIneqFun = &csolnpIneqFun;
244
245     
246         /* Set boundaries and widths. */
247         
248                /* Allocate arrays */
249         int i;
250         bl      = (double*) R_alloc ( n, sizeof ( double ) );
251         bu      = (double*) R_alloc (n, sizeof ( double ) );
252         for (i = 0; i < n; i++)
253         {
254             printf("bl is: \n");
255             printf("%2f", bl[i]); putchar('\n');
256         }
257         
258                 struct Matrix myControl = fill(6,1,(double)0.0);
259                 M(myControl,0,0) = 1.0;
260                 M(myControl,1,0) = 400.0;
261                 M(myControl,2,0) = 800.0;
262                 M(myControl,3,0) = 1.0e-7;
263                 M(myControl,4,0) = 1.0e-8;
264                 M(myControl,5,0) = 0.0;
265                 
266                 bool myDEBUG = false;
267         /* Set up actual run */
268     
269         /* needs treatment*/
270         if (ncnln == 0)
271         {
272             solIneqLB = fill(1, 1, EMPTY);
273             solIneqUB = fill(1, 1, EMPTY);
274             solEqB = fill(1, 1, EMPTY);
275         }
276         else{
277             int j;
278             int eqn;
279             for(j = 0; j < globalState->numConstraints; j++) {
280                 if (globalState->conList[j].opCode == 1)
281                 {
282                     eqn += globalState->conList[j].size;
283                 }
284             }
285             int nineqn = ncnln - eqn;
286             solIneqLB = fill(nineqn, 1, EMPTY);
287             solIneqUB = fill(nineqn, 1, EMPTY);
288             solEqB = fill(eqn, 1, EMPTY);
289         omxProcessConstraintsCsolnp(&solIneqLB, &solIneqUB, &solEqB);
290         printf("solIneqLB is: \n");
291         print(solIneqLB); putchar('\n');
292         printf("solIneqUB is: \n");
293         print(solIneqUB); putchar('\n');
294         printf("solEqB is: \n");
295         print(solEqB); putchar('\n');
296         }
297         omxSetupBoundsAndConstraints(fc->varGroup, bl, bu);
298         Matrix blvar = fillMatrix(n, 1, bl);
299                 Matrix buvar = fillMatrix(n, 1, bu);
300         
301         //Matrix blvar = fill(1, 1, EMPTY);
302         //Matrix buvar = fill(1, 1, EMPTY);
303         
304         /* Initialize Starting Values */
305         if(OMX_VERBOSE) {
306             mxLog("--------------------------\n");
307             mxLog("Starting Values (%d) are:\n", n);
308         }
309         for(k = 0; k < n; k++) {
310             if((M(myPars, k, 0) == 0.0)) {
311                 M(myPars, k, 0) += 0.1;
312             }
313             if(OMX_VERBOSE) { mxLog("%d: %f\n", k, M(myPars, k, 0)); }
314         }
315         if(OMX_DEBUG) {
316             mxLog("--------------------------\n");
317             mxLog("Setting up optimizer...");
318         }
319         
320         //Matrix myPars = fillMatrix(n, 1, x);
321         
322         /*  F77_CALL(npsol)
323          (   int *n,                 -- Number of variables
324          int *nclin,             -- Number of linear constraints
325          int *ncnln,             -- Number of nonlinear constraints
326          int *ldA,               -- Row dimension of A (Linear Constraints)
327          int *ldJ,               -- Row dimension of cJac (Jacobian)
328          int *ldR,               -- Row dimension of R (Hessian)
329          double *A,              -- Linear Constraints Array A (in Column-major order)
330          double *bl,             -- Lower Bounds Array (at least n + nclin + ncnln long)
331          double *bu,             -- Upper Bounds Array (at least n + nclin + ncnln long)
332          function funcon,        -- Nonlinear constraint function
333          function funobj,        -- Objective function
334          int *inform,            -- Used to report state.  Need not be initialized.
335          int *iter,              -- Used to report number of major iterations performed.  Need not be initialized.
336          int *istate,            -- Initial State.  Need not be initialized unless using Warm Start.
337          double *c,              -- Array of length ncnln.  Need not be initialized.  Reports nonlinear constraints at final iteration.
338          double *cJac,           -- Array of Row-length ldJ.  Unused if ncnln = 0. Generally need not be initialized.
339          double *clambda,        -- Array of length n+nclin+ncnln.  Need not be initialized unless using Warm Start. Reports final QP multipliers.
340          double *f,              -- Used to report final objective value.  Need not be initialized.
341          double *g,              -- Array of length n. Used to report final objective gradient.  Need not be initialized.
342          double *R,              -- Array of length ldR.  Need not be intialized unless using Warm Start.
343          double *x,              -- Array of length n.  Contains initial solution estimate.
344          int *iw,                -- Array of length leniw. Need not be initialized.  Provides workspace.
345          int *leniw,             -- Length of iw.  Must be at least 3n + nclin + ncnln.
346          double *w,              -- Array of length lenw. Need not be initialized.  Provides workspace.
347          int *lenw               -- Length of w.  Must be at least 2n^2 + n*nclin + 2*n*ncnln + 20*n + 11*nclin +21*ncnln
348          )
349          
350          bl, bu, istate, and clambda are all length n+nclin+ncnln.
351          First n elements refer to the vars, in order.
352          Next nclin elements refer to bounds on Ax
353          Last ncnln elements refer to bounds on c(x)
354          
355          All arrays must be in column-major order.
356          
357          */
358         
359         if(OMX_DEBUG) {
360             mxLog("Set.\n");
361         }
362         
363            /* if (globalState->numConstraints == 0)
364             {
365                 solIneqLB = fill(1,1,-999999.0);
366                 solIneqUB = fill(1,1,-999999.0);
367             }*/
368
369             // Matrix EqBFunValue = solEqBFun(myPars);
370             // Matrix EqBStartFunValue = solEqBStartFun(myPars);
371             if(OMX_DEBUG) { printf("myPars is: \n");
372                 print(myPars); putchar('\n');
373                 printf("3rd call is: \n");
374                 printf("%2f", solFun(myPars)); putchar('\n');
375                 printf("solEqB is: \n");
376                 print(solEqB); putchar('\n');
377                 printf("solEqBFun is: \n");
378                 print(solEqBFun(myPars)); putchar('\n');
379                 printf("solIneqFun is: \n");
380                 print(solIneqFun(myPars)); putchar('\n');
381                 printf("blvar is: \n");
382                 print(blvar); putchar('\n');
383                 printf("buvar is: \n");
384                 print(buvar); putchar('\n');
385                 printf("solIneqUB is: \n");
386                 print(solIneqUB); putchar('\n');
387                 printf("solIneqLB is: \n");
388                 print(solIneqLB); putchar('\n');
389             }
390         
391             myPars = solnp(myPars, solFun, solEqB, solEqBFun, solIneqFun, blvar, buvar, solIneqUB, solIneqLB, myControl, myDEBUG);
392         
393         if(OMX_DEBUG) {
394                 printf("myPars's final value is: \n");
395                 print(myPars);
396                 mxLog("Final Objective Value is: %f.\n", solFun(myPars)); 
397         }
398         
399         omxSaveCheckpoint(myPars.t, 0, TRUE); // TODO replace 0 with fit
400         
401         GLOB_fc->copyParamToModel(globalState, myPars.t);
402 }