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