SEXP R_mongo_collection_update(SEXP ptr_col, SEXP ptr_selector, SEXP ptr_update, SEXP ptr_filters, SEXP upsert, SEXP multiple, SEXP replace){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *selector = r2bson(ptr_selector);
bson_t *update = r2bson(ptr_update);
bool success;
bson_t opts;
bson_init (&opts);
BSON_APPEND_BOOL (&opts, "upsert", Rf_asLogical(upsert));
if(!Rf_isNull(ptr_filters))
BSON_APPEND_ARRAY (&opts, "arrayFilters", r2bson(ptr_filters));
bson_error_t err;
bson_t reply;
if(Rf_asLogical(replace)){
success = mongoc_collection_replace_one(col, selector, update, &opts, &reply, &err);
} else {
success = Rf_asLogical(multiple) ?
mongoc_collection_update_many(col, selector, update, &opts, &reply, &err) :
mongoc_collection_update_one(col, selector, update, &opts, &reply, &err);
}
if(!success)
stop(err.message);
return bson2list(&reply);
}
SEXP R_mongo_collection_insert_bson(SEXP ptr_col, SEXP ptr_bson, SEXP stop_on_error){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *b = r2bson(ptr_bson);
mongoc_insert_flags_t flags = Rf_asLogical(stop_on_error) ? MONGOC_INSERT_NONE : MONGOC_INSERT_CONTINUE_ON_ERROR;
bson_error_t err;
if(!mongoc_collection_insert(col, flags, b, NULL, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
SEXP R_mongo_collection_remove(SEXP ptr_col, SEXP ptr_bson, SEXP just_one){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *b = r2bson(ptr_bson);
bson_error_t err;
mongoc_remove_flags_t flags = Rf_asLogical(just_one) ? MONGOC_REMOVE_SINGLE_REMOVE : MONGOC_REMOVE_NONE;
if(!mongoc_collection_remove(col, flags, b, NULL, &err))
stop(err.message);
return Rf_ScalarLogical(1);
}
SEXP R_mongo_collection_command(SEXP ptr_col, SEXP ptr_cmd, SEXP no_timeout){
mongoc_collection_t *col = r2col(ptr_col);
bson_t *cmd = r2bson(ptr_cmd);
mongoc_query_flags_t flags = MONGOC_QUERY_NONE;
if(Rf_asLogical(no_timeout))
flags += MONGOC_QUERY_NO_CURSOR_TIMEOUT;
mongoc_cursor_t *c = mongoc_collection_command(col, flags, 0, 0, 0, cmd, NULL, NULL);
if(!c)
stop("Error executing command.");
return cursor2r(c, ptr_col);
}
SEXP R_mongo_collection_aggregate(SEXP ptr_col, SEXP ptr_pipeline, SEXP ptr_options, SEXP no_timeout) {
mongoc_collection_t *col = r2col(ptr_col);
bson_t *pipeline = r2bson(ptr_pipeline);
bson_t *options = r2bson(ptr_options);
mongoc_query_flags_t flags = MONGOC_QUERY_NONE;
if(Rf_asLogical(no_timeout))
flags += MONGOC_QUERY_NO_CURSOR_TIMEOUT;
mongoc_cursor_t *c = mongoc_collection_aggregate (col, flags, pipeline, options, NULL);
if(!c)
stop("Error executing pipeline.");
return cursor2r(c, ptr_col);
}
SEXP R_mongo_restore(SEXP con, SEXP ptr_col, SEXP verb) {
bool verbose = Rf_asLogical(verb);
mongoc_collection_t *col = r2col(ptr_col);
bson_reader_t *reader = bson_reader_new_from_handle(con, bson_reader_feed, bson_reader_finalize);
mongoc_bulk_operation_t *bulk = NULL;
const bson_t *b;
bson_error_t err;
int count = 0;
int i = 0;
bool done = false;
bson_t reply;
while(!done) {
//note: default opts uses {ordered:true}
bulk = mongoc_collection_create_bulk_operation_with_opts(col, NULL);
for(i = 0; i < 1000; i++){
if(!(b = bson_reader_read (reader, &done)))
break;
mongoc_bulk_operation_insert (bulk, b);
count++;
}
if(i == 0)
break;
if(!mongoc_bulk_operation_execute (bulk, &reply, &err)){
bson_reader_destroy(reader);
mongoc_bulk_operation_destroy (bulk);
Rf_error(err.message);
}
if(verbose)
Rprintf("\rRestored %d records...", count);
}
if(verbose)
Rprintf("\rDone! Inserted total of %d records.\n", count);
if (!done)
Rf_warning("Failed to read all documents.\n");
bson_reader_destroy(reader);
mongoc_bulk_operation_destroy (bulk);
return Rf_ScalarInteger(count);
}
SEXP R_mongo_collection_insert_page(SEXP ptr_col, SEXP json_vec, SEXP stop_on_error){
if(!Rf_isString(json_vec) || !Rf_length(json_vec))
stop("json_vec must be character string of at least length 1");
//ordered means serial execution
bool ordered = Rf_asLogical(stop_on_error);
//create bulk operation
bson_error_t err;
bson_t *b;
bson_t reply;
mongoc_bulk_operation_t *bulk = mongoc_collection_create_bulk_operation_with_opts (r2col(ptr_col), NULL);
for(int i = 0; i < Rf_length(json_vec); i++){
b = bson_new_from_json ((uint8_t*) Rf_translateCharUTF8(Rf_asChar(STRING_ELT(json_vec, i))), -1, &err);
if(!b){
mongoc_bulk_operation_destroy (bulk);
stop(err.message);
}
mongoc_bulk_operation_insert(bulk, b);
bson_destroy (b);
b = NULL;
}
//execute bulk operation
bool success = mongoc_bulk_operation_execute (bulk, &reply, &err);
mongoc_bulk_operation_destroy (bulk);
//check for errors
if(!success){
if(ordered){
Rf_errorcall(R_NilValue, err.message);
} else {
Rf_warningcall(R_NilValue, "Not all inserts were successful: %s\n", err.message);
}
}
//get output
SEXP out = PROTECT(bson2list(&reply));
bson_destroy (&reply);
UNPROTECT(1);
return out;
}
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;
}
SEXP jsClientLib_jsclient_callback_(SEXP channelSEXP, SEXP dataSEXP, SEXP bufferSEXP) {
const char *channel = CHAR(STRING_ELT(channelSEXP, 0));
jsclient_callback_( channel, dataSEXP, Rf_asLogical( bufferSEXP ));
return R_NilValue;
}
SEXP jsClientLib_jsclient_callback_sync_(SEXP dataSEXP, SEXP bufferSEXP) {
return jsclient_callback_sync_( dataSEXP, Rf_asLogical( bufferSEXP ));
}
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);
}
}
SEXP emd_r(SEXP sBase, SEXP sCur, SEXP sExtra, SEXP sFlows, SEXP sDist, SEXP sMaxIter) {
SEXP sBaseDim = Rf_getAttrib(sBase, R_DimSymbol);
SEXP sCurDim = Rf_getAttrib(sCur, R_DimSymbol);
if (sBaseDim == R_NilValue || LENGTH(sBaseDim) != 2) Rf_error("base must be a matrix");
if (sCurDim == R_NilValue || LENGTH(sCurDim) != 2) Rf_error("cur must be a matrix");
int *baseDim = INTEGER(sBaseDim);
int *curDim = INTEGER(sCurDim);
int baseRows = baseDim[0], baseCol = baseDim[1];
int curRows = curDim[0], curCol = curDim[1];
int maxIter = Rf_asInteger(sMaxIter);
if (TYPEOF(sDist) != CLOSXP && (TYPEOF(sDist) != STRSXP || LENGTH(sDist) != 1)) Rf_error("invalid distance specification");
const char *distName = (TYPEOF(sDist) == STRSXP) ? CHAR(STRING_ELT(sDist, 0)) : 0;
dist_fn_t *dist_fn = 0;
if (!distName) {
dist_fn = calc_dist_default;
set_default_dist(eval_dist);
dist_clos = sDist;
cf1 = PROTECT(Rf_allocVector(REALSXP, FDIM));
cf2 = PROTECT(Rf_allocVector(REALSXP, FDIM));
} else {
if (!strcmp(distName, "euclidean")) dist_fn = calc_dist_L2;
if (!strcmp(distName, "manhattan")) dist_fn = calc_dist_L1;
}
if (!dist_fn)
Rf_error("invalid distance specification");
if (maxIter < 1) maxIter = 10000; /* somewhat random... */
sBase = Rf_coerceVector(sBase, REALSXP);
sCur = Rf_coerceVector(sCur, REALSXP);
double *baseVal = REAL(sBase);
double *curVal = REAL(sCur);
flow_t *flows = NULL;
int n_flows = 0;
if (baseCol != curCol) Rf_error("base and current sets must have the same dimensionality");
if (baseCol < 2) Rf_error("at least two columns (weight and location) are required");
if (baseCol > FDIM + 1) Rf_warning("more than %d dimensions are used, those will be ignored", FDIM);
signature_t baseSig, curSig;
baseSig.n = baseRows;
baseSig.Features = (feature_t*) R_alloc(baseRows, sizeof(feature_t));
baseSig.Weights = (float*) R_alloc(baseRows, sizeof(float));
curSig.n = curRows;
curSig.Features = (feature_t*) R_alloc(curRows, sizeof(feature_t));
curSig.Weights = (float*) R_alloc(curRows, sizeof(float));
int i, j;
for (i = 0; i < baseRows; i++) {
for (j = 0; j < FDIM; j++)
baseSig.Features[i].loc[j] = (j + 1 < baseCol) ? baseVal[i + (j + 1) * baseRows] : 0.0;
baseSig.Weights[i] = baseVal[i];
}
for (i = 0; i < curRows; i++) {
for (j = 0; j < FDIM; j++)
curSig.Features[i].loc[j] = (j + 1 < curCol) ? curVal[i + (j + 1) * curRows] : 0.0;
curSig.Weights[i] = curVal[i];
}
if (Rf_asLogical(sFlows) == TRUE) {
flows = malloc(sizeof(flow_t) * (baseRows + curRows - 1));
if (!flows)
Rf_error("unable to allocate memory for flows");
}
double d = emd_rubner(&baseSig, &curSig, flows, flows ? &n_flows : NULL, Rf_asInteger(sExtra), dist_fn, maxIter);
if (!distName) /* cf1, cf2 */
UNPROTECT(2);
if (!flows)
return Rf_ScalarReal(d);
SEXP res = PROTECT(Rf_ScalarReal(d));
SEXP fl = PROTECT(Rf_allocVector(VECSXP, 3)); /* must protect due to install() */
Rf_setAttrib(res, Rf_install("flows"), fl);
UNPROTECT(1);
SEXP f_from = Rf_allocVector(INTSXP, n_flows); SET_VECTOR_ELT(fl, 0, f_from);
SEXP f_to = Rf_allocVector(INTSXP, n_flows); SET_VECTOR_ELT(fl, 1, f_to);
SEXP f_amt = Rf_allocVector(REALSXP, n_flows); SET_VECTOR_ELT(fl, 2, f_amt);
int * i_from = INTEGER(f_from), * i_to = INTEGER(f_to);
double * r_amt = REAL(f_amt);
for (i = 0; i < n_flows; i++) {
i_from[i] = flows[i].from;
i_to[i] = flows[i].to;
r_amt[i] = flows[i].amount;
}
free(flows);
UNPROTECT(1);
return res;
}
