void omxSadmvnWrapper(omxFitFunction *oo, omxMatrix *cov, omxMatrix *ordCov,
double *corList, double *lThresh, double *uThresh, int *Infin, double *likelihood, int *inform) {
// SADMVN calls Alan Genz's sadmvn.f--see appropriate file for licensing info.
// TODO: Check with Genz: should we be using sadmvn or sadmvn?
// Parameters are:
// N int # of vars
// Lower double* Array of lower bounds
// Upper double* Array of upper bounds
// Infin int* Array of flags: 0 = (-Inf, upper] 1 = [lower, Inf), 2 = [lower, upper]
// Correl double* Array of correlation coeffs: in row-major lower triangular order
// MaxPts int Maximum # of function values (use 1000*N or 1000*N*N)
// Abseps double Absolute Rf_error tolerance. Yick.
// Releps double Relative Rf_error tolerance. Use EPSILON.
// Error &double On return: absolute real Rf_error, 99% confidence
// Value &double On return: evaluated value
// Inform &int On return: 0 = OK; 1 = Rerun, increase MaxPts; 2 = Bad input
// TODO: Separate block diagonal covariance matrices into pieces for integration separately
double Error;
double absEps = Global->absEps;
double relEps = Global->relEps;
int MaxPts = Global->maxptsa + Global->maxptsb * cov->rows + Global->maxptsc * cov->rows * cov->rows;
int numVars = ordCov->rows;
int fortranThreadId = omx_absolute_thread_num() + 1;
/* FOR DEBUGGING PURPOSES */
/* numVars = 2;
lThresh[0] = -2;
uThresh[0] = -1.636364;
Infin[0] = 2;
lThresh[1] = 0;
uThresh[1] = 0;
Infin[1] = 0;
smallCor[0] = 1.0; smallCor[1] = 0; smallCor[2] = 1.0; */
F77_CALL(sadmvn)(&numVars, lThresh, uThresh, Infin, corList, &MaxPts,
&absEps, &relEps, &Error, likelihood, inform, &fortranThreadId);
if(OMX_DEBUG && !oo->matrix->currentState->currentRow) {
char infinCodes[3][20];
strcpy(infinCodes[0], "(-INF, upper]");
strcpy(infinCodes[1], "[lower, INF)");
strcpy(infinCodes[2], "[lower, upper]");
mxLog("Input to sadmvn is (%d rows):", numVars); //:::DEBUG:::
omxPrint(ordCov, "Ordinal Covariance Matrix"); //:::DEBUG:::
for(int i = 0; i < numVars; i++) {
mxLog("Row %d: %f, %f, %d(%s)", i, lThresh[i], uThresh[i], Infin[i], infinCodes[Infin[i]]);
}
mxLog("Cor: (Lower %d x %d):", cov->rows, cov->cols); //:::DEBUG:::
for(int i = 0; i < cov->rows*(cov->rows-1)/2; i++) {
// mxLog("Row %d of Cor: ", i);
// for(int j = 0; j < i; j++)
mxLog(" %f", corList[i]); // (i*(i-1)/2) + j]);
// mxLog("");
}
}
if(OMX_DEBUG) {
mxLog("Output of sadmvn is %f, %f, %d.", Error, *likelihood, *inform);
}
}
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;
}
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;
}
}
}
}
static void
ba81compute(omxExpectation *oo, FitContext *fc, const char *what, const char *how)
{
BA81Expect *state = (BA81Expect *) oo->argStruct;
if (what) {
if (strcmp(what, "latentDistribution")==0 && how && strcmp(how, "copy")==0) {
omxCopyMatrix(state->_latentMeanOut, state->estLatentMean);
omxCopyMatrix(state->_latentCovOut, state->estLatentCov);
double sampleSizeAdj = (state->weightSum - 1.0) / state->weightSum;
int covSize = state->_latentCovOut->rows * state->_latentCovOut->cols;
for (int cx=0; cx < covSize; ++cx) {
state->_latentCovOut->data[cx] *= sampleSizeAdj;
}
return;
}
if (strcmp(what, "scores")==0) {
state->expectedUsed = true;
state->type = EXPECTATION_AUGMENTED;
} else if (strcmp(what, "nothing")==0) {
state->type = EXPECTATION_OBSERVED;
} else {
omxRaiseErrorf("%s: don't know how to predict '%s'",
oo->name, what);
}
if (state->verbose >= 1) {
mxLog("%s: predict %s", oo->name, what);
}
return;
}
bool latentClean = state->latentParamVersion == getLatentVersion(state);
bool itemClean = state->itemParamVersion == omxGetMatrixVersion(state->itemParam) && latentClean;
ba81NormalQuad &quad = state->getQuad();
if (state->verbose >= 1) {
mxLog("%s: Qinit %d itemClean %d latentClean %d (1=clean) expectedUsed=%d",
oo->name, (int)quad.isAllocated(), itemClean, latentClean, state->expectedUsed);
}
if (!latentClean) {
ba81RefreshQuadrature(oo);
state->latentParamVersion = getLatentVersion(state);
}
if (!itemClean) {
double *param = state->EitemParam? state->EitemParam : state->itemParam->data;
state->grp.quad.cacheOutcomeProb(param, FALSE);
bool estep = state->expectedUsed;
if (estep) {
if (oo->dynamicDataSource) {
BA81Engine<BA81Expect*, BA81LatentSummary, BA81Estep> engine;
engine.ba81Estep1(&state->grp, state);
} else {
BA81Engine<BA81Expect*, BA81LatentFixed, BA81Estep> engine;
engine.ba81Estep1(&state->grp, state);
}
} else {
state->grp.quad.releaseEstep();
refreshPatternLikelihood(state, oo->dynamicDataSource);
}
if (oo->dynamicDataSource && state->verbose >= 2) {
mxLog("%s: empirical distribution mean and cov:", state->name);
omxPrint(state->estLatentMean, "mean");
omxPrint(state->estLatentCov, "cov");
}
if (state->verbose >= 1) {
const int numUnique = state->getNumUnique();
mxLog("%s: estep<%s, %s> %d/%d rows excluded",
state->name,
(estep && oo->dynamicDataSource? "summary":"fixed"),
(estep? "estep":"omitEstep"),
state->grp.excludedPatterns, numUnique);
}
}
state->itemParamVersion = omxGetMatrixVersion(state->itemParam);
}
