Remove most instances of setFinalReturns
[openmx:openmx.git] / src / omxRFitFunction.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 #include <R_ext/Rdynload.h>
21 #include <R_ext/BLAS.h>
22 #include <R_ext/Lapack.h>
23 #include "omxAlgebraFunctions.h"
24 #include "omxRFitFunction.h"
25 #include "omxOpenmpWrap.h"
26 #include "npsolWrap.h"
27 #include "Compute.h"
28
29 void omxDestroyRFitFunction(omxFitFunction *off) {
30         UNPROTECT(4);                   // fitfun, model, flatModel, and state
31 }
32
33 static void omxCallRFitFunction(omxFitFunction *oo, int want, FitContext *) {
34         if (want & FF_COMPUTE_PREOPTIMIZE) return;
35
36         omxState* currentState = oo->matrix->currentState;
37         omxRFitFunction* rFitFunction = (omxRFitFunction*)oo->argStruct;
38
39         SEXP theCall, theReturn;
40         PROTECT(theCall = allocVector(LANGSXP, 3));
41         SETCAR(theCall, rFitFunction->fitfun);
42         SETCADR(theCall, rFitFunction->model);
43         SETCADDR(theCall, rFitFunction->state);
44
45         PROTECT(theReturn = eval(theCall, R_GlobalEnv));
46
47         if (LENGTH(theReturn) < 1) {
48                 // seems impossible, but report it if it happens
49                 omxRaiseErrorf(currentState, "FitFunction returned nothing");
50         } else if (LENGTH(theReturn) == 1) {
51                 oo->matrix->data[0] = asReal(theReturn);
52         } else if (LENGTH(theReturn) == 2) {
53                 oo->matrix->data[0] = asReal(VECTOR_ELT(theReturn, 0));
54                 REPROTECT(rFitFunction->state = VECTOR_ELT(theReturn, 1), rFitFunction->stateIndex);
55         } else if (LENGTH(theReturn) > 2) {
56                 omxRaiseErrorf(currentState, "FitFunction returned more than 2 arguments");
57         }
58
59         UNPROTECT(2); // theCall and theReturn
60 }
61
62 void omxInitRFitFunction(omxFitFunction* oo) {
63         FitContext::setRFitFunction(oo);
64
65         if(OMX_DEBUG) { mxLog("Initializing R fit function."); }
66         omxRFitFunction *newObj = (omxRFitFunction*) R_alloc(1, sizeof(omxRFitFunction));
67         
68         SEXP rObj = oo->rObj;
69
70         /* Set Fit Function Calls to RFitFunction Calls */
71         oo->computeFun = omxCallRFitFunction;
72         oo->destructFun = omxDestroyRFitFunction;
73         oo->argStruct = (void*) newObj;
74         
75         PROTECT(newObj->fitfun = GET_SLOT(rObj, install("fitfun")));
76         PROTECT_WITH_INDEX(newObj->model = GET_SLOT(rObj, install("model")), &(newObj->modelIndex));
77         PROTECT(newObj->flatModel = GET_SLOT(rObj, install("flatModel")));
78         PROTECT_WITH_INDEX(newObj->state = GET_SLOT(rObj, install("state")), &(newObj->stateIndex));
79
80 }
81
82