static void omxCallRFitFunction(omxFitFunction *oo, int want, FitContext *) { if (want & (FF_COMPUTE_PREOPTIMIZE)) return; omxRFitFunction* rFitFunction = (omxRFitFunction*)oo->argStruct; SEXP theCall, theReturn; ScopedProtect p2(theCall, Rf_allocVector(LANGSXP, 3)); SETCAR(theCall, rFitFunction->fitfun); SETCADR(theCall, rFitFunction->model); SETCADDR(theCall, rFitFunction->state); { ScopedProtect p1(theReturn, Rf_eval(theCall, R_GlobalEnv)); if (LENGTH(theReturn) < 1) { // seems impossible, but report it if it happens omxRaiseErrorf("FitFunction returned nothing"); } else if (LENGTH(theReturn) == 1) { oo->matrix->data[0] = Rf_asReal(theReturn); } else if (LENGTH(theReturn) == 2) { oo->matrix->data[0] = Rf_asReal(VECTOR_ELT(theReturn, 0)); R_Reprotect(rFitFunction->state = VECTOR_ELT(theReturn, 1), rFitFunction->stateIndex); } else if (LENGTH(theReturn) > 2) { omxRaiseErrorf("FitFunction returned more than 2 arguments"); } } }
SEXP audio_wait(SEXP instance, SEXP timeout) { if (instance == R_NilValue) { /* unlike other functions we allow NULL for a system-wide sleep without any event */ if (current_driver && current_driver->wait) return Rf_ScalarInteger(current_driver->wait(NULL, Rf_asReal(timeout))); return Rf_ScalarInteger(fallback_wait(Rf_asReal(timeout))); } if (TYPEOF(instance) != EXTPTRSXP) Rf_error("invalid audio instance"); audio_instance_t *p = (audio_instance_t *) EXTPTR_PTR(instance); if (!p) Rf_error("invalid audio instance"); return Rf_ScalarInteger(p->driver->wait ? p->driver->wait(p, Rf_asReal(timeout)) : WAIT_ERROR); }
SEXP audio_player(SEXP source, SEXP rate) { float fRate = -1.0; if (!current_driver) load_default_audio_driver(0); if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP) fRate = (float) Rf_asReal(rate); audio_instance_t *p = current_driver->create_player(source, fRate, 0); if (!p) Rf_error("cannot start audio driver"); p->driver = current_driver; p->kind = AI_PLAYER; SEXP ptr = R_MakeExternalPtr(p, R_NilValue, R_NilValue); Rf_protect(ptr); R_RegisterCFinalizer(ptr, audio_instance_destructor); Rf_setAttrib(ptr, Rf_install("class"), Rf_mkString("audioInstance")); Rf_unprotect(1); return ptr; }
SEXP cr_connect(SEXP sHost, SEXP sPort, SEXP sTimeout, SEXP sReconnect, SEXP sRetry) { const char *host = "localhost"; double tout = Rf_asReal(sTimeout); int port = Rf_asInteger(sPort), reconnect = (Rf_asInteger(sReconnect) > 0), retry = (Rf_asInteger(sRetry) > 0); redisContext *ctx; rconn_t *c; SEXP res; struct timeval tv; if (TYPEOF(sHost) == STRSXP && LENGTH(sHost) > 0) host = CHAR(STRING_ELT(sHost, 0)); tv.tv_sec = (int) tout; tv.tv_usec = (tout - (double)tv.tv_sec) * 1000000.0; if (port < 1) ctx = redisConnectUnixWithTimeout(host, tv); else ctx = redisConnectWithTimeout(host, port, tv); if (!ctx) Rf_error("connect to redis failed (NULL context)"); if (ctx->err){ SEXP es = Rf_mkChar(ctx->errstr); redisFree(ctx); Rf_error("connect to redis failed: %s", CHAR(es)); } c = malloc(sizeof(rconn_t)); if (!c) { redisFree(ctx); Rf_error("unable to allocate connection context"); } c->rc = ctx; c->flags = (reconnect ? RCF_RECONNECT : 0) | (retry ? RCF_RETRY : 0); c->host = strdup(host); c->port = port; c->timeout = tout; redisSetTimeout(ctx, tv); res = PROTECT(R_MakeExternalPtr(c, R_NilValue, R_NilValue)); Rf_setAttrib(res, R_ClassSymbol, Rf_mkString("redisConnection")); R_RegisterCFinalizer(res, rconn_fin); UNPROTECT(1); return res; }
SEXP audio_recorder(SEXP source, SEXP rate, SEXP channels) { float fRate = -1.0; int chs = Rf_asInteger(channels); if (!current_driver) load_default_audio_driver(0); if (TYPEOF(rate) == INTSXP || TYPEOF(rate) == REALSXP) fRate = (float) Rf_asReal(rate); if (chs < 1) chs = 1; if (!current_driver->create_recorder) Rf_error("the currently used audio driver doesn't support recording"); audio_instance_t *p = current_driver->create_recorder(source, fRate, chs, 0); if (!p) Rf_error("cannot start audio driver"); p->driver = current_driver; p->kind = AI_RECORDER; SEXP ptr = R_MakeExternalPtr(p, R_NilValue, R_NilValue); Rf_protect(ptr); R_RegisterCFinalizer(ptr, audio_instance_destructor); Rf_setAttrib(ptr, Rf_install("class"), Rf_mkString("audioInstance")); Rf_unprotect(1); return ptr; }
SEXP newJavaGD(SEXP sName, SEXP sWidth, SEXP sHeight, SEXP sSizeUnit, SEXP sXpinch, SEXP sYpinch, SEXP sCanvasColor, SEXP sPointsize, SEXP sGamma) { double width = Rf_asReal(sWidth); double height = Rf_asReal(sHeight); if (!R_FINITE(width) || width < 0.0) { error("Illegal argument: width"); } if (!R_FINITE(height) || height < 0.0) { error("Illegal argument: height"); } int sizeUnit = Rf_asInteger(sSizeUnit); double xpinch = Rf_asReal(sXpinch); double ypinch = Rf_asReal(sYpinch); if (!R_FINITE(xpinch) || xpinch <= 0.0) { xpinch = 0.0; ypinch = 0.0; } else if (!R_FINITE(ypinch)) { ypinch = xpinch; } int canvas = Rf_RGBpar(sCanvasColor, 0); double pointsize = Rf_asReal(sPointsize); double gamma = Rf_asReal(sGamma); if (!R_FINITE(gamma)) { gamma = 1.0; } addJavaGDDevice("", width, height, sizeUnit, xpinch, ypinch, canvas, pointsize, gamma ); return R_NilValue; }
/* Convert an R value to a GenericValue based on the type expected, given by type. */ bool convertRToGenericValue(llvm::GenericValue *rv, SEXP rval, const llvm::Type *type) { llvm::Type::TypeID ty; if(!type) { REprintf("var arg %d\n", TYPEOF(rval)); rv->IntVal = INTEGER(rval)[0]; // rv->IntVal = llvm::APInt((unsigned) 32, INTEGER(rval)[0]); return(true); } // FIX - enhance to cover more situations. if(type->isPointerTy()) { const llvm::Type *elType = ((const llvm::PointerType*) type)->getElementType(); ty = elType->getTypeID(); bool ok = true; switch(ty) { case llvm::Type::IntegerTyID: if(elType->isIntegerTy(8)) { if(TYPEOF(rval) == STRSXP) { rv->PointerVal = Rf_length(rval) ? (void*) CHAR(STRING_ELT(rval, 0)) : (void *) NULL; } else if(TYPEOF(rval) == NILSXP) { rv->PointerVal = (void*) NULL; } else ok = false; } else if(TYPEOF(rval) == INTSXP) rv->PointerVal = INTEGER(rval); else ok = false; break; case llvm::Type::DoubleTyID: if(TYPEOF(rval) == REALSXP) rv->PointerVal = REAL(rval); else ok = false; break; case llvm::Type::PointerTyID: if(TYPEOF(rval) == STRSXP) { rv->PointerVal = Rf_length(rval) ? (void*) CHAR(STRING_ELT(rval, 0)) : (void *) NULL; } if(TYPEOF(rval) == NILSXP || rval == R_NilValue) { rv->PointerVal = (void*) NULL; } else if(TYPEOF(rval) == RAWSXP) rv->PointerVal = (void*) RAW(rval); else ok = false; break; case llvm::Type::VoidTyID: if(rval == R_NilValue) rv->PointerVal = (void*) NULL; else if(TYPEOF(rval) == RAWSXP) rv->PointerVal = (void*) RAW(rval); break; default: ok = false; } if(ok == false) { int rtype = isSEXPType(type); if(rtype > 0) { rv->PointerVal = rval; ok = true; } } if(ok == false && TYPEOF(rval) == EXTPTRSXP) { rv->PointerVal = R_ExternalPtrAddr(rval); ok = true; } /* See if this is an S4 object with a "ref" slot that is an external pointer */ SEXP refRVal = NULL; if(ok == false && IS_S4_OBJECT(rval) && (refRVal = GET_SLOT(rval, Rf_install("ref"))) && refRVal != R_NilValue && TYPEOF(refRVal) == EXTPTRSXP) { rv->PointerVal = R_ExternalPtrAddr(refRVal); ok = true; } if(ok == false) { PROBLEM "no method to convert R object of R type %d to LLVM pointer to type %d", TYPEOF(rval), ty WARN; } return(ok); } ty = type->getTypeID(); switch(ty) { case llvm::Type::IntegerTyID: { uint64_t val = asInteger(rval); unsigned BitWidth = llvm::cast<llvm::IntegerType>(type)->getBitWidth(); rv->IntVal = llvm::APInt(BitWidth, val); return rv; } break; case llvm::Type::DoubleTyID: { rv->DoubleVal = Rf_asReal(rval); } break; case llvm::Type::FloatTyID: { rv->FloatVal = Rf_asReal(rval); } break; default: PROBLEM "no code yet for converting R to GV for type %d", (int) ty ERROR; } return(true); }
void ifaGroup::import(SEXP Rlist) { SEXP argNames; Rf_protect(argNames = Rf_getAttrib(Rlist, R_NamesSymbol)); if (Rf_length(Rlist) != Rf_length(argNames)) { mxThrow("All list elements must be named"); } std::vector<const char *> dataColNames; paramRows = -1; int pmatCols=-1; int mips = 1; int dataRows = 0; SEXP Rmean=0, Rcov=0; for (int ax=0; ax < Rf_length(Rlist); ++ax) { const char *key = R_CHAR(STRING_ELT(argNames, ax)); SEXP slotValue = VECTOR_ELT(Rlist, ax); if (strEQ(key, "spec")) { importSpec(slotValue); } else if (strEQ(key, "param")) { if (!Rf_isReal(slotValue)) mxThrow("'param' must be a numeric matrix of item parameters"); param = REAL(slotValue); getMatrixDims(slotValue, ¶mRows, &pmatCols); SEXP dimnames; Rf_protect(dimnames = Rf_getAttrib(slotValue, R_DimNamesSymbol)); if (!Rf_isNull(dimnames) && Rf_length(dimnames) == 2) { SEXP names; Rf_protect(names = VECTOR_ELT(dimnames, 0)); int nlen = Rf_length(names); factorNames.resize(nlen); for (int nx=0; nx < nlen; ++nx) { factorNames[nx] = CHAR(STRING_ELT(names, nx)); } Rf_protect(names = VECTOR_ELT(dimnames, 1)); nlen = Rf_length(names); itemNames.resize(nlen); for (int nx=0; nx < nlen; ++nx) { itemNames[nx] = CHAR(STRING_ELT(names, nx)); } } } else if (strEQ(key, "mean")) { Rmean = slotValue; if (!Rf_isReal(slotValue)) mxThrow("'mean' must be a numeric vector or matrix"); mean = REAL(slotValue); } else if (strEQ(key, "cov")) { Rcov = slotValue; if (!Rf_isReal(slotValue)) mxThrow("'cov' must be a numeric matrix"); cov = REAL(slotValue); } else if (strEQ(key, "data")) { Rdata = slotValue; dataRows = Rf_length(VECTOR_ELT(Rdata, 0)); SEXP names; Rf_protect(names = Rf_getAttrib(Rdata, R_NamesSymbol)); int nlen = Rf_length(names); dataColNames.reserve(nlen); for (int nx=0; nx < nlen; ++nx) { dataColNames.push_back(CHAR(STRING_ELT(names, nx))); } Rf_protect(dataRowNames = Rf_getAttrib(Rdata, R_RowNamesSymbol)); } else if (strEQ(key, "weightColumn")) { if (Rf_length(slotValue) != 1) { mxThrow("You can only have one %s", key); } weightColumnName = CHAR(STRING_ELT(slotValue, 0)); } else if (strEQ(key, "freqColumn")) { if (Rf_length(slotValue) != 1) { mxThrow("You can only have one %s", key); } freqColumnName = CHAR(STRING_ELT(slotValue, 0)); } else if (strEQ(key, "qwidth")) { qwidth = Rf_asReal(slotValue); } else if (strEQ(key, "qpoints")) { qpoints = Rf_asInteger(slotValue); } else if (strEQ(key, "minItemsPerScore")) { mips = Rf_asInteger(slotValue); } else { // ignore } } learnMaxAbilities(); if (itemDims < (int) factorNames.size()) factorNames.resize(itemDims); if (int(factorNames.size()) < itemDims) { factorNames.reserve(itemDims); const int SMALLBUF = 24; char buf[SMALLBUF]; while (int(factorNames.size()) < itemDims) { snprintf(buf, SMALLBUF, "s%d", int(factorNames.size()) + 1); factorNames.push_back(CHAR(Rf_mkChar(buf))); } } if (Rmean) { if (Rf_isMatrix(Rmean)) { int nrow, ncol; getMatrixDims(Rmean, &nrow, &ncol); if (!(nrow * ncol == itemDims && (nrow==1 || ncol==1))) { mxThrow("mean must be a column or row matrix of length %d", itemDims); } } else { if (Rf_length(Rmean) != itemDims) { mxThrow("mean must be a vector of length %d", itemDims); } } verifyFactorNames(Rmean, "mean"); } if (Rcov) { if (Rf_isMatrix(Rcov)) { int nrow, ncol; getMatrixDims(Rcov, &nrow, &ncol); if (nrow != itemDims || ncol != itemDims) { mxThrow("cov must be %dx%d matrix", itemDims, itemDims); } } else { if (Rf_length(Rcov) != 1) { mxThrow("cov must be %dx%d matrix", itemDims, itemDims); } } verifyFactorNames(Rcov, "cov"); } setLatentDistribution(mean, cov); setMinItemsPerScore(mips); if (numItems() != pmatCols) { mxThrow("item matrix implies %d items but spec is length %d", pmatCols, numItems()); } if (Rdata) { if (itemNames.size() == 0) mxThrow("Item matrix must have colnames"); for (int ix=0; ix < numItems(); ++ix) { bool found=false; for (int dc=0; dc < int(dataColNames.size()); ++dc) { if (strEQ(itemNames[ix], dataColNames[dc])) { SEXP col = VECTOR_ELT(Rdata, dc); if (!Rf_isFactor(col)) { if (TYPEOF(col) == INTSXP) { mxThrow("Column '%s' is an integer but " "not an ordered factor", dataColNames[dc]); } else { mxThrow("Column '%s' is of type %s; expecting an " "ordered factor (integer)", dataColNames[dc], Rf_type2char(TYPEOF(col))); } } dataColumns.push_back(INTEGER(col)); found=true; break; } } if (!found) { mxThrow("Cannot find item '%s' in data", itemNames[ix]); } } if (weightColumnName) { for (int dc=0; dc < int(dataColNames.size()); ++dc) { if (strEQ(weightColumnName, dataColNames[dc])) { SEXP col = VECTOR_ELT(Rdata, dc); if (TYPEOF(col) != REALSXP) { mxThrow("Column '%s' is of type %s; expecting type numeric (double)", dataColNames[dc], Rf_type2char(TYPEOF(col))); } rowWeight = REAL(col); break; } } if (!rowWeight) { mxThrow("Cannot find weight column '%s'", weightColumnName); } } if (freqColumnName) { for (int dc=0; dc < int(dataColNames.size()); ++dc) { if (strEQ(freqColumnName, dataColNames[dc])) { SEXP col = VECTOR_ELT(Rdata, dc); if (TYPEOF(col) != INTSXP) { mxThrow("Column '%s' is of type %s; expecting type integer", dataColNames[dc], Rf_type2char(TYPEOF(col))); } rowFreq = INTEGER(col); break; } } if (!rowFreq) { mxThrow("Cannot find frequency column '%s'", freqColumnName); } } rowMap.reserve(dataRows); for (int rx=0; rx < dataRows; ++rx) rowMap.push_back(rx); } Eigen::Map< Eigen::ArrayXXd > Eparam(param, paramRows, numItems()); Eigen::Map< Eigen::VectorXd > meanVec(mean, itemDims); Eigen::Map< Eigen::MatrixXd > covMat(cov, itemDims, itemDims); quad.setStructure(qwidth, qpoints, Eparam, meanVec, covMat); if (paramRows < impliedParamRows) { mxThrow("At least %d rows are required in the item parameter matrix, only %d found", impliedParamRows, paramRows); } quad.refresh(meanVec, covMat); }
SEXP makeVector(SEXP ans, int len, int type, SEXP nullValue) { SEXP tmp; int ctr; if(type == REALSXP) { PROTECT(tmp = NEW_NUMERIC(len)); for(ctr = 0; ctr < len; ctr++) { SEXP el = VECTOR_ELT(ans, ctr); REAL(tmp)[ctr] = TYPEOF(el) == LGLSXP && LOGICAL(el)[0] == NA_INTEGER ? NA_REAL : (TYPEOF(el) == REALSXP ? REAL(el)[0] : Rf_asReal(el)); } } else if(type == LGLSXP) { PROTECT(tmp = NEW_LOGICAL(len)); for(ctr = 0; ctr < len; ctr++) { SEXP el = VECTOR_ELT(ans, ctr); LOGICAL(tmp)[ctr] = TYPEOF(el) == LGLSXP ? LOGICAL(el)[0] : Rf_asInteger(el); } } else if(type == STRSXP) { PROTECT(tmp = NEW_CHARACTER(len)); for(ctr = 0; ctr < len; ctr++) { SEXP el = VECTOR_ELT(ans, ctr); if(TYPEOF(el) == STRSXP) SET_STRING_ELT(tmp, ctr, STRING_ELT(el, 0)); else if(TYPEOF(el) == LGLSXP) { SET_STRING_ELT(tmp, ctr, LOGICAL(el)[0] == NA_INTEGER ? NA_STRING : mkChar(LOGICAL(el)[0] ? "TRUE" : "FALSE")); } else if(TYPEOF(el) == REALSXP) { char buf[70]; sprintf(buf, "%lf", REAL(el)[0]); SET_STRING_ELT(tmp, ctr, mkChar(buf)); } } } else return(ans); UNPROTECT(1); return(tmp); }
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); } }