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