SEXP graph_intersection(SEXP xN, SEXP yN, SEXP xE, SEXP yE,
SEXP edgeMode) {
/* edgeMode == 0 implies "undirected" */
SEXP bN, newXE, newYE;
SEXP klass, outGraph;
SEXP rval, ans, curRval, curWeights, curEdges, newNames, matches;
int i, j, curEle=0;
klass = MAKE_CLASS("graphNEL");
PROTECT(outGraph = NEW_OBJECT(klass));
if (INTEGER(edgeMode)[0])
SET_SLOT(outGraph, Rf_install("edgemode"),
R_scalarString("directed"));
else
SET_SLOT(outGraph, Rf_install("edgemode"),
R_scalarString("undirected"));
PROTECT(bN = intersectStrings(xN, yN));
if (length(bN) == 0) {
SET_SLOT(outGraph, Rf_install("nodes"), allocVector(STRSXP, 0));
SET_SLOT(outGraph, Rf_install("edgeL"), allocVector(VECSXP, 0));
UNPROTECT(1);
return(outGraph);
}
PROTECT(newXE = checkEdgeList(xE, bN));
PROTECT(newYE = checkEdgeList(yE, bN));
PROTECT(newNames = allocVector(STRSXP, 2));
SET_STRING_ELT(newNames, 0, mkChar("edges"));
SET_STRING_ELT(newNames, 1, mkChar("weights"));
PROTECT(rval = allocVector(VECSXP, length(newXE)));
for (i = 0; i < length(newXE); i++) {
PROTECT(curRval = allocVector(VECSXP, 2));
setAttrib(curRval, R_NamesSymbol, newNames);
PROTECT(ans = intersectStrings(VECTOR_ELT(newXE, i), VECTOR_ELT(newYE,
i)));
if (length(ans) == 0) {
SET_VECTOR_ELT(curRval, 0, allocVector(INTSXP, 0));
SET_VECTOR_ELT(curRval, 1, allocVector(INTSXP, 0));
}
else {
PROTECT(curEdges = allocVector(INTSXP, length(ans)));
PROTECT(matches = Rf_match(bN, ans, 0));
curEle = 0;
for (j = 0; j < length(matches); j++) {
if (INTEGER(matches)[j] != 0)
INTEGER(curEdges)[curEle++] = INTEGER(matches)[j];
}
SET_VECTOR_ELT(curRval, 0, curEdges);
PROTECT(curWeights = allocVector(INTSXP, length(ans)));
for (j = 0; j < length(ans); j++)
INTEGER(curWeights)[j] = 1;
SET_VECTOR_ELT(curRval, 1, curWeights);
UNPROTECT(3);
}
SET_VECTOR_ELT(rval, i, curRval);
UNPROTECT(2);
}
setAttrib(rval, R_NamesSymbol, bN);
SET_SLOT(outGraph, Rf_install("nodes"), bN);
SET_SLOT(outGraph, Rf_install("edgeL"), rval);
UNPROTECT(6);
return(outGraph);
}
SEXP
R_convertDCOMObjectToR(VARIANT *var)
{
SEXP ans = R_NilValue;
VARTYPE type = V_VT(var);
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Converting VARIANT to R %d\n", V_VT(var));
#endif
if(V_ISARRAY(var)) {
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finishing convertDCOMObjectToR - convert array\n");
#endif
return(convertArrayToR(var));
} else if(V_VT(var) == VT_DISPATCH || (V_ISBYREF(var) && ((V_VT(var) & (~ VT_BYREF)) == VT_DISPATCH)) ) {
IDispatch *ptr;
if(V_ISBYREF(var)) {
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("BYREF and DISPATCH in convertDCOMObjectToR\n");
#endif
IDispatch **tmp = V_DISPATCHREF(var);
if(!tmp)
return(ans);
ptr = *tmp;
} else
ptr = V_DISPATCH(var);
//xxx
if(ptr)
ptr->AddRef();
ans = R_createRCOMUnknownObject((void*) ptr, "COMIDispatch");
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finished convertDCOMObjectToR COMIDispatch\n");
#endif
return(ans);
}
if(V_ISBYREF(var)) {
VARTYPE rtype = type & (~ VT_BYREF);
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("ISBYREF() in convertDCOMObjectToR: ref type %d\n", rtype);
#endif
if(rtype == VT_BSTR) {
BSTR *tmp;
const char *ptr = "";
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("BYREF and BSTR convertDCOMObjectToR (scalar string)\n");
#endif
tmp = V_BSTRREF(var);
if(tmp)
ptr = FromBstr(*tmp);
ans = R_scalarString(ptr);
return(ans);
} else if(rtype == VT_BOOL || rtype == VT_I4 || rtype == VT_R8){
return(createVariantRef(var, rtype));
} else {
fprintf(stderr, "Unhandled by-reference conversion type %d\n", V_VT(var));fflush(stderr);
return(R_NilValue);
}
}
switch(type) {
case VT_BOOL:
ans = R_scalarLogical( (Rboolean) (V_BOOL(var) ? TRUE : FALSE));
break;
case VT_UI1:
case VT_UI2:
case VT_UI4:
case VT_UINT:
VariantChangeType(var, var, 0, VT_I4);
ans = R_scalarReal((double) V_I4(var));
break;
case VT_I1:
case VT_I2:
case VT_I4:
case VT_INT:
VariantChangeType(var, var, 0, VT_I4);
ans = R_scalarInteger(V_I4(var));
break;
case VT_R4:
case VT_R8:
case VT_I8:
VariantChangeType(var, var, 0, VT_R8);
ans = R_scalarReal(V_R8(var));
break;
case VT_CY:
case VT_DATE:
case VT_HRESULT:
case VT_DECIMAL:
VariantChangeType(var, var, 0, VT_R8);
ans = numberFromVariant(var, type);
break;
case VT_BSTR:
{
char *ptr = FromBstr(V_BSTR(var));
ans = R_scalarString(ptr);
}
break;
case VT_UNKNOWN:
{
IUnknown *ptr = V_UNKNOWN(var);
//xxx
if(ptr)
ptr->AddRef();
ans = R_createRCOMUnknownObject((void**) ptr, "COMUnknown");
}
break;
case VT_EMPTY:
case VT_NULL:
case VT_VOID:
return(R_NilValue);
break;
/*XXX Need to fill these in */
case VT_RECORD:
case VT_FILETIME:
case VT_BLOB:
case VT_STREAM:
case VT_STORAGE:
case VT_STREAMED_OBJECT:
/* case LPSTR: */
case VT_LPWSTR:
case VT_PTR:
case VT_ERROR:
case VT_VARIANT:
case VT_CARRAY:
case VT_USERDEFINED:
default:
fprintf(stderr, "Unhandled conversion type %d\n", V_VT(var));fflush(stderr);
//XXX this consumes the variant. So the variant clearance in Invoke() does it again!
ans = createRVariantObject(var, V_VT(var));
}
#if defined(RDCOM_VERBOSE) && RDCOM_VERBOSE
errorLog("Finished convertDCOMObjectToR\n");
#endif
return(ans);
}
