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; }