Store matrixList as a std::vector
[openmx:openmx.git] / src / omxFitFunction.cpp
1 /*
2  *  Copyright 2007-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 /***********************************************************
18
19 *  omxFitFunction.cc
20 *
21 *  Created: Timothy R. Brick    Date: 2008-11-13 12:33:06
22 *
23 *       FitFunction objects are a subclass of data matrix that evaluates
24 *   itself anew at each iteration, so that any changes to
25 *   free parameters can be incorporated into the update.
26 *   // Question: Should FitFunction be a ``subtype'' of 
27 *   // omxAlgebra or a separate beast entirely?
28 *
29 **********************************************************/
30
31 #include "omxFitFunction.h"
32 #include "omxOptimizer.h"
33
34 typedef struct omxFitFunctionTableEntry omxFitFunctionTableEntry;
35
36 struct omxFitFunctionTableEntry {
37
38         char name[32];
39         void (*initFun)(omxFitFunction*, SEXP);
40
41 };
42
43 extern void omxInitAlgebraFitFunction(omxFitFunction *off, SEXP rObj);
44 extern void omxInitWLSFitFunction(omxFitFunction *off, SEXP rObj);
45 extern void omxInitRowFitFunction(omxFitFunction *off, SEXP rObj);
46 extern void omxInitMLFitFunction(omxFitFunction *off, SEXP rObj);
47 extern void omxInitRFitFunction(omxFitFunction *off, SEXP rObj);
48
49 static const omxFitFunctionTableEntry omxFitFunctionSymbolTable[] = {
50         {"MxFitFunctionAlgebra",                        &omxInitAlgebraFitFunction},
51         {"MxFitFunctionWLS",                            &omxInitWLSFitFunction},
52         {"MxFitFunctionRow",                            &omxInitRowFitFunction},
53         {"MxFitFunctionML",                             &omxInitMLFitFunction},
54         {"MxFitFunctionR",                                      &omxInitRFitFunction},
55         {"", 0}
56 };
57
58 void omxCalculateStdErrorFromHessian(double scale, omxFitFunction *off) {
59         /* This function calculates the standard errors from the hessian matrix */
60         // sqrt(diag(solve(hessian)))
61
62         if(off->hessian == NULL) return;
63         
64         int numParams = off->matrix->currentState->numFreeParams;
65         
66         if(off->stdError == NULL) {
67                 off->stdError = (double*) R_alloc(numParams, sizeof(double));
68         }
69         
70         double* stdErr = off->stdError;
71         
72         double* hessian = off->hessian;
73         double* workspace = (double *) Calloc(numParams * numParams, double);
74         
75         for(int i = 0; i < numParams; i++)
76                 for(int j = 0; j <= i; j++)
77                         workspace[i*numParams+j] = hessian[i*numParams+j];              // Populate upper triangle
78         
79         char u = 'U';
80         int ipiv[numParams];
81         int lwork = -1;
82         double temp;
83         int info = 0;
84         
85         F77_CALL(dsytrf)(&u, &numParams, workspace, &numParams, ipiv, &temp, &lwork, &info);
86         
87         lwork = (temp > numParams?temp:numParams);
88         
89         double* work = (double*) Calloc(lwork, double);
90         
91         F77_CALL(dsytrf)(&u, &numParams, workspace, &numParams, ipiv, work, &lwork, &info);
92         
93         if(info != 0) {
94                 
95                 off->stdError = NULL;
96                 
97         } else {
98                 
99                 F77_CALL(dsytri)(&u, &numParams, workspace, &numParams, ipiv, work, &info);
100         
101                 if(info != 0) {
102                         off->stdError = NULL;
103                 } else {
104                         for(int i = 0; i < numParams; i++) {
105                                 stdErr[i] = sqrt(scale) * sqrt(workspace[i * numParams + i]);
106                         }
107                 }
108         }
109         
110         Free(workspace);
111         Free(work);
112         
113 }
114
115 void omxInitEmptyFitFunction(omxFitFunction *off) {
116         /* Sets everything to NULL to avoid bad pointer calls */
117         
118         memset(off, 0, sizeof(omxFitFunction));
119 }
120
121 void omxFreeFitFunctionArgs(omxFitFunction *off) {
122         if(off==NULL) return;
123     
124         /* Completely destroy the fit function structures */
125         if(OMX_DEBUG) {Rprintf("Freeing fit function object at 0x%x.\n", off);}
126         if(off->matrix != NULL) {
127                 if(off->destructFun != NULL) {
128                         if(OMX_DEBUG) {Rprintf("Calling fit function destructor for 0x%x.\n", off);}
129                         off->destructFun(off);
130                 }
131                 off->matrix = NULL;
132         }
133 }
134
135 void omxFitFunctionCreateChildren(omxState *globalState, int numThreads)
136 {
137         if (numThreads <= 1) return;
138
139         omxMatrix *fm = globalState->fitMatrix;
140         if (!fm) return;
141
142         omxFitFunction *ff = fm->fitFunction;
143         if (!ff->usesChildModels) return;
144
145         globalState->numChildren = numThreads;
146
147         globalState->childList = (omxState**) Calloc(numThreads, omxState*);
148
149         for(int ii = 0; ii < numThreads; ii++) {
150                 globalState->childList[ii] = new omxState;
151                 omxInitState(globalState->childList[ii], globalState);
152                 omxDuplicateState(globalState->childList[ii], globalState);
153         }
154 }
155
156 void omxDuplicateFitMatrix(omxMatrix *tgt, const omxMatrix *src, omxState* newState) {
157
158         if(tgt == NULL || src == NULL) return;
159         if(src->fitFunction == NULL) return;
160     
161         omxFillMatrixFromMxFitFunction(tgt, src->fitFunction->rObj, src->hasMatrixNumber, src->matrixNumber);
162
163 }
164
165 omxFitFunction* omxCreateDuplicateFitFunction(omxFitFunction *tgt, const omxFitFunction *src, omxState* newState) {
166
167         if(OMX_DEBUG) {Rprintf("Duplicating fit function 0x%x into 0x%x.", src, tgt);}
168
169         if(src == NULL) {
170                 return NULL;
171         }
172         
173         if(tgt == NULL) {
174         tgt = (omxFitFunction*) R_alloc(1, sizeof(omxFitFunction));
175         omxInitEmptyFitFunction(tgt);
176     } else {
177                 omxRaiseError(newState, -1,
178                         "omxCreateDuplicateFitFunction requested to overwrite target");
179                 return NULL;
180         }
181
182         memcpy(tgt, src, sizeof(omxFitFunction));
183         return tgt;
184
185 }
186
187 void omxFitFunctionCompute(omxFitFunction *off, int want, double* gradient) {
188         if(OMX_DEBUG_ALGEBRA) { 
189             Rprintf("FitFunction compute: 0x%0x (needed: %s).\n", off, (off->matrix->isDirty?"Yes":"No"));
190         }
191
192         off->computeFun(off, want, gradient);
193
194         omxMarkClean(off->matrix);
195 }
196
197 void omxFillMatrixFromMxFitFunction(omxMatrix* om, SEXP rObj,
198         unsigned short hasMatrixNumber, int matrixNumber) {
199
200         SEXP slotValue, fitFunctionClass;
201         omxFitFunction *obj = (omxFitFunction*) R_alloc(1, sizeof(omxFitFunction));
202         omxInitEmptyFitFunction(obj);
203
204         /* Register FitFunction and Matrix with each other */
205         obj->matrix = om;
206         omxResizeMatrix(om, 1, 1, FALSE);                                       // FitFunction matrices MUST be 1x1.
207         om->fitFunction = obj;
208         om->hasMatrixNumber = hasMatrixNumber;
209         om->matrixNumber = matrixNumber;
210         
211         /* Get FitFunction Type */
212         PROTECT(fitFunctionClass = STRING_ELT(getAttrib(rObj, install("class")), 0));
213         {
214           const char *fitType = CHAR(fitFunctionClass);
215         
216           /* Switch based on fit function type. */ 
217           const omxFitFunctionTableEntry *entry = omxFitFunctionSymbolTable;
218           while (entry->initFun) {
219             if(strncmp(fitType, entry->name, MAX_STRING_LEN) == 0) {
220               obj->fitType = entry->name;
221               obj->initFun = entry->initFun;
222               break;
223             }
224             entry += 1;
225           }
226
227           if(obj->initFun == NULL) {
228             const int MaxErrorLen = 256;
229             char newError[MaxErrorLen];
230             snprintf(newError, MaxErrorLen, "Fit function %s not implemented.\n", fitType);
231             omxRaiseError(om->currentState, -1, newError);
232             return;
233           }
234         }
235         UNPROTECT(1);   /* fitType */
236
237         PROTECT(slotValue = GET_SLOT(rObj, install("expectation")));
238         if (LENGTH(slotValue) != 1) {
239             const int MaxErrorLen = 256;
240             char newError[MaxErrorLen];
241             snprintf(newError, MaxErrorLen, "Fit function %s expectation improperly initialized\n", obj->fitType);
242             error(newError);
243         }
244         int expNumber = INTEGER(slotValue)[0];  
245         if(expNumber == NA_INTEGER) {                                           // Has no expectation associated with it
246                 obj->expectation = NULL;
247         } else {
248                 obj->expectation = omxExpectationFromIndex(expNumber, om->currentState);
249         }
250         UNPROTECT(1);   /* slotValue */
251         
252         if (om->currentState->statusMsg[0]) return;
253
254         obj->rObj = rObj;
255         obj->initFun(obj, rObj);
256
257         if(obj->computeFun == NULL) {// If initialization fails, error code goes in argStruct
258                 const char *errorCode;
259                 if(om->currentState->statusCode != 0) {
260                         errorCode = om->currentState->statusMsg;
261                 } else {
262                         // If no error code is reported, we report that.
263                         errorCode = "No error code reported.";
264                 }
265                 if(obj->argStruct != NULL) {
266                         errorCode = (char*)(obj->argStruct);
267                 }
268         const int MaxErrorLen = 256;
269         char newError[MaxErrorLen];
270         snprintf(newError, MaxErrorLen, "Could not initialize fit function %s.  Error: %s\n",
271                         obj->fitType, errorCode); 
272                 omxRaiseError(om->currentState, -1, newError);
273         }
274         
275         obj->matrix->isDirty = TRUE;
276
277 }
278
279 void omxFitFunctionPrint(omxFitFunction* off, const char* d) {
280         Rprintf("(FitFunction, type %s) ", off->fitType);
281         omxPrintMatrix(off->matrix, d);
282 }
283
284
285 /* Helper functions */
286 omxMatrix* omxNewMatrixFromSlot(SEXP rObj, omxState* currentState, const char* slotName) {
287         SEXP slotValue;
288         PROTECT(slotValue = GET_SLOT(rObj, install(slotName)));
289         omxMatrix* newMatrix = omxMatrixLookupFromState1(slotValue, currentState);
290         if (newMatrix) omxRecompute(newMatrix);
291         UNPROTECT(1);
292         return newMatrix;
293 }
294