Enable R_NO_REMAP for a cleaner namespace
[openmx:openmx.git] / src / omxExpectation.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 /***********************************************************
18
19 *  omxExpectation.cc
20 *
21 *  Created: Timothy R. Brick    Date: 2008-11-13 12:33:06
22 *
23 *       Expectation objects carry distributional expectations
24 *               for the model.  Because they have no requirement
25 *               to produce a single matrix of output, they are
26 *               not a subclass of mxMatrix, but rather their own
27 *               strange beast.
28 *       // TODO:  Create a multi-matrix Algebra type, and make
29 *       //      MxExpectation a subtype of that.
30 *
31 **********************************************************/
32
33 #include "omxExpectation.h"
34
35 typedef struct omxExpectationTableEntry omxExpectationTableEntry;
36
37 struct omxExpectationTableEntry {
38         char name[32];
39         void (*initFun)(omxExpectation*);
40 };
41
42 static const omxExpectationTableEntry omxExpectationSymbolTable[] = {
43         {"MxExpectationLISREL",                 &omxInitLISRELExpectation},
44         {"MxExpectationStateSpace",                     &omxInitStateSpaceExpectation},
45         {"MxExpectationNormal",                 &omxInitNormalExpectation},
46         {"MxExpectationRAM",                    &omxInitRAMExpectation},
47         {"MxExpectationBA81", &omxInitExpectationBA81}
48 };
49
50 void omxFreeExpectationArgs(omxExpectation *ox) {
51         if(ox==NULL) return;
52     
53         if (ox->destructFun) ox->destructFun(ox);
54         Free(ox->submodels);
55         Free(ox);
56 }
57
58 void omxExpectationRecompute(omxExpectation *ox) {
59         if(ox->thresholds != NULL) {
60                 for(int i = 0; i < ox->numOrdinal; i++) {
61                         if (!ox->thresholds[i].matrix) continue;
62                         omxRecompute(ox->thresholds[i].matrix);
63                 }
64         }
65
66         omxExpectationCompute(ox, NULL);
67 }
68
69 void omxExpectationCompute(omxExpectation *ox, const char *what, const char *how)
70 {
71         if (!ox) return;
72
73         ox->computeFun(ox, what, how);
74 }
75
76 omxMatrix* omxGetExpectationComponent(omxExpectation* ox, omxFitFunction* off, const char* component) {
77
78         if(component == NULL) return NULL;
79
80         /* Hard-wired expectation components */
81         if(!strncmp("dataColumns", component, 11)) {
82                 return ox->dataColumns;
83         }
84
85         if(ox->componentFun == NULL) return NULL;
86
87         return(ox->componentFun(ox, off, component));
88         
89 }
90
91 void omxSetExpectationComponent(omxExpectation* ox, omxFitFunction* off, const char* component, omxMatrix* om) {
92         if(!strcmp(ox->expType, "MxExpectationStateSpace")) {
93                 ox->mutateFun(ox, off, component, om);
94         }
95 }
96
97 omxExpectation* omxDuplicateExpectation(const omxExpectation *src, omxState* newState) {
98
99         return omxNewIncompleteExpectation(src->rObj, src->expNum, newState);
100 }
101
102 omxExpectation* omxNewIncompleteExpectation(SEXP rObj, int expNum, omxState* os) {
103
104         SEXP ExpectationClass;
105         Rf_protect(ExpectationClass = STRING_ELT(Rf_getAttrib(rObj, Rf_install("class")), 0));
106         const char* expType = CHAR(ExpectationClass);
107
108         omxExpectation* expect = omxNewInternalExpectation(expType, os);
109
110         expect->rObj = rObj;
111         expect->expNum = expNum;
112         
113         return expect;
114 }
115
116 omxExpectation* omxExpectationFromIndex(int expIndex, omxState* os)
117 {
118         omxExpectation* ox = os->expectationList.at(expIndex);
119         return ox;
120 }
121
122 void omxExpectationProcessDataStructures(omxExpectation* ox, SEXP rObj){
123
124         int index, numDefs, nextDef, numCols, numOrdinal=0;
125         SEXP nextMatrix, itemList, nextItem, threshMatrix; 
126         
127         if(rObj == NULL) return;
128
129         if(OMX_DEBUG) { mxLog("Retrieving data."); }
130         Rf_protect(nextMatrix = R_do_slot(rObj, Rf_install("data")));
131         ox->data = omxDataLookupFromState(nextMatrix, ox->currentState);
132
133         if(OMX_DEBUG) {
134                 mxLog("Accessing variable mapping structure.");
135         }
136
137         if (R_has_slot(rObj, Rf_install("dataColumns"))) {
138                 Rf_protect(nextMatrix = R_do_slot(rObj, Rf_install("dataColumns")));
139                 ox->dataColumns = omxNewMatrixFromRPrimitive(nextMatrix, ox->currentState, 0, 0);
140                 if(OMX_DEBUG) {
141                         omxPrint(ox->dataColumns, "Variable mapping");
142                 }
143         
144                 numCols = ox->dataColumns->cols;
145
146                 if (R_has_slot(rObj, Rf_install("thresholds"))) {
147                         if(OMX_DEBUG) {
148                                 mxLog("Accessing Threshold matrix.");
149                         }
150                         Rf_protect(threshMatrix = R_do_slot(rObj, Rf_install("thresholds")));
151
152                         if(INTEGER(threshMatrix)[0] != NA_INTEGER) {
153                                 if(OMX_DEBUG) {
154                                         mxLog("Accessing Threshold Mappings.");
155                                 }
156         
157                                 /* Process the data and threshold mapping structures */
158                                 /* if (threshMatrix == NA_INTEGER), then we could ignore the slot "thresholdColumns"
159                                  * and fill all the thresholds with {NULL, 0, 0}.
160                                  * However the current path does not have a lot of overhead. */
161                                 Rf_protect(nextMatrix = R_do_slot(rObj, Rf_install("thresholdColumns")));
162                                 Rf_protect(itemList = R_do_slot(rObj, Rf_install("thresholdLevels")));
163                                 int* thresholdColumn, *thresholdNumber;
164                                 thresholdColumn = INTEGER(nextMatrix);
165                                 thresholdNumber = INTEGER(itemList);
166                                 ox->thresholds = (omxThresholdColumn *) R_alloc(numCols, sizeof(omxThresholdColumn));
167                                 for(index = 0; index < numCols; index++) {
168                                         if(thresholdColumn[index] == NA_INTEGER) {      // Continuous variable
169                                                 if(OMX_DEBUG) {
170                                                         mxLog("Column %d is continuous.", index);
171                                                 }
172                                                 ox->thresholds[index].matrix = NULL;
173                                                 ox->thresholds[index].column = 0;
174                                                 ox->thresholds[index].numThresholds = 0;
175                                         } else {
176                                                 ox->thresholds[index].matrix = omxMatrixLookupFromState1(threshMatrix, 
177                                                                                                        ox->currentState);
178                                                 ox->thresholds[index].column = thresholdColumn[index];
179                                                 ox->thresholds[index].numThresholds = thresholdNumber[index];
180                                                 if(OMX_DEBUG) {
181                                                         mxLog("Column %d is ordinal with %d thresholds in threshold column %d.", 
182                                                                 index, thresholdColumn[index], thresholdNumber[index]);
183                                                 }
184                                                 numOrdinal++;
185                                         }
186                                 }
187                                 if(OMX_DEBUG) {
188                                         mxLog("%d threshold columns processed.", numOrdinal);
189                                 }
190                                 ox->numOrdinal = numOrdinal;
191                         } else {
192                                 if (OMX_DEBUG) {
193                                         mxLog("No thresholds matrix; not processing thresholds.");
194                                 }
195                                 ox->thresholds = NULL;
196                                 ox->numOrdinal = 0;
197                         }
198                 }
199         }
200
201         if(!R_has_slot(rObj, Rf_install("definitionVars"))) {
202                 ox->numDefs = 0;
203                 ox->defVars = NULL;
204         } else {        
205                 if(OMX_DEBUG) {
206                         mxLog("Accessing definition variables structure.");
207                 }
208                 Rf_protect(nextMatrix = R_do_slot(rObj, Rf_install("definitionVars")));
209                 numDefs = Rf_length(nextMatrix);
210                 ox->numDefs = numDefs;
211                 if(OMX_DEBUG) {
212                         mxLog("Number of definition variables is %d.", numDefs);
213                 }
214                 ox->defVars = (omxDefinitionVar *) R_alloc(numDefs, sizeof(omxDefinitionVar));
215                 for(nextDef = 0; nextDef < numDefs; nextDef++) {
216                         SEXP dataSource, columnSource, depsSource; 
217                         int nextDataSource, numDeps;
218
219                         Rf_protect(itemList = VECTOR_ELT(nextMatrix, nextDef));
220                         Rf_protect(dataSource = VECTOR_ELT(itemList, 0));
221                         nextDataSource = INTEGER(dataSource)[0];
222                         if(OMX_DEBUG) {
223                                 mxLog("Data source number is %d.", nextDataSource);
224                         }
225                         ox->defVars[nextDef].data = nextDataSource;
226                         ox->defVars[nextDef].source = ox->currentState->dataList[nextDataSource];
227                         Rf_protect(columnSource = VECTOR_ELT(itemList, 1));
228                         if(OMX_DEBUG) {
229                                 mxLog("Data column number is %d.", INTEGER(columnSource)[0]);
230                         }
231                         ox->defVars[nextDef].column = INTEGER(columnSource)[0];
232                         Rf_protect(depsSource = VECTOR_ELT(itemList, 2));
233                         numDeps = LENGTH(depsSource);
234                         ox->defVars[nextDef].numDeps = numDeps;
235                         ox->defVars[nextDef].deps = (int*) R_alloc(numDeps, sizeof(int));
236                         for(int i = 0; i < numDeps; i++) {
237                                 ox->defVars[nextDef].deps[i] = INTEGER(depsSource)[i];
238                         }
239
240                         ox->defVars[nextDef].numLocations = Rf_length(itemList) - 3;
241                         ox->defVars[nextDef].matrices = (int *) R_alloc(Rf_length(itemList) - 3, sizeof(int));
242                         ox->defVars[nextDef].rows = (int *) R_alloc(Rf_length(itemList) - 3, sizeof(int));
243                         ox->defVars[nextDef].cols = (int *) R_alloc(Rf_length(itemList) - 3, sizeof(int));
244                         for(index = 3; index < Rf_length(itemList); index++) {
245                                 Rf_protect(nextItem = VECTOR_ELT(itemList, index));
246                                 ox->defVars[nextDef].matrices[index-3] = INTEGER(nextItem)[0];
247                                 ox->defVars[nextDef].rows[index-3] = INTEGER(nextItem)[1];
248                                 ox->defVars[nextDef].cols[index-3] = INTEGER(nextItem)[2];
249                         }
250                 }
251         }
252         
253 }
254
255 void omxCompleteExpectation(omxExpectation *ox) {
256         
257         if(ox->isComplete) return;
258
259         omxState* os = ox->currentState;
260
261         if (ox->rObj) {
262                 SEXP slot;
263                 Rf_protect(slot = R_do_slot(ox->rObj, Rf_install("container")));
264                 if (Rf_length(slot) == 1) {
265                         int ex = INTEGER(slot)[0];
266                         ox->container = os->expectationList.at(ex);
267                 }
268
269                 Rf_protect(slot = R_do_slot(ox->rObj, Rf_install("submodels")));
270                 if (Rf_length(slot)) {
271                         ox->numSubmodels = Rf_length(slot);
272                         ox->submodels = Realloc(NULL, Rf_length(slot), omxExpectation*);
273                         int *submodel = INTEGER(slot);
274                         for (int ex=0; ex < ox->numSubmodels; ex++) {
275                                 int sx = submodel[ex];
276                                 ox->submodels[ex] = omxExpectationFromIndex(sx, os);
277                                 omxCompleteExpectation(ox->submodels[ex]);
278                         }
279                 }
280
281                 omxExpectationProcessDataStructures(ox, ox->rObj);
282         }
283
284         ox->initFun(ox);
285
286         if(ox->computeFun == NULL) {
287                 // Should never happen
288                 Rf_error("Could not initialize Expectation function %s", ox->expType);
289         }
290
291         ox->isComplete = TRUE;
292
293 }
294
295 static void defaultSetVarGroup(omxExpectation *ox, FreeVarGroup *fvg)
296 {
297         if (ox->freeVarGroup && ox->freeVarGroup != fvg) {
298                 Rf_warning("setFreeVarGroup called with different group (%d vs %d) on %s",
299                         ox->name, ox->freeVarGroup->id[0], fvg->id[0]);
300         }
301         ox->freeVarGroup = fvg;
302 }
303
304 void setFreeVarGroup(omxExpectation *ox, FreeVarGroup *fvg)
305 {
306         (*ox->setVarGroup)(ox, fvg);
307 }
308
309 omxExpectation *
310 omxNewInternalExpectation(const char *expType, omxState* os)
311 {
312         omxExpectation* expect = Calloc(1, omxExpectation);
313         expect->setVarGroup = defaultSetVarGroup;
314
315         /* Switch based on Expectation type. */ 
316         for (size_t ex=0; ex < OMX_STATIC_ARRAY_SIZE(omxExpectationSymbolTable); ex++) {
317                 const omxExpectationTableEntry *entry = omxExpectationSymbolTable + ex;
318                 if(strncmp(expType, entry->name, MAX_STRING_LEN) == 0) {
319                         expect->expType = entry->name;
320                         expect->initFun = entry->initFun;
321                         break;
322                 }
323         }
324
325         if(!expect->initFun) {
326                 Free(expect);
327                 Rf_error("Expectation %s not implemented", expType);
328         }
329
330         expect->currentState = os;
331
332         return expect;
333 }
334
335 void omxExpectationPrint(omxExpectation* ox, char* d) {
336         if(ox->printFun != NULL) {
337                 ox->printFun(ox);
338         } else {
339                 mxLog("(Expectation, type %s) ", (ox->expType==NULL?"Untyped":ox->expType));
340         }
341 }