Store algebraList in std::vector
[openmx:openmx.git] / src / omxExportBackendState.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 #include "R.h"
18 #include <Rinternals.h>
19 #include <Rdefines.h>
20
21 #include <sys/stat.h>
22
23 #include "omxDefines.h"
24 #include "omxState.h"
25 #include "omxNPSOLSpecific.h"
26 #include "npsolWrap.h"
27
28 void omxFinalAlgebraCalculation(omxState *currentState, SEXP matrices, SEXP algebras, SEXP expectations) {
29         SEXP nextMat, algebra;
30         for(size_t index = 0; index < currentState->matrixList.size(); index++) {
31                 if(OMX_DEBUG) { Rprintf("Final Calculation and Copy of Matrix %d.\n", index); }
32                 omxMatrix* nextMatrix = currentState->matrixList[index];
33                 omxRecompute(nextMatrix);
34                 nextMat = omxExportMatrix(nextMatrix);
35                 SET_VECTOR_ELT(matrices, index, nextMat);
36         }
37
38         for(size_t index = 0; index < currentState->algebraList.size(); index++) {
39                 if(OMX_DEBUG) { Rprintf("Final Calculation and Copy of Algebra %d.\n", index); }
40                 omxMatrix* nextAlgebra = currentState->algebraList[index];
41                 omxRecompute(nextAlgebra);
42                 algebra = omxExportMatrix(nextAlgebra);
43                 /* If an fit function, populate attributes.  Will skip if not fit function. */
44                 omxFitFunction* currentFit = nextAlgebra->fitFunction;
45                 if(currentFit != NULL) {
46                         if(OMX_DEBUG) { Rprintf("Algebra %d is a fit function.\n", index); }
47                         if(currentFit->populateAttrFun != NULL) {
48                                 if(OMX_DEBUG) { Rprintf("Algebra %d has attribute population.\n", index); }
49                                 currentFit->populateAttrFun(currentFit, algebra);
50                     }
51                 }
52
53                 if(OMX_DEBUG) { Rprintf("Final Calculation of Algebra %d Complete.\n", index); }
54                 SET_VECTOR_ELT(algebras, index, algebra);
55         }
56         if(OMX_DEBUG) { Rprintf("All Algebras complete.\n"); }
57         
58         for(int index = 0; index < currentState->numExpects; index++) {
59                 if(OMX_DEBUG) { Rprintf("Final Calculation of Expectation %d.\n", index); }
60                 omxExpectation* nextExpectation = currentState->expectationList[index];
61                 omxExpectationRecompute(nextExpectation);
62                 SEXP rExpect;
63                 PROTECT(rExpect = allocVector(LGLSXP, 1));
64                 if(nextExpectation->populateAttrFun != NULL) {
65                         if(OMX_DEBUG) { Rprintf("Expectation %d has attribute population.\n", index); }
66                         nextExpectation->populateAttrFun(nextExpectation, rExpect);
67             }
68                 SET_VECTOR_ELT(expectations, index, rExpect);
69         }
70 }
71
72 void omxPopulateFitFunction(omxState *currentState, int numReturns, SEXP *ans, SEXP *names) {
73         omxMatrix* om = currentState->fitMatrix;
74         if(om != NULL) {                                        // In the event of a no-fit function run.
75                 omxFitFunction* off = om->fitFunction;
76                 if(OMX_DEBUG) { Rprintf("Checking for additional fit function info.\n"); }
77
78                 if(off != NULL && off->setFinalReturns != NULL) {
79                         if(OMX_DEBUG) { Rprintf("Expecting fit function Info....");}
80                         int numEls;
81                         SEXP oElement;
82                         omxRListElement* orle = off->setFinalReturns(off, &numEls);
83                         PROTECT(*ans = allocVector(VECSXP, numReturns + numEls));
84                         PROTECT(*names = allocVector(STRSXP, numReturns + numEls));
85                         if(numEls != 0) {
86                                 if(OMX_DEBUG) { Rprintf("Adding %d sets of fit function Info....", numEls);}
87                                 for(int i = 0; i < numEls; i++) {
88                                         if (orle[i].numValues == -1) {
89                                                 PROTECT(oElement = allocMatrix(REALSXP, orle[i].rows, orle[i].cols));
90                                         } else {
91                                                 PROTECT(oElement = allocVector(REALSXP, orle[i].numValues));
92                                         }
93                                         memcpy(REAL(oElement), orle[i].values, sizeof(double)*LENGTH(oElement)); // TODO avoid another copy
94                                         SET_STRING_ELT(*names, i+numReturns, mkChar(orle[i].label));
95                                         SET_VECTOR_ELT(*ans, i+numReturns, oElement);
96                                 }
97                         }
98                 } else {
99                         PROTECT(*ans = allocVector(VECSXP, numReturns));
100                         PROTECT(*names = allocVector(STRSXP, numReturns));
101                 }
102                 if(OMX_DEBUG) { Rprintf("Done.\n");}
103         } else {
104                 PROTECT(*ans = allocVector(VECSXP, numReturns));
105                 PROTECT(*names = allocVector(STRSXP, numReturns));
106         }
107 }
108
109 void omxPopulateHessians(int numHessians, omxMatrix* currentFit, 
110                 SEXP calculatedHessian, SEXP stdErrors, int calculateStdErrors, int n) {
111         if(OMX_DEBUG) { Rprintf("Populating hessians for %d fit functions.\n", numHessians); }
112         omxFitFunction* off = currentFit->fitFunction;
113         if(off->hessian == NULL) {
114                 if(OMX_DEBUG) { Rprintf("Fit function 0 has no hessian. Aborting.\n");}
115                 return;
116         }
117
118         if(OMX_DEBUG) { Rprintf("Fit function 0 has hessian at 0x%x.\n", off->hessian);}
119
120         double* hessian  = REAL(calculatedHessian);
121         double* stdError = REAL(stdErrors);
122         for(int k = 0; k < n * n; k++) {
123                 if(OMX_DEBUG) {Rprintf("Populating hessian at %d.\n", k);}
124                 hessian[k] = off->hessian[k];           // For expediency, ignore majority for symmetric matrices.
125         }
126         if(calculateStdErrors) {
127                 if(off->stdError == NULL) {
128                         for(int k = 0; k < n; k++) {
129                                 if(OMX_DEBUG) {Rprintf("Populating NA standard error at %d.\n", k);}
130                                 stdError[k] = R_NaReal;
131                         }
132                 } else {
133                         for(int k = 0; k < n; k++) {
134                                 if(OMX_DEBUG) {Rprintf("Populating standard error at %d.\n", k);}
135                                 stdError[k] = off->stdError[k];
136                         }
137                 }
138         }
139 }
140
141 void omxPopulateConfidenceIntervals(omxState* currentState, SEXP intervals, SEXP intervalCodes) {
142         int numInts = currentState->numIntervals;
143         if(OMX_DEBUG) { Rprintf("Populating CIs for %d fit functions.\n", numInts); }
144         double* interval = REAL(intervals);
145         int* intervalCode = INTEGER(intervalCodes);
146         for(int j = 0; j < numInts; j++) {
147                 omxConfidenceInterval *oCI = &(currentState->intervalList[j]);
148                 interval[j] = oCI->min;
149                 interval[j + numInts] = oCI->max;
150                 intervalCode[j] = oCI->lCode;
151                 intervalCode[j + numInts] = oCI->uCode;
152         }
153 }