Revert "Store algebraList in std::vector"
[openmx:openmx.git] / src / omxImportFrontendState.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 "R.h"
18 #include <Rinternals.h>
19 #include <Rdefines.h>
20
21 #include <sys/stat.h>
22 #include <errno.h>
23
24 #include "omxDefines.h"
25 #include "omxState.h"
26 #include "omxGlobalState.h"
27 #include "omxNPSOLSpecific.h"
28
29 /* Outside R Functions */
30 static int isDir(const char *path);
31
32 int matchCaseInsensitive(const char *source, const char *target) {
33         return strcasecmp(source, target) == 0;
34 }
35
36 void omxProcessMxDataEntities(SEXP data) {
37         SEXP nextLoc;
38         if(OMX_DEBUG) { Rprintf("Processing %d data source(s).\n", length(data));}
39
40         for(int index = 0; index < length(data); index++) {
41                 PROTECT(nextLoc = VECTOR_ELT(data, index));                     // Retrieve the data object
42                 omxNewDataFromMxData(nextLoc, globalState);
43                 if(OMX_DEBUG) {
44                         Rprintf("Data initialized at 0x%0xd = (%d x %d).\n",
45                                 globalState->dataList[index], globalState->dataList[index]->rows, globalState->dataList[index]->cols);
46                 }
47         }
48 }
49
50 void omxProcessMxMatrixEntities(SEXP matList) {
51         if(OMX_DEBUG) { Rprintf("Processing %d matrix(ces).\n", length(matList));}
52         SEXP nextLoc, nextMat;
53         globalState->matrixList.clear();
54         SEXP matListNames = getAttrib(matList, R_NamesSymbol);
55
56         for(int index = 0; index < length(matList); index++) {
57                 PROTECT(nextLoc = VECTOR_ELT(matList, index));          // This is the matrix + populations
58                 PROTECT(nextMat = VECTOR_ELT(nextLoc, 0));              // The first element of the list is the matrix of values
59                 omxMatrix *mat = omxNewMatrixFromRPrimitive(nextMat, globalState, 1, -index - 1);
60                 globalState->matrixList.push_back(mat);
61                 globalState->matrixList[index]->name = CHAR(STRING_ELT(matListNames, index));
62                 if(OMX_DEBUG) {
63                         Rprintf("Matrix initialized at 0x%0xd = (%d x %d).\n",
64                                 globalState->matrixList[index], globalState->matrixList[index]->rows, globalState->matrixList[index]->cols);
65                 }
66                 if(globalState->statusCode < 0) {
67                         error("%s", globalState->statusMsg);
68                 }
69         }
70 }
71
72 void omxProcessMxAlgebraEntities(SEXP algList) {
73         SEXP nextAlgTuple;
74         SEXP algListNames = getAttrib(algList, R_NamesSymbol);
75
76         if(OMX_DEBUG) { Rprintf("Processing %d algebras.\n", globalState->numAlgs); }
77         globalState->algebraList = (omxMatrix**) R_alloc(globalState->numAlgs, sizeof(omxMatrix*));
78
79         for(int index = 0; index < globalState->numAlgs; index++) {
80                 globalState->algebraList[index] = omxInitMatrix(NULL, 0, 0, TRUE, globalState);
81         }
82
83         for(int index = 0; index < globalState->numAlgs; index++) {
84                 PROTECT(nextAlgTuple = VECTOR_ELT(algList, index));             // The next algebra or fit function to process
85                 if(OMX_DEBUG) { Rprintf("Initializing algebra %d at location 0x%0x.\n", index, globalState->algebraList + index); }
86                 if(IS_S4_OBJECT(nextAlgTuple)) {
87                         // delay until expectations are ready
88                 } else {                                                                // This is an algebra spec.
89                         SEXP initialValue, formula, dependencies;
90                         PROTECT(initialValue = VECTOR_ELT(nextAlgTuple, 0));
91                         omxFillMatrixFromRPrimitive(globalState->algebraList[index],
92                                 initialValue, globalState, 1, index);
93                         PROTECT(formula = VECTOR_ELT(nextAlgTuple, 1));
94                         omxFillMatrixFromMxAlgebra(globalState->algebraList[index],
95                                 formula, CHAR(STRING_ELT(algListNames, index)));
96                         PROTECT(dependencies = VECTOR_ELT(nextAlgTuple, 2));
97                 }
98                 if (globalState->statusMsg[0]) return;
99         }
100 }
101
102 void omxProcessMxFitFunction(SEXP algList)
103 {
104         SEXP nextAlgTuple;
105
106         for(int index = 0; index < globalState->numAlgs; index++) {
107                 PROTECT(nextAlgTuple = VECTOR_ELT(algList, index));             // The next algebra or fit function to process
108                 if(OMX_DEBUG) { Rprintf("Initializing fit %d at location 0x%0x.\n", index, globalState->algebraList + index); }
109                 if(IS_S4_OBJECT(nextAlgTuple)) {
110                         omxFillMatrixFromMxFitFunction(globalState->algebraList[index], nextAlgTuple,
111                                                        TRUE, index);
112                 }
113                 if (globalState->statusMsg[0]) return;
114         }
115 }
116
117 void omxProcessMxExpectationEntities(SEXP expList) {
118         if(OMX_DEBUG) { Rprintf("Initializing %d Model Expectation(s).\n", length(expList));}
119         SEXP nextExp;
120         globalState->numExpects = length(expList);
121         globalState->expectationList = (omxExpectation**) R_alloc(length(expList), sizeof(omxExpectation*));
122
123         for(int index = 0; index < length(expList); index++) {
124                 PROTECT(nextExp = VECTOR_ELT(expList, index));
125                 globalState->expectationList[index] = omxNewIncompleteExpectation(nextExp, index, globalState);
126                 if(OMX_DEBUG) {
127                         Rprintf("%s incomplete expectation set up at 0x%0xd.\n",
128                                 (globalState->expectationList[index]->expType
129                                         == NULL ? "Untyped" : globalState->expectationList[index]->expType),
130                                          globalState->expectationList[index]);
131                 }
132                 if(globalState->statusCode < 0) {
133                         error("%s", globalState->statusMsg);
134                 }
135         }
136 }
137
138
139 void omxCompleteMxExpectationEntities() {
140         if(OMX_DEBUG) { Rprintf("Completing %d Model Expectation(s).\n", globalState->numExpects);}
141         
142         for(int index = 0; index < globalState->numExpects; index++) {
143                 omxCompleteExpectation(globalState->expectationList[index]);
144                 if(OMX_DEBUG) {
145                         Rprintf("%s expectation completed at 0x%0xd.\n",
146                                 (globalState->expectationList[index]->expType
147                                         == NULL ? "Untyped" : globalState->expectationList[index]->expType),
148                                          globalState->expectationList[index]);
149                 }
150                 if(globalState->statusCode < 0) {
151                         error("%s", globalState->statusMsg);
152                 }
153         }
154 }
155
156
157 void omxInitialMatrixAlgebraCompute() {
158         size_t numMats = globalState->matrixList.size();
159         int numAlgs = globalState->numAlgs;
160
161         if(OMX_DEBUG) {Rprintf("Completed Algebras and Matrices.  Beginning Initial Compute.\n");}
162         omxStateNextEvaluation(globalState);
163
164         for(size_t index = 0; index < numMats; index++) {
165                 omxRecompute(globalState->matrixList[index]);
166         }
167
168         for(int index = 0; index < numAlgs; index++) {
169                 omxRecompute(globalState->algebraList[index]);
170         }
171 }
172
173 /*
174 checkpointList is a list().  Each element refers to one checkpointing request.
175 Each interval request is a list of length 5.
176 The first element is an integer that specifies type: 0 = file, 1 = socket, 2=R_connection
177 For a file, the next two are the directory(string)  and file name (string).
178 For a socket, they are server (string) and port number (int).
179 For a connection, the next one is the R_connection SEXP object.
180 After that is an integer <type> specifier.  0 means minutes, 1 means iterations.
181 The last element is an integer count, indicating the number of <type>s per checkpoint.
182 */
183 void omxProcessCheckpointOptions(SEXP checkpointList) {
184         if(OMX_VERBOSE) { Rprintf("Processing Checkpoint Requests.\n");}
185         globalState->numCheckpoints = length(checkpointList);
186         if(OMX_DEBUG) {Rprintf("Found %d checkpoints.\n", globalState->numCheckpoints); }
187         globalState->checkpointList = (omxCheckpoint*) R_alloc(globalState->numCheckpoints, sizeof(omxCheckpoint));
188         SEXP nextLoc;
189
190         for(int index = 0; index < globalState->numCheckpoints; index++) {
191                 omxCheckpoint *oC = &(globalState->checkpointList[index]);
192
193                 /* Initialize Checkpoint object */
194                 oC->file = NULL;
195                 oC->connection = NULL;
196                 oC->time = 0;
197                 oC->numIterations = 0;
198                 oC->lastCheckpoint = 0;
199
200                 const char *pathName, *fileName;
201                 const char __attribute__((unused)) *serverName;
202
203                 PROTECT(nextLoc = VECTOR_ELT(checkpointList, index));
204                 int next = 0;
205                 oC->type = (omxCheckpointType) INTEGER(VECTOR_ELT(nextLoc, next++))[0];
206                 switch(oC->type) {
207                 case OMX_FILE_CHECKPOINT:{
208                         pathName = CHAR(STRING_ELT(VECTOR_ELT(nextLoc, next++), 0));                    // FIXME: Might need PROTECT()ion
209                         fileName = CHAR(STRING_ELT(VECTOR_ELT(nextLoc, next++), 0));
210                         char sep ='/';
211
212                         if(!isDir(pathName)) {
213                                 error("Unable to open directory %s for checkpoint storage.\n", pathName);
214                         }
215
216                         char* fullname = Calloc(strlen(pathName) + strlen(fileName) + 5, char);
217                         sprintf(fullname, "%s%c%s", pathName, sep, fileName);
218                         if(OMX_VERBOSE) { Rprintf("Opening File: %s\n", fullname); }
219                         oC->file = fopen(fullname, "w");
220                         if(!oC->file) {
221                                 error("Unable to open file %s for checkpoint storage: %s.\n", fullname, strerror(errno));
222                         }
223                         Free(fullname);
224                         oC->saveHessian = FALSE;        // TODO: Decide if this should be true.
225                         break;}
226
227                 case OMX_CONNECTION_CHECKPOINT:{        // NYI :::DEBUG:::
228                         oC->connection = VECTOR_ELT(nextLoc, next++);
229                         Rprintf("Warning NYI: Socket checkpoints Not Yet Implemented.\n");
230                         oC->saveHessian = FALSE;
231                         break;}
232                 }
233
234                 int isCount = INTEGER(VECTOR_ELT(nextLoc, next++))[0];
235                 if(isCount) {
236                         oC->numIterations = INTEGER(AS_INTEGER(VECTOR_ELT(nextLoc, next++)))[0];
237                 } else {
238                         oC->time = REAL(AS_NUMERIC(VECTOR_ELT(nextLoc, next++)))[0] * 60;       // Constrained to seconds.
239                         if(oC->time < 1) oC->time = 1;                                                                          // Constrained to at least one.
240                 }
241         }
242 }
243
244 /*
245 varList is a list().  Each element of this list corresponds to one free parameter.
246 Each free parameter is a list.  The first element of this list is the lower bound.
247 The second element of the list is the upper bound.  The third element of the list
248 is a vector of mxIndices specifying the dependencies of the free parameter. 
249 The remaining elements of the list are 3-tuples.  These 3-tuples are (mxIndex, row, col).
250 */
251 void omxProcessFreeVarList(SEXP varList) {
252         int n = globalState->numFreeParams = length(varList);
253         SEXP nextVar, nextLoc;
254         if(OMX_VERBOSE) { Rprintf("Processing Free Parameters.\n"); }
255         globalState->freeVarList = new omxFreeVar[n];
256         for(int freeVarIndex = 0; freeVarIndex < n; freeVarIndex++) {
257                 int numDeps;
258                 PROTECT(nextVar = VECTOR_ELT(varList, freeVarIndex));
259                 int numLocs = length(nextVar) - 3;
260                 globalState->freeVarList[freeVarIndex].name = CHAR(STRING_ELT(GET_NAMES(varList), freeVarIndex));
261
262                 /* Lower Bound */
263                 PROTECT(nextLoc = VECTOR_ELT(nextVar, 0));                                                      // Position 0 is lower bound.
264                 globalState->freeVarList[freeVarIndex].lbound = REAL(nextLoc)[0];
265                 if(ISNA(globalState->freeVarList[freeVarIndex].lbound)) globalState->freeVarList[freeVarIndex].lbound = NEG_INF;
266                 if(globalState->freeVarList[freeVarIndex].lbound == 0.0) globalState->freeVarList[freeVarIndex].lbound = 0.0;
267
268                 /* Upper Bound */
269                 PROTECT(nextLoc = VECTOR_ELT(nextVar, 1));                                                      // Position 1 is upper bound.
270                 globalState->freeVarList[freeVarIndex].ubound = REAL(nextLoc)[0];
271                 if(ISNA(globalState->freeVarList[freeVarIndex].ubound)) globalState->freeVarList[freeVarIndex].ubound = INF;
272                 if(globalState->freeVarList[freeVarIndex].ubound == 0.0) globalState->freeVarList[freeVarIndex].ubound = -0.0;
273
274                 PROTECT(nextLoc = VECTOR_ELT(nextVar, 2));                                                      // Position 2 is a vector of dependencies.
275                 numDeps = LENGTH(nextLoc);
276                 globalState->freeVarList[freeVarIndex].numDeps = numDeps;
277                 globalState->freeVarList[freeVarIndex].deps = (int*) R_alloc(numDeps, sizeof(int));
278                 for(int i = 0; i < numDeps; i++) {
279                         globalState->freeVarList[freeVarIndex].deps[i] = INTEGER(nextLoc)[i];
280                 }
281
282                 if(OMX_DEBUG) { 
283                         Rprintf("Free parameter %d bounded (%f, %f): %d locations\n", freeVarIndex, 
284                                 globalState->freeVarList[freeVarIndex].lbound, 
285                                 globalState->freeVarList[freeVarIndex].ubound, numLocs);
286                 }
287                 for(int locIndex = 0; locIndex < numLocs; locIndex++) {
288                         PROTECT(nextLoc = VECTOR_ELT(nextVar, locIndex+3));
289                         int* theVarList = INTEGER(nextLoc);                     // These come through as integers.
290
291                         omxFreeVarLocation loc;
292                         loc.matrix = theVarList[0];
293                         loc.row = theVarList[1];
294                         loc.col = theVarList[2];
295
296                         globalState->freeVarList[freeVarIndex].locations.push_back(loc);
297                 }
298         }
299
300 }
301
302 /*
303         intervalList is a list().  Each element refers to one confidence interval request.
304         Each interval request is a length 5 vector of REAL.
305         The first three elements are the matrixPointer, Row, and Column of the element
306         for which bounds are to be calculated, and are cast to ints here for speed.
307         The last two are the upper and lower boundaries for the confidence space (respectively).
308 */
309 void omxProcessConfidenceIntervals(SEXP intervalList)  {
310         SEXP nextVar;
311         if(OMX_VERBOSE) { Rprintf("Processing Confidence Interval Requests.\n");}
312         globalState->numIntervals = length(intervalList);
313         if(OMX_DEBUG) {Rprintf("Found %d requests.\n", globalState->numIntervals); }
314         globalState->intervalList = (omxConfidenceInterval*) R_alloc(globalState->numIntervals, sizeof(omxConfidenceInterval));
315         for(int index = 0; index < globalState->numIntervals; index++) {
316                 omxConfidenceInterval *oCI = &(globalState->intervalList[index]);
317                 PROTECT(nextVar = VECTOR_ELT(intervalList, index));
318                 double* intervalInfo = REAL(nextVar);
319                 oCI->matrix = omxMatrixLookupFromState1( nextVar, globalState); // Expects an R object
320                 oCI->row = (int) intervalInfo[1];               // Cast to int in C to save memory/Protection ops
321                 oCI->col = (int) intervalInfo[2];               // Cast to int in C to save memory/Protection ops
322                 oCI->lbound = intervalInfo[3];
323                 oCI->ubound = intervalInfo[4];
324                 oCI->max = R_NaReal;                                    // NAs, in case something goes wrong
325                 oCI->min = R_NaReal;
326         }
327         if(OMX_VERBOSE) { Rprintf("Processed.\n"); }
328         if(OMX_DEBUG) { Rprintf("%d intervals requested.\n", globalState->numIntervals); }
329 }
330
331 void omxProcessConstraints(SEXP constraints)  {
332         int ncnln = 0; 
333         if(OMX_VERBOSE) { Rprintf("Processing Constraints.\n");}
334         omxMatrix *arg1, *arg2;
335         SEXP nextVar, nextLoc;
336         globalState->numConstraints = length(constraints);
337         if(OMX_DEBUG) {Rprintf("Found %d constraints.\n", globalState->numConstraints); }
338         globalState->conList = (omxConstraint*) R_alloc(globalState->numConstraints, sizeof(omxConstraint));
339         ncnln = 0;
340         for(int constraintIndex = 0; constraintIndex < globalState->numConstraints; constraintIndex++) {
341                 PROTECT(nextVar = VECTOR_ELT(constraints, constraintIndex));
342                 PROTECT(nextLoc = VECTOR_ELT(nextVar, 0));
343                 arg1 = omxMatrixLookupFromState1(nextLoc, globalState);
344                 PROTECT(nextLoc = VECTOR_ELT(nextVar, 1));
345                 arg2 = omxMatrixLookupFromState1(nextLoc, globalState);
346                 PROTECT(nextLoc = AS_INTEGER(VECTOR_ELT(nextVar, 2)));
347                 globalState->conList[constraintIndex].opCode = INTEGER(nextLoc)[0];
348                 omxMatrix *args[2] = {arg1, arg2};
349                 globalState->conList[constraintIndex].result = omxNewAlgebraFromOperatorAndArgs(10, args, 2, globalState); // 10 = binary subtract
350                 omxRecompute(globalState->conList[constraintIndex].result);
351                 int nrows = globalState->conList[constraintIndex].result->rows;
352                 int ncols = globalState->conList[constraintIndex].result->cols;
353                 globalState->conList[constraintIndex].size = nrows * ncols;
354                 ncnln += globalState->conList[constraintIndex].size;
355         }
356         if(OMX_VERBOSE) { Rprintf("Processed.\n"); }
357         if(OMX_DEBUG) { Rprintf("%d effective constraints.\n", ncnln); }
358         globalState->ncnln = ncnln;
359         globalState->nclin = 0;
360 }
361
362 void omxSetupBoundsAndConstraints(double * bl, double * bu, int n, int nclin) {
363         /* Set min and max limits */
364         for(int index = 0; index < n; index++) {
365                 bl[index] = globalState->freeVarList[index].lbound;                             // -Infinity'd be -10^20.
366                 bu[index] = globalState->freeVarList[index].ubound;                             // Infinity would be at 10^20.
367         }
368
369         for(int index = n; index < n+nclin; index++) {                                          // At present, nclin == 0.
370                 bl[index] = NEG_INF;                                                    // Linear constraints have no bounds.
371                 bu[index] = INF;                                                                // Because there are no linear constraints.
372         }                                                                                                   // But if there were, they would go here.
373
374         int index = n + nclin;
375         for(int constraintIndex = 0; constraintIndex < globalState->numConstraints; constraintIndex++) {                // Nonlinear constraints:
376                 if(OMX_DEBUG) { Rprintf("Constraint %d: ", constraintIndex);}
377                 switch(globalState->conList[constraintIndex].opCode) {
378                 case 0:                                                                 // Less than: Must be strictly less than 0.
379                         if(OMX_DEBUG) { Rprintf("Bounded at (-INF, 0).\n");}
380                         for(int offset = 0; offset < globalState->conList[constraintIndex].size; offset++) {
381                                 bl[index] = NEG_INF;
382                                 bu[index] = -0.0;
383                                 index++;
384                         }
385                         break;
386                 case 1:                                                                 // Equal: Must be roughly equal to 0.
387                         if(OMX_DEBUG) { Rprintf("Bounded at (-0, 0).\n");}
388                         for(int offset = 0; offset < globalState->conList[constraintIndex].size; offset++) {
389                                 bl[index] = -0.0;
390                                 bu[index] = 0.0;
391                                 index++;
392                         }
393                         break;
394                 case 2:                                                                 // Greater than: Must be strictly greater than 0.
395                         if(OMX_DEBUG) { Rprintf("Bounded at (0, INF).\n");}
396                         for(int offset = 0; offset < globalState->conList[constraintIndex].size; offset++) {
397                                 if(OMX_DEBUG) { Rprintf("\tBounds set for constraint %d.%d.\n", constraintIndex, offset);}
398                                 bl[index] = 0.0;
399                                 bu[index] = INF;
400                                 index++;
401                         }
402                         break;
403                 default:
404                         if(OMX_DEBUG) { Rprintf("Bounded at (-INF, INF).\n");}
405                         for(int offset = 0; offset < globalState->conList[constraintIndex].size; offset++) {
406                                 bl[index] = NEG_INF;
407                                 bu[index] = INF;
408                                 index++;
409                         }
410                         break;
411                 }
412         }
413 }
414
415 /*
416 *  Acknowledgement:
417 *  This function is duplicated from the function of the same name in the R source code.
418 *  The function appears in src/main/sysutils.c
419 *  Thanks to Michael Spiegel for finding it.
420 *  This code is licensed under the terms of the GNU General Public License.
421 */
422 static int isDir(const char *path)
423 {
424     struct stat sb;
425     int isdir = 0;
426     if(!path) return 0;
427     if(stat(path, &sb) == 0) {
428         isdir = (sb.st_mode & S_IFDIR) > 0; /* is a directory */
429         /* We want to know if the directory is writable by this user,
430            which mode does not tell us */
431         isdir &= (access(path, W_OK) == 0);
432     }
433     return isdir;
434 }
435