Proper handling for an empty free.set
[openmx:openmx.git] / src / Compute.cpp
1 /*
2  *  Copyright 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 "omxDefines.h"
18 #include "Compute.h"
19 #include "omxState.h"
20 #include "omxExportBackendState.h"
21 #include "omxRFitFunction.h"
22
23 void FitContext::init()
24 {
25         size_t numParam = varGroup->vars.size();
26         fit = parent? parent->fit : 0;
27         est = new double[numParam];
28         grad = new double[numParam];
29         hess = new double[numParam * numParam];
30 }
31
32 FitContext::FitContext(std::vector<double> &startingValues)
33 {
34         parent = NULL;
35         varGroup = Global->freeGroup[0];
36         init();
37
38         size_t numParam = varGroup->vars.size();
39         if (startingValues.size() != numParam) error("mismatch");
40         memcpy(est, startingValues.data(), sizeof(double) * numParam);
41
42         for (size_t v1=0; v1 < numParam; v1++) {
43                 grad[v1] = nan("unset");
44                 for (size_t v2=0; v2 < numParam; v2++) {
45                         hess[v1 * numParam + v2] = nan("unset");
46                 }
47         }
48 }
49
50 // arg to control what to copy? usually don't want everything TODO
51 FitContext::FitContext(FitContext *parent, FreeVarGroup *varGroup)
52 {
53         this->parent = parent;
54         this->varGroup = varGroup;
55         init();
56
57         FreeVarGroup *src = parent->varGroup;
58         FreeVarGroup *dest = varGroup;
59         size_t svars = parent->varGroup->vars.size();
60         size_t dvars = varGroup->vars.size();
61         if (dvars == 0) return;
62
63         size_t d1 = 0;
64         for (size_t s1=0; s1 < src->vars.size(); ++s1) {
65                 if (src->vars[s1] != dest->vars[d1]) continue;
66                 est[d1] = parent->est[s1];
67                 grad[d1] = parent->grad[s1];
68
69                 size_t d2 = 0;
70                 for (size_t s2=0; s2 < src->vars.size(); ++s2) {
71                         if (src->vars[s2] != dest->vars[d2]) continue;
72                         hess[d1 * dvars + d2] = parent->hess[s1 * svars + s2];
73                         if (++d2 == dvars) break;
74                 }
75
76                 if (++d1 == dvars) break;
77         }
78         if (d1 != dvars) error("Parent free parameter group is not a superset");
79
80         // pda(parent->est, 1, svars);
81         // pda(est, 1, dvars);
82         // pda(parent->grad, 1, svars);
83         // pda(grad, 1, dvars);
84         // pda(parent->hess, svars, svars);
85         // pda(hess, dvars, dvars);
86 }
87
88 void FitContext::copyParamToModel(omxMatrix *mat)
89 { copyParamToModel(mat->currentState); }
90
91 void FitContext::copyParamToModel(omxMatrix *mat, double *at)
92 { copyParamToModel(mat->currentState, at); }
93
94 void FitContext::updateParentAndFree()
95 {
96         FreeVarGroup *src = varGroup;
97         FreeVarGroup *dest = parent->varGroup;
98         size_t svars = varGroup->vars.size();
99         size_t dvars = parent->varGroup->vars.size();
100
101         parent->fit = fit;
102
103         if (svars > 0) {
104                 size_t s1 = 0;
105                 for (size_t d1=0; d1 < dest->vars.size(); ++d1) {
106                         if (dest->vars[d1] != src->vars[s1]) continue;
107                         parent->est[d1] = est[s1];
108                         parent->grad[d1] = grad[s1];
109
110                         size_t s2 = 0;
111                         for (size_t d2=0; d2 < dest->vars.size(); ++d2) {
112                                 if (dest->vars[d2] != src->vars[s2]) continue;
113                                 parent->hess[d1 * dvars + d2] = hess[s1 * svars + s2];
114                                 if (++s2 == svars) break;
115                         }
116
117                         if (++s1 == svars) break;
118                 }
119         }
120         
121         // pda(est, 1, svars);
122         // pda(parent->est, 1, dvars);
123         // pda(grad, 1, svars);
124         // pda(parent->grad, 1, dvars);
125         // pda(hess, svars, svars);
126         // pda(parent->hess, dvars, dvars);
127
128         delete this;
129 }
130
131 void FitContext::log(const char *where, int what)
132 {
133         size_t count = varGroup->vars.size();
134         std::string buf(where);
135         buf += " ---\n";
136         if (what & FF_COMPUTE_FIT) buf += string_snprintf("fit: %.5f\n", fit);
137         if (what & FF_COMPUTE_ESTIMATE) {
138                 buf += string_snprintf("est %lu: c(", count);
139                 for (size_t vx=0; vx < count; ++vx) {
140                         buf += string_snprintf("%.5f", est[vx]);
141                         if (vx < count - 1) buf += ", ";
142                 }
143                 buf += ")\n";
144         }
145         if (what & FF_COMPUTE_GRADIENT) {
146                 buf += string_snprintf("grad %lu: c(", count);
147                 for (size_t vx=0; vx < count; ++vx) {
148                         buf += string_snprintf("%.5f", grad[vx]);
149                         if (vx < count - 1) buf += ", ";
150                 }
151                 buf += ")\n";
152         }
153         if (what & FF_COMPUTE_HESSIAN) {
154                 buf += string_snprintf("hess %lux%lu: c(", count, count);
155                 for (size_t v1=0; v1 < count; ++v1) {
156                         for (size_t v2=0; v2 < count; ++v2) {
157                                 buf += string_snprintf("%.5f", hess[v1 * count + v2]);
158                                 if (v1 < count-1 || v2 < count-1) buf += ", ";
159                         }
160                         buf += "\n";
161                 }
162                 buf += ")\n";
163         }
164         mxLogBig(buf);
165 }
166
167 void FitContext::fixHessianSymmetry()
168 {
169         size_t numParam = varGroup->vars.size();
170         for (size_t h1=1; h1 < numParam; h1++) {
171                 for (size_t h2=0; h2 < h1; h2++) {
172                         if (hess[h2 * numParam + h1] != 0) {
173                                 error("Hessian is not lower triangular");
174                         }
175                         hess[h2 * numParam + h1] = hess[h1 * numParam + h2];
176                 }
177         }
178 }
179
180 static void omxRepopulateRFitFunction(omxFitFunction* oo, double* x, int n)
181 {
182         omxRFitFunction* rFitFunction = (omxRFitFunction*)oo->argStruct;
183
184         SEXP theCall, estimate;
185
186         PROTECT(estimate = allocVector(REALSXP, n));
187         double *est = REAL(estimate);
188         for(int i = 0; i < n ; i++) {
189                 est[i] = x[i];
190         }
191
192         PROTECT(theCall = allocVector(LANGSXP, 4));
193
194         SETCAR(theCall, install("imxUpdateModelValues"));
195         SETCADR(theCall, rFitFunction->model);
196         SETCADDR(theCall, rFitFunction->flatModel);
197         SETCADDDR(theCall, estimate);
198
199         REPROTECT(rFitFunction->model = eval(theCall, R_GlobalEnv), rFitFunction->modelIndex);
200
201         UNPROTECT(2); // theCall, estimate
202 }
203
204 void FitContext::copyParamToModel(omxState* os)
205 {
206         copyParamToModel(os, est);
207 }
208
209 void FitContext::copyParamToModel(omxState* os, double *at)
210 {
211         size_t numParam = varGroup->vars.size();
212         if(OMX_DEBUG) {
213                 mxLog("Copying %lu free parameter estimates to model %p", numParam, os);
214         }
215
216         if(numParam == 0) return;
217
218         // Confidence Intervals & Hessian Calculation probe the parameter space
219         // near the best estimate. If stale, we need to restore the best estimate
220         // before returning results to the user.
221         os->stale = at != est;
222
223         os->computeCount++;
224
225         if(OMX_VERBOSE) {
226                 std::string buf;
227                 buf += string_snprintf("Call: %d.%d (%ld) ", os->majorIteration, os->minorIteration, os->computeCount);
228                 buf += ("Estimates: [");
229                 for(size_t k = 0; k < numParam; k++) {
230                         buf += string_snprintf(" %f", at[k]);
231                 }
232                 buf += ("]\n");
233                 mxLogBig(buf);
234         }
235
236         for(size_t k = 0; k < numParam; k++) {
237                 omxFreeVar* freeVar = varGroup->vars[k];
238                 for(size_t l = 0; l < freeVar->locations.size(); l++) {
239                         omxFreeVarLocation *loc = &freeVar->locations[l];
240                         omxMatrix *matrix = os->matrixList[loc->matrix];
241                         int row = loc->row;
242                         int col = loc->col;
243                         omxSetMatrixElement(matrix, row, col, at[k]);
244                         if(OMX_DEBUG) {
245                                 mxLog("Setting location (%d, %d) of matrix %d to value %f for var %lu",
246                                         row, col, loc->matrix, at[k], k);
247                         }
248                 }
249         }
250
251         if (RFitFunction) omxRepopulateRFitFunction(RFitFunction, at, numParam);
252
253         varGroup->markDirty(os);
254
255         if (!os->childList) return;
256
257         for(int i = 0; i < Global->numChildren; i++) {
258                 copyParamToModel(os->childList[i], at);
259         }
260 }
261
262 FitContext::~FitContext()
263 {
264         delete [] est;
265         delete [] grad;
266         delete [] hess;
267 }
268
269 omxFitFunction *FitContext::RFitFunction = NULL;
270
271 void FitContext::setRFitFunction(omxFitFunction *rff)
272 {
273         if (rff) {
274                 Global->numThreads = 1;
275                 if (RFitFunction) {
276                         error("You can only create 1 MxRFitFunction per independent model");
277                 }
278         }
279         RFitFunction = rff;
280 }
281
282 omxCompute::omxCompute()
283 {
284         varGroup = NULL;
285 }
286
287 omxCompute::~omxCompute()
288 {}
289
290 void omxCompute::initFromFrontend(SEXP rObj)
291 {
292         SEXP slotValue;
293         PROTECT(slotValue = GET_SLOT(rObj, install("id")));
294         if (length(slotValue) == 1) {
295                 int id = INTEGER(slotValue)[0];
296                 varGroup = Global->findVarGroup(id);
297         }
298
299         if (!varGroup) {
300                 if (!R_has_slot(rObj, install("free.set"))) {
301                         varGroup = Global->freeGroup[0];
302                 } else {
303                         PROTECT(slotValue = GET_SLOT(rObj, install("free.set")));
304                         if (length(slotValue) != 0) {
305                                 // it's a free.set with no free variables
306                                 varGroup = Global->findVarGroup(-1);
307                         } else {
308                                 varGroup = Global->freeGroup[0];
309                         }
310                 }
311         }
312 }
313
314 class omxComputeSequence : public omxCompute {
315         typedef omxCompute super;
316         std::vector< omxCompute* > clist;
317
318  public:
319         virtual void initFromFrontend(SEXP rObj);
320         virtual void compute(FitContext *fc);
321         virtual void reportResults(FitContext *fc, MxRList *out);
322         virtual double getOptimizerStatus();
323         virtual ~omxComputeSequence();
324 };
325
326 class omxComputeIterate : public omxCompute {
327         typedef omxCompute super;
328         std::vector< omxCompute* > clist;
329         int maxIter;
330         double tolerance;
331         int verbose;
332
333  public:
334         virtual void initFromFrontend(SEXP rObj);
335         virtual void compute(FitContext *fc);
336         virtual void reportResults(FitContext *fc, MxRList *out);
337         virtual double getOptimizerStatus();
338         virtual ~omxComputeIterate();
339 };
340
341 class omxComputeOnce : public omxCompute {
342         typedef omxCompute super;
343         std::vector< omxMatrix* > algebras;
344         std::vector< omxExpectation* > expectations;
345         bool adjustStart;
346         const char *context;
347         bool gradient;
348         bool hessian;
349
350  public:
351         virtual void initFromFrontend(SEXP rObj);
352         virtual void compute(FitContext *fc);
353         virtual void reportResults(FitContext *fc, MxRList *out);
354 };
355
356 static class omxCompute *newComputeSequence()
357 { return new omxComputeSequence(); }
358
359 static class omxCompute *newComputeIterate()
360 { return new omxComputeIterate(); }
361
362 static class omxCompute *newComputeOnce()
363 { return new omxComputeOnce(); }
364
365 struct omxComputeTableEntry {
366         char name[32];
367         omxCompute *(*ctor)();
368 };
369
370 static const struct omxComputeTableEntry omxComputeTable[] = {
371         {"MxComputeEstimatedHessian", &newComputeEstimatedHessian},
372         {"MxComputeGradientDescent", &newComputeGradientDescent},
373         {"MxComputeSequence", &newComputeSequence },
374         {"MxComputeIterate", &newComputeIterate },
375         {"MxComputeOnce", &newComputeOnce },
376         {"MxComputeNewtonRaphson", &newComputeNewtonRaphson},
377 };
378
379 omxCompute *omxNewCompute(omxState* os, const char *type)
380 {
381         omxCompute *got = NULL;
382
383         for (size_t fx=0; fx < OMX_STATIC_ARRAY_SIZE(omxComputeTable); fx++) {
384                 const struct omxComputeTableEntry *entry = omxComputeTable + fx;
385                 if(strcmp(type, entry->name) == 0) {
386                         got = entry->ctor();
387                         break;
388                 }
389         }
390
391         if (!got) error("Compute %s is not implemented", type);
392
393         return got;
394 }
395
396 void omxComputeSequence::initFromFrontend(SEXP rObj)
397 {
398         super::initFromFrontend(rObj);
399
400         SEXP slotValue;
401         PROTECT(slotValue = GET_SLOT(rObj, install("steps")));
402
403         for (int cx = 0; cx < length(slotValue); cx++) {
404                 SEXP step = VECTOR_ELT(slotValue, cx);
405                 SEXP s4class;
406                 PROTECT(s4class = STRING_ELT(getAttrib(step, install("class")), 0));
407                 omxCompute *compute = omxNewCompute(globalState, CHAR(s4class));
408                 compute->initFromFrontend(step);
409                 if (isErrorRaised(globalState)) break;
410                 clist.push_back(compute);
411         }
412 }
413
414 void omxComputeSequence::compute(FitContext *fc)
415 {
416         for (size_t cx=0; cx < clist.size(); ++cx) {
417                 FitContext *context = fc;
418                 if (fc->varGroup != clist[cx]->varGroup) {
419                         context = new FitContext(fc, clist[cx]->varGroup);
420                 }
421                 clist[cx]->compute(context);
422                 if (context != fc) context->updateParentAndFree();
423                 if (isErrorRaised(globalState)) break;
424         }
425 }
426
427 void omxComputeSequence::reportResults(FitContext *fc, MxRList *out)
428 {
429         // put this stuff in a new list?
430         // merge with Iterate TODO
431         for (size_t cx=0; cx < clist.size(); ++cx) {
432                 FitContext *context = fc;
433                 if (fc->varGroup != clist[cx]->varGroup) {
434                         context = new FitContext(fc, clist[cx]->varGroup);
435                 }
436                 clist[cx]->reportResults(context, out);
437                 if (context != fc) context->updateParentAndFree();
438                 if (isErrorRaised(globalState)) break;
439         }
440 }
441
442 double omxComputeSequence::getOptimizerStatus()
443 {
444         // for backward compatibility, not indended to work generally
445         for (size_t cx=0; cx < clist.size(); ++cx) {
446                 double got = clist[cx]->getOptimizerStatus();
447                 if (got != NA_REAL) return got;
448         }
449         return NA_REAL;
450 }
451
452 omxComputeSequence::~omxComputeSequence()
453 {
454         for (size_t cx=0; cx < clist.size(); ++cx) {
455                 delete clist[cx];
456         }
457 }
458
459 void omxComputeIterate::initFromFrontend(SEXP rObj)
460 {
461         SEXP slotValue;
462
463         super::initFromFrontend(rObj);
464
465         PROTECT(slotValue = GET_SLOT(rObj, install("maxIter")));
466         maxIter = INTEGER(slotValue)[0];
467
468         PROTECT(slotValue = GET_SLOT(rObj, install("tolerance")));
469         tolerance = REAL(slotValue)[0];
470         if (tolerance <= 0) error("tolerance must be positive");
471
472         PROTECT(slotValue = GET_SLOT(rObj, install("steps")));
473
474         for (int cx = 0; cx < length(slotValue); cx++) {
475                 SEXP step = VECTOR_ELT(slotValue, cx);
476                 SEXP s4class;
477                 PROTECT(s4class = STRING_ELT(getAttrib(step, install("class")), 0));
478                 omxCompute *compute = omxNewCompute(globalState, CHAR(s4class));
479                 compute->initFromFrontend(step);
480                 if (isErrorRaised(globalState)) break;
481                 clist.push_back(compute);
482         }
483
484         PROTECT(slotValue = GET_SLOT(rObj, install("verbose")));
485         verbose = asInteger(slotValue);
486 }
487
488 void omxComputeIterate::compute(FitContext *fc)
489 {
490         int iter = 0;
491         double prevFit = 0;
492         double change = tolerance * 10;
493         while (1) {
494                 for (size_t cx=0; cx < clist.size(); ++cx) {
495                         FitContext *context = fc;
496                         if (fc->varGroup != clist[cx]->varGroup) {
497                                 context = new FitContext(fc, clist[cx]->varGroup);
498                         }
499                         clist[cx]->compute(context);
500                         if (context != fc) context->updateParentAndFree();
501                         if (isErrorRaised(globalState)) break;
502                 }
503                 if (fc->fit == 0) {
504                         warning("Fit estimated at 0; something is wrong");
505                         break;
506                 }
507                 if (prevFit != 0) {
508                         change = prevFit - fc->fit;
509                         if (verbose) mxLog("fit %.9g change %.9g", fc->fit, change);
510                 }
511                 prevFit = fc->fit;
512                 if (isErrorRaised(globalState) || ++iter > maxIter || fabs(change) < tolerance) break;
513         }
514 }
515
516 void omxComputeIterate::reportResults(FitContext *fc, MxRList *out)
517 {
518         for (size_t cx=0; cx < clist.size(); ++cx) {
519                 FitContext *context = fc;
520                 if (fc->varGroup != clist[cx]->varGroup) {
521                         context = new FitContext(fc, clist[cx]->varGroup);
522                 }
523                 clist[cx]->reportResults(context, out);
524                 if (context != fc) context->updateParentAndFree();
525                 if (isErrorRaised(globalState)) break;
526         }
527 }
528
529 double omxComputeIterate::getOptimizerStatus()
530 {
531         // for backward compatibility, not indended to work generally
532         for (size_t cx=0; cx < clist.size(); ++cx) {
533                 double got = clist[cx]->getOptimizerStatus();
534                 if (got != NA_REAL) return got;
535         }
536         return NA_REAL;
537 }
538
539 omxComputeIterate::~omxComputeIterate()
540 {
541         for (size_t cx=0; cx < clist.size(); ++cx) {
542                 delete clist[cx];
543         }
544 }
545
546 void omxComputeOnce::initFromFrontend(SEXP rObj)
547 {
548         super::initFromFrontend(rObj);
549
550         SEXP slotValue;
551         PROTECT(slotValue = GET_SLOT(rObj, install("what")));
552         for (int wx=0; wx < length(slotValue); ++wx) {
553                 int objNum = INTEGER(slotValue)[wx];
554                 if (objNum >= 0) {
555                         omxMatrix *algebra = globalState->algebraList[objNum];
556                         if (algebra->fitFunction) {
557                                 setFreeVarGroup(algebra->fitFunction, varGroup);
558                                 omxCompleteFitFunction(algebra);
559                         }
560                         algebras.push_back(algebra);
561                 } else {
562                         omxExpectation *expectation = globalState->expectationList[~objNum];
563                         setFreeVarGroup(expectation, varGroup);
564                         omxCompleteExpectation(expectation);
565                         expectations.push_back(expectation);
566                 }
567         }
568
569         context = "";
570
571         PROTECT(slotValue = GET_SLOT(rObj, install("context")));
572         if (length(slotValue) == 0) {
573                 // OK
574         } else if (length(slotValue) == 1) {
575                 SEXP elem;
576                 PROTECT(elem = STRING_ELT(slotValue, 0));
577                 context = CHAR(elem);
578         }
579
580         PROTECT(slotValue = GET_SLOT(rObj, install("gradient")));
581         gradient = asLogical(slotValue);
582
583         PROTECT(slotValue = GET_SLOT(rObj, install("hessian")));
584         hessian = asLogical(slotValue);
585
586         if (algebras.size() == 1 && algebras[0]->fitFunction) {
587                 omxFitFunction *ff = algebras[0]->fitFunction;
588                 if (gradient && !ff->gradientAvailable) {
589                         error("Gradient requested but not available");
590                 }
591                 if (hessian && !ff->hessianAvailable) {
592                         error("Hessian requested but not available");
593                 }
594         }
595
596         PROTECT(slotValue = GET_SLOT(rObj, install("adjustStart")));
597         adjustStart = asLogical(slotValue);
598 }
599
600 void omxComputeOnce::compute(FitContext *fc)
601 {
602         if (algebras.size()) {
603                 int want = FF_COMPUTE_FIT;
604                 size_t numParam = fc->varGroup->vars.size();
605                 if (gradient) {
606                         want |= FF_COMPUTE_GRADIENT;
607                         OMXZERO(fc->grad, numParam);
608                 }
609                 if (hessian) {
610                         want |= FF_COMPUTE_HESSIAN;
611                         OMXZERO(fc->hess, numParam * numParam);
612                 }
613
614                 for (size_t wx=0; wx < algebras.size(); ++wx) {
615                         omxMatrix *algebra = algebras[wx];
616                         if (algebra->fitFunction) {
617                                 if (adjustStart) {
618                                         omxFitFunctionCompute(algebra->fitFunction, FF_COMPUTE_PREOPTIMIZE, fc);
619                                         fc->copyParamToModel(globalState);
620                                 }
621
622                                 omxFitFunctionCompute(algebra->fitFunction, want, fc);
623                                 fc->fit = algebra->data[0];
624                                 if (hessian) fc->fixHessianSymmetry();
625                         } else {
626                                 omxForceCompute(algebra);
627                         }
628                 }
629         } else if (expectations.size()) {
630                 for (size_t wx=0; wx < expectations.size(); ++wx) {
631                         omxExpectation *expectation = expectations[wx];
632                         omxExpectationCompute(expectation, context);
633                 }
634         }
635 }
636
637 void omxComputeOnce::reportResults(FitContext *fc, MxRList *out)
638 {
639         if (algebras.size()==0 || algebras[0]->fitFunction == NULL) return;
640
641         omxMatrix *algebra = algebras[0];
642
643         omxPopulateFitFunction(algebra, out);
644
645         out->push_back(std::make_pair(mkChar("minimum"), ScalarReal(fc->fit)));
646         out->push_back(std::make_pair(mkChar("Minus2LogLikelihood"), ScalarReal(fc->fit)));
647
648         size_t numFree = fc->varGroup->vars.size();
649         if (numFree) {
650                 SEXP estimate;
651                 PROTECT(estimate = allocVector(REALSXP, numFree));
652                 memcpy(REAL(estimate), fc->est, sizeof(double)*numFree);
653                 out->push_back(std::make_pair(mkChar("estimate"), estimate));
654
655                 if (gradient) {
656                         SEXP Rgradient;
657                         PROTECT(Rgradient = allocVector(REALSXP, numFree));
658                         memcpy(REAL(Rgradient), fc->grad, sizeof(double) * numFree);
659                         out->push_back(std::make_pair(mkChar("gradient"), Rgradient));
660                 }
661
662                 if (hessian) {
663                         SEXP Rhessian;
664                         PROTECT(Rhessian = allocMatrix(REALSXP, numFree, numFree));
665                         memcpy(REAL(Rhessian), fc->hess, sizeof(double) * numFree * numFree);
666                         out->push_back(std::make_pair(mkChar("hessian"), Rhessian));
667                 }
668         }
669 }