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