void AlgebraFitFunction::init()
{
auto *off = this;
omxState *currentState = off->matrix->currentState;
AlgebraFitFunction *aff = this;
aff->ff = off;
ProtectedSEXP Ralg(R_do_slot(rObj, Rf_install("algebra")));
aff->algebra = omxMatrixLookupFromState1(Ralg, currentState);
ProtectedSEXP Runit(R_do_slot(rObj, Rf_install("units")));
off->setUnitsFromName(CHAR(STRING_ELT(Runit, 0)));
ProtectedSEXP Rgr(R_do_slot(rObj, Rf_install("gradient")));
aff->gradient = omxMatrixLookupFromState1(Rgr, currentState);
if (aff->gradient) off->gradientAvailable = TRUE;
ProtectedSEXP Rh(R_do_slot(rObj, Rf_install("hessian")));
aff->hessian = omxMatrixLookupFromState1(Rh, currentState);
if (aff->hessian) off->hessianAvailable = TRUE;
ProtectedSEXP Rverb(R_do_slot(rObj, Rf_install("verbose")));
aff->verbose = Rf_asInteger(Rverb);
off->canDuplicate = true;
}
void omxExpectation::loadFromR()
{
if (!rObj || !data) return;
auto ox = this;
int numCols=0;
bool isRaw = strEQ(omxDataType(data), "raw");
if (isRaw || data->hasSummaryStats()) {
ProtectedSEXP Rdcn(R_do_slot(rObj, Rf_install("dataColumnNames")));
loadCharVecFromR(name, Rdcn, dataColumnNames);
ProtectedSEXP Rdc(R_do_slot(rObj, Rf_install("dataColumns")));
numCols = Rf_length(Rdc);
ox->saveDataColumnsInfo(Rdc);
if(OMX_DEBUG) mxPrintMat("Variable mapping", base::getDataColumns());
if (isRaw) {
auto dc = base::getDataColumns();
for (int cx=0; cx < numCols; ++cx) {
int var = dc[cx];
data->assertColumnIsData(var);
}
}
}
if (R_has_slot(rObj, Rf_install("thresholds"))) {
if(OMX_DEBUG) {
mxLog("Accessing Threshold matrix.");
}
ProtectedSEXP threshMatrix(R_do_slot(rObj, Rf_install("thresholds")));
if(INTEGER(threshMatrix)[0] != NA_INTEGER) {
ox->thresholdsMat = omxMatrixLookupFromState1(threshMatrix, ox->currentState);
ox->loadThresholds();
} else {
if (OMX_DEBUG) {
mxLog("No thresholds matrix; not processing thresholds.");
}
ox->numOrdinal = 0;
}
}
}
void omxInitRowFitFunction(omxFitFunction* oo) {
if(OMX_DEBUG) { mxLog("Initializing Row/Reduce fit function."); }
SEXP rObj = oo->rObj;
SEXP nextMatrix, nextItem;
int numDeps;
omxRowFitFunction *newObj = new omxRowFitFunction;
if(OMX_DEBUG) {mxLog("Accessing data source."); }
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("data")));
newObj->data = omxDataLookupFromState(nextMatrix, oo->matrix->currentState);
if(newObj->data == NULL) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "No data provided to omxRowFitFunction.");
omxRaiseError(errstr);
free(errstr);
}
}
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("rowAlgebra")));
newObj->rowAlgebra = omxMatrixLookupFromState1(nextMatrix, oo->matrix->currentState);
if(newObj->rowAlgebra == NULL) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "No row-wise algebra in omxRowFitFunction.");
omxRaiseError(errstr);
free(errstr);
}
}
{
ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("units")));
oo->setUnitsFromName(CHAR(STRING_ELT(nextMatrix, 0)));
}
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("filteredDataRow")));
newObj->filteredDataRow = omxMatrixLookupFromState1(nextMatrix, oo->matrix->currentState);
}
if(newObj->filteredDataRow == NULL) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "No row results matrix in omxRowFitFunction.");
omxRaiseError(errstr);
free(errstr);
}
// Create the original data row from which to filter.
newObj->dataRow = omxInitMatrix(newObj->filteredDataRow->rows,
newObj->filteredDataRow->cols, TRUE, oo->matrix->currentState);
omxCopyMatrix(newObj->filteredDataRow, newObj->dataRow);
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("existenceVector")));
newObj->existenceVector = omxMatrixLookupFromState1(nextMatrix, oo->matrix->currentState);
}
// Do we allow NULL existence? (Whoa, man. That's, like, deep, or something.)
if(newObj->existenceVector == NULL) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "No existance matrix in omxRowFitFunction.");
omxRaiseError(errstr);
free(errstr);
}
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("rowResults")));
newObj->rowResults = omxMatrixLookupFromState1(nextMatrix, oo->matrix->currentState);
}
if(newObj->rowResults == NULL) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "No row results matrix in omxRowFitFunction.");
omxRaiseError(errstr);
free(errstr);
}
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("reduceAlgebra")));
newObj->reduceAlgebra = omxMatrixLookupFromState1(nextMatrix, oo->matrix->currentState);
}
if(newObj->reduceAlgebra == NULL) {
char *errstr = (char*) calloc(250, sizeof(char));
sprintf(errstr, "No row reduction algebra in omxRowFitFunction.");
omxRaiseError(errstr);
free(errstr);
}
if(OMX_DEBUG) {mxLog("Accessing variable mapping structure."); }
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("dataColumns")));
newObj->dataColumns = omxNewMatrixFromRPrimitive(nextMatrix, oo->matrix->currentState, 0, 0);
}
if(OMX_DEBUG) { omxPrint(newObj->dataColumns, "Variable mapping"); }
if(OMX_DEBUG) {mxLog("Accessing data row dependencies."); }
{ ScopedProtect p1(nextItem, R_do_slot(rObj, Rf_install("dataRowDeps")));
numDeps = LENGTH(nextItem);
newObj->numDataRowDeps = numDeps;
newObj->dataRowDeps = (int*) R_alloc(numDeps, sizeof(int));
for(int i = 0; i < numDeps; i++) {
newObj->dataRowDeps[i] = INTEGER(nextItem)[i];
}
}
/* Set up data columns */
EigenVectorAdaptor dc(newObj->dataColumns);
omxSetContiguousDataColumns(&(newObj->contiguous), newObj->data, dc);
oo->computeFun = omxCallRowFitFunction;
oo->destructFun = omxDestroyRowFitFunction;
oo->canDuplicate = true;
oo->openmpUser = true;
oo->argStruct = (void*) newObj;
}
void omxInitGREMLFitFunction(omxFitFunction *oo){
if(OMX_DEBUG) { mxLog("Initializing GREML fitfunction."); }
SEXP rObj = oo->rObj;
SEXP dV, dVnames;
int i=0;
oo->units = FIT_UNITS_MINUS2LL;
oo->computeFun = omxCallGREMLFitFunction;
oo->ciFun = loglikelihoodCIFun;
oo->destructFun = omxDestroyGREMLFitFunction;
oo->populateAttrFun = omxPopulateGREMLAttributes;
omxGREMLFitState *newObj = new omxGREMLFitState;
oo->argStruct = (void*)newObj;
omxExpectation* expectation = oo->expectation;
omxState* currentState = expectation->currentState;
newObj->usingGREMLExpectation = (strcmp(expectation->expType, "MxExpectationGREML")==0 ? 1 : 0);
if(!newObj->usingGREMLExpectation){
//Maybe someday GREML fitfunction could be made compatible with another expectation, but not at present:
Rf_error("GREML fitfunction is currently only compatible with GREML expectation");
}
else{
omxGREMLExpectation* oge = (omxGREMLExpectation*)(expectation->argStruct);
oge->alwaysComputeMeans = 0;
}
newObj->y = omxGetExpectationComponent(expectation, oo, "y");
newObj->cov = omxGetExpectationComponent(expectation, oo, "cov");
newObj->invcov = omxGetExpectationComponent(expectation, oo, "invcov");
newObj->X = omxGetExpectationComponent(expectation, oo, "X");
newObj->means = omxGetExpectationComponent(expectation, oo, "means");
newObj->nll = 0;
newObj->REMLcorrection = 0;
newObj->varGroup = NULL;
//Derivatives:
{ScopedProtect p1(dV, R_do_slot(rObj, Rf_install("dV")));
ScopedProtect p2(dVnames, R_do_slot(rObj, Rf_install("dVnames")));
newObj->dVlength = Rf_length(dV);
newObj->dV.resize(newObj->dVlength);
newObj->dVnames.resize(newObj->dVlength);
if(newObj->dVlength){
if(!newObj->usingGREMLExpectation){
//Probably best not to allow use of dV if we aren't sure means will be calculated GREML-GLS way:
Rf_error("derivatives of 'V' matrix in GREML fitfunction only compatible with GREML expectation");
}
if(OMX_DEBUG) { mxLog("Processing derivatives of V."); }
int* dVint = INTEGER(dV);
for(i=0; i < newObj->dVlength; i++){
newObj->dV[i] = omxMatrixLookupFromState1(dVint[i], currentState);
SEXP elem;
{ScopedProtect p3(elem, STRING_ELT(dVnames, i));
newObj->dVnames[i] = CHAR(elem);}
}}
}
if(newObj->dVlength){
oo->gradientAvailable = true;
newObj->gradient.setZero(newObj->dVlength,1);
oo->hessianAvailable = true;
newObj->avgInfo.setZero(newObj->dVlength,newObj->dVlength);
for(i=0; i < newObj->dVlength; i++){
if( (newObj->dV[i]->rows != newObj->cov->rows) || (newObj->dV[i]->cols != newObj->cov->cols) ){
Rf_error("all derivatives of V must have the same dimensions as V");
}}}}
static void omxExpectationProcessDataStructures(omxExpectation* ox, SEXP rObj)
{
int index, numCols, numOrdinal=0;
SEXP nextMatrix, itemList, threshMatrix;
if(rObj == NULL) return;
if(OMX_DEBUG) {
mxLog("Accessing variable mapping structure.");
}
if (R_has_slot(rObj, Rf_install("dataColumns"))) {
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("dataColumns")));
ox->dataColumns = omxNewMatrixFromRPrimitive(nextMatrix, ox->currentState, 0, 0);
}
if(OMX_DEBUG) {
omxPrint(ox->dataColumns, "Variable mapping");
}
numCols = ox->dataColumns->cols;
if (R_has_slot(rObj, Rf_install("thresholds"))) {
if(OMX_DEBUG) {
mxLog("Accessing Threshold matrix.");
}
ScopedProtect p1(threshMatrix, R_do_slot(rObj, Rf_install("thresholds")));
if(INTEGER(threshMatrix)[0] != NA_INTEGER) {
if(OMX_DEBUG) {
mxLog("Accessing Threshold Mappings.");
}
/* Process the data and threshold mapping structures */
/* if (threshMatrix == NA_INTEGER), then we could ignore the slot "thresholdColumns"
* and fill all the thresholds with {NULL, 0, 0}.
* However the current path does not have a lot of overhead. */
int* thresholdColumn, *thresholdNumber;
{ScopedProtect pc(nextMatrix, R_do_slot(rObj, Rf_install("thresholdColumns")));
thresholdColumn = INTEGER(nextMatrix);
}
{ScopedProtect pi(itemList, R_do_slot(rObj, Rf_install("thresholdLevels")));
thresholdNumber = INTEGER(itemList);
}
ox->thresholds.reserve(numCols);
for(index = 0; index < numCols; index++) {
if(thresholdColumn[index] == NA_INTEGER) { // Continuous variable
if(OMX_DEBUG) {
mxLog("Column %d is continuous.", index);
}
omxThresholdColumn col;
ox->thresholds.push_back(col);
} else {
omxThresholdColumn col;
col.matrix = omxMatrixLookupFromState1(threshMatrix, ox->currentState);
col.column = thresholdColumn[index];
col.numThresholds = thresholdNumber[index];
ox->thresholds.push_back(col);
if(OMX_DEBUG) {
mxLog("Column %d is ordinal with %d thresholds in threshold column %d.",
index, thresholdNumber[index], thresholdColumn[index]);
}
numOrdinal++;
}
}
if(OMX_DEBUG) {
mxLog("%d threshold columns processed.", numOrdinal);
}
ox->numOrdinal = numOrdinal;
} else {
if (OMX_DEBUG) {
mxLog("No thresholds matrix; not processing thresholds.");
}
ox->numOrdinal = 0;
}
}
}
}
/* Helper functions */
omxMatrix* omxNewMatrixFromSlot(SEXP rObj, omxState* currentState, const char* slotName) {
SEXP slotValue;
ScopedProtect p1(slotValue, R_do_slot(rObj, Rf_install(slotName)));
omxMatrix* newMatrix = omxMatrixLookupFromState1(slotValue, currentState);
return newMatrix;
}
