Enable R_NO_REMAP for a cleaner namespace
[openmx:openmx.git] / src / omxExportBackendState.cpp
1 /*
2  *  Copyright 2007-2014 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 <sys/stat.h>
18
19 #define R_NO_REMAP
20 #include <R.h>
21 #include <Rinternals.h>
22
23 #include "omxDefines.h"
24 #include "omxState.h"
25 #include "omxNPSOLSpecific.h"
26 #include "glue.h"
27 #include "omxExportBackendState.h"
28
29 void omxExportResults(omxState *currentState, MxRList *out)
30 {
31         SEXP matrices;
32         SEXP algebras;
33         SEXP expectations;
34
35         Rf_protect(matrices = Rf_allocVector(VECSXP, globalState->matrixList.size()));
36         Rf_protect(algebras = Rf_allocVector(VECSXP, globalState->algebraList.size()));
37         Rf_protect(expectations = Rf_allocVector(VECSXP, globalState->expectationList.size()));
38
39         SEXP nextMat, algebra;
40         for(size_t index = 0; index < currentState->matrixList.size(); index++) {
41                 if(OMX_DEBUG) { mxLog("Final Calculation and Copy of Matrix %lu.", index); }
42                 omxMatrix* nextMatrix = currentState->matrixList[index];
43                 omxRecompute(nextMatrix);
44                 nextMat = omxExportMatrix(nextMatrix);
45                 SET_VECTOR_ELT(matrices, index, nextMat);
46         }
47
48         for(size_t index = 0; index < currentState->algebraList.size(); index++) {
49                 if(OMX_DEBUG) { mxLog("Final Calculation and Copy of Algebra %lu.", index); }
50                 omxMatrix* nextAlgebra = currentState->algebraList[index];
51                 omxInitialCompute(nextAlgebra);
52                 algebra = omxExportMatrix(nextAlgebra);
53                 /* If an fit function, populate attributes.  Will skip if not fit function. */
54                 omxFitFunction* currentFit = nextAlgebra->fitFunction;
55                 if(currentFit != NULL) {
56                         if(OMX_DEBUG) { mxLog("Algebra %lu is a fit function.", index); }
57                         if(currentFit->populateAttrFun != NULL) {
58                                 if(OMX_DEBUG) { mxLog("Algebra %lu has attribute population.", index); }
59                                 currentFit->populateAttrFun(currentFit, algebra);
60                     }
61                 }
62
63                 if(OMX_DEBUG) { mxLog("Final Calculation of Algebra %lu Complete.", index); }
64                 SET_VECTOR_ELT(algebras, index, algebra);
65         }
66         if(OMX_DEBUG) { mxLog("All Algebras complete."); }
67         
68         for(size_t index = 0; index < currentState->expectationList.size(); index++) {
69                 if(OMX_DEBUG) { mxLog("Final Calculation of Expectation %lu.", index); }
70                 omxExpectation* nextExpectation = currentState->expectationList[index];
71                 omxExpectationRecompute(nextExpectation);
72                 SEXP rExpect;
73                 Rf_protect(rExpect = Rf_allocVector(LGLSXP, 1)); // placeholder to attach attributes
74                 if(nextExpectation->populateAttrFun != NULL) {
75                         if(OMX_DEBUG) { mxLog("Expectation %lu has attribute population.", index); }
76                         nextExpectation->populateAttrFun(nextExpectation, rExpect);
77             }
78                 SET_VECTOR_ELT(expectations, index, rExpect);
79         }
80
81         out->push_back(std::make_pair(Rf_mkChar("matrices"), matrices));
82         out->push_back(std::make_pair(Rf_mkChar("algebras"), algebras));
83         out->push_back(std::make_pair(Rf_mkChar("expectations"), expectations));
84 }
85
86 void omxPopulateFitFunction(omxMatrix *om, MxRList *result) // deprecated
87 {
88         omxFitFunction* off = om->fitFunction;
89         if (!off) return;
90
91         off->addOutput(off, result);
92
93         if (off->setFinalReturns == NULL) return;
94
95         int numEls;
96         SEXP oElement;
97         omxRListElement* orle = off->setFinalReturns(off, &numEls);
98         if (!orle || numEls == 0) return;
99
100         if(OMX_DEBUG) { mxLog("Adding %d sets of fit function Info....", numEls);}
101         for(int i = 0; i < numEls; i++) {
102                 if (!orle[i].values) {
103                         Rf_warning("Ignored %s in omxPopulateFitFunction", orle[i].label);
104                         continue;
105                 }
106                 if (orle[i].numValues == -1) {
107                         Rf_protect(oElement = Rf_allocMatrix(REALSXP, orle[i].rows, orle[i].cols));
108                 } else {
109                         Rf_protect(oElement = Rf_allocVector(REALSXP, orle[i].numValues));
110                 }
111                 memcpy(REAL(oElement), orle[i].values, sizeof(double)*LENGTH(oElement)); // TODO avoid another copy
112                 result->push_back(std::make_pair(Rf_mkChar(orle[i].label), oElement));
113         }
114 }
115
116 void omxPopulateConfidenceIntervals(SEXP intervals, SEXP intervalCodes) {
117         int numInts = Global->numIntervals;
118         if(OMX_DEBUG) { mxLog("Populating CIs for %d fit functions.", numInts); }
119         double* interval = REAL(intervals);
120         int* intervalCode = INTEGER(intervalCodes);
121         for(int j = 0; j < numInts; j++) {
122                 omxConfidenceInterval *oCI = Global->intervalList + j;
123                 interval[j] = oCI->min;
124                 interval[j + numInts] = oCI->max;
125                 intervalCode[j] = oCI->lCode;
126                 intervalCode[j + numInts] = oCI->uCode;
127         }
128 }