Checkpoint rewrite
[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 <algorithm>
18 #include <stdarg.h>
19
20 #include "Compute.h"
21 #include "Eigen/Cholesky"
22 #include "omxState.h"
23 #include "omxExportBackendState.h"
24 #include "omxRFitFunction.h"
25 #include "matrix.h"
26 #include "omxBuffer.h"
27 #include "omxState.h"
28
29 void pda(const double *ar, int rows, int cols);
30
31 // static bool compareBlocks(const HessianBlock*& lhs, const HessianBlock*& rhs)
32 // {
33 //      return lhs->vars[0] < rhs->vars[0];
34 // }
35
36 void FitContext::queue(HessianBlock *hb)
37 {
38         if (hb->vars.size() == 0) {
39                 delete hb;
40                 return;
41         }
42
43         allBlocks.push_back(hb);
44         //std::push_heap(allBlocks.begin(), allBlocks.end(), compareBlocks); // maybe TODO
45 }
46
47 void FitContext::negateHessian()
48 {
49         // this assumes that we haven't processed the blocks yet, need to check TODO
50         for (size_t bx=0; bx < allBlocks.size(); ++bx) {
51                 allBlocks[bx]->mat *= -1.0;
52         }
53 }
54
55 void FitContext::refreshDenseHess()
56 {
57         if (haveDenseHess) return;
58
59         hess.triangularView<Eigen::Upper>().setZero();
60
61         for (size_t bx=0; bx < allBlocks.size(); ++bx) {
62                 HessianBlock *hb = allBlocks[bx];
63
64                 std::vector<int> &map = hb->vars;
65                 size_t bsize = map.size();
66
67                 for (size_t v1=0; v1 < bsize; ++v1) {
68                         for (size_t v2=0; v2 <= v1; ++v2) {
69                                 hess(map[v2], map[v1]) += hb->mat(v2, v1);
70                         }
71                 }
72         }
73
74         haveDenseHess = true;
75 }
76
77 void FitContext::copyDenseHess(double *dest)
78 {
79         refreshDenseHess();
80         for (size_t v1=0; v1 < numParam; ++v1) {
81                 for (size_t v2=0; v2 <= v1; ++v2) {
82                         double coef = hess.selfadjointView<Eigen::Upper>()(v2,v1);
83                         if (v1==v2) {
84                                 dest[v1 * numParam + v2] = coef;
85                         } else {
86                                 dest[v1 * numParam + v2] = coef;
87                                 dest[v2 * numParam + v1] = coef;
88                         }
89                 }
90         }
91 }
92
93 double *FitContext::getDenseHessUninitialized()
94 {
95         // Assume the caller is going to fill it out
96         haveDenseHess = true;
97         haveDenseIHess = false;
98         return hess.data();
99 }
100
101 void FitContext::refreshDenseIHess()
102 {
103         if (haveDenseIHess) return;
104
105         refreshDenseHess();
106         ihess = hess;
107         Matrix wmat(ihess.data(), numParam, numParam);
108         InvertSymmetricIndef(wmat, 'U');
109
110         haveDenseIHess = true;
111 }
112
113 Eigen::VectorXd FitContext::ihessGradProd()
114 {
115         refreshDenseIHess();
116         return ihess.selfadjointView<Eigen::Upper>() * grad;
117 }
118
119 Eigen::VectorXd FitContext::ihessDiag()
120 {
121         refreshDenseIHess();
122         return ihess.diagonal();
123 }
124
125 double *FitContext::getDenseIHessUninitialized()
126 {
127         // Assume the caller is going to fill it out
128         haveDenseIHess = true;
129         haveDenseHess = false;
130         return ihess.data();
131 }
132
133 Eigen::MatrixXd &FitContext::getDenseIHess()
134 {
135         refreshDenseIHess();
136         return ihess;
137 }
138
139 void FitContext::copyDenseIHess(double *dest)
140 {
141         refreshDenseIHess();
142         for (size_t v1=0; v1 < numParam; ++v1) {
143                 for (size_t v2=0; v2 <= v1; ++v2) {
144                         double coef = ihess.selfadjointView<Eigen::Upper>()(v2,v1);
145                         if (v1==v2) {
146                                 dest[v1 * numParam + v2] = coef;
147                         } else {
148                                 dest[v1 * numParam + v2] = coef;
149                                 dest[v2 * numParam + v1] = coef;
150                         }
151                 }
152         }
153 }
154
155 double *FitContext::getDenseHessianish()
156 {
157         if (haveDenseHess) return hess.data();
158         if (haveDenseIHess) return ihess.data();
159         // try harder TODO
160         return NULL;
161 }
162
163 HessianBlock *HessianBlock::clone()
164 {
165         HessianBlock *hb = new HessianBlock;
166         hb->vars = vars;
167         hb->mat.resize(vars.size(), vars.size());
168         return hb;
169 }
170
171 bool HessianBlock::posDefinite()
172 {
173         Eigen::LLT<Eigen::MatrixXd> llt;
174         llt.compute(mat);
175         return llt.info() == Eigen::Success;
176 }
177
178 void FitContext::init()
179 {
180         numParam = varGroup->vars.size();
181         wanted = 0;
182         mac = parent? parent->mac : 0;
183         fit = parent? parent->fit : NA_REAL;
184         est = new double[numParam];
185         infoDefinite = NA_LOGICAL;
186         infoCondNum = NA_REAL;
187         infoA = NULL;
188         infoB = NULL;
189         stderrs = NULL;
190         inform = INFORM_UNINITIALIZED;
191         iterations = 0;
192
193         hess.resize(numParam, numParam);
194         ihess.resize(numParam, numParam);
195         clearHessian();
196 }
197
198 void FitContext::clearHessian()
199 {
200         for (size_t bx=0; bx < allBlocks.size(); ++bx) {
201                 delete allBlocks[bx];
202         }
203
204         allBlocks.clear();
205         haveSparseHess = false;
206         haveSparseIHess = false;
207         haveDenseHess = false;
208         haveDenseIHess = false;
209 }
210
211 void FitContext::allocStderrs()
212 {
213         if (stderrs) return;
214
215         size_t numParam = varGroup->vars.size();
216         stderrs = new double[numParam];
217
218         for (size_t px=0; px < numParam; ++px) {
219                 stderrs[px] = NA_REAL;
220         }
221 }
222
223 FitContext::FitContext(std::vector<double> &startingValues)
224 {
225         parent = NULL;
226         varGroup = Global->freeGroup[FREEVARGROUP_ALL];
227         init();
228
229         size_t numParam = varGroup->vars.size();
230         if (startingValues.size() != numParam) {
231                 Rf_error("Got %d starting values for %d parameters",
232                       startingValues.size(), numParam);
233         }
234         memcpy(est, startingValues.data(), sizeof(double) * numParam);
235 }
236
237 FitContext::FitContext(FitContext *parent, FreeVarGroup *varGroup)
238 {
239         this->parent = parent;
240         this->varGroup = varGroup;
241         init();
242
243         FreeVarGroup *src = parent->varGroup;
244         FreeVarGroup *dest = varGroup;
245         size_t dvars = varGroup->vars.size();
246         if (dvars == 0) return;
247         mapToParent.resize(dvars);
248
249         size_t d1 = 0;
250         for (size_t s1=0; s1 < src->vars.size(); ++s1) {
251                 if (src->vars[s1] != dest->vars[d1]) continue;
252                 mapToParent[d1] = s1;
253                 est[d1] = parent->est[s1];
254                 if (++d1 == dvars) break;
255         }
256         if (d1 != dvars) Rf_error("Parent free parameter group (id=%d) is not a superset of %d",
257                                src->id[0], dest->id[0]);
258
259         wanted = parent->wanted;
260         infoDefinite = parent->infoDefinite;
261         infoCondNum = parent->infoCondNum;
262         IterationError = parent->IterationError;
263         iterations = parent->iterations;
264 }
265
266 void FitContext::copyParamToModel(omxMatrix *mat)
267 { copyParamToModel(mat->currentState); }
268
269 void FitContext::copyParamToModel(omxMatrix *mat, double *at)
270 { copyParamToModel(mat->currentState, at); }
271
272 void FitContext::updateParent()
273 {
274         FreeVarGroup *src = varGroup;
275         FreeVarGroup *dest = parent->varGroup;
276         size_t svars = varGroup->vars.size();
277
278         parent->wanted |= wanted;
279         parent->fit = fit;
280         parent->IterationError = IterationError;
281         parent->mac = mac;
282         parent->infoDefinite = infoDefinite;
283         parent->infoCondNum = infoCondNum;
284         parent->iterations = iterations;
285
286         // rewrite using mapToParent TODO
287
288         if (svars > 0) {
289                 size_t s1 = 0;
290                 for (size_t d1=0; d1 < dest->vars.size(); ++d1) {
291                         if (dest->vars[d1] != src->vars[s1]) continue;
292                         parent->est[d1] = est[s1];
293                         if (++s1 == svars) break;
294                 }
295                 if (stderrs) {
296                         parent->allocStderrs();
297                         for (size_t s1=0; s1 < src->vars.size(); ++s1) {
298                                 parent->stderrs[mapToParent[s1]] = stderrs[s1];
299                         }
300                 }
301         }
302         
303         // pda(est, 1, svars);
304         // pda(parent->est, 1, dvars);
305 }
306
307 void FitContext::updateParentAndFree()
308 {
309         updateParent();
310         delete this;
311 }
312
313 void FitContext::log(int what)
314 {
315         size_t count = varGroup->vars.size();
316         std::string buf;
317         if (what & FF_COMPUTE_MAXABSCHANGE) buf += string_snprintf("MAC: %.5f\n", mac);
318         if (what & FF_COMPUTE_FIT) buf += string_snprintf("fit: %.5f (scale %f)\n", fit, Global->llScale);
319         if (what & FF_COMPUTE_ESTIMATE) {
320                 buf += string_snprintf("est %d: c(", (int) count);
321                 for (size_t vx=0; vx < count; ++vx) {
322                         buf += string_snprintf("%.5f", est[vx]);
323                         if (vx < count - 1) buf += ", ";
324                 }
325                 buf += ")\n";
326         }
327         mxLogBig(buf);
328 }
329
330 void FitContext::recordIterationError(const char* msg, ...)
331 {
332         // could record the parameter vector here for a better error message TODO
333         va_list ap;
334         va_start(ap, msg);
335         std::string str = string_vsnprintf(msg, ap);
336         va_end(ap);
337
338 #pragma omp critical(IterationError)
339         IterationError = str;
340 }
341
342 std::string FitContext::getIterationError()
343 {
344         return IterationError;
345 }
346
347 static void _fixSymmetry(const char *name, double *mat, size_t numParam, bool force)
348 {
349         for (size_t h1=1; h1 < numParam; h1++) {
350                 for (size_t h2=0; h2 < h1; h2++) {
351                         if (!force && mat[h2 * numParam + h1] != 0) {
352                                 omxRaiseErrorf(globalState, "%s is not upper triangular", name);
353                                 break;
354                         }
355                         mat[h2 * numParam + h1] = mat[h1 * numParam + h2];
356                 }
357         }
358 }
359
360 static void omxRepopulateRFitFunction(omxFitFunction* oo, double* x, int n)
361 {
362         omxRFitFunction* rFitFunction = (omxRFitFunction*)oo->argStruct;
363
364         SEXP theCall, estimate;
365
366         Rf_protect(estimate = Rf_allocVector(REALSXP, n));
367         double *est = REAL(estimate);
368         for(int i = 0; i < n ; i++) {
369                 est[i] = x[i];
370         }
371
372         Rf_protect(theCall = Rf_allocVector(LANGSXP, 4));
373
374         SETCAR(theCall, Rf_install("imxUpdateModelValues"));
375         SETCADR(theCall, rFitFunction->model);
376         SETCADDR(theCall, rFitFunction->flatModel);
377         SETCADDDR(theCall, estimate);
378
379         R_Reprotect(rFitFunction->model = Rf_eval(theCall, R_GlobalEnv), rFitFunction->modelIndex);
380
381         Rf_unprotect(2); // theCall, estimate
382 }
383
384 void FitContext::copyParamToModel(omxState* os)
385 {
386         copyParamToModel(os, est);
387 }
388
389 void FitContext::copyParamToModel(omxState* os, double *at)
390 {
391         size_t numParam = varGroup->vars.size();
392
393         if(numParam == 0) return;
394
395         // Confidence Intervals & Hessian Calculation probe the parameter space
396         // near the best estimate. If stale, we need to restore the best estimate
397         // before returning results to the user.
398         os->stale = at != est;
399
400         os->computeCount++;
401
402         if(OMX_VERBOSE) {
403                 std::string buf;
404                 buf += string_snprintf("Call: %d (%d) ", iterations, (int) os->computeCount);
405                 buf += ("Estimates: [");
406                 for(size_t k = 0; k < numParam; k++) {
407                         buf += string_snprintf(" %f", at[k]);
408                 }
409                 buf += ("]\n");
410                 mxLogBig(buf);
411         }
412
413         for(size_t k = 0; k < numParam; k++) {
414                 omxFreeVar* freeVar = varGroup->vars[k];
415                 for(size_t l = 0; l < freeVar->locations.size(); l++) {
416                         omxFreeVarLocation *loc = &freeVar->locations[l];
417                         omxMatrix *matrix = os->matrixList[loc->matrix];
418                         int row = loc->row;
419                         int col = loc->col;
420                         omxSetMatrixElement(matrix, row, col, at[k]);
421                         if(OMX_DEBUG) {
422                                 mxLog("Setting location (%d, %d) of matrix %d to value %f for var %d",
423                                         row, col, loc->matrix, at[k], (int) k);
424                         }
425                 }
426         }
427
428         if (RFitFunction) omxRepopulateRFitFunction(RFitFunction, at, numParam);
429
430         varGroup->markDirty(os);
431
432         if (os->childList.size() == 0) return;
433
434         for(size_t i = 0; i < os->childList.size(); i++) {
435                 copyParamToModel(os->childList[i], at);
436         }
437 }
438
439 double *FitContext::take(int want)
440 {
441         if (!(want & (wanted | FF_COMPUTE_ESTIMATE))) {
442                 Rf_error("Attempt to take %d but not available", want);
443         }
444
445         double *ret = NULL;
446         switch(want) {
447         case FF_COMPUTE_ESTIMATE:
448                 ret = est;
449                 est = NULL;
450                 break;
451         default:
452                 Rf_error("Taking of %d is not implemented", want);
453         }
454         if (!ret) Rf_error("Attempt to take %d, already taken", want);
455         return ret;
456 }
457
458 // Rethink this whole design TODO
459 // If we compute things blockwise then most of this can go away?
460 void FitContext::preInfo()
461 {
462         size_t npsq = numParam * numParam;
463
464         if (!infoA) infoA = new double[npsq];
465         if (!infoB) infoB = new double[npsq];
466
467         switch (infoMethod) {
468         case INFO_METHOD_SANDWICH:
469         case INFO_METHOD_MEAT:
470                 OMXZERO(infoB, npsq);
471         case INFO_METHOD_BREAD:
472                 OMXZERO(infoA, npsq);
473                 break;
474         case INFO_METHOD_HESSIAN:
475                 clearHessian();
476                 break;
477         default:
478                 Rf_error("Unknown information matrix estimation method %d", infoMethod);
479         }
480 }
481
482 void FitContext::postInfo()
483 {
484         size_t numParam = varGroup->vars.size();
485         switch (infoMethod) {
486         case INFO_METHOD_SANDWICH:{
487                 // move into FCDeriv TODO
488                 omxBuffer<double> work(numParam * numParam);
489                 Matrix amat(infoA, numParam, numParam);
490                 InvertSymmetricIndef(amat, 'U');
491                 _fixSymmetry("InfoB", infoB, numParam, false);
492                 Matrix bmat(infoB, numParam, numParam);
493                 Matrix wmat(work.data(), numParam, numParam);
494                 Matrix hmat(getDenseIHessUninitialized(), numParam, numParam);
495                 SymMatrixMultiply('L', 'U', 1, 0, amat, bmat, wmat);
496                 SymMatrixMultiply('R', 'U', 1, 0, amat, wmat, hmat);
497                 wanted |= FF_COMPUTE_IHESSIAN;
498                 break;}
499         case INFO_METHOD_MEAT:{
500                 memcpy(getDenseHessUninitialized(), infoB, sizeof(double) * numParam * numParam); // avoid copy TODO
501                 wanted |= FF_COMPUTE_HESSIAN;
502                 break;}
503         case INFO_METHOD_BREAD:{
504                 memcpy(getDenseHessUninitialized(), infoA, sizeof(double) * numParam * numParam); // avoid copy TODO
505                 wanted |= FF_COMPUTE_HESSIAN;
506                 break;}
507         case INFO_METHOD_HESSIAN:
508                 if (Global->llScale > 0) negateHessian();
509                 wanted |= FF_COMPUTE_HESSIAN;
510                 break;
511         default:
512                 Rf_error("Unknown information matrix estimation method %d", infoMethod);
513         }
514 }
515
516 FitContext::~FitContext()
517 {
518         clearHessian();
519         if (est) delete [] est;
520         if (stderrs) delete [] stderrs;
521         if (infoA) delete [] infoA;
522         if (infoB) delete [] infoB;
523 }
524
525 omxFitFunction *FitContext::RFitFunction = NULL;
526
527 void FitContext::setRFitFunction(omxFitFunction *rff)
528 {
529         if (rff) {
530                 Global->numThreads = 1;
531                 if (RFitFunction) {
532                         Rf_error("You can only create 1 MxRFitFunction per independent model");
533                 }
534         }
535         RFitFunction = rff;
536 }
537
538 Ramsay1975::Ramsay1975(FitContext *fc, const char *flavor, int verbose, double minCaution) :
539         fc(fc), flavor(flavor), verbose(verbose), minCaution(minCaution)
540 {
541         if (!flavor) Rf_error("Ramsay: flavor cannot be NULL");
542
543         maxCaution = 0.0;
544         boundsHit = 0;
545         caution = 0;
546         highWatermark = std::max(0.5, caution);  // arbitrary guess
547
548         numParam = fc->varGroup->vars.size();
549         for (size_t px=0; px < numParam; ++px) {
550                 if (strcmp(fc->flavor[px], flavor) != 0) continue;
551                 vars.push_back(px);
552         }
553
554         prevAdj1.assign(numParam, 0);
555         prevAdj2.resize(numParam);
556         prevEst.resize(numParam);
557         memcpy(prevEst.data(), fc->est, sizeof(double) * numParam);
558
559         if (verbose >= 2) {
560                 mxLog("Ramsay[%10s]: %d parameters, caution %f, min caution %f",
561                       flavor, (int)vars.size(), caution, minCaution);
562         }
563 }
564
565 void Ramsay1975::recordEstimate(int px, double newEst)
566 {
567         omxFreeVar *fv = fc->varGroup->vars[px];
568         bool hitBound=false;
569         double param = newEst;
570         if (param < fv->lbound) {
571                 hitBound=true;
572                 param = prevEst[px] - (prevEst[px] - fv->lbound) / 2;
573         }
574         if (param > fv->ubound) {
575                 hitBound=true;
576                 param = prevEst[px] + (fv->ubound - prevEst[px]) / 2;
577         }
578         boundsHit += hitBound;
579         
580         prevAdj2[px] = prevAdj1[px];
581         prevAdj1[px] = param - prevEst[px];
582         
583         if (verbose >= 4) {
584                 std::string buf;
585                 buf += string_snprintf("Ramsay[%10s]: %d~%s %.4f -> %.4f", flavor, px, fv->name, prevEst[px], param);
586                 if (hitBound) {
587                         buf += string_snprintf(" wanted %.4f but hit bound", newEst);
588                 }
589                 if (prevAdj1[px] * prevAdj2[px] < 0) {
590                         buf += " *OSC*";
591                 }
592                 buf += "\n";
593                 mxLogBig(buf);
594         }
595
596         fc->est[px] = param;
597         prevEst[px] = param;
598 }
599
600 void Ramsay1975::apply()
601 {
602         for (size_t px=0; px < vars.size(); ++px) {
603                 int vx = vars[px];
604                 recordEstimate(vx, (1 - caution) * fc->est[vx] + caution * prevEst[vx]);
605         }
606 }
607
608 void Ramsay1975::recalibrate(bool *restart)
609 {
610         if (vars.size() == 0) return;
611
612         double normPrevAdj2 = 0;
613         double normAdjDiff = 0;
614         std::vector<double> adjDiff(numParam);
615
616         // The choice of norm is also arbitrary. Other norms might work better.
617         for (size_t vx=0; vx < vars.size(); ++vx) {
618                 int px = vars[vx];
619                 adjDiff[px] = prevAdj1[px] - prevAdj2[px];
620                 normPrevAdj2 += prevAdj2[px] * prevAdj2[px];
621         }
622
623         for (size_t vx=0; vx < vars.size(); ++vx) {
624                 int px = vars[vx];
625                 normAdjDiff += adjDiff[px] * adjDiff[px];
626         }
627         if (normAdjDiff == 0) {
628                 return;
629                 //Rf_error("Ramsay: no free variables of flavor %d", flavor);
630         }
631
632         double ratio = sqrt(normPrevAdj2 / normAdjDiff);
633         //if (verbose >= 3) mxLog("Ramsay[%d]: sqrt(%.5f/%.5f) = %.5f",
634         // flavor, normPrevAdj2, normAdjDiff, ratio);
635
636         double newCaution = 1 - (1-caution) * ratio / (1+boundsHit);
637         if (newCaution > .95) newCaution = .95;  // arbitrary guess
638         if (newCaution < 0) newCaution /= 2;     // don't get overconfident
639         if (newCaution < minCaution) newCaution = minCaution;
640         if (newCaution < caution) {
641                 caution = newCaution/3 + 2*caution/3;  // don't speed up too fast, arbitrary ratio
642         } else {
643                 caution = newCaution;
644         }
645         maxCaution = std::max(maxCaution, caution);
646         goingWild = false;
647         if (caution < highWatermark || (normPrevAdj2 < 1e-3 && normAdjDiff < 1e-3)) {
648                 if (verbose >= 3) mxLog("Ramsay[%10s]: %.2f caution", flavor, caution);
649         } else {
650                 if (verbose >= 3) {
651                         mxLog("Ramsay[%10s]: caution %.2f > %.2f, extreme oscillation, restart recommended",
652                               flavor, caution, highWatermark);
653                 }
654                 *restart = TRUE;
655                 goingWild = true;
656         }
657         highWatermark += .02; // arbitrary guess
658         boundsHit = 0;
659 }
660
661 void Ramsay1975::restart(bool myFault)
662 {
663         memcpy(prevEst.data(), fc->est, sizeof(double) * numParam);
664         prevAdj1.assign(numParam, 0);
665         prevAdj2.assign(numParam, 0);
666         myFault |= goingWild;
667         if (myFault) {
668                 highWatermark = 1 - (1 - highWatermark) * .5; // arbitrary guess
669                 caution = std::max(caution, highWatermark);   // arbitrary guess
670                 maxCaution = std::max(maxCaution, caution);
671                 highWatermark = caution;
672         }
673         if (vars.size() && verbose >= 3) {
674                 mxLog("Ramsay[%10s]: restart%s with %.2f caution %.2f highWatermark",
675                       flavor, myFault? " (my fault)":"", caution, highWatermark);
676         }
677 }
678
679 omxCompute::omxCompute()
680 {
681         varGroup = NULL;
682 }
683
684 void omxCompute::collectResultsHelper(FitContext *fc, std::vector< omxCompute* > &clist,
685                                       LocalComputeResult *lcr, MxRList *out)
686 {
687         for (std::vector< omxCompute* >::iterator it = clist.begin(); it != clist.end(); ++it) {
688                 omxCompute *c1 = *it;
689                 c1->collectResults(fc, lcr, out);
690         }
691 }
692
693 void omxCompute::collectResults(FitContext *fc, LocalComputeResult *lcr, MxRList *out)
694 {
695         MxRList *slots = new MxRList();
696         reportResults(fc, slots, out);
697         if (slots->size()) {
698                 lcr->push_back(std::make_pair(computeId, slots));
699         } else {
700                 delete slots;
701         }
702 }
703
704 omxCompute::~omxCompute()
705 {}
706
707 void omxCompute::initFromFrontend(SEXP rObj)
708 {
709         SEXP slotValue;
710         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("id")));
711         if (Rf_length(slotValue) != 1) Rf_error("MxCompute has no ID");
712
713         computeId = INTEGER(slotValue)[0];
714         varGroup = Global->findVarGroup(computeId);
715
716         if (!varGroup) {
717                 Rf_protect(slotValue = R_do_slot(rObj, Rf_install("free.set")));
718                 if (Rf_length(slotValue) == 0) {
719                         varGroup = Global->findVarGroup(FREEVARGROUP_NONE);
720                 } else if (strcmp(CHAR(STRING_ELT(slotValue, 0)), ".")==0) {
721                         varGroup = Global->freeGroup[FREEVARGROUP_ALL];
722                 } else {
723                         Rf_warning("MxCompute ID %d references matrix '%s' in its free.set "
724                                 "but this matrix contains no free parameters",
725                                 computeId, CHAR(STRING_ELT(slotValue, 0)));
726                         varGroup = Global->findVarGroup(FREEVARGROUP_NONE);
727                 }
728         }
729         if (OMX_DEBUG) {
730                 mxLog("MxCompute id %d assigned to var group %d", computeId, varGroup->id[0]);
731         }
732 }
733
734 void omxCompute::compute(FitContext *fc)
735 {
736         ComputeInform origInform = fc->inform;
737         FitContext *narrow = fc;
738         if (fc->varGroup != varGroup) narrow = new FitContext(fc, varGroup);
739         narrow->inform = INFORM_UNINITIALIZED;
740         computeImpl(narrow);
741         fc->inform = std::max(origInform, narrow->inform);
742         if (fc->varGroup != varGroup) narrow->updateParentAndFree();
743         Global->checkpointMessage(fc, fc->est, "%s", name);
744 }
745
746 class ComputeContainer : public omxCompute {
747         typedef omxCompute super;
748 protected:
749         std::vector< omxCompute* > clist;
750 public:
751         virtual void collectResults(FitContext *fc, LocalComputeResult *lcr, MxRList *out);
752 };
753
754 void ComputeContainer::collectResults(FitContext *fc, LocalComputeResult *lcr, MxRList *out)
755 {
756         super::collectResults(fc, lcr, out);
757         collectResultsHelper(fc, clist, lcr, out);
758 }
759
760 class omxComputeSequence : public ComputeContainer {
761         typedef ComputeContainer super;
762
763  public:
764         virtual void initFromFrontend(SEXP rObj);
765         virtual void computeImpl(FitContext *fc);
766         virtual ~omxComputeSequence();
767 };
768
769 class omxComputeIterate : public ComputeContainer {
770         typedef ComputeContainer super;
771         int maxIter;
772         double tolerance;
773         int verbose;
774
775  public:
776         virtual void initFromFrontend(SEXP rObj);
777         virtual void computeImpl(FitContext *fc);
778         virtual ~omxComputeIterate();
779 };
780
781 class omxComputeOnce : public omxCompute {
782         typedef omxCompute super;
783         std::vector< omxMatrix* > algebras;
784         std::vector< omxExpectation* > expectations;
785         std::vector< const char* > predict;
786         const char *how;
787         int verbose;
788         bool mac;
789         bool starting;
790         bool fit;
791         bool gradient;
792         bool hessian;
793         bool ihessian;
794         bool infoMat;
795         enum ComputeInfoMethod infoMethod;
796         bool hgprod;
797         bool isBestFit; // for backward compatibility
798
799  public:
800         virtual void initFromFrontend(SEXP rObj);
801         virtual omxFitFunction *getFitFunction();
802         virtual void computeImpl(FitContext *fc);
803         virtual void reportResults(FitContext *fc, MxRList *slots, MxRList *out);
804 };
805
806 class ComputeEM : public omxCompute {
807         typedef omxCompute super;
808         std::vector< omxExpectation* > expectations;
809         const char *predict;
810         omxCompute *fit1;  // maybe rename to stage1, stage2, stage3 TODO
811         omxCompute *fit2;
812         omxCompute *fit3;
813         int EMcycles;
814         int maxIter;
815         int mstepIter;
816         int totalMstepIter;
817         double tolerance;
818         double semTolerance;
819         int verbose;
820         bool useRamsay;
821         bool information;
822         std::vector< omxMatrix * > semFitFunction;
823         enum ComputeInfoMethod infoMethod;
824         enum SEMMethod { ClassicSEM, TianSEM, GridSEM, AgileSEM } semMethod;
825         double *semMethodData;
826         int semMethodLen;
827         bool semDebug;
828         bool semFixSymmetry;
829         bool semForcePD;
830         int agileMaxIter;
831         SEXP rateMatrix; //debug
832         SEXP inputInfoMatrix; //debug
833         SEXP outputInfoMatrix; //debug
834         SEXP origEigenvalues; //debug
835         std::vector<Ramsay1975*> ramsay;
836         double noiseTarget;
837         double noiseTolerance;
838         std::vector<double*> estHistory;
839         std::vector<double> probeOffset;
840         std::vector<double> diffWork;
841         std::vector<int> paramHistLen;
842         std::vector<double> optimum;
843         double bestFit;
844         static const double MIDDLE_START;
845         static const double MIDDLE_END;
846         size_t maxHistLen;
847         int semProbeCount;
848
849         void setExpectationPrediction(const char *context);
850         void probeEM(FitContext *fc, int vx, double offset, std::vector<double> *rijWork);
851         void recordDiff(FitContext *fc, int v1, std::vector<double> &rijWork,
852                         double *stdDiff, bool *mengOK);
853
854  public:
855         virtual void initFromFrontend(SEXP rObj);
856         virtual void computeImpl(FitContext *fc);
857         virtual void collectResults(FitContext *fc, LocalComputeResult *lcr, MxRList *out);
858         virtual void reportResults(FitContext *fc, MxRList *slots, MxRList *out);
859         virtual ~ComputeEM();
860 };
861
862 const double ComputeEM::MIDDLE_START = 0.105360515657826281366; // -log(.9) constexpr
863 const double ComputeEM::MIDDLE_END = 0.001000500333583534363566; // -log(.999) constexpr
864
865 class ComputeStandardError : public omxCompute {
866         typedef omxCompute super;
867  public:
868         virtual void reportResults(FitContext *fc, MxRList *slots, MxRList *out);
869 };
870
871 class ComputeHessianQuality : public omxCompute {
872         typedef omxCompute super;
873  public:
874         virtual void reportResults(FitContext *fc, MxRList *slots, MxRList *out);
875 };
876
877 class ComputeReportDeriv : public omxCompute {
878         typedef omxCompute super;
879  public:
880         virtual void reportResults(FitContext *fc, MxRList *slots, MxRList *out);
881 };
882
883 static class omxCompute *newComputeSequence()
884 { return new omxComputeSequence(); }
885
886 static class omxCompute *newComputeIterate()
887 { return new omxComputeIterate(); }
888
889 static class omxCompute *newComputeOnce()
890 { return new omxComputeOnce(); }
891
892 static class omxCompute *newComputeEM()
893 { return new ComputeEM(); }
894
895 static class omxCompute *newComputeStandardError()
896 { return new ComputeStandardError(); }
897
898 static class omxCompute *newComputeHessianQuality()
899 { return new ComputeHessianQuality(); }
900
901 static class omxCompute *newComputeReportDeriv()
902 { return new ComputeReportDeriv(); }
903
904 struct omxComputeTableEntry {
905         char name[32];
906         omxCompute *(*ctor)();
907 };
908
909 static const struct omxComputeTableEntry omxComputeTable[] = {
910         {"MxComputeNumericDeriv", &newComputeNumericDeriv},
911         {"MxComputeGradientDescent", &newComputeGradientDescent},
912         {"MxComputeSequence", &newComputeSequence },
913         {"MxComputeIterate", &newComputeIterate },
914         {"MxComputeOnce", &newComputeOnce },
915         {"MxComputeNewtonRaphson", &newComputeNewtonRaphson},
916         {"MxComputeEM", &newComputeEM },
917         {"MxComputeStandardError", &newComputeStandardError},
918         {"MxComputeHessianQuality", &newComputeHessianQuality},
919         {"MxComputeReportDeriv", &newComputeReportDeriv}
920 };
921
922 omxCompute *omxNewCompute(omxState* os, const char *type)
923 {
924         omxCompute *got = NULL;
925
926         for (size_t fx=0; fx < OMX_STATIC_ARRAY_SIZE(omxComputeTable); fx++) {
927                 const struct omxComputeTableEntry *entry = omxComputeTable + fx;
928                 if(strcmp(type, entry->name) == 0) {
929                         got = entry->ctor();
930                         got->name = entry->name;
931                         break;
932                 }
933         }
934
935         if (!got) Rf_error("Compute %s is not implemented", type);
936
937         return got;
938 }
939
940 void omxComputeSequence::initFromFrontend(SEXP rObj)
941 {
942         super::initFromFrontend(rObj);
943
944         SEXP slotValue;
945         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("steps")));
946
947         for (int cx = 0; cx < Rf_length(slotValue); cx++) {
948                 SEXP step = VECTOR_ELT(slotValue, cx);
949                 SEXP s4class;
950                 Rf_protect(s4class = STRING_ELT(Rf_getAttrib(step, Rf_install("class")), 0));
951                 omxCompute *compute = omxNewCompute(globalState, CHAR(s4class));
952                 compute->initFromFrontend(step);
953                 if (isErrorRaised(globalState)) break;
954                 clist.push_back(compute);
955         }
956 }
957
958 void omxComputeSequence::computeImpl(FitContext *fc)
959 {
960         for (size_t cx=0; cx < clist.size(); ++cx) {
961                 clist[cx]->compute(fc);
962                 if (isErrorRaised(globalState)) break;
963         }
964 }
965
966 omxComputeSequence::~omxComputeSequence()
967 {
968         for (size_t cx=0; cx < clist.size(); ++cx) {
969                 delete clist[cx];
970         }
971 }
972
973 void omxComputeIterate::initFromFrontend(SEXP rObj)
974 {
975         SEXP slotValue;
976
977         super::initFromFrontend(rObj);
978
979         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("maxIter")));
980         maxIter = INTEGER(slotValue)[0];
981
982         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("tolerance")));
983         tolerance = REAL(slotValue)[0];
984         if (tolerance <= 0) Rf_error("tolerance must be positive");
985
986         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("steps")));
987
988         for (int cx = 0; cx < Rf_length(slotValue); cx++) {
989                 SEXP step = VECTOR_ELT(slotValue, cx);
990                 SEXP s4class;
991                 Rf_protect(s4class = STRING_ELT(Rf_getAttrib(step, Rf_install("class")), 0));
992                 omxCompute *compute = omxNewCompute(globalState, CHAR(s4class));
993                 compute->initFromFrontend(step);
994                 if (isErrorRaised(globalState)) break;
995                 clist.push_back(compute);
996         }
997
998         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("verbose")));
999         verbose = Rf_asInteger(slotValue);
1000 }
1001
1002 void omxComputeIterate::computeImpl(FitContext *fc)
1003 {
1004         int iter = 0;
1005         double prevFit = 0;
1006         double mac = tolerance * 10;
1007         while (1) {
1008                 for (size_t cx=0; cx < clist.size(); ++cx) {
1009                         clist[cx]->compute(fc);
1010                         if (isErrorRaised(globalState)) break;
1011                 }
1012                 if (fc->wanted & FF_COMPUTE_MAXABSCHANGE) {
1013                         if (fc->mac < 0) {
1014                                 Rf_warning("MAC estimated at %.4f; something is wrong", fc->mac);
1015                                 break;
1016                         } else {
1017                                 mac = fc->mac;
1018                                 if (verbose) mxLog("ComputeIterate: mac %.9g", mac);
1019                         }
1020                 }
1021                 if (fc->wanted & FF_COMPUTE_FIT) {
1022                         if (fc->fit == 0) {
1023                                 Rf_warning("Fit estimated at 0; something is wrong");
1024                                 break;
1025                         }
1026                         if (prevFit != 0) {
1027                                 double change = prevFit - fc->fit;
1028                                 if (verbose) mxLog("ComputeIterate: fit %.9g change %.9g", fc->fit, change);
1029                                 mac = fabs(change);
1030                         } else {
1031                                 if (verbose) mxLog("ComputeIterate: initial fit %.9g", fc->fit);
1032                         }
1033                         prevFit = fc->fit;
1034                 }
1035                 if (!(fc->wanted & (FF_COMPUTE_MAXABSCHANGE | FF_COMPUTE_FIT))) {
1036                         omxRaiseErrorf(globalState, "ComputeIterate: neither MAC nor fit available");
1037                 }
1038                 if (isErrorRaised(globalState) || ++iter > maxIter || mac < tolerance) break;
1039         }
1040 }
1041
1042 omxComputeIterate::~omxComputeIterate()
1043 {
1044         for (size_t cx=0; cx < clist.size(); ++cx) {
1045                 delete clist[cx];
1046         }
1047 }
1048
1049 void ComputeEM::initFromFrontend(SEXP rObj)
1050 {
1051         SEXP slotValue;
1052         SEXP s4class;
1053
1054         super::initFromFrontend(rObj);
1055
1056         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("maxIter")));
1057         maxIter = INTEGER(slotValue)[0];
1058
1059         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("information")));
1060         information = Rf_asLogical(slotValue);
1061         infoMethod = INFO_METHOD_DEFAULT;
1062
1063         if (information) {
1064                 SEXP infoArgs, argNames;
1065                 Rf_protect(infoArgs = R_do_slot(rObj, Rf_install("infoArgs")));
1066                 Rf_protect(argNames = Rf_getAttrib(infoArgs, R_NamesSymbol));
1067
1068                 for (int ax=0; ax < Rf_length(infoArgs); ++ax) {
1069                         const char *key = R_CHAR(STRING_ELT(argNames, ax));
1070                         if (strcmp(key, "fitfunction") == 0) {
1071                                 slotValue = VECTOR_ELT(infoArgs, ax);
1072                                 for (int fx=0; fx < Rf_length(slotValue); ++fx) {
1073                                         omxMatrix *ff = globalState->algebraList[INTEGER(slotValue)[fx]];
1074                                         if (!ff->fitFunction) Rf_error("infoArgs$fitfunction is %s, not a fitfunction", ff->name);
1075                                         semFitFunction.push_back(ff);
1076                                 }
1077                         } else {
1078                                 mxLog("Unknown key %s", key);
1079                         }
1080                 }
1081
1082                 Rf_protect(slotValue = R_do_slot(rObj, Rf_install("info.method")));
1083                 SEXP elem;
1084                 Rf_protect(elem = STRING_ELT(slotValue, 0));
1085                 infoMethod = stringToInfoMethod(CHAR(elem));
1086         }
1087
1088         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("semMethod")));
1089         semMethodLen = Rf_length(slotValue);
1090         if (semMethodLen == 0) {
1091                 semMethod = AgileSEM;
1092                 semMethodData = NULL;
1093         } else {
1094                 semMethodData = REAL(slotValue);
1095                 if (semMethodLen > 1) {
1096                         semMethod = GridSEM;
1097                 } else if (semMethodData[0] == 1) {
1098                         semMethod = ClassicSEM;
1099                 } else if (semMethodData[0] == 2) {
1100                         semMethod = TianSEM;
1101                 } else if (semMethodData[0] == 3) {
1102                         semMethod = AgileSEM;
1103                 } else {
1104                         Rf_error("Unknown SEM method %f", semMethodData[0]);
1105                 }
1106         }
1107
1108         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("agileMaxIter")));
1109         agileMaxIter = INTEGER(slotValue)[0];
1110
1111         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("semDebug")));
1112         semDebug = Rf_asLogical(slotValue);
1113
1114         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("semFixSymmetry")));
1115         semFixSymmetry = Rf_asLogical(slotValue);
1116
1117         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("semForcePD")));
1118         semForcePD = Rf_asLogical(slotValue);
1119
1120         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("ramsay")));
1121         useRamsay = Rf_asLogical(slotValue);
1122
1123         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("tolerance")));
1124         tolerance = REAL(slotValue)[0];
1125         if (tolerance <= 0) Rf_error("tolerance must be positive");
1126
1127         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("noiseTarget")));
1128         noiseTarget = REAL(slotValue)[0];
1129         if (noiseTarget <= 0) Rf_error("noiseTarget must be positive");
1130
1131         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("noiseTolerance")));
1132         noiseTolerance = REAL(slotValue)[0];
1133         if (noiseTolerance < 1) Rf_error("noiseTolerance must be >=1");
1134
1135         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("expectation")));
1136         for (int wx=0; wx < Rf_length(slotValue); ++wx) {
1137                 int objNum = INTEGER(slotValue)[wx];
1138                 omxExpectation *expectation = globalState->expectationList[objNum];
1139                 setFreeVarGroup(expectation, varGroup);
1140                 omxCompleteExpectation(expectation);
1141                 expectations.push_back(expectation);
1142         }
1143
1144         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("predict")));
1145         {
1146                 // Should accept a vector here TODO
1147                 if (Rf_length(slotValue) != 1) Rf_error("Not implemented");
1148                 SEXP elem;
1149                 Rf_protect(elem = STRING_ELT(slotValue, 0));
1150                 predict = CHAR(elem);
1151         }
1152
1153         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("mstep")));
1154         Rf_protect(s4class = STRING_ELT(Rf_getAttrib(slotValue, Rf_install("class")), 0));
1155         fit1 = omxNewCompute(globalState, CHAR(s4class));
1156         fit1->initFromFrontend(slotValue);
1157
1158         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("post.mstep")));
1159         Rf_protect(s4class = STRING_ELT(Rf_getAttrib(slotValue, Rf_install("class")), 0));
1160         fit2 = omxNewCompute(globalState, CHAR(s4class));
1161         fit2->initFromFrontend(slotValue);
1162
1163         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("observed.fit")));
1164         Rf_protect(s4class = STRING_ELT(Rf_getAttrib(slotValue, Rf_install("class")), 0));
1165         fit3 = omxNewCompute(globalState, CHAR(s4class));
1166         fit3->initFromFrontend(slotValue);
1167
1168         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("verbose")));
1169         verbose = Rf_asInteger(slotValue);
1170
1171         semTolerance = sqrt(tolerance);  // override needed?
1172
1173         inputInfoMatrix = NULL;
1174         outputInfoMatrix = NULL;
1175         rateMatrix = NULL;
1176         origEigenvalues = NULL;
1177 }
1178
1179 void ComputeEM::setExpectationPrediction(const char *context)
1180 {
1181         for (size_t wx=0; wx < expectations.size(); ++wx) {
1182                 omxExpectation *expectation = expectations[wx];
1183                 if (verbose >= 4) mxLog("ComputeEM: expectation[%d] %s predict %s", (int) wx, expectation->name, context);
1184                 omxExpectationCompute(expectation, context);
1185         }
1186 }
1187
1188 void ComputeEM::probeEM(FitContext *fc, int vx, double offset, std::vector<double> *rijWork)
1189 {
1190         const size_t freeVars = fc->varGroup->vars.size();
1191         const int base = paramHistLen[vx] * freeVars;
1192         probeOffset[vx * maxHistLen + paramHistLen[vx]] = offset;
1193         paramHistLen[vx] += 1;
1194
1195         memcpy(fc->est, optimum.data(), sizeof(double) * freeVars);
1196         fc->est[vx] += offset;
1197         fc->copyParamToModel(globalState);
1198
1199         setExpectationPrediction(predict);
1200         fit1->compute(fc);
1201         setExpectationPrediction("nothing");
1202
1203         const size_t extraVars = fit2->varGroup->vars.size();
1204         if (extraVars) fit2->compute(fc);
1205
1206         if (verbose >= 3) mxLog("ComputeEM: probe %d of param %d offset %.6f",
1207                                 paramHistLen[vx], vx, offset);
1208
1209         for (size_t v1=0; v1 < freeVars; ++v1) {
1210                 double got = (fc->est[v1] - optimum[v1]) / offset;
1211                 (*rijWork)[base + v1] = got;
1212         }
1213         //pda(rij.data() + base, 1, freeVars);
1214         ++semProbeCount;
1215 }
1216
1217 void ComputeEM::recordDiff(FitContext *fc, int v1, std::vector<double> &rijWork,
1218                            double *stdDiff, bool *mengOK)
1219 {
1220         const size_t freeVars = fc->varGroup->vars.size();
1221         int h1 = paramHistLen[v1]-2;
1222         int h2 = paramHistLen[v1]-1;
1223         double *rij1 = rijWork.data() + h1 * freeVars;
1224         double *rij2 = rijWork.data() + h2 * freeVars;
1225         double diff = 0;
1226         *mengOK = true;
1227         for (size_t v2=0; v2 < freeVars; ++v2) {
1228                 double diff1 = fabs(rij1[v2] - rij2[v2]);
1229                 if (diff1 >= semTolerance) *mengOK = false;
1230                 diff += diff1;
1231         }
1232         double p1 = probeOffset[v1 * maxHistLen + h1];
1233         double p2 = probeOffset[v1 * maxHistLen + h2];
1234         double dist = fabs(p1 - p2);
1235         if (dist < tolerance/4) Rf_error("SEM: invalid probe offset distance %.9f", dist);
1236         *stdDiff = diff / (freeVars * dist);
1237         diffWork[v1 * maxHistLen + h1] = *stdDiff;
1238         if (verbose >= 2) mxLog("ComputeEM: (%f,%f) mengOK %d diff %f stdDiff %f",
1239                                 p1, p2, *mengOK, diff / freeVars, *stdDiff);
1240 }
1241
1242 void ComputeEM::computeImpl(FitContext *fc)
1243 {
1244         const double Scale = fabs(Global->llScale);
1245         double prevFit = 0;
1246         double mac = tolerance * 10;
1247         bool converged = false;
1248         const size_t freeVars = fc->varGroup->vars.size();
1249         bool in_middle = false;
1250         maxHistLen = 0;
1251         EMcycles = 0;
1252         semProbeCount = 0;
1253
1254         if (verbose >= 1) mxLog("ComputeEM: Welcome, tolerance=%g ramsay=%d info=%d",
1255                                 tolerance, useRamsay, information);
1256
1257         // Some evidence suggests that better performance is obtained when the
1258         // item parameters and latent distribution parameters are split into
1259         // separate Ramsay1975 groups with different minimum caution limits,
1260         //
1261         // ramsay.push_back(new Ramsay1975(fc, 1+int(ramsay.size()), 0, verbose, -1.25)); // M-step param
1262         // ramsay.push_back(new Ramsay1975(fc, 1+int(ramsay.size()), 0, verbose, -1));    // extra param
1263         //
1264         // I had this hardcoded for a while, but in making the API more generic,
1265         // I'm not sure how to allow specification of the Ramsay1975 grouping.
1266         // One possibility is list(flavor1=c("ItemParam"), flavor2=c("mean","cov"))
1267         // but this doesn't allow finer grain than matrix-wise assignment. The
1268         // other question is whether more Ramsay1975 groups really help or not.
1269         // nightly/ifa-cai2009.R actually got faster with 1 Ramsay group.
1270
1271         const char *flavor = "EM";
1272         fc->flavor.assign(freeVars, flavor);
1273         ramsay.push_back(new Ramsay1975(fc, flavor, verbose, -1.25));
1274
1275         while (1) {
1276                 if (verbose >= 4) mxLog("ComputeEM[%d]: E-step", EMcycles);
1277                 setExpectationPrediction(predict);
1278
1279                 {
1280                         if (verbose >= 4) mxLog("ComputeEM[%d]: M-step", EMcycles);
1281                         FitContext *fc1 = new FitContext(fc, fit1->varGroup);
1282                         int startIter = fc1->iterations;
1283                         fit1->compute(fc1);
1284                         mstepIter = fc1->iterations - startIter;
1285                         fc1->updateParentAndFree();
1286                 }
1287
1288                 setExpectationPrediction("nothing");
1289                 {
1290                         if (verbose >= 4) mxLog("ComputeEM[%d]: post M-step", EMcycles);
1291                         fit2->compute(fc);
1292
1293                         if (useRamsay) {
1294                                 bool wantRestart;
1295                                 if (EMcycles > 3 && EMcycles % 3 == 0) {
1296                                         for (size_t rx=0; rx < ramsay.size(); ++rx) {
1297                                                 ramsay[rx]->recalibrate(&wantRestart);
1298                                         }
1299                                 }
1300                                 for (size_t rx=0; rx < ramsay.size(); ++rx) {
1301                                         ramsay[rx]->apply();
1302                                 }
1303                         }
1304                         fc->copyParamToModel(globalState);
1305                         if (verbose >= 4) mxLog("ComputeEM[%d]: observed fit", EMcycles);
1306                         Global->checkpointPrefit(fc, fc->est, false);
1307                         fit3->compute(fc);
1308                         Global->checkpointPostfit(fc);
1309                 }
1310
1311                 totalMstepIter += mstepIter;
1312
1313                 if (!(fc->wanted & FF_COMPUTE_FIT)) {
1314                         omxRaiseErrorf(globalState, "ComputeEM: fit not available");
1315                         break;
1316                 }
1317                 if (fc->fit == 0) {
1318                         omxRaiseErrorf(globalState, "Fit estimated at 0; something is wrong");
1319                         break;
1320                 }
1321                 double change = 0;
1322                 if (prevFit != 0) {
1323                         change = prevFit - fc->fit;
1324                         if (verbose >= 2) mxLog("ComputeEM[%d]: msteps %d fit %.9g change %.9g",
1325                                                 EMcycles, mstepIter, fc->fit, change);
1326                         mac = fabs(change);
1327                         if (mac < MIDDLE_START * Scale) in_middle = true;
1328                         if (mac < MIDDLE_END * Scale) in_middle = false;
1329                 } else {
1330                         if (verbose >= 2) mxLog("ComputeEM: msteps %d initial fit %.9g",
1331                                                 mstepIter, fc->fit);
1332                 }
1333
1334                 prevFit = fc->fit;
1335                 converged = mac < tolerance;
1336                 ++fc->iterations;
1337                 if (isErrorRaised(globalState) || ++EMcycles > maxIter || converged) break;
1338
1339                 if (semMethod == ClassicSEM || ((semMethod == TianSEM || semMethod == AgileSEM) && in_middle)) {
1340                         double *estCopy = new double[freeVars];
1341                         memcpy(estCopy, fc->est, sizeof(double) * freeVars);
1342                         estHistory.push_back(estCopy);
1343                 }
1344         }
1345
1346         int wanted = FF_COMPUTE_FIT | FF_COMPUTE_BESTFIT | FF_COMPUTE_ESTIMATE;
1347         fc->wanted = wanted;
1348         bestFit = fc->fit;
1349         if (verbose >= 1) mxLog("ComputeEM: cycles %d/%d total mstep %d fit %f",
1350                                 EMcycles, maxIter, totalMstepIter, bestFit);
1351
1352         if (!converged || !information) return;
1353
1354         if (verbose >= 1) mxLog("ComputeEM: tolerance=%f semMethod=%d, semTolerance=%f ideal noise=[%f,%f]",
1355                                 tolerance, semMethod, semTolerance,
1356                                 noiseTarget/noiseTolerance, noiseTarget*noiseTolerance);
1357
1358         optimum.resize(freeVars);
1359         memcpy(optimum.data(), fc->est, sizeof(double) * freeVars);
1360
1361         if (semMethod == AgileSEM) {
1362                 maxHistLen = 2 + agileMaxIter * 2;
1363         } else if (semMethod == ClassicSEM || semMethod == TianSEM) {
1364                 maxHistLen = estHistory.size();
1365         } else {
1366                 maxHistLen = semMethodLen;
1367         }
1368
1369         probeOffset.resize(maxHistLen * freeVars);
1370         diffWork.resize(maxHistLen * freeVars);
1371         paramHistLen.assign(freeVars, 0);
1372         omxBuffer<double> rij(freeVars * freeVars);
1373
1374         size_t semConverged=0;
1375         for (size_t v1=0; v1 < freeVars; ++v1) {
1376                 std::vector<double> rijWork(freeVars * maxHistLen);
1377                 int pick = 0;
1378                 bool paramConverged = false;
1379                 if (semMethod == AgileSEM) {
1380                         const double stepSize = tolerance;
1381
1382                         double offset1 = tolerance * 50;
1383                         double sign = 1;
1384                         if (estHistory.size()) {
1385                                 int hpick = estHistory.size() /2;
1386                                 double popt = optimum[v1];
1387                                 sign = (popt < estHistory[hpick][v1])? 1 : -1;
1388                                 offset1 = fabs(estHistory[hpick][v1] - popt);
1389                                 if (offset1 < 10 * tolerance) offset1 = 10 * tolerance;
1390                                 if (offset1 > 1000 * tolerance) offset1 = 1000 * tolerance;
1391                         }
1392
1393                         probeEM(fc, v1, sign * offset1, &rijWork);
1394                         double offset2 = offset1 + stepSize;
1395                         probeEM(fc, v1, sign * offset2, &rijWork);
1396                         double diff;
1397                         bool mengOK;
1398                         recordDiff(fc, v1, rijWork, &diff, &mengOK);
1399                         double midOffset = (offset1 + offset2) / 2;
1400
1401                         int iter = 0;
1402                         omxBuffer<double> coefHist(agileMaxIter);
1403                         while (++iter <= agileMaxIter &&
1404                                !(noiseTarget/noiseTolerance < diff && diff < noiseTarget*noiseTolerance)) {
1405                                 coefHist[iter-1] = diff * midOffset * midOffset;
1406                                 double coef = 0;
1407                                 for (int cx=0; cx < iter; ++cx) coef += coefHist[cx];
1408                                 coef /= iter;
1409                                 if (verbose >= 4) mxLog("ComputeEM: agile iter[%d] coef=%.6g", iter, coef);
1410                                 offset1 = sqrt(coef/noiseTarget);
1411                                 probeEM(fc, v1, sign * offset1, &rijWork);
1412                                 if (iter < agileMaxIter || semDebug) {
1413                                         offset2 = offset1 + stepSize;
1414                                         probeEM(fc, v1, sign * offset2, &rijWork);
1415                                         midOffset = (offset1 + offset2) / 2;
1416                                         recordDiff(fc, v1, rijWork, &diff, &mengOK);
1417                                 }
1418                                 pick += 2;
1419                         }
1420                         paramConverged = true;
1421                 } else if (semMethod == ClassicSEM || semMethod == TianSEM) {
1422                         if (!estHistory.size()) {
1423                                 if (verbose >= 1) mxLog("ComputeEM: no history available;"
1424                                                         " Classic or Tian SEM require convergence history");
1425                                 return;
1426                         }
1427                         for (size_t hx=0; hx < estHistory.size(); ++hx) {
1428                                 double popt = optimum[v1];
1429                                 double offset1 = estHistory[hx][v1] - popt;
1430                                 if (paramHistLen[v1] && fabs(probeOffset[v1 * maxHistLen + paramHistLen[v1]-1] -
1431                                                              offset1) < tolerance) continue;
1432                                 if (fabs(offset1) < tolerance) continue;
1433                                 probeEM(fc, v1, offset1, &rijWork);
1434                                 if (hx == 0) continue;
1435                                 pick = hx;
1436                                 double diff;
1437                                 bool mengOK;
1438                                 recordDiff(fc, v1, rijWork, &diff, &mengOK);
1439                                 if (mengOK) {
1440                                         paramConverged = true;
1441                                         break;
1442                                 }
1443                         }
1444                 } else {
1445                         for (int hx=0; hx < semMethodLen; ++hx) {
1446                                 probeEM(fc, v1, semMethodData[hx], &rijWork);
1447                                 if (hx == 0) continue;
1448                                 double diff;
1449                                 bool mengOK;
1450                                 recordDiff(fc, v1, rijWork, &diff, &mengOK);
1451                         }
1452                         paramConverged = true;
1453                 }
1454
1455                 if (paramConverged) {
1456                         ++semConverged;
1457                         memcpy(rij.data() + v1 * freeVars, rijWork.data() + pick*freeVars, sizeof(double) * freeVars);
1458                         if (verbose >= 2) mxLog("ComputeEM: param %d converged in %d probes",
1459                                                 (int) v1, paramHistLen[v1]);
1460                 } else {
1461                         if (verbose >= 2) mxLog("ComputeEM: param %d failed to converge after %d probes",
1462                                                 (int) v1, paramHistLen[v1]);
1463                         break;
1464                 }
1465         }
1466
1467         if (verbose >= 1) {
1468                 if (semConverged == freeVars) {
1469                         mxLog("ComputeEM: %d probes used to estimate Hessian", semProbeCount);
1470                 } else {
1471                         mxLog("ComputeEM: %d probes used for SEM but failed to converge", semProbeCount);
1472                 }
1473         }
1474         if (semConverged < freeVars) return;
1475
1476         fc->fit = bestFit;
1477         memcpy(fc->est, optimum.data(), sizeof(double) * freeVars);
1478         fc->copyParamToModel(globalState);
1479
1480         if (semDebug) {
1481                 Rf_protect(rateMatrix = Rf_allocMatrix(REALSXP, freeVars, freeVars));
1482                 memcpy(REAL(rateMatrix), rij.data(), sizeof(double) * freeVars * freeVars);
1483         }
1484
1485         // rij = I-rij
1486         for (size_t v1=0; v1 < freeVars; ++v1) {
1487                 for (size_t v2=0; v2 < freeVars; ++v2) {
1488                         int cell = v1 * freeVars + v2;
1489                         double entry = rij[cell];
1490                         if (v1 == v2) entry = 1 - entry;
1491                         else entry = -entry;
1492                         rij[cell] = entry;
1493                 }
1494         }
1495
1496         //mxLog("rij symm");
1497         //pda(rij.data(), freeVars, freeVars);
1498
1499         setExpectationPrediction(predict);
1500         fc->wanted = 0;
1501         fc->infoMethod = infoMethod;
1502         fc->preInfo();
1503         for (size_t fx=0; fx < semFitFunction.size(); ++fx) {
1504                 omxFitFunctionCompute(semFitFunction[fx]->fitFunction, FF_COMPUTE_INFO, fc);
1505         }
1506         fc->postInfo();
1507         setExpectationPrediction("nothing");
1508
1509         Rf_protect(inputInfoMatrix = Rf_allocMatrix(REALSXP, freeVars, freeVars));
1510         double *hess = REAL(inputInfoMatrix);
1511         fc->copyDenseHess(hess);
1512
1513         Matrix rijMat(rij.data(), freeVars, freeVars);
1514         Matrix hessMat(hess, freeVars, freeVars);
1515         omxBuffer<double> infoBuf(freeVars * freeVars);
1516         Matrix infoMat(infoBuf.data(), freeVars, freeVars);
1517
1518         SymMatrixMultiply('L', 'U', 1, 0, hessMat, rijMat, infoMat);  // result not symmetric!
1519
1520         double *ihess = fc->getDenseIHessUninitialized();
1521         int singular;
1522         if (semFixSymmetry) {
1523                 MeanSymmetric(infoMat);
1524                 singular = InvertSymmetricIndef(infoMat, 'U');
1525                 memcpy(ihess, infoBuf.data(), sizeof(double) * freeVars * freeVars);
1526         } else {
1527                 Matrix ihessMat(ihess, freeVars, freeVars);
1528                 singular = MatrixSolve(infoMat, ihessMat, true);
1529         }
1530         if (singular) {
1531                 if (verbose >= 1) mxLog("ComputeEM: SEM Hessian is singular %d", singular);
1532                 return;
1533         }
1534
1535         if (semForcePD) {
1536                 double *oev = NULL;
1537                 if (semDebug) {
1538                         Rf_protect(origEigenvalues = Rf_allocVector(REALSXP, freeVars));
1539                         oev = REAL(origEigenvalues);
1540                 }
1541                 Matrix mat(ihess, freeVars, freeVars);
1542                 InplaceForcePosSemiDef(mat, oev, &fc->infoCondNum);
1543         }
1544
1545         if (semDebug) {
1546                 // ihess is always symmetric, this could be asymmetric
1547                 Rf_protect(outputInfoMatrix = Rf_allocMatrix(REALSXP, freeVars, freeVars));
1548                 memcpy(REAL(outputInfoMatrix), ihess, sizeof(double) * freeVars * freeVars);
1549         }
1550
1551         fc->wanted = wanted | FF_COMPUTE_IHESSIAN;
1552         //pda(fc->ihess, freeVars, freeVars);
1553 }
1554
1555 void ComputeEM::collectResults(FitContext *fc, LocalComputeResult *lcr, MxRList *out)
1556 {
1557         super::collectResults(fc, lcr, out);
1558
1559         std::vector< omxCompute* > clist(3);
1560         clist[0] = fit1;
1561         clist[1] = fit2;
1562         clist[2] = fit3;
1563
1564         collectResultsHelper(fc, clist, lcr, out);
1565 }
1566
1567 void ComputeEM::reportResults(FitContext *fc, MxRList *slots, MxRList *)
1568 {
1569         size_t numFree = fc->varGroup->vars.size();
1570         if (!numFree) return;
1571
1572         MxRList out;
1573         out.add("EMcycles", Rf_ScalarInteger(EMcycles));
1574         out.add("totalMstep", Rf_ScalarInteger(totalMstepIter));
1575         out.add("semProbeCount", Rf_ScalarInteger(semProbeCount));
1576         slots->add("output", out.asR());
1577
1578         if (semDebug) {
1579                 const int freeVars = (int) fc->varGroup->vars.size();
1580                 MxRList dbg;
1581
1582                 if (probeOffset.size()) {
1583                         SEXP Rpo;
1584                         Rf_protect(Rpo = Rf_allocMatrix(REALSXP, maxHistLen, freeVars));
1585                         memcpy(REAL(Rpo), probeOffset.data(), sizeof(double) * maxHistLen * freeVars);
1586                         dbg.add("probeOffset", Rpo);
1587                 }
1588
1589                 if (diffWork.size()) {
1590                         SEXP Rdiff;
1591                         Rf_protect(Rdiff = Rf_allocMatrix(REALSXP, maxHistLen, freeVars));
1592                         memcpy(REAL(Rdiff), diffWork.data(), sizeof(double) * maxHistLen * freeVars);
1593                         dbg.add("semDiff", Rdiff);
1594                 }
1595
1596                 if (paramHistLen.size()) {
1597                         SEXP Rphl;
1598                         Rf_protect(Rphl = Rf_allocVector(INTSXP, freeVars));
1599                         memcpy(INTEGER(Rphl), paramHistLen.data(), sizeof(int) * freeVars);
1600                         dbg.add("paramHistLen", Rphl);
1601                 }
1602
1603                 if (inputInfoMatrix) dbg.add("inputInfo", inputInfoMatrix);
1604                 if (outputInfoMatrix) dbg.add("outputInfo", outputInfoMatrix);
1605                 if (rateMatrix) dbg.add("rateMatrix", rateMatrix);
1606                 if (origEigenvalues) dbg.add("origEigenvalues", origEigenvalues);
1607
1608                 slots->add("debug", dbg.asR());
1609         }
1610 }
1611
1612 ComputeEM::~ComputeEM()
1613 {
1614         for (size_t rx=0; rx < ramsay.size(); ++rx) {
1615                 delete ramsay[rx];
1616         }
1617         ramsay.clear();
1618
1619         delete fit1;
1620         delete fit2;
1621         delete fit3;
1622
1623         for (size_t hx=0; hx < estHistory.size(); ++hx) {
1624                 delete [] estHistory[hx];
1625         }
1626         estHistory.clear();
1627 }
1628
1629 enum ComputeInfoMethod omxCompute::stringToInfoMethod(const char *iMethod)
1630 {
1631         enum ComputeInfoMethod infoMethod = INFO_METHOD_DEFAULT; // to avoid gcc warning
1632         if (strcmp(iMethod, "sandwich")==0) {
1633                 infoMethod = INFO_METHOD_SANDWICH;
1634         } else if (strcmp(iMethod, "meat")==0) {
1635                 infoMethod = INFO_METHOD_MEAT;
1636         } else if (strcmp(iMethod, "bread")==0) {
1637                 infoMethod = INFO_METHOD_BREAD;
1638         } else if (strcmp(iMethod, "hessian")==0) {
1639                 infoMethod = INFO_METHOD_HESSIAN;
1640         } else {
1641                 Rf_error("Unknown information matrix estimation method '%s'", iMethod);
1642         }
1643         return infoMethod;
1644 }
1645
1646 void omxComputeOnce::initFromFrontend(SEXP rObj)
1647 {
1648         super::initFromFrontend(rObj);
1649
1650         SEXP slotValue;
1651         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("from")));
1652         for (int wx=0; wx < Rf_length(slotValue); ++wx) {
1653                 int objNum = INTEGER(slotValue)[wx];
1654                 if (objNum >= 0) {
1655                         omxMatrix *algebra = globalState->algebraList[objNum];
1656                         if (algebra->fitFunction) {
1657                                 setFreeVarGroup(algebra->fitFunction, varGroup);
1658                                 omxCompleteFitFunction(algebra);
1659                         }
1660                         algebras.push_back(algebra);
1661                 } else {
1662                         omxExpectation *expectation = globalState->expectationList[~objNum];
1663                         setFreeVarGroup(expectation, varGroup);
1664                         omxCompleteExpectation(expectation);
1665                         expectations.push_back(expectation);
1666                 }
1667         }
1668
1669         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("verbose")));
1670         verbose = Rf_asInteger(slotValue);
1671
1672         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("what")));
1673         int whatLen = Rf_length(slotValue);
1674         if (algebras.size()) {
1675                 for (int wx=0; wx < whatLen; ++wx) {
1676                         SEXP elem;
1677                         Rf_protect(elem = STRING_ELT(slotValue, wx));
1678                         const char *what = CHAR(elem);
1679                         if      (strcmp(what, "maxAbsChange")==0) mac = true;
1680                         else if (strcmp(what, "set-starting-values")==0) starting = true;
1681                         else if (strcmp(what, "fit")         ==0) fit = true;
1682                         else if (strcmp(what, "gradient")    ==0) gradient = true;
1683                         else if (strcmp(what, "hessian")     ==0) hessian = true;
1684                         else if (strcmp(what, "information") ==0) infoMat = true;
1685                         else if (strcmp(what, "ihessian")    ==0) ihessian = true;
1686                         else omxRaiseErrorf(globalState, "mxComputeOnce: don't know how to compute %s", what);
1687                 }
1688
1689                 if (hessian && infoMat) Rf_error("Cannot compute the Hessian and Fisher Information matrix simultaneously");
1690         } else {
1691                 for (int wx=0; wx < whatLen; ++wx) {
1692                         SEXP elem;
1693                         Rf_protect(elem = STRING_ELT(slotValue, wx));
1694                         predict.push_back(CHAR(elem));
1695                 }
1696         }
1697
1698         Rf_protect(slotValue = R_do_slot(rObj, Rf_install(".is.bestfit")));
1699         isBestFit = Rf_asLogical(slotValue);
1700
1701         bool howConflict = false;
1702         Rf_protect(slotValue = R_do_slot(rObj, Rf_install("how")));
1703         if (Rf_length(slotValue) > 1) {
1704                 omxRaiseErrorf(globalState, "mxComputeOnce: more than one method specified");
1705         } else if (Rf_length(slotValue) == 1) {
1706                 SEXP elem;
1707                 Rf_protect(elem = STRING_ELT(slotValue, 0));
1708                 if (algebras.size()) {
1709                         const char *iMethod = CHAR(elem);
1710                         if (infoMat) {
1711                                 infoMethod = stringToInfoMethod(iMethod);
1712                                 if (infoMethod == INFO_METHOD_MEAT && gradient && whatLen == 2) {
1713                                         //OK
1714                                 } else if (whatLen > 1) {
1715                                         howConflict = true;
1716                                 }
1717                         } else {
1718                                 omxRaiseErrorf(globalState, "mxComputeOnce: unknown method %s requested", iMethod);
1719                         }
1720                 } else {
1721                         how = CHAR(elem);
1722                         if (whatLen > 1) howConflict = true;
1723                 }
1724         }
1725         if (howConflict) {
1726                 omxRaiseErrorf(globalState, "mxComputeOnce: when how is specified, you can only compute one thing at a time");
1727         }
1728
1729         if (algebras.size() == 1 && algebras[0]->fitFunction) {
1730                 omxFitFunction *ff = algebras[0]->fitFunction;
1731                 if (gradient && !ff->gradientAvailable) {
1732                         Rf_error("Gradient requested but not available");
1733                 }
1734                 if ((hessian || ihessian || hgprod) && !ff->hessianAvailable) {
1735                         // add a separate flag for hgprod TODO
1736                         Rf_error("Hessian requested but not available");
1737                 }
1738                 // add check for information TODO
1739         }
1740 }
1741
1742 omxFitFunction *omxComputeOnce::getFitFunction()
1743 {
1744         if (algebras.size() == 1 && algebras[0]->fitFunction) {
1745                 return algebras[0]->fitFunction;
1746         } else {
1747                 return NULL;
1748         }
1749 }
1750
1751 void omxComputeOnce::computeImpl(FitContext *fc)
1752 {
1753         if (algebras.size()) {
1754                 int want = 0;
1755                 if (starting) {
1756                         want |= FF_COMPUTE_STARTING;
1757                 }
1758                 if (mac) {
1759                         want |= FF_COMPUTE_MAXABSCHANGE;
1760                         fc->mac = 0;
1761                 }
1762                 if (fit) {
1763                         want |= FF_COMPUTE_FIT;
1764                         if (isBestFit) want |= FF_COMPUTE_BESTFIT;
1765                         fc->fit = 0;
1766                 }
1767                 if (gradient) {
1768                         want |= FF_COMPUTE_GRADIENT;
1769                         fc->grad = Eigen::VectorXd::Zero(fc->numParam);
1770                 }
1771                 if (hessian) {
1772                         want |= FF_COMPUTE_HESSIAN;
1773                         fc->clearHessian();
1774                 }
1775                 if (infoMat) {
1776                         want |= FF_COMPUTE_INFO;
1777                         fc->infoMethod = infoMethod;
1778                         fc->grad = Eigen::VectorXd::Zero(fc->numParam);
1779                         fc->clearHessian();
1780                         fc->preInfo();
1781                 }
1782                 if (ihessian) {
1783                         want |= FF_COMPUTE_IHESSIAN;
1784                         fc->clearHessian();
1785                 }
1786                 if (!want) return;
1787
1788                 for (size_t wx=0; wx < algebras.size(); ++wx) {
1789                         omxMatrix *algebra = algebras[wx];
1790                         if (algebra->fitFunction) {
1791                                 omxFitFunctionCompute(algebra->fitFunction, FF_COMPUTE_PREOPTIMIZE, fc);
1792                                 omxFitFunctionCompute(algebra->fitFunction, want, fc);
1793                                 fc->fit = algebra->data[0];
1794                                 if (infoMat) {
1795                                         fc->postInfo();
1796                                 }
1797                         } else {
1798                                 omxForceCompute(algebra);
1799                         }
1800                 }
1801         } else if (expectations.size()) {
1802                 if (predict.size() > 1) Rf_error("Not implemented");
1803                 for (size_t wx=0; wx < expectations.size(); ++wx) {
1804                         omxExpectation *expectation = expectations[wx];
1805                         omxExpectationCompute(expectation, predict[0], how);
1806                 }
1807         }
1808 }
1809
1810 void omxComputeOnce::reportResults(FitContext *fc, MxRList *slots, MxRList *out)
1811 {
1812         if (algebras.size()==0 || algebras[0]->fitFunction == NULL) return;
1813
1814         omxMatrix *algebra = algebras[0];
1815         omxPopulateFitFunction(algebra, out);
1816 }
1817
1818 void ComputeStandardError::reportResults(FitContext *fc, MxRList *slots, MxRList *)
1819 {
1820         fc->allocStderrs();  // at least report NAs
1821
1822         const size_t numParams = fc->numParam;
1823
1824         Eigen::VectorXd ihessDiag(fc->ihessDiag());
1825
1826         const double scale = fabs(Global->llScale);
1827
1828         // This function calculates the standard errors from the Hessian matrix
1829         // sqrt(scale * diag(solve(hessian)))
1830
1831         for(size_t i = 0; i < numParams; i++) {
1832                 double got = ihessDiag[i];
1833                 if (got <= 0) continue;
1834                 fc->stderrs[i] = sqrt(scale * got);
1835         }
1836 }
1837
1838 /*
1839 Date: Fri, 3 Jan 2014 14:02:34 -0600
1840 From: Michael Hunter <mhunter@ou.edu>
1841
1842 Determining positive definiteness of matrix is typically done by
1843 trying the Cholesky decomposition.  If it fails, the matrix is not
1844 positive definite; if it passes, the matrix is.  The benefit of the
1845 Cholesky is that it's much faster and easier to compute than a set of
1846 eigenvalues.
1847
1848 The BLAS/LAPACK routine DTRCO quickly computes a good approximation to the
1849 reciprocal condition number of a triangular matrix.  Hand it the Cholesky
1850 (a triangular matrix) the rest is history.  I don't think we need the
1851 exact condition number as long as it's just for finding very
1852 ill-conditioned problems.  For the solution to a linear system of
1853 equations, if you really care about the difference in precision between
1854 1e-14 and 1e-11, then the exact condition number is needed.  Otherwise, the
1855 approximation is faster and equally useful.
1856 */
1857 void ComputeHessianQuality::reportResults(FitContext *fc, MxRList *slots, MxRList *)
1858 {
1859         // See Luenberger & Ye (2008) Second Order Test (p. 190) and Condition Number (p. 239)
1860
1861         // memcmp is required here because NaN != NaN always
1862         if (fc->infoDefinite != NA_LOGICAL ||
1863             memcmp(&fc->infoCondNum, &NA_REAL, sizeof(double)) != 0) return; // already set elsewhere
1864
1865         int numParams = int(fc->varGroup->vars.size());
1866
1867         double *mat = fc->getDenseHessianish();
1868         omxBuffer<double> hessWork(numParams * numParams);
1869         memcpy(hessWork.data(), mat, sizeof(double) * numParams * numParams);
1870
1871         char jobz = 'N';
1872         char range = 'A';
1873         char uplo = 'U';
1874         double abstol = 0;
1875         int m;
1876         omxBuffer<double> w(numParams);
1877         double optWork;
1878         int lwork = -1;
1879         omxBuffer<int> iwork(5 * numParams);
1880         int info;
1881         double realIgn = 0;
1882         int intIgn = 0;
1883         F77_CALL(dsyevx)(&jobz, &range, &uplo, &numParams, hessWork.data(),
1884                          &numParams, &realIgn, &realIgn, &intIgn, &intIgn, &abstol, &m, w.data(),
1885                          NULL, &numParams, &optWork, &lwork, iwork.data(), NULL, &info);
1886
1887         lwork = optWork;
1888         omxBuffer<double> work(lwork);
1889         F77_CALL(dsyevx)(&jobz, &range, &uplo, &numParams, hessWork.data(),
1890                          &numParams, &realIgn, &realIgn, &intIgn, &intIgn, &abstol, &m, w.data(),
1891                          NULL, &numParams, work.data(), &lwork, iwork.data(), NULL, &info);
1892         if (info < 0) {
1893                 Rf_error("dsyevx %d", info);
1894         } else if (info) {
1895                 return;
1896         }
1897
1898         bool definite = true;
1899         bool neg = w[0] < 0;
1900         for (int px=1; px < numParams; ++px) {
1901                 if ((w[px] < 0) ^ neg) {
1902                         definite = false;
1903                         break;
1904                 }
1905         }
1906
1907         fc->infoDefinite = definite;
1908
1909         if (definite) {
1910                 double ev[2] = { fabs(w[0]), fabs(w[numParams-1]) };
1911                 if (ev[0] < ev[1]) std::swap(ev[0], ev[1]);
1912                 double got = ev[0] / ev[1];
1913                 if (std::isfinite(got)) fc->infoCondNum = got;
1914         }
1915 }
1916
1917 void ComputeReportDeriv::reportResults(FitContext *fc, MxRList *, MxRList *result)
1918 {
1919         size_t numFree = fc->numParam;
1920
1921         if (fc->wanted & FF_COMPUTE_GRADIENT) {
1922                 if (!fc->grad.data()) {
1923                         Rf_warning("ComputeReportDeriv: Gradient requested but not available");
1924                 } else {
1925                         SEXP Rgradient;
1926                         Rf_protect(Rgradient = Rf_allocVector(REALSXP, numFree));
1927                         memcpy(REAL(Rgradient), fc->grad.data(), sizeof(double) * numFree);
1928                         result->add("gradient", Rgradient);
1929                 }
1930         }
1931         if (fc->wanted & FF_COMPUTE_HESSIAN) {
1932                 SEXP Rhessian;
1933                 Rf_protect(Rhessian = Rf_allocMatrix(REALSXP, numFree, numFree));
1934                 fc->copyDenseHess(REAL(Rhessian));
1935                 result->add("hessian", Rhessian);
1936         }
1937         if (fc->wanted & FF_COMPUTE_IHESSIAN) {
1938                 SEXP Rihessian;
1939                 Rf_protect(Rihessian = Rf_allocMatrix(REALSXP, numFree, numFree));
1940                 fc->copyDenseIHess(REAL(Rihessian));
1941                 result->add("ihessian", Rihessian);
1942         }
1943 }