Add option to checkpoint every evaluation
[openmx:openmx.git] / src / omxImportFrontendState.cpp
1 /*
2  *  Copyright 2007-2014 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 #define R_NO_REMAP
18 #include <R.h>
19 #include <Rinternals.h>
20
21 #include <sys/stat.h>
22 #include <errno.h>
23
24 #include "omxDefines.h"
25 #include "glue.h"
26 #include "omxState.h"
27 #include "omxNPSOLSpecific.h"
28 #include "Compute.h"
29
30 /* Outside R Functions */
31 static int isDir(const char *path);
32
33 int matchCaseInsensitive(const char *source, const char *target) {
34         return strcasecmp(source, target) == 0;
35 }
36
37 void omxProcessMxDataEntities(SEXP data) {
38         SEXP nextLoc;
39         if(OMX_DEBUG) { mxLog("Processing %d data source(s).", Rf_length(data));}
40
41         for(int index = 0; index < Rf_length(data); index++) {
42                 Rf_protect(nextLoc = VECTOR_ELT(data, index));                  // Retrieve the data object
43                 omxNewDataFromMxData(nextLoc);
44         }
45 }
46
47 void omxProcessMxMatrixEntities(SEXP matList) {
48         if(OMX_DEBUG) { mxLog("Processing %d matrix(ces).", Rf_length(matList));}
49         SEXP nextLoc, nextMat;
50         globalState->matrixList.clear();
51         SEXP matListNames = Rf_getAttrib(matList, R_NamesSymbol);
52
53         for(int index = 0; index < Rf_length(matList); index++) {
54                 omxManageProtectInsanity protectManager;
55                 Rf_protect(nextLoc = VECTOR_ELT(matList, index));               // This is the matrix + populations
56                 Rf_protect(nextMat = VECTOR_ELT(nextLoc, 0));           // The first element of the list is the matrix of values
57                 omxMatrix *mat = omxNewMatrixFromRPrimitive(nextMat, globalState, 1, -index - 1);
58                 mat->name = CHAR(STRING_ELT(matListNames, index));
59                 globalState->matrixList.push_back(mat);
60
61                 if(OMX_DEBUG) { omxPrintMatrix(mat, "Imported"); }
62
63                 if (isErrorRaised(globalState)) return;
64         }
65 }
66
67 void omxProcessMxAlgebraEntities(SEXP algList) {
68         SEXP nextAlgTuple;
69         SEXP algListNames = Rf_getAttrib(algList, R_NamesSymbol);
70
71         if(OMX_DEBUG) { mxLog("Processing %d algebras.", Rf_length(algList)); }
72
73         for(int index = 0; index < Rf_length(algList); index++) {
74                 globalState->algebraList.push_back(omxInitMatrix(0, 0, TRUE, globalState));
75         }
76
77         for(int index = 0; index < Rf_length(algList); index++) {
78                 omxManageProtectInsanity protectManager;
79                 Rf_protect(nextAlgTuple = VECTOR_ELT(algList, index));
80                 if(IS_S4_OBJECT(nextAlgTuple)) {
81                         // fitfunction, delay until expectations are ready
82                 } else {                                                                // This is an algebra spec.
83                         SEXP dimnames, formula;
84                         omxMatrix *amat = globalState->algebraList[index];
85                         Rf_protect(dimnames = VECTOR_ELT(nextAlgTuple, 0));
86                         omxFillMatrixFromRPrimitive(amat, NULL, globalState, 1, index);
87                         Rf_protect(formula = VECTOR_ELT(nextAlgTuple, 1));
88                         omxFillMatrixFromMxAlgebra(amat, formula, CHAR(STRING_ELT(algListNames, index)), dimnames);
89                         omxMarkDirty(amat);
90                 }
91                 if (isErrorRaised(globalState)) return;
92         }
93 }
94
95 void omxProcessMxFitFunction(SEXP algList)
96 {
97         SEXP nextAlgTuple;
98         SEXP algListNames = Rf_getAttrib(algList, R_NamesSymbol);
99
100         for(int index = 0; index < Rf_length(algList); index++) {
101                 Rf_protect(nextAlgTuple = VECTOR_ELT(algList, index));          // The next algebra or fit function to process
102                 if(IS_S4_OBJECT(nextAlgTuple)) {
103                         SEXP fitFunctionClass;
104                         Rf_protect(fitFunctionClass = STRING_ELT(Rf_getAttrib(nextAlgTuple, Rf_install("class")), 0));
105                         const char *fitType = CHAR(fitFunctionClass);
106                         omxMatrix *fm = globalState->algebraList[index];
107                         omxFillMatrixFromMxFitFunction(fm, fitType, index);
108                         fm->fitFunction->rObj = nextAlgTuple;
109                         fm->name = CHAR(STRING_ELT(algListNames, index));
110                         Rf_unprotect(1);        // fitFunctionClass
111                 }
112                 if (isErrorRaised(globalState)) return;
113                 Rf_unprotect(1); //nextAlgTuple
114         }
115 }
116
117 void omxCompleteMxFitFunction(SEXP algList)
118 {
119         SEXP nextAlgTuple;
120
121         for(int index = 0; index < Rf_length(algList); index++) {
122                 Rf_protect(nextAlgTuple = VECTOR_ELT(algList, index));             // The next algebra or fit function to process
123                 if(IS_S4_OBJECT(nextAlgTuple)) {
124                         omxMatrix *fm = globalState->algebraList[index];
125                         if (!fm->fitFunction->freeVarGroup) {
126                                 setFreeVarGroup(fm->fitFunction, Global->freeGroup[0]);
127                         }
128                         omxCompleteFitFunction(fm);
129                 }
130                 Rf_unprotect(1);
131         }
132 }
133
134 void omxProcessMxExpectationEntities(SEXP expList) {
135         if(OMX_DEBUG) { mxLog("Initializing %d Model Expectation(s).", Rf_length(expList));}
136         SEXP nextExp;
137         SEXP eNames = Rf_getAttrib(expList, R_NamesSymbol);
138
139         for(int index = 0; index < Rf_length(expList); index++) {
140                 Rf_protect(nextExp = VECTOR_ELT(expList, index));
141                 omxExpectation *ex = omxNewIncompleteExpectation(nextExp, index, globalState);
142                 ex->name = CHAR(STRING_ELT(eNames, index));
143                 globalState->expectationList.push_back(ex);
144                 if (isErrorRaised(globalState)) return;
145         }
146 }
147
148
149 void omxCompleteMxExpectationEntities() {
150         if(OMX_DEBUG) { mxLog("Completing %d Model Expectation(s).", (int) globalState->expectationList.size());}
151         
152         for(size_t index = 0; index < globalState->expectationList.size(); index++) {
153                 omxCompleteExpectation(globalState->expectationList[index]);
154                 if (isErrorRaised(globalState)) return;
155         }
156 }
157
158 void omxProcessMxComputeEntities(SEXP rObj)
159 {
160         if (Rf_isNull(rObj)) return;
161
162         SEXP s4class;
163         Rf_protect(s4class = STRING_ELT(Rf_getAttrib(rObj, Rf_install("class")), 0));
164         omxCompute *compute = omxNewCompute(globalState, CHAR(s4class));
165         compute->initFromFrontend(rObj);
166         Global->computeList.push_back(compute);
167 }
168
169 void omxInitialMatrixAlgebraCompute() {
170         size_t numMats = globalState->matrixList.size();
171         int numAlgs = globalState->algebraList.size();
172
173         if(OMX_DEBUG) {mxLog("Completed Algebras and Matrices.  Beginning Initial Compute.");}
174
175         for(size_t index = 0; index < numMats; index++) {
176                 omxRecompute(globalState->matrixList[index]);
177         }
178
179         for(int index = 0; index < numAlgs; index++) {
180                 omxMatrix *matrix = globalState->algebraList[index];
181                 omxInitialCompute(matrix);
182         }
183 }
184
185 /*
186 checkpointList is a list().  Each element refers to one checkpointing request.
187 Each interval request is a list of Rf_length 5.
188 The first element is an integer that specifies type: 0 = file, 1 = socket, 2=R_connection
189 For a file, the next two are the directory(string)  and file name (string).
190 For a socket, they are server (string) and port number (int).
191 For a connection, the next one is the R_connection SEXP object.
192 After that is an integer <type> specifier.  0 means minutes, 1 means iterations.
193 The last element is an integer count, indicating the number of <type>s per checkpoint.
194 */
195 void omxProcessCheckpointOptions(SEXP checkpointList)
196 {
197         if(OMX_DEBUG) {mxLog("Found %d checkpoints", Rf_length(checkpointList)); }
198
199         SEXP nextLoc;
200
201         for(int index = 0; index < Rf_length(checkpointList); ++index) {
202                 omxCheckpoint *oC = new omxCheckpoint;
203
204                 const char *pathName, *fileName;
205
206                 Rf_protect(nextLoc = VECTOR_ELT(checkpointList, index));
207                 int next = 0;
208                 oC->type = (omxCheckpointType) INTEGER(VECTOR_ELT(nextLoc, next++))[0];
209                 switch(oC->type) {
210                 case OMX_FILE_CHECKPOINT:{
211                         pathName = CHAR(STRING_ELT(VECTOR_ELT(nextLoc, next++), 0));
212                         fileName = CHAR(STRING_ELT(VECTOR_ELT(nextLoc, next++), 0));
213
214                         if(!isDir(pathName)) {
215                                 Rf_error("Unable to open directory %s for checkpoint storage.\n", pathName);
216                         }
217
218                         std::string fullname = string_snprintf("%s/%s", pathName, fileName);
219                         if(OMX_VERBOSE) { mxLog("Opening File: %s", fullname.c_str()); }
220                         oC->file = fopen(fullname.c_str(), "w");
221                         if(!oC->file) {
222                                 Rf_error("Unable to open file %s for checkpoint storage: %s.\n",
223                                          fullname.c_str(), strerror(errno));
224                         }
225                         break;}
226
227                 case OMX_CONNECTION_CHECKPOINT:{
228                         Rf_error("Warning NYI: Socket checkpoints Not Yet Implemented.\n");
229                         break;}
230                 }
231
232                 const char *units = CHAR(STRING_ELT(VECTOR_ELT(nextLoc, next++), 0));
233                 if (strEQ(units, "iterations")) {
234                         oC->iterPerCheckpoint = Rf_asInteger(VECTOR_ELT(nextLoc, next++));
235                 } else if (strEQ(units, "minutes")) {
236                         oC->timePerCheckpoint = Rf_asReal(VECTOR_ELT(nextLoc, next++)) * 60.0; // Constrained to seconds.
237                         if(oC->timePerCheckpoint < 1) oC->timePerCheckpoint = 1;
238                 } else if (strEQ(units, "evaluations")) {
239                         oC->evalsPerCheckpoint = Rf_asInteger(VECTOR_ELT(nextLoc, next++));
240                 } else {
241                         Rf_error("In 'Checkpoint Units' model option, '%s' not recognized", units);
242                 }
243                 Global->checkpointList.push_back(oC);
244         }
245 }
246
247 void omxProcessFreeVarList(SEXP varList, std::vector<double> *startingValues)
248 {
249         if(OMX_VERBOSE) { mxLog("Processing Free Parameters."); }
250
251         {
252                 FreeVarGroup *fvg = new FreeVarGroup;
253                 fvg->id.push_back(FREEVARGROUP_ALL);   // all variables
254                 Global->freeGroup.push_back(fvg);
255
256                 fvg = new FreeVarGroup;
257                 fvg->id.push_back(FREEVARGROUP_NONE);  // no variables
258                 Global->freeGroup.push_back(fvg);
259         }
260
261         SEXP nextVar, nextLoc;
262         int numVars = Rf_length(varList);
263         startingValues->resize(numVars);
264         for (int fx = 0; fx < numVars; fx++) {
265                 omxManageProtectInsanity mpi;
266
267                 omxFreeVar *fv = new omxFreeVar;
268                 // default group has free all variables
269                 Global->freeGroup[0]->vars.push_back(fv);
270
271                 fv->id = fx;
272                 fv->name = CHAR(Rf_asChar(STRING_ELT(Rf_getAttrib(varList, R_NamesSymbol), fx)));
273                 Rf_protect(nextVar = VECTOR_ELT(varList, fx));
274
275                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, 0));
276                 fv->lbound = REAL(nextLoc)[0];
277                 if (ISNA(fv->lbound)) fv->lbound = NEG_INF;
278                 if (fv->lbound == 0.0) fv->lbound = 0.0;
279
280                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, 1));
281                 fv->ubound = REAL(nextLoc)[0];
282                 if (ISNA(fv->ubound)) fv->ubound = INF;
283                 if (fv->ubound == 0.0) fv->ubound = -0.0;
284
285                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, 2));
286                 int groupCount = Rf_length(nextLoc);
287                 for (int gx=0; gx < groupCount; ++gx) {
288                         int group = INTEGER(nextLoc)[gx];
289                         if (group == 0) continue;
290                         Global->findOrCreateVarGroup(group)->vars.push_back(fv);
291                 }
292
293                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, 3));
294                 int numDeps = LENGTH(nextLoc);
295                 fv->numDeps = numDeps;
296                 fv->deps = (int*) R_alloc(numDeps, sizeof(int));
297                 for (int i = 0; i < numDeps; i++) {
298                         fv->deps[i] = INTEGER(nextLoc)[i];
299                 }
300
301                 int numLocs = Rf_length(nextVar) - 5;
302                 if(OMX_DEBUG) { 
303                         mxLog("Free parameter %d bounded (%f, %f): %d locations", fx, 
304                               fv->lbound, fv->ubound, numLocs);
305                 }
306                 for(int locIndex = 0; locIndex < numLocs; locIndex++) {
307                         Rf_protect(nextLoc = VECTOR_ELT(nextVar, locIndex+4));
308                         int* theVarList = INTEGER(nextLoc);
309
310                         omxFreeVarLocation loc;
311                         loc.matrix = theVarList[0];
312                         loc.row = theVarList[1];
313                         loc.col = theVarList[2];
314
315                         fv->locations.push_back(loc);
316                 }
317                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, Rf_length(nextVar)-1));
318                 double sv = REAL(nextLoc)[0];
319                 /*if (sv < fv->lbound) {
320                         Rf_warning("Moving starting value of parameter '%s' within bounds %f -> %f",
321                                 fv->name, sv, fv->lbound);
322                         sv = fv->lbound;
323                 } else if (sv > fv->ubound) {
324                         Rf_warning("Moving starting value of parameter '%s' within bounds %f -> %f",
325                                 fv->name, sv, fv->ubound);
326                         sv = fv->ubound;
327                 }*/
328                 (*startingValues)[fx] = sv;
329         }
330
331         Global->deduplicateVarGroups();
332 }
333
334 /*
335         intervalList is a list().  Each element refers to one confidence interval request.
336         Each interval request is a Rf_length 5 vector of REAL.
337         The first three elements are the matrixPointer, Row, and Column of the element
338         for which bounds are to be calculated, and are cast to ints here for speed.
339         The last two are the upper and lower boundaries for the confidence space (respectively).
340 */
341 void omxProcessConfidenceIntervals(SEXP intervalList)  {
342         SEXP nextVar;
343         if(OMX_VERBOSE) { mxLog("Processing Confidence Interval Requests.");}
344         Global->numIntervals = Rf_length(intervalList);
345         if(OMX_DEBUG) {mxLog("Found %d requests.", Global->numIntervals); }
346         Global->intervalList = (omxConfidenceInterval*) R_alloc(Global->numIntervals, sizeof(omxConfidenceInterval));
347         for(int index = 0; index < Global->numIntervals; index++) {
348                 omxConfidenceInterval *oCI = &(Global->intervalList[index]);
349                 Rf_protect(nextVar = VECTOR_ELT(intervalList, index));
350                 double* intervalInfo = REAL(nextVar);
351                 oCI->matrix = omxMatrixLookupFromState1( nextVar, globalState); // Expects an R object
352                 oCI->row = (int) intervalInfo[1];               // Cast to int in C to save memory/Protection ops
353                 oCI->col = (int) intervalInfo[2];               // Cast to int in C to save memory/Protection ops
354                 oCI->lbound = intervalInfo[3];
355                 oCI->ubound = intervalInfo[4];
356                 oCI->max = R_NaReal;                                    // NAs, in case something goes wrong
357                 oCI->min = R_NaReal;
358         }
359         if(OMX_VERBOSE) { mxLog("Processed."); }
360         if(OMX_DEBUG) { mxLog("%d intervals requested.", Global->numIntervals); }
361 }
362
363 void omxProcessConstraints(SEXP constraints)  {
364         int ncnln = 0; 
365         if(OMX_VERBOSE) { mxLog("Processing Constraints.");}
366         omxMatrix *arg1, *arg2;
367         SEXP nextVar, nextLoc;
368         globalState->numConstraints = Rf_length(constraints);
369         if(OMX_DEBUG) {mxLog("Found %d constraints.", globalState->numConstraints); }
370         globalState->conList = (omxConstraint*) R_alloc(globalState->numConstraints, sizeof(omxConstraint));
371         ncnln = 0;
372         for(int constraintIndex = 0; constraintIndex < globalState->numConstraints; constraintIndex++) {
373                 Rf_protect(nextVar = VECTOR_ELT(constraints, constraintIndex));
374                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, 0));
375                 arg1 = omxMatrixLookupFromState1(nextLoc, globalState);
376                 Rf_protect(nextLoc = VECTOR_ELT(nextVar, 1));
377                 arg2 = omxMatrixLookupFromState1(nextLoc, globalState);
378                 globalState->conList[constraintIndex].opCode = Rf_asInteger(VECTOR_ELT(nextVar, 2));
379                 omxMatrix *args[2] = {arg1, arg2};
380                 globalState->conList[constraintIndex].result = omxNewAlgebraFromOperatorAndArgs(10, args, 2, globalState); // 10 = binary subtract
381                 omxRecompute(globalState->conList[constraintIndex].result);
382                 int nrows = globalState->conList[constraintIndex].result->rows;
383                 int ncols = globalState->conList[constraintIndex].result->cols;
384                 globalState->conList[constraintIndex].size = nrows * ncols;
385                 ncnln += globalState->conList[constraintIndex].size;
386         }
387         if(OMX_VERBOSE) { mxLog("Processed."); }
388         if(OMX_DEBUG) { mxLog("%d effective constraints.", ncnln); }
389         globalState->ncnln = ncnln;
390 }
391
392 /*
393 *  Acknowledgement:
394 *  This function is duplicated from the function of the same name in the R source code.
395 *  The function appears in src/main/sysutils.c
396 *  Thanks to Michael Spiegel for finding it.
397 *  This code is licensed under the terms of the GNU General Public License.
398 */
399 static int isDir(const char *path)
400 {
401     struct stat sb;
402     int isdir = 0;
403     if(!path) return 0;
404     if(stat(path, &sb) == 0) {
405         isdir = (sb.st_mode & S_IFDIR) > 0; /* is a directory */
406         /* We want to know if the directory is writable by this user,
407            which mode does not tell us */
408         isdir &= (access(path, W_OK) == 0);
409     }
410     return isdir;
411 }
412