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;
}
Eigen::SparseMatrix<Type> asSparseMatrix(SEXP M){
int *i=INTEGER(R_do_slot(M,install("i")));
int *j=INTEGER(R_do_slot(M,install("j")));
double *x=REAL(R_do_slot(M,install("x")));
int n=LENGTH(R_do_slot(M,install("x")));
int *dim=INTEGER(R_do_slot(M,install("Dim")));
typedef Eigen::Triplet<Type> T;
std::vector<T> tripletList;
for(int k=0;k<n;k++){
tripletList.push_back(T(i[k],j[k],x[k]));
}
Eigen::SparseMatrix<Type> mat(dim[0],dim[1]);
mat.setFromTriplets(tripletList.begin(), tripletList.end());
return mat;
}
void ifaGroup::importSpec(SEXP slotValue)
{
for (int sx=0; sx < Rf_length(slotValue); ++sx) {
SEXP model = VECTOR_ELT(slotValue, sx);
if (!OBJECT(model)) {
Rf_error("Item models must inherit rpf.base");
}
SEXP Rspec;
Rf_protect(Rspec = R_do_slot(model, Rf_install("spec")));
spec.push_back(REAL(Rspec));
}
dataColumns.reserve(spec.size());
itemOutcomes.reserve(spec.size());
cumItemOutcomes.reserve(spec.size());
impliedParamRows = 0;
totalOutcomes = 0;
maxItemDims = 0;
for (int cx = 0; cx < numItems(); cx++) {
const double *ispec = spec[cx];
int id = ispec[RPF_ISpecID];
int dims = ispec[RPF_ISpecDims];
if (maxItemDims < dims)
maxItemDims = dims;
int no = ispec[RPF_ISpecOutcomes];
itemOutcomes.push_back(no);
cumItemOutcomes.push_back(totalOutcomes);
totalOutcomes += no;
int numParam = (*librpf_model[id].numParam)(ispec);
if (impliedParamRows < numParam)
impliedParamRows = numParam;
}
}
// Does vector=TRUE mean something sensible? Mixture of mixtures?
void state::init()
{
auto *oo = this;
auto *ms = this;
if (!oo->expectation) { mxThrow("%s requires an expectation", oo->fitType); }
oo->units = FIT_UNITS_MINUS2LL;
oo->canDuplicate = true;
omxState *currentState = oo->matrix->currentState;
const char *myex1 = "MxExpectationHiddenMarkov";
const char *myex2 = "MxExpectationMixture";
if (!expectation || !(strEQ(expectation->expType, myex1) ||
strEQ(expectation->expType, myex2)))
mxThrow("%s must be paired with %s or %s", oo->name(), myex1, myex2);
ProtectedSEXP Rverbose(R_do_slot(oo->rObj, Rf_install("verbose")));
ms->verbose = Rf_asInteger(Rverbose);
ProtectedSEXP Rcomponents(R_do_slot(oo->rObj, Rf_install("components")));
int nc = Rf_length(Rcomponents);
int *cvec = INTEGER(Rcomponents);
componentUnits = FIT_UNITS_UNINITIALIZED;
for (int cx=0; cx < nc; ++cx) {
omxMatrix *fmat = currentState->algebraList[ cvec[cx] ];
if (fmat->fitFunction) {
omxCompleteFitFunction(fmat);
auto ff = fmat->fitFunction;
if (ff->units != FIT_UNITS_PROBABILITY) {
omxRaiseErrorf("%s: component %s must be in probability units",
oo->name(), ff->name());
return;
}
if (componentUnits == FIT_UNITS_UNINITIALIZED) {
componentUnits = ff->units;
} else if (ff->units != componentUnits) {
omxRaiseErrorf("%s: components with heterogenous units %s and %s in same mixture",
oo->name(), fitUnitsToName(ff->units), fitUnitsToName(componentUnits));
}
}
ms->components.push_back(fmat);
}
if (componentUnits == FIT_UNITS_UNINITIALIZED) componentUnits = FIT_UNITS_PROBABILITY;
ms->initial = expectation->getComponent("initial");
ms->transition = expectation->getComponent("transition");
}
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 FitMultigroup::init()
{
auto *oo = this;
FitMultigroup *mg =this;
SEXP rObj = oo->rObj;
if (!rObj) return;
if (mg->fits.size()) return; // hack to prevent double initialization, remove TOOD
oo->units = FIT_UNITS_UNINITIALIZED;
oo->gradientAvailable = TRUE;
oo->hessianAvailable = TRUE;
oo->canDuplicate = true;
omxState *os = oo->matrix->currentState;
ProtectedSEXP Rverb(R_do_slot(rObj, Rf_install("verbose")));
mg->verbose = Rf_asInteger(Rverb);
ProtectedSEXP Rgroups(R_do_slot(rObj, Rf_install("groups")));
int *fits = INTEGER(Rgroups);
for(int gx = 0; gx < Rf_length(Rgroups); gx++) {
if (isErrorRaised()) break;
omxMatrix *mat;
if (fits[gx] >= 0) {
mat = os->algebraList[fits[gx]];
} else {
mxThrow("Can only add algebra and fitfunction");
}
if (mat == oo->matrix) mxThrow("Cannot add multigroup to itself");
mg->fits.push_back(mat);
if (mat->fitFunction) {
omxCompleteFitFunction(mat);
oo->gradientAvailable = (oo->gradientAvailable && mat->fitFunction->gradientAvailable);
oo->hessianAvailable = (oo->hessianAvailable && mat->fitFunction->hessianAvailable);
} else {
oo->gradientAvailable = FALSE;
oo->hessianAvailable = FALSE;
}
}
}
SEXP RR_do_new_object(SEXP class_def)
{
static SEXP s_virtual = NULL, s_prototype, s_className;
SEXP e, value;
if(!s_virtual) {
s_virtual = Rf_install("virtual");
s_prototype = Rf_install("prototype");
s_className = Rf_install("className");
}
if(!class_def)
error("C level NEW macro called with null class definition pointer");
e = R_do_slot(class_def, s_virtual);
if(asLogical(e) != 0) { /* includes NA, TRUE, or anything other than FALSE */
e = R_do_slot(class_def, s_className);
error("Trying to generate an object in C from a virtual class (\"%s\")",
CHAR(asChar(e)));
}
e = R_do_slot(class_def, s_className);
value = duplicate(R_do_slot(class_def, s_prototype));
setAttrib(value, R_ClassSymbol, e);
return value;
}
void MarkovExpectation::init()
{
ProtectedSEXP Rverbose(R_do_slot(rObj, Rf_install("verbose")));
verbose = Rf_asInteger(Rverbose);
ProtectedSEXP Rcomponents(R_do_slot(rObj, Rf_install("components")));
int *cvec = INTEGER(Rcomponents);
int nc = Rf_length(Rcomponents);
for (int cx=0; cx < nc; ++cx) {
components.push_back(omxExpectationFromIndex(cvec[cx], currentState));
}
if (isMixtureInterface) {
initial = omxNewMatrixFromSlot(rObj, currentState, "weights");
transition = 0;
} else {
initial = omxNewMatrixFromSlot(rObj, currentState, "initial");
transition = omxNewMatrixFromSlot(rObj, currentState, "transition");
}
ProtectedSEXP Rscale(R_do_slot(rObj, Rf_install("scale")));
auto scaleName = CHAR(STRING_ELT(Rscale, 0));
if (strEQ(scaleName, "softmax")) {
scale = SCALE_SOFTMAX;
} else if (strEQ(scaleName, "sum")) {
scale = SCALE_SUM;
} else if (strEQ(scaleName, "none")) {
scale = SCALE_NONE;
} else {
Rf_error("%s: unknown scale '%s'", name, scaleName);
}
scaledInitial = omxInitMatrix(1, 1, TRUE, currentState);
scaledTransition = 0;
if (transition) {
scaledTransition = omxInitMatrix(1, 1, TRUE, currentState);
}
}
void omxFillMatrixFromMxFitFunction(omxMatrix* om, const char *fitType, int matrixNumber, SEXP rObj)
{
om->hasMatrixNumber = TRUE;
om->matrixNumber = matrixNumber;
SEXP slotValue;
omxExpectation *expect = NULL;
{
ScopedProtect p1(slotValue, R_do_slot(rObj, Rf_install("expectation")));
if (Rf_length(slotValue) == 1) {
int expNumber = Rf_asInteger(slotValue);
if(expNumber != NA_INTEGER) {
expect = omxExpectationFromIndex(expNumber, om->currentState);
}
}
}
bool rowLik = Rf_asInteger(R_do_slot(rObj, Rf_install("vector")));
omxFitFunction *ff =
omxNewInternalFitFunction(om->currentState, fitType, expect, om, rowLik);
ff->rObj = rObj;
}
void omxFillMatrixFromMxFitFunction(omxMatrix* om, int matrixNumber, SEXP rObj)
{
om->hasMatrixNumber = TRUE;
om->matrixNumber = matrixNumber;
ProtectedSEXP fitFunctionClass(STRING_ELT(Rf_getAttrib(rObj, R_ClassSymbol), 0));
const char *fitType = CHAR(fitFunctionClass);
omxExpectation *expect = NULL;
ProtectedSEXP slotValue(R_do_slot(rObj, Rf_install("expectation")));
if (Rf_length(slotValue) == 1) {
int expNumber = Rf_asInteger(slotValue);
if(expNumber != NA_INTEGER) {
expect = omxExpectationFromIndex(expNumber, om->currentState);
}
}
bool rowLik = Rf_asInteger(R_do_slot(rObj, Rf_install("vector")));
omxFitFunction *ff =
omxNewInternalFitFunction(om->currentState, fitType, expect, om, rowLik);
ff->rObj = rObj;
}
void omxInitRFitFunction(omxFitFunction* oo) {
FitContext::setRFitFunction(oo);
if(OMX_DEBUG) { mxLog("Initializing R fit function."); }
omxRFitFunction *newObj = (omxRFitFunction*) R_alloc(1, sizeof(omxRFitFunction));
SEXP rObj = oo->rObj;
/* Set Fit Function Calls to RFitFunction Calls */
oo->computeFun = omxCallRFitFunction;
oo->argStruct = (void*) newObj;
{
SEXP newptr;
ScopedProtect p1(newptr, R_do_slot(rObj, Rf_install("units")));
oo->setUnitsFromName(CHAR(STRING_ELT(newptr, 0)));
}
Rf_protect(newObj->fitfun = R_do_slot(rObj, Rf_install("fitfun")));
R_ProtectWithIndex(newObj->model = R_do_slot(rObj, Rf_install("model")), &(newObj->modelIndex));
Rf_protect(newObj->flatModel = R_do_slot(rObj, Rf_install("flatModel")));
R_ProtectWithIndex(newObj->state = R_do_slot(rObj, Rf_install("state")), &(newObj->stateIndex));
}
omxExpectation* omxNewIncompleteExpectation(SEXP rObj, int expNum, omxState* os) {
SEXP ExpectationClass;
const char *expType;
{ScopedProtect p1(ExpectationClass, STRING_ELT(Rf_getAttrib(rObj, R_ClassSymbol), 0));
expType = CHAR(ExpectationClass);
}
omxExpectation* expect = omxNewInternalExpectation(expType, os);
expect->rObj = rObj;
expect->expNum = expNum;
ProtectedSEXP Rdata(R_do_slot(rObj, Rf_install("data")));
if (TYPEOF(Rdata) == INTSXP) {
expect->data = omxDataLookupFromState(Rdata, os);
}
return expect;
}
omxExpectation* omxNewIncompleteExpectation(SEXP rObj, int expNum, omxState* os) {
SEXP ExpectationClass;
const char *expType;
{ScopedProtect p1(ExpectationClass, STRING_ELT(Rf_getAttrib(rObj, Rf_install("class")), 0));
expType = CHAR(ExpectationClass);
}
omxExpectation* expect = omxNewInternalExpectation(expType, os);
expect->rObj = rObj;
expect->expNum = expNum;
SEXP nextMatrix;
{ScopedProtect p1(nextMatrix, R_do_slot(rObj, Rf_install("data")));
expect->data = omxDataLookupFromState(nextMatrix, os);
}
return expect;
}
void ifaGroup::importSpec(SEXP slotValue)
{
for (int sx=0; sx < Rf_length(slotValue); ++sx) {
SEXP model = VECTOR_ELT(slotValue, sx);
if (!OBJECT(model)) {
mxThrow("Item models must inherit rpf.base");
}
SEXP Rspec;
ScopedProtect p1(Rspec, R_do_slot(model, Rf_install("spec")));
spec.push_back(REAL(Rspec));
}
dataColumns.reserve(spec.size());
itemOutcomes.reserve(spec.size());
impliedParamRows = 0;
totalOutcomes = 0;
maxOutcomes = 0;
itemDims = -1;
for (int cx = 0; cx < numItems(); cx++) {
const double *ispec = spec[cx];
int id = ispec[RPF_ISpecID];
int dims = ispec[RPF_ISpecDims];
if (itemDims == -1) {
itemDims = dims;
} else if (dims != itemDims) {
mxThrow("All items must have the same number of factors (%d != %d)",
itemDims, dims);
}
int no = ispec[RPF_ISpecOutcomes];
itemOutcomes.push_back(no);
maxOutcomes = std::max(maxOutcomes, no);
totalOutcomes += no;
int numParam = (*Glibrpf_model[id].numParam)(ispec);
if (impliedParamRows < numParam)
impliedParamRows = numParam;
}
}
void omxInitFitFunctionBA81(omxFitFunction* oo)
{
if (!oo->argStruct) { // ugh!
BA81FitState *state = new BA81FitState;
oo->argStruct = state;
}
omxState *currentState = oo->matrix->currentState;
BA81FitState *state = (BA81FitState*) oo->argStruct;
omxExpectation *expectation = oo->expectation;
BA81Expect *estate = (BA81Expect*) expectation->argStruct;
estate->fit = oo;
oo->computeFun = ba81Compute;
oo->setVarGroup = ba81SetFreeVarGroup;
oo->destructFun = ba81Destroy;
oo->gradientAvailable = TRUE;
oo->hessianAvailable = TRUE;
int maxParam = estate->itemParam->rows;
state->itemDerivPadSize = maxParam + triangleLoc1(maxParam);
int numItems = estate->itemParam->cols;
for (int ix=0; ix < numItems; ix++) {
const double *spec = estate->itemSpec(ix);
int id = spec[RPF_ISpecID];
if (id < 0 || id >= Glibrpf_numModels) {
Rf_error("ItemSpec %d has unknown item model %d", ix, id);
}
}
state->itemParam = omxInitMatrix(0, 0, TRUE, currentState);
state->latentMean = omxInitMatrix(0, 0, TRUE, currentState);
state->latentCov = omxInitMatrix(0, 0, TRUE, currentState);
state->copyEstimates(estate);
state->returnRowLikelihoods = Rf_asInteger(R_do_slot(oo->rObj, Rf_install("vector")));
}
/* Set elements of a dbvector. When the new value is NA, the original element
deleted from the table.
*/
SEXP set(SEXP x, SEXP index, SEXP value)
{
SEXP ans = R_NilValue;
rdbVector *origInfo, *info;
unsigned int len, i;
unsigned int *_index;
origInfo = getInfo(x);
/* check value type */
if (!(isInteger(value)||isReal(value)||isComplex(value)))
{
error("wrong value type");
}
/* connect to database */
MYSQL *sqlconn = NULL;
int success = connectToLocalDB(&sqlconn);
if(!success || sqlconn == NULL)
{
error("cannot connect to local db\n");
return ans;
}
/* convert index to int */
if (isInteger(index))
{
len = length(index);
Rprintf(" integer length %d\n",len);
_index = calloc(len, sizeof(unsigned int));
_index = INTEGER(index);
}
else if (isReal(index))
{
len = length(index);
_index = calloc(len, sizeof(unsigned int));
for (i=0;i<len;i++)
_index[i] = (unsigned int)REAL(index)[i];
}
else if (IS_DBVECTOR(index))
{
rdbVector *iinfo = getInfo(index);
if (iinfo->sxp_type != INTSXP && iinfo->sxp_type != REALSXP && iinfo->sxp_type!=LGLSXP) {
mysql_close(sqlconn);
error("index must be of logical, integer or numeric type");
}
int settype = origInfo->sxp_type * 100 + TYPEOF(value);
if (iinfo->sxp_type == LGLSXP){
switch(settype)
{
case 1010: /* logical, logical */
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setLogicElementsWithLogic(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1013: /* logical, int */
x = duplicateOrConvert(x, convertLogicToInteger, sqlconn, 1);
info = getInfo(x);
setIntElementsWithLogic(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1014: /* logical, real */
x = duplicateOrConvert(x, convertLogicToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1313: /* int,int*/
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setIntElementsWithLogic(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1314: /* int,real */
x = duplicateOrConvert(x, convertIntegerToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1315: /* int, cplx */
x = duplicateOrConvert(x,convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1413:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(coerceVector(value,REALSXP)), length(value));
break;
case 1414:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWithLogic(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1415:
x = duplicateOrConvert(x, convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1513:
case 1514:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(coerceVector(value,CPLXSXP)), length(value));
break;
case 1515:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWithLogic(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
default:
error("Setting elements of this type of dbvector is not supported");
break;
}
}
else { /* int or real type index */
switch(settype)
{
case 1010: /* logical, logical */
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setLogicElementsWDBVector(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1013: /* logical, int */
x = duplicateOrConvert(x, convertLogicToInteger, sqlconn, 1);
info = getInfo(x);
setIntElementsWDBVector(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1014: /* logical, real */
x = duplicateOrConvert(x, convertLogicToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1313: /* int,int*/
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setIntElementsWDBVector(sqlconn, info, iinfo, INTEGER(value), length(value));
break;
case 1314: /* int,real */
x = duplicateOrConvert(x, convertIntegerToDouble, sqlconn, 1);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1315: /* int, cplx */
x = duplicateOrConvert(x,convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1413:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(coerceVector(value,REALSXP)), length(value));
break;
case 1414:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setDoubleElementsWDBVector(sqlconn, info, iinfo, REAL(value), length(value));
break;
case 1415:
x = duplicateOrConvert(x, convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
case 1513:
case 1514:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(coerceVector(value,CPLXSXP)), length(value));
break;
case 1515:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setComplexElementsWDBVector(sqlconn, info, iinfo, COMPLEX(value), length(value));
break;
default:
error("Setting elements of this type of dbvector is not supported");
break;
}
} /* end if */
mysql_close(sqlconn);
free(_index);
/* info has possibly been updated */
rdbVector *temp = (rdbVector*)R_ExternalPtrAddr(R_do_slot(x,install("ext")));
temp->isView = info->isView;
temp->refCounter = info->refCounter;
return x;
}
/* detect type */
int settype = origInfo->sxp_type *100 + TYPEOF(value);
switch(settype)
{
case 1010: /* logical, logical */
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseLogicElements(sqlconn, info, _index, len, INTEGER(value), length(value));
break;
case 1013: /* logical, int */
x = duplicateOrConvert(x, convertLogicToInteger, sqlconn, 1);
info = getInfo(x);
setSparseIntElements(sqlconn, info, _index, len, INTEGER(value), length(value));
break;
case 1014: /* logical, real */
x = duplicateOrConvert(x, convertLogicToDouble, sqlconn, 1);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(value), length(value));
break;
case 1313: /* int,int*/
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseIntElements(sqlconn, info, _index, len, INTEGER(value), length(value));
break;
case 1314: /* int,real */
x = duplicateOrConvert(x, convertIntegerToDouble, sqlconn, 1);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(value), length(value));
break;
case 1315: /* int, cplx */
x = duplicateOrConvert(x,convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(value), length(value));
break;
case 1413:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(coerceVector(value,REALSXP)), length(value));
break;
case 1414:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseDoubleElements(sqlconn, info, _index, len, REAL(value), length(value));
break;
case 1415:
x = duplicateOrConvert(x, convertNumericToComplex, sqlconn, 1);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(value), length(value));
break;
case 1513:
case 1514:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(coerceVector(value,CPLXSXP)), length(value));
break;
case 1515:
x = duplicateOrConvert(x, duplicateVectorTable, sqlconn, 0);
info = getInfo(x);
setSparseComplexElements(sqlconn, info, _index, len, COMPLEX(value), length(value));
break;
default:
error("Setting elements of this type of dbvector is not supported");
break;
}
mysql_close(sqlconn);
free(_index);
/* info has possibly been updated */
rdbVector *temp = (rdbVector*)R_ExternalPtrAddr(R_do_slot(x,install("ext")));
temp->isView = info->isView;
temp->refCounter = info->refCounter;
return x;
}
SEXP duplicateOrConvert(SEXP orig, int (*func)(MYSQL*,rdbVector*,rdbVector*), MYSQL *sqlconn, int needConvert)
{
SEXP x, tname;
rdbVector *info;
rdbVector *origInfo = getInfo(orig);
/* if this dbvector is shared by more than one variable
we should copy before set */
if (origInfo->sxp_spare > 1 || needConvert)
{
PROTECT(x = duplicate(orig));
Rprintf("new address %p \n",x);
SEXP s = R_do_slot(x,install("info"));
info = (rdbVector*)RAW(s);
initRDBVector(info);
info->sxp_spare = 0;
func(sqlconn, origInfo, info);
Rprintf("duplicated into table %s\n",info->tableName);
/* set tablename slot */
PROTECT(tname = ScalarString(mkChar(info->tableName)));
R_do_slot_assign(x, install("tablename"), tname);
free(info->tableName);
/* register finalizer for the new duplicate */
rdbVector *ptr = malloc(sizeof(rdbVector));
*ptr = *info;
SEXP rptr;
R_do_slot_assign(x, install("ext"), (rptr=R_MakeExternalPtr(ptr, R_NilValue, R_NilValue)));
R_RegisterCFinalizerEx(rptr, rdbVectorFinalizer, TRUE);
origInfo->sxp_spare--;
UNPROTECT(2);
}
else
{
x = orig;
/* set ref counter to 0 because it'll be incremented when the result is bound to a name */
origInfo->sxp_spare = 0;
/*
rdbVector oldInfo = *origInfo;
origInfo->tableName = calloc(MAX_TABLE_NAME, sizeof(char));
func(sqlconn, &oldInfo, origInfo);
*/
/* save new table name */
/*
PROTECT(tname = ScalarString(mkChar(origInfo->tableName)));
R_do_slot_assign(x, install("tablename"), tname);
UNPROTECT(1);
*/
/* update finalizer */
/*
SEXP rptr = R_do_slot(x, install("ext"));
rdbVector *ptr = R_ExternalPtrAddr(rptr);
rdbVector *ptr = malloc(sizeof(rdbVector));
*ptr = *info;
rep->tableName = calloc(MAX_TABLE_NAME, sizeof(char));
strcpy(ptr->tableName, info->tableName);
SEXP rptr;
R_do_slot_assign(x, install("ext"), (rptr=R_MakeExternalPtr(ptr, R_NilValue, R_NilValue)));
R_RegisterCFinalizerEx(rptr, rdbvectorFinalizer, TRUE);
*/
}
return x;
}
SEXP R_get_slot(SEXP obj, SEXP name)
{
return R_do_slot(obj, name);
}
void omxInitExpectationBA81(omxExpectation* oo) {
omxState* currentState = oo->currentState;
SEXP rObj = oo->rObj;
SEXP tmp;
if(OMX_DEBUG) {
mxLog("Initializing %s.", oo->name);
}
if (!Glibrpf_model) {
#if USE_EXTERNAL_LIBRPF
get_librpf_t get_librpf = (get_librpf_t) R_GetCCallable("rpf", "get_librpf_model_GPL");
(*get_librpf)(LIBIFA_RPF_API_VERSION, &Glibrpf_numModels, &Glibrpf_model);
#else
// if linking against included source code
Glibrpf_numModels = librpf_numModels;
Glibrpf_model = librpf_model;
#endif
}
BA81Expect *state = new BA81Expect;
// These two constants should be as identical as possible
state->name = oo->name;
if (0) {
state->LogLargestDouble = 0.0;
state->LargestDouble = 1.0;
} else {
state->LogLargestDouble = log(std::numeric_limits<double>::max()) - 1;
state->LargestDouble = exp(state->LogLargestDouble);
ba81NormalQuad &quad = state->getQuad();
quad.setOne(state->LargestDouble);
}
state->expectedUsed = false;
state->estLatentMean = NULL;
state->estLatentCov = NULL;
state->type = EXPECTATION_OBSERVED;
state->itemParam = NULL;
state->EitemParam = NULL;
state->itemParamVersion = 0;
state->latentParamVersion = 0;
oo->argStruct = (void*) state;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("data")));
state->data = omxDataLookupFromState(tmp, currentState);
}
if (strcmp(omxDataType(state->data), "raw") != 0) {
omxRaiseErrorf("%s unable to handle data type %s", oo->name, omxDataType(state->data));
return;
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("verbose")));
state->verbose = Rf_asInteger(tmp);
}
int targetQpoints;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("qpoints")));
targetQpoints = Rf_asInteger(tmp);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("qwidth")));
state->grp.setGridFineness(Rf_asReal(tmp), targetQpoints);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("ItemSpec")));
state->grp.importSpec(tmp);
if (state->verbose >= 2) mxLog("%s: found %d item specs", oo->name, state->numItems());
}
state->_latentMeanOut = omxNewMatrixFromSlot(rObj, currentState, "mean");
state->_latentCovOut = omxNewMatrixFromSlot(rObj, currentState, "cov");
state->itemParam = omxNewMatrixFromSlot(rObj, currentState, "item");
state->grp.param = state->itemParam->data; // algebra not allowed yet TODO
const int numItems = state->itemParam->cols;
if (state->numItems() != numItems) {
omxRaiseErrorf("ItemSpec length %d must match the number of item columns (%d)",
state->numItems(), numItems);
return;
}
if (state->itemParam->rows != state->grp.impliedParamRows) {
omxRaiseErrorf("item matrix must have %d rows", state->grp.impliedParamRows);
return;
}
state->grp.paramRows = state->itemParam->rows;
// for algebra item param, will need to defer until later?
state->grp.learnMaxAbilities();
int maxAbilities = state->grp.itemDims;
state->grp.setFactorNames(state->itemParam->rownames);
{
ProtectedSEXP tmp2(R_do_slot(rObj, Rf_install(".detectIndependence")));
state->grp.detectIndependence = Rf_asLogical(tmp2);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("EstepItem")));
if (!Rf_isNull(tmp)) {
int rows, cols;
getMatrixDims(tmp, &rows, &cols);
if (rows != state->itemParam->rows || cols != state->itemParam->cols) {
Rf_error("EstepItem must have the same dimensions as the item MxMatrix");
}
state->EitemParam = REAL(tmp);
}
}
oo->computeFun = ba81compute;
oo->setVarGroup = ignoreSetVarGroup;
oo->destructFun = ba81Destroy;
oo->populateAttrFun = ba81PopulateAttributes;
oo->componentFun = getComponent;
oo->canDuplicate = false;
// TODO: Exactly identical rows do not contribute any information.
// The sorting algorithm ought to remove them so we get better cache behavior.
// The following summary stats would be cheaper to calculate too.
omxData *data = state->data;
if (data->hasDefinitionVariables()) Rf_error("%s: not implemented yet", oo->name);
std::vector<int> &rowMap = state->grp.rowMap;
int weightCol;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("weightColumn")));
weightCol = INTEGER(tmp)[0];
}
if (weightCol == NA_INTEGER) {
// Should rowMap be part of omxData? This is essentially a
// generic compression step that shouldn't be specific to IFA models.
state->grp.rowWeight = (double*) R_alloc(data->rows, sizeof(double));
rowMap.resize(data->rows);
int numUnique = 0;
for (int rx=0; rx < data->rows; ) {
int rw = 1;
state->grp.rowWeight[numUnique] = rw;
rowMap[numUnique] = rx;
rx += rw;
++numUnique;
}
rowMap.resize(numUnique);
state->weightSum = state->data->rows;
}
else {
if (omxDataColumnIsFactor(data, weightCol)) {
omxRaiseErrorf("%s: weightColumn %d is a factor", oo->name, 1 + weightCol);
return;
}
state->grp.rowWeight = omxDoubleDataColumn(data, weightCol);
state->weightSum = 0;
for (int rx=0; rx < data->rows; ++rx) { state->weightSum += state->grp.rowWeight[rx]; }
rowMap.resize(data->rows);
for (size_t rx=0; rx < rowMap.size(); ++rx) {
rowMap[rx] = rx;
}
}
// complain about non-integral rowWeights (EAP can't work) TODO
auto colMap = oo->getDataColumns();
for (int cx = 0; cx < numItems; cx++) {
int *col = omxIntDataColumnUnsafe(data, colMap[cx]);
state->grp.dataColumns.push_back(col);
}
// sanity check data
for (int cx = 0; cx < numItems; cx++) {
if (!omxDataColumnIsFactor(data, colMap[cx])) {
data->omxPrintData("diagnostic", 3);
omxRaiseErrorf("%s: column %d is not a factor", oo->name, int(1 + colMap[cx]));
return;
}
}
// TODO the max outcome should be available from omxData
for (int rx=0; rx < data->rows; rx++) {
int cols = 0;
for (int cx = 0; cx < numItems; cx++) {
const int *col = state->grp.dataColumns[cx];
int pick = col[rx];
if (pick == NA_INTEGER) continue;
++cols;
const int no = state->grp.itemOutcomes[cx];
if (pick > no) {
Rf_error("Data for item '%s' has at least %d outcomes, not %d",
state->itemParam->colnames[cx], pick, no);
}
}
if (cols == 0) {
Rf_error("Row %d has all NAs", 1+rx);
}
}
if (state->_latentMeanOut && state->_latentMeanOut->rows * state->_latentMeanOut->cols != maxAbilities) {
Rf_error("The mean matrix '%s' must be a row or column vector of size %d",
state->_latentMeanOut->name(), maxAbilities);
}
if (state->_latentCovOut && (state->_latentCovOut->rows != maxAbilities ||
state->_latentCovOut->cols != maxAbilities)) {
Rf_error("The cov matrix '%s' must be %dx%d",
state->_latentCovOut->name(), maxAbilities, maxAbilities);
}
state->grp.setLatentDistribution(state->_latentMeanOut? state->_latentMeanOut->data : NULL,
state->_latentCovOut? state->_latentCovOut->data : NULL);
{
EigenArrayAdaptor Eparam(state->itemParam);
Eigen::Map< Eigen::VectorXd > meanVec(state->grp.mean, maxAbilities);
Eigen::Map< Eigen::MatrixXd > covMat(state->grp.cov, maxAbilities, maxAbilities);
state->grp.quad.setStructure(state->grp.qwidth, state->grp.qpoints,
Eparam, meanVec, covMat);
}
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("minItemsPerScore")));
state->grp.setMinItemsPerScore(Rf_asInteger(tmp));
}
state->grp.buildRowSkip();
if (isErrorRaised()) return;
{ScopedProtect p1(tmp, R_do_slot(rObj, Rf_install("debugInternal")));
state->debugInternal = Rf_asLogical(tmp);
}
state->ElatentVersion = 0;
if (state->_latentMeanOut) {
state->estLatentMean = omxInitMatrix(maxAbilities, 1, TRUE, currentState);
omxCopyMatrix(state->estLatentMean, state->_latentMeanOut); // rename matrices TODO
}
if (state->_latentCovOut) {
state->estLatentCov = omxInitMatrix(maxAbilities, maxAbilities, TRUE, currentState);
omxCopyMatrix(state->estLatentCov, state->_latentCovOut);
}
}
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 omxInitLISRELExpectation(omxExpectation* oo) {
SEXP rObj = oo->rObj;
if(OMX_DEBUG) {
mxLog("Initializing LISREL Expectation.");
}
int nx, nxi, ny, neta, ntotal;
SEXP slotValue;
/* Create and fill expectation */
omxLISRELExpectation *LISobj = (omxLISRELExpectation*) R_alloc(1, sizeof(omxLISRELExpectation));
omxState* currentState = oo->currentState;
/* Set Expectation Calls and Structures */
oo->computeFun = omxCallLISRELExpectation;
oo->destructFun = omxDestroyLISRELExpectation;
oo->componentFun = omxGetLISRELExpectationComponent;
oo->populateAttrFun = omxPopulateLISRELAttributes;
oo->argStruct = (void*) LISobj;
/* Set up expectation structures */
if(OMX_DEBUG) {
mxLog("Initializing LISREL Meta Data for expectation.");
}
if(OMX_DEBUG) {
mxLog("Processing LX.");
}
LISobj->LX = omxNewMatrixFromSlot(rObj, currentState, "LX");
if(OMX_DEBUG) {
mxLog("Processing LY.");
}
LISobj->LY = omxNewMatrixFromSlot(rObj, currentState, "LY");
if(OMX_DEBUG) {
mxLog("Processing BE.");
}
LISobj->BE = omxNewMatrixFromSlot(rObj, currentState, "BE");
if(OMX_DEBUG) {
mxLog("Processing GA.");
}
LISobj->GA = omxNewMatrixFromSlot(rObj, currentState, "GA");
if(OMX_DEBUG) {
mxLog("Processing PH.");
}
LISobj->PH = omxNewMatrixFromSlot(rObj, currentState, "PH");
if(OMX_DEBUG) {
mxLog("Processing PS.");
}
LISobj->PS = omxNewMatrixFromSlot(rObj, currentState, "PS");
if(OMX_DEBUG) {
mxLog("Processing TD.");
}
LISobj->TD = omxNewMatrixFromSlot(rObj, currentState, "TD");
if(OMX_DEBUG) {
mxLog("Processing TE.");
}
LISobj->TE = omxNewMatrixFromSlot(rObj, currentState, "TE");
if(OMX_DEBUG) {
mxLog("Processing TH.");
}
LISobj->TH = omxNewMatrixFromSlot(rObj, currentState, "TH");
if(OMX_DEBUG) {
mxLog("Processing TX.");
}
LISobj->TX = omxNewMatrixFromSlot(rObj, currentState, "TX");
if(OMX_DEBUG) {
mxLog("Processing TY.");
}
LISobj->TY = omxNewMatrixFromSlot(rObj, currentState, "TY");
if(OMX_DEBUG) {
mxLog("Processing KA.");
}
LISobj->KA = omxNewMatrixFromSlot(rObj, currentState, "KA");
if(OMX_DEBUG) {
mxLog("Processing AL.");
}
LISobj->AL = omxNewMatrixFromSlot(rObj, currentState, "AL");
LISobj->noLY = LISobj->LY == NULL;
if(LISobj->noLY) {
LISobj->LY = omxInitMatrix(0, 0, TRUE, currentState);
LISobj->PS = omxInitMatrix(0, 0, TRUE, currentState);
LISobj->BE = omxInitMatrix(0, 0, TRUE, currentState);
LISobj->TE = omxInitMatrix(0, 0, TRUE, currentState);
}
LISobj->noLX = LISobj->LX == NULL;
if(LISobj->noLX) {
LISobj->LX = omxInitMatrix(0, 0, TRUE, currentState);
LISobj->PH = omxInitMatrix(0, 0, TRUE, currentState);
LISobj->TD = omxInitMatrix(0, 0, TRUE, currentState);
}
LISobj->Lnocol = LISobj->LY->cols == 0 || LISobj->LX->cols == 0;
if(LISobj->Lnocol) {
LISobj->GA = omxInitMatrix(LISobj->LY->cols, LISobj->LX->cols, TRUE, currentState);
LISobj->TH = omxInitMatrix(LISobj->LX->rows, LISobj->LY->rows, TRUE, currentState);
}
/* Identity Matrix, Size Of BE */
if(OMX_DEBUG) {
mxLog("Generating I.");
}
LISobj->I = omxNewIdentityMatrix(LISobj->BE->rows, currentState);
/* Get the nilpotency index of the BE matrix for I-BE inverse speedup */
if(OMX_DEBUG) {
mxLog("Processing expansion iteration depth.");
}
{ ScopedProtect p1(slotValue, R_do_slot(rObj, Rf_install("depth")));
LISobj->numIters = INTEGER(slotValue)[0];
if(OMX_DEBUG) {
mxLog("Using %d iterations.", LISobj->numIters);
}
}
/* Initialize the place holder matrices used in calculations */
nx = LISobj->LX->rows;
nxi = LISobj->LX->cols;
ny = LISobj->LY->rows;
neta = LISobj->LY->cols;
ntotal = nx + ny;
if(OMX_DEBUG) {
mxLog("Generating internals for computation.");
}
LISobj->A = omxInitMatrix(nx, nxi, TRUE, currentState);
LISobj->B = omxInitMatrix(nx, nx, TRUE, currentState);
LISobj->C = omxInitMatrix(neta, neta, TRUE, currentState);
LISobj->D = omxInitMatrix(ny, neta, TRUE, currentState);
LISobj->E = omxInitMatrix(nx, neta, TRUE, currentState);
LISobj->F = omxInitMatrix(nx, ny, TRUE, currentState);
LISobj->G = omxInitMatrix(neta, nxi, TRUE, currentState);
LISobj->H = omxInitMatrix(ny, neta, TRUE, currentState);
LISobj->J = omxInitMatrix(ny, ny, TRUE, currentState);
LISobj->K = omxInitMatrix(neta, 1, TRUE, currentState);
LISobj->L = omxInitMatrix(neta, neta, TRUE, currentState);
LISobj->TOP = omxInitMatrix(ny, ntotal, TRUE, currentState);
LISobj->BOT = omxInitMatrix(nx, ntotal, TRUE, currentState);
LISobj->MUX = omxInitMatrix(nx, 1, TRUE, currentState);
LISobj->MUY = omxInitMatrix(ny, 1, TRUE, currentState);
LISobj->cov = omxInitMatrix(ntotal, ntotal, TRUE, currentState);
LISobj->args = (omxMatrix**) R_alloc(2, sizeof(omxMatrix*));
/* Means */
if(LISobj->TX != NULL || LISobj->TY != NULL || LISobj->KA != NULL || LISobj->AL != NULL) {
LISobj->means = omxInitMatrix(1, ntotal, TRUE, currentState);
} else LISobj->means = NULL;
//TODO: Adjust means processing to allow only Xs or only Ys
}
rdbMatrix *getMatrixInfo(SEXP x)
{
rdbMatrix *info = (rdbMatrix*)RAW(R_do_slot(x,install("info")));
info->tableName = CHAR(STRING_ELT(R_do_slot(x,install("tablename")),0));
return info;
}
void omxCompleteExpectation(omxExpectation *ox) {
if(ox->isComplete) return;
if (ox->rObj) {
omxState *os = ox->currentState;
SEXP rObj = ox->rObj;
SEXP slot;
{ScopedProtect(slot, R_do_slot(rObj, Rf_install("container")));
if (Rf_length(slot) == 1) {
int ex = INTEGER(slot)[0];
ox->container = os->expectationList.at(ex);
}
}
{ScopedProtect(slot, R_do_slot(rObj, Rf_install("submodels")));
if (Rf_length(slot)) {
int numSubmodels = Rf_length(slot);
int *submodel = INTEGER(slot);
for (int ex=0; ex < numSubmodels; ex++) {
int sx = submodel[ex];
ox->submodels.push_back(omxExpectationFromIndex(sx, os));
}
}
}
}
omxExpectationProcessDataStructures(ox, ox->rObj);
int numSubmodels = (int) ox->submodels.size();
for (int ex=0; ex < numSubmodels; ex++) {
omxCompleteExpectation(ox->submodels[ex]);
}
ox->initFun(ox);
if(ox->computeFun == NULL) {
if (isErrorRaised()) {
Rf_error("Failed to initialize '%s' of type %s: %s", ox->name, ox->expType, Global->getBads());
} else {
Rf_error("Failed to initialize '%s' of type %s", ox->name, ox->expType);
}
}
if (OMX_DEBUG) {
omxData *od = ox->data;
omxState *state = ox->currentState;
std::string msg = string_snprintf("Expectation '%s' of type '%s' has"
" %d definition variables:\n", ox->name, ox->expType,
int(od->defVars.size()));
for (int dx=0; dx < int(od->defVars.size()); ++dx) {
omxDefinitionVar &dv = od->defVars[dx];
msg += string_snprintf("[%d] column '%s' ->", dx, omxDataColumnName(od, dv.column));
for (int lx=0; lx < dv.numLocations; ++lx) {
msg += string_snprintf(" %s[%d,%d]", state->matrixToName(~dv.matrices[lx]),
dv.rows[lx], dv.cols[lx]);
}
msg += "\n dirty:";
for (int mx=0; mx < dv.numDeps; ++mx) {
msg += string_snprintf(" %s", state->matrixToName(dv.deps[mx]));
}
msg += "\n";
}
mxLogBig(msg);
}
ox->isComplete = TRUE;
}
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;
}
}
}
}
void omxComputeNumericDeriv::initFromFrontend(omxState *state, SEXP rObj)
{
super::initFromFrontend(state, rObj);
/*if (state->conListX.size()) {
mxThrow("%s: cannot proceed with constraints (%d constraints found)",
name, int(state->conListX.size()));
}*/
fitMat = omxNewMatrixFromSlot(rObj, state, "fitfunction");
SEXP slotValue;
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("iterations")));
numIter = INTEGER(slotValue)[0];
if (numIter < 2) mxThrow("stepSize must be 2 or greater");
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("parallel")));
parallel = Rf_asLogical(slotValue);
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("checkGradient")));
checkGradient = Rf_asLogical(slotValue);
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("verbose")));
verbose = Rf_asInteger(slotValue);
{
ProtectedSEXP Rhessian(R_do_slot(rObj, Rf_install("hessian")));
wantHessian = Rf_asLogical(Rhessian);
}
Rf_protect(slotValue = R_do_slot(rObj, Rf_install("stepSize")));
stepSize = GRADIENT_FUDGE_FACTOR(3.0) * REAL(slotValue)[0];
if (stepSize <= 0) mxThrow("stepSize must be positive");
knownHessian = NULL;
{
ScopedProtect(slotValue, R_do_slot(rObj, Rf_install("knownHessian")));
if (!Rf_isNull(slotValue)) {
knownHessian = REAL(slotValue);
SEXP dimnames;
ScopedProtect pdn(dimnames, Rf_getAttrib(slotValue, R_DimNamesSymbol));
{
SEXP names;
ScopedProtect p1(names, VECTOR_ELT(dimnames, 0));
{
int nlen = Rf_length(names);
khMap.assign(nlen, -1);
for (int nx=0; nx < nlen; ++nx) {
const char *vname = CHAR(STRING_ELT(names, nx));
for (int vx=0; vx < int(varGroup->vars.size()); ++vx) {
if (strEQ(vname, varGroup->vars[vx]->name)) {
khMap[nx] = vx;
if (verbose >= 1) mxLog("%s: knownHessian[%d] '%s' mapped to %d",
name, nx, vname, vx);
break;
}
}
}
}
}
}
}
numParams = 0;
totalProbeCount = 0;
numParams = 0;
recordDetail = true;
detail = 0;
}
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 int n_ov = 0;
SEXP R_clear_method_selection()
{
n_ov = 0;
return R_NilValue;
}
static SEXP R_find_method(SEXP mlist, const char *class, SEXP fname)
{
/* find the element of the methods list that matches this class,
but not including inheritance. */
SEXP value, methods;
methods = R_do_slot(mlist, s_allMethods);
if(methods == R_NilValue) {
error(_("no \"allMethods\" slot found in object of class \"%s\" used as methods list for function '%s'"),
class_string(mlist), CHAR(asChar(fname)));
return(R_NilValue); /* -Wall */
}
value = R_element_named(methods, class);
return value;
}
SEXP R_quick_method_check(SEXP args, SEXP mlist, SEXP fdef)
{
/* Match the list of (evaluated) args to the methods list. */
SEXP object, methods, value, retValue = R_NilValue;
const char *class; int nprotect = 0;
if(!mlist)
/* 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;
}
void omxInitFIMLFitFunction(omxFitFunction* off)
{
if(OMX_DEBUG) {
mxLog("Initializing FIML fit function function.");
}
off->canDuplicate = TRUE;
SEXP rObj = off->rObj;
int numOrdinal = 0, numContinuous = 0;
omxMatrix *cov, *means;
omxFIMLFitFunction *newObj = new omxFIMLFitFunction;
omxExpectation* expectation = off->expectation;
if(expectation == NULL) {
omxRaiseError("FIML cannot fit without model expectations.");
return;
}
cov = omxGetExpectationComponent(expectation, "cov");
if(cov == NULL) {
omxRaiseError("No covariance expectation in FIML evaluation.");
return;
}
means = omxGetExpectationComponent(expectation, "means");
if(OMX_DEBUG) {
mxLog("FIML Initialization Completed.");
}
newObj->cov = cov;
newObj->means = means;
newObj->smallMeans = NULL;
newObj->ordMeans = NULL;
newObj->contRow = NULL;
newObj->ordRow = NULL;
newObj->ordCov = NULL;
newObj->ordContCov = NULL;
newObj->halfCov = NULL;
newObj->reduceCov = NULL;
off->computeFun = CallFIMLFitFunction;
newObj->corList = NULL;
newObj->weights = NULL;
newObj->SingleIterFn = omxFIMLSingleIterationJoint;
off->destructFun = omxDestroyFIMLFitFunction;
off->populateAttrFun = omxPopulateFIMLAttributes;
if(OMX_DEBUG) {
mxLog("Accessing data source.");
}
newObj->data = off->expectation->data;
if(OMX_DEBUG) {
mxLog("Accessing row likelihood option.");
}
newObj->returnRowLikelihoods = Rf_asInteger(R_do_slot(rObj, Rf_install("vector")));
newObj->rowLikelihoods = omxInitMatrix(newObj->data->rows, 1, TRUE, off->matrix->currentState);
newObj->rowLogLikelihoods = omxInitMatrix(newObj->data->rows, 1, TRUE, off->matrix->currentState);
if(OMX_DEBUG) {
mxLog("Accessing row likelihood population option.");
}
newObj->populateRowDiagnostics = Rf_asInteger(R_do_slot(rObj, Rf_install("rowDiagnostics")));
if(OMX_DEBUG) {
mxLog("Accessing variable mapping structure.");
}
newObj->dataColumns = off->expectation->dataColumns;
if(OMX_DEBUG) {
mxLog("Accessing Threshold matrix.");
}
numOrdinal = off->expectation->numOrdinal;
numContinuous = newObj->dataColumns->cols - numOrdinal;
omxSetContiguousDataColumns(&(newObj->contiguous), newObj->data, newObj->dataColumns);
/* Temporary storage for calculation */
int covCols = newObj->cov->cols;
if(OMX_DEBUG){mxLog("Number of columns found is %d", covCols);}
// int ordCols = omxDataNumFactor(newObj->data); // Unneeded, since we don't use it.
// int contCols = omxDataNumNumeric(newObj->data);
newObj->smallRow = omxInitMatrix(1, covCols, TRUE, off->matrix->currentState);
newObj->smallCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
newObj->RCX = omxInitMatrix(1, covCols, TRUE, off->matrix->currentState);
// newObj->zeros = omxInitMatrix(1, newObj->cov->cols, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->smallCov, newObj->cov); // Will keep its aliased state from here on.
if (means) {
newObj->smallMeans = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->smallMeans, newObj->means);
newObj->ordMeans = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordMeans, newObj->means);
}
newObj->contRow = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->contRow, newObj->smallRow );
newObj->ordCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordCov, newObj->cov);
newObj->ordRow = omxInitMatrix(covCols, 1, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordRow, newObj->smallRow );
newObj->Infin = (int*) R_alloc(covCols, sizeof(int));
off->argStruct = (void*)newObj;
//if (strEQ(expectation->expType, "MxExpectationStateSpace")) {
// newObj->SingleIterFn = omxFIMLSingleIteration; // remove this TODO
//}
if(numOrdinal > 0 && numContinuous <= 0) {
if(OMX_DEBUG) {
mxLog("Ordinal Data detected. Using Ordinal FIML.");
}
newObj->weights = (double*) R_alloc(covCols, sizeof(double));
newObj->corList = (double*) R_alloc(covCols * (covCols + 1) / 2, sizeof(double));
newObj->smallCor = (double*) R_alloc(covCols * (covCols + 1) / 2, sizeof(double));
newObj->lThresh = (double*) R_alloc(covCols, sizeof(double));
newObj->uThresh = (double*) R_alloc(covCols, sizeof(double));
} else if(numOrdinal > 0) {
if(OMX_DEBUG) {
mxLog("Ordinal and Continuous Data detected. Using Joint Ordinal/Continuous FIML.");
}
newObj->weights = (double*) R_alloc(covCols, sizeof(double));
newObj->ordContCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
newObj->halfCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
newObj->reduceCov = omxInitMatrix(covCols, covCols, TRUE, off->matrix->currentState);
omxCopyMatrix(newObj->ordContCov, newObj->cov);
newObj->corList = (double*) R_alloc(covCols * (covCols + 1) / 2, sizeof(double));
newObj->lThresh = (double*) R_alloc(covCols, sizeof(double));
newObj->uThresh = (double*) R_alloc(covCols, sizeof(double));
}
}