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 */
omxSetContiguousDataColumns(&(newObj->contiguous), newObj->data, newObj->dataColumns);
oo->computeFun = omxCallRowFitFunction;
oo->destructFun = omxDestroyRowFitFunction;
oo->argStruct = (void*) newObj;
}
/* 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);
}
SEXP R_NPAPI_Invoke(SEXP plug, SEXP Robj, SEXP Rname, SEXP Rargs, SEXP RconvArgsEnum, SEXP RconvArgsFuns, SEXP RconvRet, SEXP RkeepRes )
{
NPP inst = (NPP) R_ExternalPtrAddr(GET_SLOT( plug , Rf_install( "ref" ) ) );
NPNetscapeFuncs *funcs = (NPNetscapeFuncs *) R_ExternalPtrAddr(GET_SLOT( GET_SLOT(plug, Rf_install("funcs")), Rf_install("ref")));
NPVariant *obj = (NPVariant *) R_ExternalPtrAddr(GET_SLOT( Robj , Rf_install( "ref" ) ) );
if(!NPVARIANT_IS_OBJECT(*obj))
{
//What should we return in this case?
Rf_error("Robj is not an NPVariant containing an NPObject.");
return R_NilValue;
}
//custom conversion functions are applied on R side for return value.
convert_t convRet = (convert_t) INTEGER(RconvRet)[0];
convert_t curConvArg;
int nargs = LENGTH(Rargs);
NPVariant *args = (NPVariant *) funcs->memalloc(nargs*sizeof(NPVariant));
for(int i = 0; i < nargs; i++)
{
curConvArg = (convert_t) INTEGER(RconvArgsEnum)[i];
ConvertRToNP(VECTOR_ELT(Rargs, i), inst, funcs, &(args[i]), curConvArg);
//If we have a custom converter we invoke it with here
if(curConvArg == CONV_CUSTOM)
{
fprintf(stderr, "Custom argument converter detected. Attempting to call JS Conversion function.");fflush(stderr);
funcs->invokeDefault(inst, ((NPVariant *) R_ExternalPtrAddr(GET_SLOT( VECTOR_ELT(RconvArgsFuns, i), Rf_install( "ref" ) ) ) ) -> value.objectValue, &args[i], 1, &args[i]) ;
}
}
NPVariant *ret = (NPVariant *) funcs->memalloc(sizeof(NPVariant));
const char *ccname = CHAR(STRING_ELT(Rname, 0));
bool hasMethod = funcs->hasmethod(inst, obj->value.objectValue, funcs->getstringidentifier(ccname));
if(!hasMethod)
{
char msg[200];
sprintf(msg, "Object has no %s method.", ccname);
Rf_error(msg);
return R_NilValue;
}
bool success = funcs->invoke(inst, obj->value.objectValue, funcs->getstringidentifier(ccname), args, nargs, ret);
if(!success)
{
fprintf(stderr, "\nInvocation of JS method %s failed.", ccname);fflush(stderr);
}
for(int j=0; j<nargs; j++)
{
if (NPVARIANT_IS_OBJECT(args[j]))
funcs->releaseobject(args[j].value.objectValue);
//funcs->releasevariantvalue(&args[j]);
}
funcs->memfree(args);
if(!success)
{
char msg2[200];
sprintf(msg2, "Invoke failed for %s method.", ccname);
Rf_error(msg2);
return R_NilValue;
}
SEXP ans;
//PROTECT(ans = R_NilValue);
PROTECT(ans = NEW_INTEGER(1));
bool canfree = ConvertNPToR(ret, inst, funcs, convRet, &ans);
bool keepRes = LOGICAL(RkeepRes)[0];
if(canfree || !keepRes)
funcs->releasevariantvalue(ret);
UNPROTECT(1);
if(keepRes)
return ans ;
else
return R_NilValue;
}
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;
}
/* {{{ proto mixed R::callWithNames(string function_name, array arguments)
*/
static PHP_METHOD(R, callWithNames)
{
char *func;
int func_len, error_occurred = 0, num_args;
zval *args;
SEXP e, fun, val, arg, next;
HashPosition pos;
zval **element;
if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "sa", &func, &func_len, &args) == FAILURE) {
return;
}
fun = Rf_install(func);
if (!fun) {
RETURN_FALSE;
}
num_args = zend_hash_num_elements(Z_ARRVAL_P(args));
PROTECT(fun);
PROTECT(e = allocVector(LANGSXP, num_args + 1));
SETCAR(e, fun);
next = CDR(e);
for(zend_hash_internal_pointer_reset_ex(Z_ARRVAL_P(args), &pos);
zend_hash_get_current_data_ex(Z_ARRVAL_P(args), (void **)&element, &pos) == SUCCESS;
zend_hash_move_forward_ex(Z_ARRVAL_P(args), &pos)
) {
char *string_key;
uint string_key_len;
ulong num_key;
arg = php_zval_to_r(element);
switch (zend_hash_get_current_key_ex(Z_ARRVAL_P(args), &string_key, &string_key_len, &num_key, 0, &pos)) {
case HASH_KEY_IS_STRING:
if (string_key_len > 0) {
SET_TAG(next, Rf_install(string_key));
}
break;
case HASH_KEY_IS_LONG:
/* ignore the key */
break;
}
SETCAR(next, arg);
next = CDR(next);
}
val = R_tryEval(e, R_GlobalEnv, &error_occurred);
if (error_occurred) {
UNPROTECT(2);
RETURN_FALSE;
}
/* okay, the call succeeded */
PROTECT(val);
php_r_to_zval(val, return_value);
UNPROTECT(3);
}
SEXP
R_create2DArray(SEXP obj)
{
SAFEARRAYBOUND bounds[2] = {{0, 0}, {0, 0}};;
SAFEARRAY *arr;
void *data, *el;
VARTYPE type = VT_R8;
SEXP dim = GET_DIM(obj);
int integer;
double real;
BSTR bstr;
bounds[0].cElements = INTEGER(dim)[0];
bounds[1].cElements = INTEGER(dim)[1];
type = getDCOMType(obj);
arr = SafeArrayCreate(type, 2, bounds);
SafeArrayAccessData(arr, (void**) &data);
long indices[2];
UINT i, j, ctr = 0;
for(j = 0 ; j < bounds[1].cElements; j++) {
indices[1] = j;
for(i = 0; i < bounds[0].cElements; i++, ctr++) {
indices[0] = i;
switch(TYPEOF(obj)) {
case LGLSXP:
integer = (LOGICAL(obj)[ctr] ? 1:0);
el = &integer;
break;
case REALSXP:
real = REAL(obj)[ctr];
el = ℜ
break;
case INTSXP:
integer = INTEGER(obj)[ctr];
el = &integer;
break;
case STRSXP:
bstr = AsBstr(CHAR(STRING_ELT(obj, ctr)));
el = (void*) bstr;
break;
default:
continue;
break;
}
SafeArrayPutElement(arr, indices, el);
}
}
SafeArrayUnaccessData(arr);
VARIANT *var;
var = (VARIANT*) malloc(sizeof(VARIANT));
VariantInit(var);
V_VT(var) = VT_ARRAY | type;
V_ARRAY(var) = arr;
SEXP ans;
PROTECT(ans = R_MakeExternalPtr((void*) var, Rf_install("R_VARIANT"), R_NilValue));
R_RegisterCFinalizer(ans, RDCOM_SafeArray_finalizer);
UNPROTECT(1);
return(ans);
}
void CallProxy::traverse_call( SEXP obj ){
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("local") ) return ;
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("global") ){
SEXP symb = CADR(obj) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find(CHAR(PRINTNAME(symb))) ;
call = res ;
return ;
}
if( TYPEOF(obj) == LANGSXP && CAR(obj) == Rf_install("column") ){
call = get_column(CADR(obj), env, subsets) ;
return ;
}
if( ! Rf_isNull(obj) ){
SEXP head = CAR(obj) ;
switch( TYPEOF( head ) ){
case LANGSXP:
if( CAR(head) == Rf_install("global") ){
SEXP symb = CADR(head) ;
if( TYPEOF(symb) != SYMSXP ) stop( "global only handles symbols" ) ;
SEXP res = env.find( CHAR(PRINTNAME(symb)) ) ;
SETCAR(obj, res) ;
SET_TYPEOF(obj, LISTSXP) ;
break ;
}
if( CAR(head) == Rf_install("column")){
Symbol column = get_column( CADR(head), env, subsets) ;
SETCAR(obj, column ) ;
head = CAR(obj) ;
proxies.push_back( CallElementProxy( head, obj ) );
break ;
}
if( CAR(head) == Rf_install("~")) break ;
if( CAR(head) == Rf_install("order_by") ) break ;
if( CAR(head) == Rf_install("function") ) break ;
if( CAR(head) == Rf_install("local") ) return ;
if( CAR(head) == Rf_install("<-") ){
stop( "assignments are forbidden" ) ;
}
if( Rf_length(head) == 3 ){
SEXP symb = CAR(head) ;
if( symb == R_DollarSymbol || symb == Rf_install("@") || symb == Rf_install("::") || symb == Rf_install(":::") ){
// Rprintf( "CADR(obj) = " ) ;
// Rf_PrintValue( CADR(obj) ) ;
// for things like : foo( bar = bling )$bla
// so that `foo( bar = bling )` gets processed
if( TYPEOF(CADR(head)) == LANGSXP ){
traverse_call( CDR(head) ) ;
}
// deal with foo$bar( bla = boom )
if( TYPEOF(CADDR(head)) == LANGSXP ){
traverse_call( CDDR(head) ) ;
}
break ;
} else {
traverse_call( CDR(head) ) ;
}
} else {
traverse_call( CDR(head) ) ;
}
break ;
case LISTSXP:
traverse_call( head ) ;
traverse_call( CDR(head) ) ;
break ;
case SYMSXP:
if( TYPEOF(obj) != LANGSXP ){
if( ! subsets.count(head) ){
if( head == R_MissingArg ) break ;
if( head == Rf_install(".") ) break ;
// in the Environment -> resolve
try{
Shield<SEXP> x( env.find( CHAR(PRINTNAME(head)) ) ) ;
SETCAR( obj, x );
} catch( ...){
// what happens when not found in environment
}
} else {
// in the data frame
proxies.push_back( CallElementProxy( head, obj ) );
}
break ;
}
}
traverse_call( CDR(obj) ) ;
}
}
SEXP getEdgeLocs(Agraph_t *g) {
SEXP outList, curCP, curEP, pntList, pntSet, curXY, curLab;
SEXP epClass, cpClass, xyClass, labClass;
Agnode_t *node, *head;
Agedge_t *edge;
char *tmpString;
bezier bez;
int nodes;
int i,k,l,pntLstEl;
int curEle = 0;
epClass = MAKE_CLASS("AgEdge");
cpClass = MAKE_CLASS("BezierCurve");
xyClass = MAKE_CLASS("xyPoint");
labClass = MAKE_CLASS("AgTextLabel");
/* tmpString is used to convert a char to a char* w/ labels */
tmpString = (char *)R_alloc(2, sizeof(char));
if (tmpString == NULL) error("Allocation error in getEdgeLocs");
PROTECT(outList = allocVector(VECSXP, agnedges(g)));
nodes = agnnodes(g);
node = agfstnode(g);
for (i = 0; i < nodes; i++) {
edge = agfstout(g, node);
while (edge != NULL && edge->u.spl != NULL) {
PROTECT(curEP = NEW_OBJECT(epClass));
bez = edge->u.spl->list[0];
PROTECT(pntList = allocVector(VECSXP, ((bez.size-1)/3)));
pntLstEl = 0;
/* There are really (bez.size-1)/3 sets of control */
/* points, with the first set containing teh first 4 */
/* points, and then every other set starting with the */
/* last point from the previous set and then the next 3 */
for (k = 1; k < bez.size; k += 3) {
PROTECT(curCP = NEW_OBJECT(cpClass));
PROTECT(pntSet = allocVector(VECSXP, 4));
for (l = -1; l < 3; l++) {
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.list[k+l].x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.list[k+l].y));
SET_ELEMENT(pntSet, l+1, curXY);
UNPROTECT(1);
}
SET_SLOT(curCP, Rf_install("cPoints"), pntSet);
SET_ELEMENT(pntList, pntLstEl++, curCP);
UNPROTECT(2);
}
SET_SLOT(curEP, Rf_install("splines"), pntList);
/* get the sp and ep */
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.sp.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.sp.y));
SET_SLOT(curEP, Rf_install("sp"), curXY);
UNPROTECT(1);
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(bez.ep.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(bez.ep.y));
SET_SLOT(curEP, Rf_install("ep"), curXY);
UNPROTECT(1);
SET_SLOT(curEP, Rf_install("tail"), Rgraphviz_ScalarStringOrNull(node->name));
head = edge->head;
SET_SLOT(curEP, Rf_install("head"), Rgraphviz_ScalarStringOrNull(head->name));
/* TODO: clean up the use of attrs: dir, arrowhead, arrowtail.
* the following are for interactive plotting in R-env, not needed
* for output to files. The existing codes set "dir"-attr, but use
* "arrowhead"/"arrowtail" instead. Quite confusing.
*/
SET_SLOT(curEP, Rf_install("dir"), Rgraphviz_ScalarStringOrNull(agget(edge, "dir")));
SET_SLOT(curEP, Rf_install("arrowhead"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowhead")));
SET_SLOT(curEP, Rf_install("arrowtail"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowtail")));
SET_SLOT(curEP, Rf_install("arrowsize"), Rgraphviz_ScalarStringOrNull(agget(edge, "arrowsize")));
SET_SLOT(curEP, Rf_install("color"), Rgraphviz_ScalarStringOrNull(agget(edge, "color")));
/* get lty/lwd info */
if ( agget(edge, "lty") )
SET_SLOT(curEP, Rf_install("lty"), Rgraphviz_ScalarStringOrNull(agget(edge, "lty")));
if ( agget(edge, "lwd") )
SET_SLOT(curEP, Rf_install("lwd"), Rgraphviz_ScalarStringOrNull(agget(edge, "lwd")));
/* Get the label information */
if (edge->u.label != NULL) {
PROTECT(curLab = NEW_OBJECT(labClass));
SET_SLOT(curLab, Rf_install("labelText"),
Rgraphviz_ScalarStringOrNull(ED_label(edge)->text));
/* Get the X/Y location of the label */
PROTECT(curXY = NEW_OBJECT(xyClass));
#if GRAPHVIZ_MAJOR == 2 && GRAPHVIZ_MINOR > 20
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(ED_label(edge)->pos.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(ED_label(edge)->pos.y));
#else
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(edge->u.label->p.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(edge->u.label->p.y));
#endif
SET_SLOT(curLab, Rf_install("labelLoc"), curXY);
UNPROTECT(1);
snprintf(tmpString, 2, "%c",ED_label(edge)->u.txt.para->just);
SET_SLOT(curLab, Rf_install("labelJust"),
Rgraphviz_ScalarStringOrNull(tmpString));
SET_SLOT(curLab, Rf_install("labelWidth"),
Rf_ScalarInteger(ED_label(edge)->u.txt.para->width));
SET_SLOT(curLab, Rf_install("labelColor"),
Rgraphviz_ScalarStringOrNull(edge->u.label->fontcolor));
SET_SLOT(curLab, Rf_install("labelFontsize"), Rf_ScalarReal(edge->u.label->fontsize));
SET_SLOT(curEP, Rf_install("txtLabel"), curLab);
UNPROTECT(1);
}
SET_ELEMENT(outList, curEle++, curEP);
UNPROTECT(2);
edge = agnxtout(g, edge);
}
node = agnxtnode(g, node);
}
UNPROTECT(1);
return(outList);
}
static bool Rcpp_cache_know = false ;
static SEXP Rcpp_cache = R_NilValue ;
#define RCPP_HASH_CACHE_INDEX 4
#define RCPP_CACHE_SIZE 6
#ifndef RCPP_HASH_CACHE_INITIAL_SIZE
#define RCPP_HASH_CACHE_INITIAL_SIZE 1024
#endif
// only used for debugging
SEXP get_rcpp_cache() {
RCPP_DEBUG( "get_rcpp_cache (known = %s)", (Rcpp_cache_know ? "true" : "false" ) )
if( ! Rcpp_cache_know ){
SEXP getNamespaceSym = Rf_install("getNamespace");
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp11") ), R_GlobalEnv) );
Rcpp_cache = Rf_findVarInFrame( RCPP, Rf_install(".rcpp_cache") ) ;
Rcpp_cache_know = true ;
UNPROTECT(1) ;
}
RCPP_DEBUG( " [get_rcpp_cache] Rcpp_cache = <%p>", Rcpp_cache )
return Rcpp_cache ;
}
namespace Rcpp {
SEXP get_Rcpp11_namespace__impl(){
return VECTOR_ELT( get_rcpp_cache() , 0 ) ;
}
SEXP set_vars(SEXP x, const SymbolVector& vars) {
static SEXP vars_symbol = Rf_install("vars");
return Rf_setAttrib(x, vars_symbol, vars.get_vector());
}
SEXP getNodeLayouts(Agraph_t *g) {
Agnode_t *node;
SEXP outLst, nlClass, xyClass, curXY, curNL;
SEXP curLab, labClass;
int i, nodes;
char *tmpString;
if (g == NULL) error("getNodeLayouts passed a NULL graph");
nlClass = MAKE_CLASS("AgNode");
xyClass = MAKE_CLASS("xyPoint");
labClass = MAKE_CLASS("AgTextLabel");
/* tmpString is used to convert a char to a char* w/ labels */
tmpString = (char *)R_alloc(2, sizeof(char));
if (tmpString == NULL) error("Allocation error in getNodeLayouts");
nodes = agnnodes(g);
node = agfstnode(g);
PROTECT(outLst = allocVector(VECSXP, nodes));
for (i = 0; i < nodes; i++) {
PROTECT(curNL = NEW_OBJECT(nlClass));
PROTECT(curXY = NEW_OBJECT(xyClass));
SET_SLOT(curXY,Rf_install("x"),Rf_ScalarInteger(node->u.coord.x));
SET_SLOT(curXY,Rf_install("y"),Rf_ScalarInteger(node->u.coord.y));
SET_SLOT(curNL,Rf_install("center"),curXY);
SET_SLOT(curNL,Rf_install("height"),Rf_ScalarInteger(node->u.ht));
SET_SLOT(curNL,Rf_install("rWidth"),Rf_ScalarInteger(node->u.rw));
SET_SLOT(curNL,Rf_install("lWidth"),Rf_ScalarInteger(node->u.lw));
SET_SLOT(curNL,Rf_install("name"), Rgraphviz_ScalarStringOrNull(node->name));
SET_SLOT(curNL, Rf_install("color"), Rgraphviz_ScalarStringOrNull(agget(node, "color")));
SET_SLOT(curNL, Rf_install("fillcolor"), Rgraphviz_ScalarStringOrNull(agget(node, "fillcolor")));
SET_SLOT(curNL, Rf_install("shape"), Rgraphviz_ScalarStringOrNull(agget(node, "shape")));
SET_SLOT(curNL, Rf_install("style"), Rgraphviz_ScalarStringOrNull(agget(node, "style")));
PROTECT(curLab = NEW_OBJECT(labClass));
if (ND_label(node) == NULL) {
} else if (ND_label(node)->u.txt.para != NULL) {
SET_SLOT(curLab, Rf_install("labelText"),
Rgraphviz_ScalarStringOrNull(ND_label(node)->text));
snprintf(tmpString, 2, "%c",ND_label(node)->u.txt.para->just);
SET_SLOT(curLab, Rf_install("labelJust"), Rgraphviz_ScalarStringOrNull(tmpString));
SET_SLOT(curLab, Rf_install("labelWidth"),
Rf_ScalarInteger(ND_label(node)->u.txt.para->width));
/* Get the X/Y location of the label */
PROTECT(curXY = NEW_OBJECT(xyClass));
#if GRAPHVIZ_MAJOR == 2 && GRAPHVIZ_MINOR > 20
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(ND_label(node)->pos.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(ND_label(node)->pos.y));
#else
SET_SLOT(curXY, Rf_install("x"), Rf_ScalarInteger(node->u.label->p.x));
SET_SLOT(curXY, Rf_install("y"), Rf_ScalarInteger(node->u.label->p.y));
#endif
SET_SLOT(curLab, Rf_install("labelLoc"), curXY);
UNPROTECT(1);
SET_SLOT(curLab, Rf_install("labelColor"), Rgraphviz_ScalarStringOrNull(node->u.label->fontcolor));
SET_SLOT(curLab, Rf_install("labelFontsize"), Rf_ScalarReal(node->u.label->fontsize));
}
SET_SLOT(curNL, Rf_install("txtLabel"), curLab);
SET_ELEMENT(outLst, i, curNL);
node = agnxtnode(g,node);
UNPROTECT(3);
}
UNPROTECT(1);
return(outLst);
}
SymbolVector get_vars(SEXP x) {
static SEXP vars_symbol = Rf_install("vars");
return SymbolVector(Rf_getAttrib(x, vars_symbol));
}
/* .External */
SEXP ocl_call(SEXP args) {
struct arg_chain *float_args = 0;
ocl_call_context_t *occ;
int on, an = 0, ftype = FT_DOUBLE, ftsize, ftres, async;
SEXP ker = CADR(args), olen, arg, res, octx, dimVec;
cl_kernel kernel = getKernel(ker);
cl_context context;
cl_command_queue commands;
cl_device_id device_id = getDeviceID(getAttrib(ker, Rf_install("device")));
cl_mem output;
cl_int err;
size_t wdims[3] = {0, 0, 0};
int wdim = 1;
if (clGetKernelInfo(kernel, CL_KERNEL_CONTEXT, sizeof(context), &context, NULL) != CL_SUCCESS || !context)
Rf_error("cannot obtain kernel context via clGetKernelInfo");
args = CDDR(args);
res = Rf_getAttrib(ker, install("precision"));
if (TYPEOF(res) == STRSXP && LENGTH(res) == 1 && CHAR(STRING_ELT(res, 0))[0] != 'd')
ftype = FT_SINGLE;
ftsize = (ftype == FT_DOUBLE) ? sizeof(double) : sizeof(float);
olen = CAR(args); /* size */
args = CDR(args);
on = Rf_asInteger(olen);
if (on < 0)
Rf_error("invalid output length");
ftres = (Rf_asInteger(CAR(args)) == 1) ? 1 : 0; /* native.result */
if (ftype != FT_SINGLE) ftres = 0;
args = CDR(args);
async = (Rf_asInteger(CAR(args)) == 1) ? 0 : 1; /* wait */
args = CDR(args);
dimVec = coerceVector(CAR(args), INTSXP); /* dim */
wdim = LENGTH(dimVec);
if (wdim > 3)
Rf_error("OpenCL standard only supports up to three work item dimensions - use index vectors for higher dimensions");
if (wdim) {
int i; /* we don't use memcpy in case int and size_t are different */
for (i = 0; i < wdim; i++)
wdims[i] = INTEGER(dimVec)[i];
}
if (wdim < 1 || wdims[0] < 1 || (wdim > 1 && wdims[1] < 1) || (wdim > 2 && wdims[2] < 1))
Rf_error("invalid dimensions - muse be a numeric vector with positive values");
args = CDR(args);
occ = (ocl_call_context_t*) calloc(1, sizeof(ocl_call_context_t));
if (!occ) Rf_error("unable to allocate ocl_call context");
octx = PROTECT(R_MakeExternalPtr(occ, R_NilValue, R_NilValue));
R_RegisterCFinalizerEx(octx, ocl_call_context_fin, TRUE);
occ->output = output = clCreateBuffer(context, CL_MEM_WRITE_ONLY, ftsize * on, NULL, &err);
if (!output)
Rf_error("failed to create output buffer of %d elements via clCreateBuffer (%d)", on, err);
if (clSetKernelArg(kernel, an++, sizeof(cl_mem), &output) != CL_SUCCESS)
Rf_error("failed to set first kernel argument as output in clSetKernelArg");
if (clSetKernelArg(kernel, an++, sizeof(on), &on) != CL_SUCCESS)
Rf_error("failed to set second kernel argument as output length in clSetKernelArg");
occ->commands = commands = clCreateCommandQueue(context, device_id, 0, &err);
if (!commands)
ocl_err("clCreateCommandQueue");
if (ftype == FT_SINGLE) /* need conversions, create floats buffer */
occ->float_args = float_args = arg_alloc(0, 32);
while ((arg = CAR(args)) != R_NilValue) {
int n, ndiv = 1;
void *ptr;
size_t al;
switch (TYPEOF(arg)) {
case REALSXP:
if (ftype == FT_SINGLE) {
int i;
float *f;
double *d = REAL(arg);
n = LENGTH(arg);
f = (float*) malloc(sizeof(float) * n);
if (!f)
Rf_error("unable to allocate temporary single-precision memory for conversion from a double-precision argument vector of length %d", n);
for (i = 0; i < n; i++) f[i] = d[i];
ptr = f;
al = sizeof(float);
arg_add(float_args, ptr);
} else {
ptr = REAL(arg);
al = sizeof(double);
}
break;
case INTSXP:
ptr = INTEGER(arg);
al = sizeof(int);
break;
case LGLSXP:
ptr = LOGICAL(arg);
al = sizeof(int);
break;
case RAWSXP:
if (inherits(arg, "clFloat")) {
ptr = RAW(arg);
ndiv = al = sizeof(float);
break;
}
default:
Rf_error("only numeric or logical kernel arguments are supported");
/* no-ops but needed to make the compiler happy */
ptr = 0;
al = 0;
}
n = LENGTH(arg);
if (ndiv != 1) n /= ndiv;
if (n == 1) {/* scalar */
if (clSetKernelArg(kernel, an++, al, ptr) != CL_SUCCESS)
Rf_error("Failed to set scalar kernel argument %d (size=%d)", an, al);
} else {
cl_mem input = clCreateBuffer(context, CL_MEM_READ_ONLY | CL_MEM_USE_HOST_PTR, al * n, ptr, &err);
if (!input)
Rf_error("Unable to create buffer (%d elements, %d bytes each) for vector argument %d (oclError %d)", n, al, an, err);
if (!occ->mem_objects)
occ->mem_objects = arg_alloc(0, 32);
arg_add(occ->mem_objects, input);
#if 0 /* we used this before CL_MEM_USE_HOST_PTR */
if (clEnqueueWriteBuffer(commands, input, CL_TRUE, 0, al * n, ptr, 0, NULL, NULL) != CL_SUCCESS)
Rf_error("Failed to transfer data (%d elements) for vector argument %d", n, an);
#endif
if (clSetKernelArg(kernel, an++, sizeof(cl_mem), &input) != CL_SUCCESS)
Rf_error("Failed to set vector kernel argument %d (size=%d, length=%d)", an, al, n);
/* clReleaseMemObject(input); */
}
args = CDR(args);
}
if (clEnqueueNDRangeKernel(commands, kernel, wdim, NULL, wdims, NULL, 0, NULL, async ? &occ->event : NULL) != CL_SUCCESS)
Rf_error("Error during kernel execution");
if (async) { /* asynchronous call -> get out and return the context */
#if USE_OCL_COMPLETE_CALLBACK
clSetEventCallback(occ->event, CL_COMPLETE, ocl_complete_callback, occ);
#endif
clFlush(commands); /* the specs don't guarantee execution unless clFlush is called */
occ->ftres = ftres;
occ->ftype = ftype;
occ->on = on;
Rf_setAttrib(octx, R_ClassSymbol, mkString("clCallContext"));
UNPROTECT(1);
return octx;
}
clFinish(commands);
occ->finished = 1;
/* we can release input memory objects now */
if (occ->mem_objects) {
arg_free(occ->mem_objects, (afin_t) clReleaseMemObject);
occ->mem_objects = 0;
}
if (float_args) {
arg_free(float_args, 0);
float_args = occ->float_args = 0;
}
res = ftres ? Rf_allocVector(RAWSXP, on * sizeof(float)) : Rf_allocVector(REALSXP, on);
if (ftype == FT_SINGLE) {
if (ftres) {
if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(float) * on, RAW(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
PROTECT(res);
Rf_setAttrib(res, R_ClassSymbol, mkString("clFloat"));
UNPROTECT(1);
} else {
/* float - need a temporary buffer */
float *fr = (float*) malloc(sizeof(float) * on);
double *r = REAL(res);
int i;
if (!fr)
Rf_error("unable to allocate memory for temporary single-precision output buffer");
occ->float_out = fr;
if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(float) * on, fr, 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d float elements, oclError %d)", on, err);
for (i = 0; i < on; i++)
r[i] = fr[i];
}
} else if ((err = clEnqueueReadBuffer( commands, output, CL_TRUE, 0, sizeof(double) * on, REAL(res), 0, NULL, NULL )) != CL_SUCCESS)
Rf_error("Unable to transfer result vector (%d double elements, oclError %d)", on, err);
ocl_call_context_fin(octx);
UNPROTECT(1);
return res;
}
SEXP rlang_namespace(const char* ns) {
SEXP call = PROTECT(Rf_lang2(Rf_install("getNamespace"), Rf_mkString(ns)));
SEXP ns_env = Rf_eval(call, R_BaseEnv);
UNPROTECT(1);
return ns_env;
}
// TODO: use a vector<string> would make all this a bit more readable
void RInside::initialize(const int argc, const char* const argv[], const bool loadRcpp,
const bool verbose, const bool interactive) {
if (instance_m) {
throw std::runtime_error( "can only have one RInside instance" ) ;
} else {
instance_m = this ;
}
verbose_m = verbose; // Default is false
interactive_m = interactive;
// generated from Makevars{.win}
#include "RInsideEnvVars.h"
#ifdef WIN32
// we need a special case for Windows where users may deploy an RInside binary from CRAN
// which will have R_HOME set at compile time to CRAN's value -- so let's try to correct
// this here: a) allow user's setting of R_HOME and b) use R's get_R_HOME() function
if (getenv("R_HOME") == NULL) { // if on Windows and not set
char *rhome = get_R_HOME(); // query it, including registry
if (rhome != NULL) { // if something was found
setenv("R_HOME", get_R_HOME(), 1); // store what we got as R_HOME
} // this will now be used in next blocks
}
#endif
for (int i = 0; R_VARS[i] != NULL; i+= 2) {
if (getenv(R_VARS[i]) == NULL) { // if env variable is not yet set
if (setenv(R_VARS[i],R_VARS[i+1],1) != 0){
throw std::runtime_error(std::string("Could not set R environment variable ") +
std::string(R_VARS[i]) + std::string(" to ") +
std::string(R_VARS[i+1]));
}
}
}
#ifndef WIN32
R_SignalHandlers = 0; // Don't let R set up its own signal handlers
#endif
init_tempdir();
const char *R_argv[] = {(char*)programName, "--gui=none", "--no-save",
"--no-readline", "--silent", "--vanilla", "--slave"};
int R_argc = sizeof(R_argv) / sizeof(R_argv[0]);
Rf_initEmbeddedR(R_argc, (char**)R_argv);
#ifndef WIN32
R_CStackLimit = -1; // Don't do any stack checking, see R Exts, '8.1.5 Threading issues'
#endif
R_ReplDLLinit(); // this is to populate the repl console buffers
structRstart Rst;
R_DefParams(&Rst);
Rst.R_Interactive = (Rboolean) interactive_m; // sets interactive() to eval to false
#ifdef WIN32
Rst.rhome = getenv("R_HOME"); // which is set above as part of R_VARS
Rst.home = getRUser();
Rst.CharacterMode = LinkDLL;
Rst.ReadConsole = myReadConsole;
Rst.WriteConsole = myWriteConsole;
Rst.CallBack = myCallBack;
Rst.ShowMessage = myAskOk;
Rst.YesNoCancel = myAskYesNoCancel;
Rst.Busy = myBusy;
#endif
R_SetParams(&Rst);
if (true || loadRcpp) { // we always need Rcpp, so load it anyway
// Rf_install is used best by first assigning like this so that symbols get into the symbol table
// where they cannot be garbage collected; doing it on the fly does expose a minuscule risk of garbage
// collection -- with thanks to Doug Bates for the explanation and Luke Tierney for the heads-up
SEXP suppressMessagesSymbol = Rf_install("suppressMessages");
SEXP requireSymbol = Rf_install("require");
Rf_eval(Rf_lang2(suppressMessagesSymbol, Rf_lang2(requireSymbol, Rf_mkString("Rcpp"))), R_GlobalEnv);
}
global_env_m = new Rcpp::Environment(); // member variable for access to R's global environment
autoloads(); // loads all default packages, using code autogenerate from Makevars{,.win}
if ((argc - optind) > 1){ // for argv vector in Global Env */
Rcpp::CharacterVector s_argv( argv+(1+optind), argv+argc );
assign(s_argv, "argv");
} else {
assign(R_NilValue, "argv") ;
}
init_rand(); // for tempfile() to work correctly */
}
void*
getRDCOMReference(SEXP obj)
{
SEXP el = GET_SLOT(obj, Rf_install("ref"));
return(derefRDCOMPointer(el));
}
HRESULT
R_convertRObjectToDCOM(SEXP obj, VARIANT *var)
{
HRESULT status;
int type = R_typeof(obj);
if(!var)
return(S_FALSE);
#ifdef RDCOM_VERBOSE
errorLog("Type of argument %d\n", type);
#endif
if(type == EXTPTRSXP && EXTPTR_TAG(obj) == Rf_install("R_VARIANT")) {
VARIANT *tmp;
tmp = (VARIANT *) R_ExternalPtrAddr(obj);
if(tmp) {
//XXX
VariantCopy(var, tmp);
return(S_OK);
}
}
if(ISCOMIDispatch(obj)) {
IDispatch *ptr;
ptr = (IDispatch *) derefRIDispatch(obj);
V_VT(var) = VT_DISPATCH;
V_DISPATCH(var) = ptr;
//XX
ptr->AddRef();
return(S_OK);
}
if(ISSInstanceOf(obj, "COMDate")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_DATE;
V_DATE(var) = val;
return(S_OK);
} else if(ISSInstanceOf(obj, "COMCurrency")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_CY);
return(S_OK);
} else if(ISSInstanceOf(obj, "COMDecimal")) {
double val;
val = NUMERIC_DATA(GET_SLOT(obj, Rf_install(".Data")))[0];
V_VT(var) = VT_R8;
V_R8(var) = val;
VariantChangeType(var, var, 0, VT_DECIMAL);
return(S_OK);
}
/* We have a complex object and we are not going to try to convert it directly
but instead create an COM server object to represent it to the outside world. */
if((type == VECSXP && Rf_length(GET_NAMES(obj))) || Rf_length(GET_CLASS(obj)) > 0 || isMatrix(obj)) {
status = createGenericCOMObject(obj, var);
if(status == S_OK)
return(S_OK);
}
if(Rf_length(obj) == 0) {
V_VT(var) = VT_VOID;
return(S_OK);
}
if(type == VECSXP || Rf_length(obj) > 1) {
createRDCOMArray(obj, var);
return(S_OK);
}
switch(type) {
case STRSXP:
V_VT(var) = VT_BSTR;
V_BSTR(var) = AsBstr(getRString(obj, 0));
break;
case INTSXP:
V_VT(var) = VT_I4;
V_I4(var) = R_integerScalarValue(obj, 0);
break;
case REALSXP:
V_VT(var) = VT_R8;
V_R8(var) = R_realScalarValue(obj, 0);
break;
case LGLSXP:
V_VT(var) = VT_BOOL;
V_BOOL(var) = R_logicalScalarValue(obj, 0) ? VARIANT_TRUE : VARIANT_FALSE;
break;
case VECSXP:
break;
}
return(S_OK);
}
void *
derefRIDispatch(SEXP obj)
{
return(derefRDCOMPointer(GET_SLOT(obj, Rf_install("ref"))));
}
str RAPIeval(Client cntxt, MalBlkPtr mb, MalStkPtr stk, InstrPtr pci, bit grouped) {
sql_func * sqlfun = NULL;
str exprStr = *getArgReference_str(stk, pci, pci->retc + 1);
SEXP x, env, retval;
SEXP varname = R_NilValue;
SEXP varvalue = R_NilValue;
ParseStatus status;
int i = 0;
char argbuf[64];
char *argnames = NULL;
size_t argnameslen;
size_t pos;
char* rcall = NULL;
size_t rcalllen;
int ret_cols = 0; /* int because pci->retc is int, too*/
str *args;
int evalErr;
char *msg = MAL_SUCCEED;
BAT *b;
node * argnode;
int seengrp = FALSE;
rapiClient = cntxt;
if (!RAPIEnabled()) {
throw(MAL, "rapi.eval",
"Embedded R has not been enabled. Start server with --set %s=true",
rapi_enableflag);
}
if (!rapiInitialized) {
throw(MAL, "rapi.eval",
"Embedded R initialization has failed");
}
if (!grouped) {
sql_subfunc *sqlmorefun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc));
if (sqlmorefun) sqlfun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc))->func;
} else {
sqlfun = *(sql_func**) getArgReference(stk, pci, pci->retc);
}
args = (str*) GDKzalloc(sizeof(str) * pci->argc);
if (args == NULL) {
throw(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
}
// get the lock even before initialization of the R interpreter, as this can take a second and must be done only once.
MT_lock_set(&rapiLock);
env = PROTECT(eval(lang1(install("new.env")), R_GlobalEnv));
assert(env != NULL);
// first argument after the return contains the pointer to the sql_func structure
// NEW macro temporarily renamed to MNEW to allow including sql_catalog.h
if (sqlfun != NULL && sqlfun->ops->cnt > 0) {
int carg = pci->retc + 2;
argnode = sqlfun->ops->h;
while (argnode) {
char* argname = ((sql_arg*) argnode->data)->name;
args[carg] = GDKstrdup(argname);
carg++;
argnode = argnode->next;
}
}
// the first unknown argument is the group, we don't really care for the rest.
argnameslen = 2;
for (i = pci->retc + 2; i < pci->argc; i++) {
if (args[i] == NULL) {
if (!seengrp && grouped) {
args[i] = GDKstrdup("aggr_group");
seengrp = TRUE;
} else {
snprintf(argbuf, sizeof(argbuf), "arg%i", i - pci->retc - 1);
args[i] = GDKstrdup(argbuf);
}
}
argnameslen += strlen(args[i]) + 2; /* extra for ", " */
}
// install the MAL variables into the R environment
// we can basically map values to int ("INTEGER") or double ("REAL")
for (i = pci->retc + 2; i < pci->argc; i++) {
int bat_type = getBatType(getArgType(mb,pci,i));
// check for BAT or scalar first, keep code left
if (!isaBatType(getArgType(mb,pci,i))) {
b = COLnew(0, getArgType(mb, pci, i), 0, TRANSIENT);
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
if ( getArgType(mb,pci,i) == TYPE_str) {
if (BUNappend(b, *getArgReference_str(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
} else {
if (BUNappend(b, getArgReference(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
} else {
b = BATdescriptor(*getArgReference_bat(stk, pci, i));
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
// check the BAT count, if it is bigger than RAPI_MAX_TUPLES, fail
if (BATcount(b) > RAPI_MAX_TUPLES) {
msg = createException(MAL, "rapi.eval",
"Got "BUNFMT" rows, but can only handle "LLFMT". Sorry.",
BATcount(b), (lng) RAPI_MAX_TUPLES);
BBPunfix(b->batCacheid);
goto wrapup;
}
varname = PROTECT(Rf_install(args[i]));
varvalue = bat_to_sexp(b, bat_type);
if (varvalue == NULL) {
msg = createException(MAL, "rapi.eval", "unknown argument type ");
goto wrapup;
}
BBPunfix(b->batCacheid);
// install vector into R environment
Rf_defineVar(varname, varvalue, env);
UNPROTECT(2);
}
/* we are going to evaluate the user function within an anonymous function call:
* ret <- (function(arg1){return(arg1*2)})(42)
* the user code is put inside the {}, this keeps our environment clean (TM) and gives
* a clear path for return values, namely using the builtin return() function
* this is also compatible with PL/R
*/
pos = 0;
argnames = malloc(argnameslen);
if (argnames == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
argnames[0] = '\0';
for (i = pci->retc + 2; i < pci->argc; i++) {
pos += snprintf(argnames + pos, argnameslen - pos, "%s%s",
args[i], i < pci->argc - 1 ? ", " : "");
}
rcalllen = 2 * pos + strlen(exprStr) + 100;
rcall = malloc(rcalllen);
if (rcall == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
snprintf(rcall, rcalllen,
"ret <- as.data.frame((function(%s){%s})(%s), nm=NA, stringsAsFactors=F)\n",
argnames, exprStr, argnames);
free(argnames);
argnames = NULL;
#ifdef _RAPI_DEBUG_
printf("# R call %s\n",rcall);
#endif
x = R_ParseVector(mkString(rcall), 1, &status, R_NilValue);
if (LENGTH(x) != 1 || status != PARSE_OK) {
msg = createException(MAL, "rapi.eval",
"Error parsing R expression '%s'. ", exprStr);
goto wrapup;
}
retval = R_tryEval(VECTOR_ELT(x, 0), env, &evalErr);
if (evalErr != FALSE) {
char* errormsg = strdup(R_curErrorBuf());
size_t c;
if (errormsg == NULL) {
msg = createException(MAL, "rapi.eval", "Error running R expression.");
goto wrapup;
}
// remove newlines from error message so it fits into a MAPI error (lol)
for (c = 0; c < strlen(errormsg); c++) {
if (errormsg[c] == '\r' || errormsg[c] == '\n') {
errormsg[c] = ' ';
}
}
msg = createException(MAL, "rapi.eval",
"Error running R expression: %s", errormsg);
free(errormsg);
goto wrapup;
}
// ret should be a data frame with exactly as many columns as we need from retc
ret_cols = LENGTH(retval);
if (ret_cols != pci->retc) {
msg = createException(MAL, "rapi.eval",
"Expected result of %d columns, got %d", pci->retc, ret_cols);
goto wrapup;
}
// collect the return values
for (i = 0; i < pci->retc; i++) {
SEXP ret_col = VECTOR_ELT(retval, i);
int bat_type = getBatType(getArgType(mb,pci,i));
if (bat_type == TYPE_any || bat_type == TYPE_void) {
getArgType(mb,pci,i) = bat_type;
msg = createException(MAL, "rapi.eval",
"Unknown return value, possibly projecting with no parameters.");
goto wrapup;
}
// hand over the vector into a BAT
b = sexp_to_bat(ret_col, bat_type);
if (b == NULL) {
msg = createException(MAL, "rapi.eval",
"Failed to convert column %i", i);
goto wrapup;
}
// bat return
if (isaBatType(getArgType(mb,pci,i))) {
*getArgReference_bat(stk, pci, i) = b->batCacheid;
} else { // single value return, only for non-grouped aggregations
BATiter li = bat_iterator(b);
if (VALinit(&stk->stk[pci->argv[i]], bat_type,
BUNtail(li, 0)) == NULL) { // TODO BUNtail here
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
msg = MAL_SUCCEED;
}
/* unprotect environment, so it will be eaten by the GC. */
UNPROTECT(1);
wrapup:
MT_lock_unset(&rapiLock);
if (argnames)
free(argnames);
if (rcall)
free(rcall);
for (i = 0; i < pci->argc; i++)
GDKfree(args[i]);
GDKfree(args);
return msg;
}
SEXP R_copyStruct_unz_file_info ( unz_file_info *value)
{
SEXP r_ans = R_NilValue, klass;
klass = MAKE_CLASS("unz_file_info");
if(klass == R_NilValue) {
PROBLEM "Cannot find R class unz_file_info "
ERROR;
}
PROTECT(klass);
PROTECT(r_ans = NEW(klass));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("version"), ScalarReal ( value -> version ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("version_needed"), ScalarReal ( value -> version_needed ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("flag"), ScalarReal ( value -> flag ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("compression_method"), ScalarReal ( value -> compression_method ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("dosDate"), ScalarReal ( value -> dosDate ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("crc"), ScalarReal ( value -> crc ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("compressed_size"), ScalarReal ( value -> compressed_size ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("uncompressed_size"), ScalarReal ( value -> uncompressed_size ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("size_filename"), ScalarReal ( value -> size_filename ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("size_file_extra"), ScalarReal ( value -> size_file_extra ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("size_file_comment"), ScalarReal ( value -> size_file_comment ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("disk_num_start"), ScalarReal ( value -> disk_num_start ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("internal_fa"), ScalarReal ( value -> internal_fa ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("external_fa"), ScalarReal ( value -> external_fa ) ));
PROTECT(r_ans = SET_SLOT(r_ans, Rf_install("tmu_date"), R_copyStruct_tm_unz( &value -> tmu_date ) ));
UNPROTECT( 17 );
return(r_ans);
}
SEXP getOption(const std::string& name)
{
return Rf_GetOption(Rf_install(name.c_str()), R_BaseEnv);
}
// TODO: split out some of the large blocks into helper functions, to make this easier to read
void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, int add_type_flags, RData *storage, int nesting_depth) {
RK_TRACE (RBACKEND);
bool at_toplevel = (toplevel_value == val);
bool is_function = false;
bool is_container = false;
bool is_environment = false;
bool no_recurse = (nesting_depth >= 2); // TODO: should be configurable
unsigned int type = 0;
RK_DEBUG (RBACKEND, DL_DEBUG, "fetching '%s': %p, s-type %d", name.toLatin1().data(), val, TYPEOF (val));
SEXP value = val;
PROTECT_INDEX value_index;
PROTECT_WITH_INDEX (value, &value_index);
// manually resolve any promises
REPROTECT (value = resolvePromise (value), value_index);
bool is_s4 = Rf_isS4 (value);
SEXP baseenv = R_BaseEnv;
if (is_s4) baseenv = R_GlobalEnv;
// first field: get name
RData *namedata = new RData;
namedata->setData (QStringList (name));
// get classes
SEXP classes_s;
if ((TYPEOF (value) == LANGSXP) || (TYPEOF (value) == SYMSXP)) { // if it's a call, we should NEVER send it through eval
extern SEXP R_data_class (SEXP, Rboolean);
classes_s = R_data_class (value, (Rboolean) 0);
REPROTECT (value = Rf_coerceVector (value, EXPRSXP), value_index); // make sure the object is safe for everything to come
PROTECT (classes_s);
} else {
classes_s = RKRSupport::callSimpleFun (class_fun, value, baseenv);
PROTECT (classes_s);
}
QStringList classes = RKRSupport::SEXPToStringList (classes_s);
UNPROTECT (1); /* classes_s */
// store classes
RData *classdata = new RData;
classdata->setData (classes);
// basic classification
for (int i = classes.size () - 1; i >= 0; --i) {
#warning: Using is.data.frame() may be more reliable (would need to be called only on List-objects, thus no major performance hit)
if (classes[i] == "data.frame") type |= RObject::DataFrame;
}
if (RKRSupport::callSimpleBool (is_matrix_fun, value, baseenv)) type |= RObject::Matrix;
if (RKRSupport::callSimpleBool (is_list_fun, value, baseenv)) type |= RObject::List;
if (type != 0) {
is_container = true;
type |= RObject::Container;
} else {
if (RKRSupport::callSimpleBool (is_function_fun, value, baseenv)) {
is_function = true;
type |= RObject::Function;
} else if (RKRSupport::callSimpleBool (is_environment_fun, value, baseenv)) {
is_container = true;
type |= RObject::Environment;
is_environment = true;
} else {
type |= RObject::Variable;
if (RKRSupport::callSimpleBool (is_factor_fun, value, baseenv)) type |= RObject::Factor;
else if (RKRSupport::callSimpleBool (is_numeric_fun, value, baseenv)) type |= RObject::Numeric;
else if (RKRSupport::callSimpleBool (is_character_fun, value, baseenv)) type |= RObject::Character;
else if (RKRSupport::callSimpleBool (is_logical_fun, value, baseenv)) type |= RObject::Logical;
if (RKRSupport::callSimpleBool (is_array_fun, value, baseenv)) type |= RObject::Array;
}
}
type |= add_type_flags;
if (is_container) {
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into %s", name.toLatin1().data ());
}
}
// get meta data, if any
RData *metadata = new RData;
if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
SEXP meta_s = RKRSupport::callSimpleFun (get_meta_fun, value, R_GlobalEnv);
PROTECT (meta_s);
metadata->setData (RKRSupport::SEXPToStringList (meta_s));
UNPROTECT (1); /* meta_s */
} else {
metadata->setData (QStringList ());
}
// get dims
RData::IntStorage dims;
SEXP dims_s = RKRSupport::callSimpleFun (dims_fun, value, baseenv);
if (!Rf_isNull (dims_s)) {
dims = RKRSupport::SEXPToIntArray (dims_s);
} else {
unsigned int len = Rf_length (value);
if ((len < 2) && (!is_function)) { // suspicious. Maybe some kind of list
SEXP len_s = RKRSupport::callSimpleFun (length_fun, value, baseenv);
PROTECT (len_s);
if (Rf_isNull (len_s)) {
dims.append (len);
} else {
dims = RKRSupport::SEXPToIntArray (len_s);
}
UNPROTECT (1); /* len_s */
} else {
dims.append (len);
}
}
// store dims
RData *dimdata = new RData;
dimdata->setData (dims);
RData *slotsdata = new RData ();
// does it have slots?
if (is_s4) {
type |= RObject::S4Object;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into slots of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
SEXP slots_pseudo_object = RKRSupport::callSimpleFun (rk_get_slots_fun, value, R_GlobalEnv);
PROTECT (slots_pseudo_object);
getStructureSafe (slots_pseudo_object, "SLOTS", RObject::PseudoObject, dummy[0], nesting_depth); // do not increase depth for this pseudo-object
UNPROTECT (1);
slotsdata->setData (dummy);
}
}
// store type
RData *typedata = new RData;
typedata->setData (RData::IntStorage (1, type));
// store everything we have so far
int storage_length = RObject::StorageSizeBasicInfo;
if (is_container) {
storage_length = RObject::StorageSizeBasicInfo + 1;
} else if (is_function) {
storage_length = RObject::StorageSizeBasicInfo + 2;
}
RData::RDataStorage res (storage_length, 0);
res[RObject::StoragePositionName] = namedata;
res[RObject::StoragePositionType] = typedata;
res[RObject::StoragePositionClass] = classdata;
res[RObject::StoragePositionMeta] = metadata;
res[RObject::StoragePositionDims] = dimdata;
res[RObject::StoragePositionSlots] = slotsdata;
// now add the extra info for containers and functions
if (is_container) {
bool do_env = (is_environment && (!no_recurse));
bool do_cont = is_container && (!is_environment) && (!no_recurse);
// fetch list of child names
SEXP childnames_s;
if (do_env) {
childnames_s = R_lsInternal (value, (Rboolean) 1);
} else if (do_cont) {
childnames_s = RKRSupport::callSimpleFun (names_fun, value, baseenv);
} else {
childnames_s = R_NilValue; // dummy
}
PROTECT (childnames_s);
QStringList childnames = RKRSupport::SEXPToStringList (childnames_s);
int childcount = childnames.size ();
if (childcount > NAMED_CHILDREN_LIMIT) {
RK_DEBUG (RBACKEND, DL_WARNING, "object %s has %d named children. Will only retrieve the first %d", name.toLatin1().data (), childcount, NAMED_CHILDREN_LIMIT);
childcount = NAMED_CHILDREN_LIMIT;
}
RData::RDataStorage children (childcount, 0);
for (int i = 0; i < childcount; ++i) {
children[i] = new RData (); // NOTE: RData-ctor pre-initalizes these to empty. Thus, we're safe even if there is an error while fetching one of the children.
}
if (do_env) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into environment %s", name.toLatin1().data ());
if (!Rf_isEnvironment (value)) {
// some classes (ReferenceClasses) are identified as envionments by is.environment(), but are not internally ENVSXPs.
// For these, Rf_findVar would fail.
REPROTECT (value = RKRSupport::callSimpleFun (as_environment_fun, value, R_GlobalEnv), value_index);
}
for (int i = 0; i < childcount; ++i) {
SEXP current_childname = Rf_install(CHAR(STRING_ELT(childnames_s, i))); // ??? Why does simply using STRING_ELT(childnames_i, i) crash?
PROTECT (current_childname);
SEXP child = Rf_findVar (current_childname, value);
PROTECT (child);
bool child_misplaced = false;
if (at_toplevel && with_namespace && (!RKRBackend::this_pointer->RRuntimeIsVersion (2, 14, 0))) {
if (!Rf_isNull (namespace_envir)) {
SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);
if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;
}
}
getStructureSafe (child, childnames[i], child_misplaced ? RObject::Misplaced : 0, children[i], nesting_depth + 1);
UNPROTECT (2); /* current_childname, child */
}
} else if (do_cont) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into list %s", name.toLatin1().data ());
// fewer elements than names() can happen, although I doubt it is supposed to happen.
// see http://sourceforge.net/tracker/?func=detail&aid=3002439&group_id=50231&atid=459007
bool may_be_special = Rf_length (value) < childcount;
if (Rf_isList (value) && (!may_be_special)) { // old style list
for (int i = 0; i < childcount; ++i) {
SEXP child = CAR (value);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
CDR (value);
}
} else if (Rf_isNewList (value) && (!may_be_special)) { // new style list
for (int i = 0; i < childcount; ++i) {
SEXP child = VECTOR_ELT(value, i);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
} else { // probably an S4 object disguised as a list
SEXP index = Rf_allocVector(INTSXP, 1);
PROTECT (index);
for (int i = 0; i < childcount; ++i) {
INTEGER (index)[0] = (i + 1);
SEXP child = RKRSupport::callSimpleFun2 (double_brackets_fun, value, index, baseenv);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
UNPROTECT (1); /* index */
}
}
UNPROTECT (1); /* childnames_s */
RData *childdata = new RData;
childdata->setData (children);
res[RObject::StoragePositionChildren] = childdata;
if (is_environment && at_toplevel && with_namespace) {
RData *namespacedata = new RData;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into namespace of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
getStructureSafe (namespace_envir, "NAMESPACE", RObject::PseudoObject, dummy[0], nesting_depth+99); // HACK: By default, do not recurse into the children of the namespace, until dealing with the namespace object itself.
namespacedata->setData (dummy);
}
res.insert (RObject::StoragePositionNamespace, namespacedata);
}
} else if (is_function) {
// TODO: getting the formals is still a bit of a bottleneck, but no idea, how to improve on this, any further
SEXP formals_s;
if (Rf_isPrimitive (value)) formals_s = FORMALS (RKRSupport::callSimpleFun (args_fun, value, baseenv)); // primitives don't have formals, internally
else formals_s = FORMALS (value);
PROTECT (formals_s);
// get the default values
QStringList formals = RKRSupport::SEXPToStringList (formals_s);
// for the most part, the implicit as.character in SEXPToStringList does a good on the formals (and it's the fastest of many options that I have tried).
// Only for naked strings (as in 'function (a="something")'), we're missing the quotes. So we add quotes, after conversion, as needed:
SEXP dummy = formals_s;
const int formals_len = Rf_length (formals_s);
for (int i = 0; i < formals_len; ++i) {
if (TYPEOF (CAR (dummy)) == STRSXP) formals[i] = RKRSharedFunctionality::quote (formals[i]);
dummy = CDR (dummy);
}
RData *funargvaluesdata = new RData;
funargvaluesdata->setData (formals);
// the argument names
SEXP names_s = Rf_getAttrib (formals_s, R_NamesSymbol);
PROTECT (names_s);
RData *funargsdata = new RData;
funargsdata->setData (RKRSupport::SEXPToStringList (names_s));
UNPROTECT (2); /* names_s, formals_s */
res[RObject::StoragePositionFunArgs] = funargsdata;
res[RObject::StoragePositionFunValues] = funargvaluesdata;
}
UNPROTECT (1); /* value */
RK_ASSERT (!res.contains (0));
storage->setData (res);
}
/* {{{ proto mixed R::__call(string function_name, array arguments)
*/
static PHP_METHOD(R, __call)
{
char *func;
int func_len, error_occurred = 0, num_args;
zval *args;
SEXP e, fun, val, arg, next;
HashPosition pos;
zval **element;
SEXPTYPE type;
if (zend_parse_parameters(ZEND_NUM_ARGS() TSRMLS_CC, "sa", &func, &func_len, &args) == FAILURE) {
return;
}
fun = Rf_install(func);
if (!fun) {
RETURN_FALSE;
}
num_args = zend_hash_num_elements(Z_ARRVAL_P(args));
PROTECT(fun);
PROTECT(e = allocVector(LANGSXP, num_args + 1));
SETCAR(e, fun);
next = CDR(e);
for(zend_hash_internal_pointer_reset_ex(Z_ARRVAL_P(args), &pos);
zend_hash_get_current_data_ex(Z_ARRVAL_P(args), (void **)&element, &pos) == SUCCESS;
zend_hash_move_forward_ex(Z_ARRVAL_P(args), &pos)
) {
arg = php_zval_to_r(element);
SETCAR(next, arg);
next = CDR(next);
}
val = R_tryEval(e, R_GlobalEnv, &error_occurred);
if (error_occurred) {
UNPROTECT(2);
RETURN_FALSE;
}
/* okay, the call succeeded */
PROTECT(val);
if (val == NULL_USER_OBJECT || GET_LENGTH(val) == 0) {
/* ignore the return value */
} else if (php_is_r_primitive(val, &type)) {
int i;
array_init(return_value);
for (i = 0; i < GET_LENGTH(val); i++) {
switch (type) {
case STRSXP:
add_next_index_string(return_value, CHAR(STRING_ELT(val, 0)), 1);
break;
case LGLSXP:
add_next_index_bool(return_value, LOGICAL_DATA(val)[0] ? 1 : 0);
break;
case INTSXP:
add_next_index_long(return_value, INTEGER_DATA(val)[0]);
break;
case REALSXP:
add_next_index_double(return_value, NUMERIC_DATA(val)[0]);
break;
default:
add_next_index_null(return_value);
break;
}
}
UNPROTECT(3);
return;
}
UNPROTECT(3);
RETURN_TRUE;
}
static void nvimcom_list_env()
{
const char *varName;
SEXP envVarsSEXP, varSEXP;
if(tmpdir[0] == 0)
return;
if(objbr_auto != 1)
return;
#ifndef WIN32
struct timeval begin, middle, end, tdiff1, tdiff2;
if(verbose > 1)
gettimeofday(&begin, NULL);
#endif
memset(obbrbuf2, 0, obbrbufzise);
char *p = nvimcom_strcat(obbrbuf2, ".GlobalEnv | Libraries\n\n");
PROTECT(envVarsSEXP = R_lsInternal(R_GlobalEnv, allnames));
for(int i = 0; i < Rf_length(envVarsSEXP); i++){
varName = CHAR(STRING_ELT(envVarsSEXP, i));
PROTECT(varSEXP = Rf_findVar(Rf_install(varName), R_GlobalEnv));
if (varSEXP != R_UnboundValue) // should never be unbound
{
p = nvimcom_browser_line(&varSEXP, varName, "", " ", p);
} else {
REprintf("Unexpected R_UnboundValue returned from R_lsInternal.\n");
}
UNPROTECT(1);
}
UNPROTECT(1);
#ifndef WIN32
if(verbose > 1)
gettimeofday(&middle, NULL);
#endif
int len1 = strlen(obbrbuf1);
int len2 = strlen(obbrbuf2);
if(len1 != len2){
nvimcom_write_obbr();
} else {
for(int i = 0; i < len1; i++){
if(obbrbuf1[i] != obbrbuf2[i]){
nvimcom_write_obbr();
break;
}
}
}
#ifndef WIN32
if(verbose > 1){
gettimeofday(&end, NULL);
timersub(&middle, &begin, &tdiff1);
timersub(&end, &middle, &tdiff2);
Rprintf("Time to Update the Object Browser: %ld.%06ld + %ld.%06ld\n",
(long int)tdiff1.tv_sec, (long int)tdiff1.tv_usec,
(long int)tdiff2.tv_sec, (long int)tdiff2.tv_usec);
}
#endif
}
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");
}}}}
SEXP assignAttrs(SEXP attrList, SEXP objList,
SEXP defAttrs) {
/* Assign attributes defined by attrList (and defAttrs) */
/* to slots of the objects listed in objList */
int i, j, k, namePos, leno;
SEXP curAttrs, curObj, attrNames, objNames;
const char* curObjName;
SEXP attrsSlot, newASlot, oattrs;
SEXP names, onames;
SEXP attrPos;
SEXP curSTR;
PROTECT(attrNames = getAttrib(attrList, R_NamesSymbol));
PROTECT(objNames = getAttrib(objList, R_NamesSymbol));
PROTECT(defAttrs = coerceVector(defAttrs, STRSXP));
for (i = 0; i < length(objList); i++) {
curObj = VECTOR_ELT(objList, i);
PROTECT(attrsSlot = GET_SLOT(curObj, Rf_install("attrs")));
curObjName = CHAR(STRING_ELT(objNames, i));
for (j = 0; j < length(attrList); j++) {
PROTECT(curSTR = allocVector(STRSXP, 1));
PROTECT(curAttrs = coerceVector(VECTOR_ELT(attrList, j), STRSXP));
PROTECT(attrPos = stringEltByName(curAttrs, curObjName));
if (attrPos == R_NilValue) {
/* We need to use the default value here */
UNPROTECT(1);
attrPos = stringEltByName(defAttrs,
CHAR(STRING_ELT(attrNames, j)));
PROTECT(attrPos);
if (attrPos == R_NilValue) {
error("No attribute or default was assigned for %s",
STR(GET_SLOT(curObj, Rf_install("name"))));
}
}
/* Now we have attrVal and need to add this to the node */
namePos = getVectorPos(attrsSlot, CHAR(STRING_ELT(attrNames, j)));
if (namePos < 0) {
/* This is a new element, need to expand the vector */
PROTECT(oattrs = attrsSlot);
leno = length(oattrs);
PROTECT(onames = getAttrib(attrsSlot, R_NamesSymbol));
PROTECT(names = allocVector(STRSXP, leno+1));
PROTECT(newASlot = allocVector(VECSXP, leno+1));
for (k = 0; k < leno; k++) {
SET_VECTOR_ELT(newASlot, k, VECTOR_ELT(oattrs, k));
SET_STRING_ELT(names, k, STRING_ELT(onames, k));
}
/* Assign the new element */
SET_STRING_ELT(curSTR, 0, attrPos);
SET_VECTOR_ELT(newASlot, leno, curSTR);
SET_STRING_ELT(names, leno, STRING_ELT(attrNames, j));
setAttrib(newASlot, R_NamesSymbol, names);
attrsSlot = newASlot;
UNPROTECT(4);
}
else {
SET_STRING_ELT(curSTR, 0, attrPos);
SET_VECTOR_ELT(attrsSlot, namePos, curSTR);
}
UNPROTECT(3);
}
SET_SLOT(curObj, Rf_install("attrs"), attrsSlot);
SET_VECTOR_ELT(objList, i, curObj);
UNPROTECT(1);
}
UNPROTECT(3);
return(objList);
}
SEXP
convertRawPointerToR(void *p, const llvm::Type *type)
{
int rtype = isSEXPType(type);
if(rtype > -1)
return((SEXP) p);
if(!p) { //XXXX return an empty vector of the correct type if type indicates a primitive, e.g. character(),
return(R_NilValue);
}
/* If this is a pointer to an 8-bit integer, then let's assume it is a string.
Probably need to be able to override this, i.e. with an argument to the top-level call that is
passed down to here.
*/
/* The p here is wrong for a string pointer. */
const llvm::Type *elType = ((const llvm::PointerType*) type)->getElementType();
llvm::Type::TypeID elID = elType->getTypeID();
llvm::Type::TypeID ID = type->getTypeID();
// fprintf(stderr, "ID = %d, elID = %d\n", ID, elID);
if(ID == llvm::Type::ArrayTyID) {
SEXP ans = R_NilValue;
unsigned nels = type->getArrayNumElements(), i;
int np = 0;
// fprintf(stderr, "# elements = %d\n", nels);
if(elID == llvm::Type::IntegerTyID) {
PROTECT(ans = NEW_INTEGER(nels));
np++;
for(i = 0 ; i < nels; i++)
INTEGER(ans)[i] = ((int *) p)[i];
} else if(elID == llvm::Type::DoubleTyID) {
PROTECT(ans = NEW_NUMERIC(nels));
np++;
for(i = 0 ; i < nels; i++)
REAL(ans)[i] = ((double *) p)[i];
} else if(elID == llvm::Type::PointerTyID &&
((const llvm::PointerType*) elType)->getElementType()->getTypeID() == llvm::Type::IntegerTyID) // XXX Should really check 1 byte integer.
// llvm::Type::getInt8Ty())
{
const char **els = (const char **) p;
PROTECT(ans = NEW_CHARACTER(nels));
np++;
for(i = 0 ; i < nels; i++) {
if(els[i]) // if els[i] is NULL, don't attempt to insert it.
SET_STRING_ELT(ans, i, mkChar( els[i]));
}
} else {
PROBLEM "no code for convertRawPointerTo for type %d with pointers of type %d", elID,
((const llvm::PointerType*) type)->getElementType()->getTypeID()
WARN;
}
UNPROTECT(np);
return(ans);
} else if(elID == llvm::Type::IntegerTyID) {
const llvm::IntegerType *ity = (const llvm::IntegerType *) elType;
unsigned bw = ity->getBitWidth();
if(bw == 8) {
return(ScalarString(mkChar((const char *)p)));
} else if (bw == 32) {
}
}
return(R_MakeExternalPtr(p, Rf_install("void*"), R_NilValue));
}
void omxPopulateWLSAttributes(omxFitFunction *oo, SEXP algebra) {
if(OMX_DEBUG) { mxLog("Populating WLS Attributes."); }
omxWLSFitFunction *argStruct = ((omxWLSFitFunction*)oo->argStruct);
omxMatrix *expCovInt = argStruct->expectedCov; // Expected covariance
omxMatrix *expMeanInt = argStruct->expectedMeans; // Expected means
omxMatrix *weightInt = argStruct->weights; // Expected means
SEXP expCovExt, expMeanExt, gradients;
Rf_protect(expCovExt = Rf_allocMatrix(REALSXP, expCovInt->rows, expCovInt->cols));
for(int row = 0; row < expCovInt->rows; row++)
for(int col = 0; col < expCovInt->cols; col++)
REAL(expCovExt)[col * expCovInt->rows + row] =
omxMatrixElement(expCovInt, row, col);
if (expMeanInt != NULL) {
Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, expMeanInt->rows, expMeanInt->cols));
for(int row = 0; row < expMeanInt->rows; row++)
for(int col = 0; col < expMeanInt->cols; col++)
REAL(expMeanExt)[col * expMeanInt->rows + row] =
omxMatrixElement(expMeanInt, row, col);
} else {
Rf_protect(expMeanExt = Rf_allocMatrix(REALSXP, 0, 0));
}
if(OMX_DEBUG_ALGEBRA) {omxPrintMatrix(weightInt, "...WLS Weight Matrix: W"); }
SEXP weightExt = NULL;
if (weightInt) {
Rf_protect(weightExt = Rf_allocMatrix(REALSXP, weightInt->rows, weightInt->cols));
for(int row = 0; row < weightInt->rows; row++)
for(int col = 0; col < weightInt->cols; col++)
REAL(weightExt)[col * weightInt->rows + row] = weightInt->data[col * weightInt->rows + row];
}
if(0) { /* TODO fix for new internal API
int nLocs = Global->numFreeParams;
double gradient[Global->numFreeParams];
for(int loc = 0; loc < nLocs; loc++) {
gradient[loc] = NA_REAL;
}
//oo->gradientFun(oo, gradient);
Rf_protect(gradients = Rf_allocMatrix(REALSXP, 1, nLocs));
for(int loc = 0; loc < nLocs; loc++)
REAL(gradients)[loc] = gradient[loc];
*/
} else {
Rf_protect(gradients = Rf_allocMatrix(REALSXP, 0, 0));
}
if(OMX_DEBUG) { mxLog("Installing populated WLS Attributes."); }
Rf_setAttrib(algebra, Rf_install("expCov"), expCovExt);
Rf_setAttrib(algebra, Rf_install("expMean"), expMeanExt);
if (weightExt) Rf_setAttrib(algebra, Rf_install("weights"), weightExt);
Rf_setAttrib(algebra, Rf_install("gradients"), gradients);
Rf_setAttrib(algebra, Rf_install("SaturatedLikelihood"), Rf_ScalarReal(0));
//Rf_setAttrib(algebra, Rf_install("IndependenceLikelihood"), Rf_ScalarReal(0));
Rf_setAttrib(algebra, Rf_install("ADFMisfit"), Rf_ScalarReal(omxMatrixElement(oo->matrix, 0, 0)));
}
int execute_tool2(const wchar_t* script_path, IArray* pParameters)
{
if (pParameters == 0)
return 0;
//gp_connect_impl connect;
//if (!connect.init())
// return 1;
if (pParameters == 0)
return 0;
_bstr_t file_path(script_path);
long nParams = 0;
pParameters->get_Count(&nParams);
//CComQIPtr<IGPScriptTool>(pGPTool)->get_FileName(file_path.GetAddress());
bool ok = true;
int errorOccurred = 0;
if (file_path.length() && nParams)
{
std::vector< CAdapt<CComPtr<IGPParameter> > > return_params;
//ipParameters->get_Count(&n);
SEXP arc_env = Rf_findVar(Rf_install("arc"), R_GlobalEnv);
{
std::vector<SEXP> in_params;
std::vector<std::string> in_params_names;
std::vector<SEXP> out_params;
std::vector<std::string> out_params_names;
tools::protect pt;
for (int i = 0; i < nParams; i++)
{
CComPtr<IUnknown> ipUnk;
pParameters->get_Element(i, &ipUnk);
CComQIPtr<IGPParameter> ipParam(ipUnk);
esriGPParameterDirection eD;
ipParam->get_Direction(&eD);
std::pair<SEXP, std::string> p = param2r(ipParam);
if (eD == esriGPParameterDirectionInput)
{
in_params.push_back(pt.add(p.first));
in_params_names.push_back(p.second);
}
else
{
out_params.push_back(pt.add(p.first));
out_params_names.push_back(p.second);
return_params.push_back(ipParam);
}
}
SEXP p1 = tools::newVal(in_params, pt);
tools::nameIt(p1, in_params_names);
SEXP p2 = tools::newVal(out_params, pt);
tools::nameIt(p2, out_params_names);
Rf_defineVar(Rf_install(".file"), tools::newVal(file_path, pt), arc_env);
Rf_defineVar(Rf_install(".in"), p1, arc_env);
Rf_defineVar(Rf_install(".out"), p2, arc_env);
}
const static wchar_t eval_str[] = L"arc$.ret<-local({"
L"en<-new.env(hash=TRUE);"
L"eval(parse(file=arc$.file), envir=en);"
L"tool_exec<-get('tool_exec',en);"
L"tool_exec(in_param, out_param)"
L"},envir=list('in_param'=arc$.in,'out_param'=arc$.out))";
ok = current_connect->eval_one(eval_str) == 1;
current_connect->print_out(NULL, -1);
Rf_defineVar(Rf_install(".file"), R_NilValue, arc_env);
Rf_defineVar(Rf_install(".in"), R_NilValue, arc_env);
Rf_defineVar(Rf_install(".out"), R_NilValue, arc_env);
R_gc();
//TODO: handle ok
if (ok)
{
/*CComPtr<IGPMessages> ipMsgs;
if (connect.m_ipGeoProcessor)
connect.m_ipGeoProcessor->GetReturnMessages(&ipMsgs);
if (ipMsgs)
{
VARIANT_BOOL bErr = VARIANT_FALSE;
CComQIPtr<IGPMessage>(ipMsgs)->IsError(&bErr);
if (bErr != VARIANT_FALSE)
ok = false;
}*/
if (!return_params.empty())
{
//connect.m_ipGeoProcessor->Is
SEXP ret = Rf_findVar(Rf_install(".ret"), arc_env);
tools::vectorGeneric ret_out(ret);
//tools::vectorGeneric ret_out(ret.get());
for (size_t i = 0, n = return_params.size(); i < n; i++)
{
_bstr_t name;
return_params[i].m_T->get_Name(name.GetAddress());
size_t idx = ret_out.idx(std::string(name));
if (idx != (size_t)-1)
{
if (!r2param(ret_out.at(idx), return_params[i].m_T))
{
std::wstring msg(L"failed to set output parameter - ");
msg += name;
current_connect->print_out(msg.c_str(), 2);
}
}
}
//TODO list
}
Rf_defineVar(Rf_install(".ret"), R_NilValue, arc_env);
}
}
return ok ? 0 : 1;
}
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;
}
