Beispiel #1
0
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;
		}
	}
}
Beispiel #2
0
void omxInitWLSFitFunction(omxFitFunction* oo) {
	
	omxMatrix *cov, *means, *weights;
	
	if(OMX_DEBUG) { mxLog("Initializing WLS FitFunction function."); }
	
	int vectorSize = 0;
	
	omxSetWLSFitFunctionCalls(oo);
	
	if(OMX_DEBUG) { mxLog("Retrieving expectation.\n"); }
	if (!oo->expectation) { Rf_error("%s requires an expectation", oo->fitType); }
	
	if(OMX_DEBUG) { mxLog("Retrieving data.\n"); }
	omxData* dataMat = oo->expectation->data;
	if (dataMat->hasDefinitionVariables()) Rf_error("%s: def vars not implemented", oo->name());
	
	if(!strEQ(omxDataType(dataMat), "acov") && !strEQ(omxDataType(dataMat), "cov")) {
		char *errstr = (char*) calloc(250, sizeof(char));
		sprintf(errstr, "WLS FitFunction unable to handle data type %s.  Data must be of type 'acov'.\n", omxDataType(dataMat));
		omxRaiseError(errstr);
		free(errstr);
		if(OMX_DEBUG) { mxLog("WLS FitFunction unable to handle data type %s.  Aborting.", omxDataType(dataMat)); }
		return;
	}
	
	omxWLSFitFunction *newObj = (omxWLSFitFunction*) R_alloc(1, sizeof(omxWLSFitFunction));
	OMXZERO(newObj, 1);
	oo->argStruct = (void*)newObj;
	oo->units = FIT_UNITS_SQUARED_RESIDUAL;
	
	/* Get Expectation Elements */
	newObj->expectedCov = omxGetExpectationComponent(oo->expectation, "cov");
	newObj->expectedMeans = omxGetExpectationComponent(oo->expectation, "means");
	
	// FIXME: threshold structure should be asked for by omxGetExpectationComponent
	
	/* Read and set expected means, variances, and weights */
	cov = omxDataCovariance(dataMat);
	means = omxDataMeans(dataMat);
	weights = omxDataAcov(dataMat);
	
	newObj->observedCov = cov;
	newObj->observedMeans = means;
	newObj->weights = weights;
	newObj->n = omxDataNumObs(dataMat);
	
	// NOTE: If there are any continuous columns then these vectors
	// will not match because eThresh is indexed by column number
	// not by ordinal column number.
	std::vector< omxThresholdColumn > &oThresh = omxDataThresholds(oo->expectation->data);
	std::vector< omxThresholdColumn > &eThresh = oo->expectation->thresholds;
	
	// Error Checking: Observed/Expected means must agree.  
	// ^ is XOR: true when one is false and the other is not.
	if((newObj->expectedMeans == NULL) ^ (newObj->observedMeans == NULL)) {
		if(newObj->expectedMeans != NULL) {
			omxRaiseError("Observed means not detected, but an expected means matrix was specified.\n  If you  wish to model the means, you must provide observed means.\n");
			return;
		} else {
			omxRaiseError("Observed means were provided, but an expected means matrix was not specified.\n  If you provide observed means, you must specify a model for the means.\n");
			return;
		}
	}
	
	if((eThresh.size()==0) ^ (oThresh.size()==0)) {
		if (eThresh.size()) {
			omxRaiseError("Observed thresholds not detected, but an expected thresholds matrix was specified.\n   If you wish to model the thresholds, you must provide observed thresholds.\n ");
			return;
		} else {
			omxRaiseError("Observed thresholds were provided, but an expected thresholds matrix was not specified.\nIf you provide observed thresholds, you must specify a model for the thresholds.\n");
			return;
		}
	}
	
	/* Error check weight matrix size */
	int ncol = newObj->observedCov->cols;
	vectorSize = (ncol * (ncol + 1) ) / 2;
	if(newObj->expectedMeans != NULL) {
		vectorSize = vectorSize + ncol;
	}
	for(int i = 0; i < int(oThresh.size()); i++) {
		vectorSize = vectorSize + oThresh[i].numThresholds;
	}
	if(OMX_DEBUG) { mxLog("Intial WLSFitFunction vectorSize comes to: %d.", vectorSize); }
	
	if(weights != NULL && (weights->rows != weights->cols || weights->cols != vectorSize)) {
		omxRaiseError("Developer Error in WLS-based FitFunction object: WLS-based expectation specified an incorrectly-sized weight matrix.\nIf you are not developing a new expectation type, you should probably post this to the OpenMx forums.");
		return;
	}
	
	
	// FIXME: More Rf_error checking for incoming Fit Functions
	
	/* Temporary storage for calculation */
	newObj->observedFlattened = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
	newObj->expectedFlattened = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
	newObj->standardExpectedFlattened = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
	newObj->P = omxInitMatrix(1, vectorSize, TRUE, oo->matrix->currentState);
	newObj->B = omxInitMatrix(vectorSize, 1, TRUE, oo->matrix->currentState);
	newObj->standardExpectedCov = omxInitMatrix(ncol, ncol, TRUE, oo->matrix->currentState);
	if (oo->expectation->thresholdsMat) {
		newObj->standardExpectedThresholds = omxInitMatrix(oo->expectation->thresholdsMat->rows, oo->expectation->thresholdsMat->cols, TRUE, oo->matrix->currentState);
	}
	if(means){
		newObj->standardExpectedMeans = omxInitMatrix(1, ncol, TRUE, oo->matrix->currentState);
	}
	omxMatrix *obsThresholdsMat = oo->expectation->data->obsThresholdsMat;
	
	flattenDataToVector(newObj->observedCov, newObj->observedMeans, obsThresholdsMat, oThresh, newObj->observedFlattened);
	flattenDataToVector(newObj->expectedCov, newObj->expectedMeans, oo->expectation->thresholdsMat,
				eThresh, newObj->expectedFlattened);

}
Beispiel #3
0
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);
	}
}