SEXP intersectStrings(SEXP x, SEXP y) {
SEXP ans, matchRes, matched, dup;
int i, j, k, n, numZero=0, size;
int curEntry=0;
PROTECT(matchRes = Rf_match(y, x, 0));
for (i = 0; i < length(matchRes); i++) {
if (INTEGER(matchRes)[i] == 0)
numZero++;
}
size = length(matchRes) - numZero;
PROTECT(matched = allocVector(STRSXP, size));
for (i = 0; i < length(matchRes); i++) {
if (INTEGER(matchRes)[i] != 0) {
SET_STRING_ELT(matched, curEntry++,
STRING_ELT(y, INTEGER(matchRes)[i]-1));
}
}
PROTECT(dup = graph_duplicated(matched));
n = length(matched);
k = 0;
for (j = 0; j < n; j++)
if (LOGICAL(dup)[j] == 0)
k++;
PROTECT(ans = allocVector(STRSXP, k));
k = 0;
for (j = 0; j < n; j++) {
if (LOGICAL(dup)[j] == 0) {
SET_STRING_ELT(ans, k++, STRING_ELT(matched, j));
}
}
UNPROTECT(4);
return(ans);
}
SEXP checkEdgeList(SEXP eL, SEXP bN) {
SEXP newEL, curVec, curMatches, newVec, eleNames;
int i, j, k, size, curEle;
PROTECT(newEL = allocVector(VECSXP, length(bN)));
PROTECT(eleNames = getAttrib(eL, R_NamesSymbol));
for (i = 0; i < length(bN); i++) {
for (k = 0; k < length(eL); k++) {
if (strcmp(CHAR(STRING_ELT(eleNames, k)),
CHAR(STRING_ELT(bN, i))) == 0)
break;
}
if (k < length(eL)) {
curVec = VECTOR_ELT(eL, k);
PROTECT(curMatches = Rf_match(curVec, bN, 0));
size = length(curMatches);
for (j = 0; j < length(curMatches); j++) {
if (INTEGER(curMatches)[j] == 0)
size--;
}
PROTECT(newVec = allocVector(STRSXP, size));
curEle = 0;
for (j = 0; j < length(curMatches); j++) {
if (INTEGER(curMatches)[j] != 0) {
SET_STRING_ELT(newVec, curEle++,
STRING_ELT(curVec,
INTEGER(curMatches)[j]-1));
}
}
SET_VECTOR_ELT(newEL, i, newVec);
UNPROTECT(2);
}
}
setAttrib(newEL, R_NamesSymbol, bN);
UNPROTECT(2);
return(newEL);
}
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 transpose_impl(SEXP x, SEXP names_template) {
if (TYPEOF(x) != VECSXP)
Rf_errorcall(R_NilValue, "`.l` is not a list (%s)", Rf_type2char(TYPEOF(x)));
int n = Rf_length(x);
if (n == 0) {
return Rf_allocVector(VECSXP, 0);
}
int has_template = !Rf_isNull(names_template);
SEXP x1 = VECTOR_ELT(x, 0);
if (!Rf_isVector(x1))
Rf_errorcall(R_NilValue, "Element 1 is not a vector (%s)", Rf_type2char(TYPEOF(x1)));
int m = has_template ? Rf_length(names_template) : Rf_length(x1);
// Create space for output
SEXP out = PROTECT(Rf_allocVector(VECSXP, m));
SEXP names1 = Rf_getAttrib(x, R_NamesSymbol);
for (int j = 0; j < m; ++j) {
SEXP xj = PROTECT(Rf_allocVector(VECSXP, n));
if (!Rf_isNull(names1)) {
Rf_setAttrib(xj, R_NamesSymbol, names1);
}
SET_VECTOR_ELT(out, j, xj);
UNPROTECT(1);
}
SEXP names2 = has_template ? names_template : Rf_getAttrib(x1, R_NamesSymbol);
if (!Rf_isNull(names2)) {
Rf_setAttrib(out, R_NamesSymbol, names2);
}
// Fill output
for (int i = 0; i < n; ++i) {
SEXP xi = VECTOR_ELT(x, i);
if (!Rf_isVector(xi))
Rf_errorcall(R_NilValue, "Element %i is not a vector (%s)", i + 1, Rf_type2char(TYPEOF(x1)));
// find mapping between names and index. Use -1 to indicate not found
SEXP names_i = Rf_getAttrib(xi, R_NamesSymbol);
SEXP index;
if (!Rf_isNull(names2) && !Rf_isNull(names_i)) {
index = PROTECT(Rf_match(names_i, names2, 0));
// Rf_match returns 1-based index; convert to 0-based for C
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = INTEGER(index)[i] - 1;
}
} else {
index = PROTECT(Rf_allocVector(INTSXP, m));
int mi = Rf_length(xi);
if (m != mi) {
Rf_warningcall(R_NilValue, "Element %i has length %i not %i", i + 1, mi, m);
}
for (int i = 0; i < m; ++i) {
INTEGER(index)[i] = (i < mi) ? i : -1;
}
}
int* pIndex = INTEGER(index);
for (int j = 0; j < m; ++j) {
int pos = pIndex[j];
if (pos == -1)
continue;
switch(TYPEOF(xi)) {
case LGLSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarLogical(LOGICAL(xi)[pos]));
break;
case INTSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarInteger(INTEGER(xi)[pos]));
break;
case REALSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarReal(REAL(xi)[pos]));
break;
case STRSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, Rf_ScalarString(STRING_ELT(xi, pos)));
break;
case VECSXP:
SET_VECTOR_ELT(VECTOR_ELT(out, j), i, VECTOR_ELT(xi, pos));
break;
default:
Rf_errorcall(R_NilValue, "Unsupported type %s", Rf_type2char(TYPEOF(xi)));
}
}
UNPROTECT(1);
}
UNPROTECT(1);
return out;
}