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