/* build the arc set out of a "bn.fit" object. */
SEXP fit2arcs(SEXP bn) {
int i = 0, j = 0, k = 0, narcs = 0;
SEXP labels, node_data, children, result;
/* get the nodes' labels. */
labels = getAttrib(bn, R_NamesSymbol);
/* first pass: count the number of arcs. */
for (i = 0; i < LENGTH(bn); i++) {
/* get the node's data. */
node_data = VECTOR_ELT(bn, i);
/* count its children. */
narcs += LENGTH(getListElement(node_data, "children"));
}/*FOR*/
/* allocate the arc set. */
PROTECT(result = allocMatrix(STRSXP, narcs, 2));
/* set the column names. */
finalize_arcs(result);
/* second pass: initialize the return value. */
for (i = 0; i < LENGTH(bn); i++) {
/* get the node's data. */
node_data = VECTOR_ELT(bn, i);
/* get its children. */
children = getListElement(node_data, "children");
for (j = 0; j < LENGTH(children); j++) {
/* set the labels of the nodes incident on the arc. */
SET_STRING_ELT(result, k, STRING_ELT(labels, i));
SET_STRING_ELT(result, k + narcs, STRING_ELT(children, j));
/* go to the next arc. */
k++;
}/*FOR*/
}/*FOR*/
UNPROTECT(1);
return result;
}/*FIT2ARCS*/
/* faster rbind() implementation for arc sets. */
SEXP arcs_rbind (SEXP matrix1, SEXP matrix2, SEXP reverse2) {
int i = 0, j = 0, m1 = length(matrix1)/2, m2 = length(matrix2)/2;
SEXP res;
/* allocate the return value. */
PROTECT(res = allocMatrix(STRSXP, m1 + m2, 2));
/* allocate and initialize the column names. */
finalize_arcs(res);
/* copy the elements of the first matrix. */
for (i = 0; i < m1; i++)
for (j = 0; j < 2; j++)
SET_STRING_ELT(res, CMC(i, j, m1 + m2), STRING_ELT(matrix1, CMC(i, j, m1)));
/* copy the elements of the second matrix, reversing the order of the
* columns as needed. */
if (isTRUE(reverse2)) {
for (i = 0; i < m2; i++)
for(j = 0; j < 2; j++)
SET_STRING_ELT(res, CMC(i + m1, j, m1 + m2), STRING_ELT(matrix2, CMC(i, 1 - j, m2)));
}/*THEN*/
else {
for (i = 0; i < m2; i++)
for(j = 0; j < 2; j++)
SET_STRING_ELT(res, CMC(i + m1, j, m1 + m2), STRING_ELT(matrix2, CMC(i, j, m2)));
}/*ELSE*/
UNPROTECT(1);
return res;
}/*ARCS_RBIND*/
/* C-level interface to unique_arcs. */
SEXP c_unique_arcs(SEXP arcs, SEXP nodes, int warnlevel) {
int i = 0, j = 0, k = 0, nrows = 0, uniq_rows = 0, n = length(nodes);
int *checklist = NULL;
SEXP result, try, node, dup;
if (isNull(arcs)) {
/* use NULL as a special jolly value which returns all possible arcs
* given the specified node ordering. */
nrows = n * (n - 1)/2;
/* allocate the return value. */
PROTECT(result = allocMatrix(STRSXP, nrows, 2));
/* fill in the nodes' labels. */
for (i = 0; i < n; i++) {
node = STRING_ELT(nodes, i);
for (j = i + 1; j < n; j++) {
SET_STRING_ELT(result, CMC(k, 0, nrows), node);
SET_STRING_ELT(result, CMC(k, 1, nrows), STRING_ELT(nodes, j));
k++;
}/*FOR*/
}/*FOR*/
}/*THEN*/
else if (length(arcs) == 0) {
/* the arc set is empty, nothing to do. */
return arcs;
}/*THEN*/
else {
/* there really is a non-empty arc set, process it. */
nrows = length(arcs)/2;
/* match the node labels in the arc set. */
PROTECT(try = arc_hash(arcs, nodes, FALSE, FALSE));
/* check which are duplicated. */
PROTECT(dup = duplicated(try, FALSE));
checklist = INTEGER(dup);
/* count how many are not. */
for (i = 0; i < nrows; i++)
if (checklist[i] == 0)
uniq_rows++;
/* if there is no duplicate arc simply return the original arc set. */
if (uniq_rows == nrows) {
UNPROTECT(2);
return arcs;
}/*THEN*/
else {
/* warn the user if told to do so. */
if (warnlevel > 0)
warning("removed %d duplicate arcs.", nrows - uniq_rows);
/* allocate and initialize the return value. */
PROTECT(result = allocMatrix(STRSXP, uniq_rows, 2));
/* store the correct arcs in the return value. */
for (i = 0, k = 0; i < nrows; i++) {
if (checklist[i] == 0) {
SET_STRING_ELT(result, k, STRING_ELT(arcs, i));
SET_STRING_ELT(result, k + uniq_rows, STRING_ELT(arcs, i + nrows));
k++;
}/*THEN*/
}/*FOR*/
}/*ELSE*/
}/*ELSE*/
/* allocate, initialize and set the column names. */
finalize_arcs(result);
if (uniq_rows == 0)
UNPROTECT(1);
else
UNPROTECT(3);
return result;
}/*C_UNIQUE_ARCS*/
SEXP tiers(SEXP nodes, SEXP debug) {
int i = 0, j = 0, k = 0, narcs = 0, nnodes = 0, ntiers = LENGTH(nodes);
int *tier_size = NULL, *debuglevel = LOGICAL(debug), tier_start = 0, cur = 0;
SEXP flattened, blacklist, temp;
/* allocate the counters for tiers' sizes.*/
tier_size = alloc1dcont(ntiers);
if (!isString(nodes)) {
/* "node" is a list, each tier is an element. */
for (i = ntiers - 1; i >= 0; i--) {
temp = VECTOR_ELT(nodes, i);
tier_size[i] = LENGTH(temp);
nnodes += tier_size[i];
narcs += (nnodes - tier_size[i]) * tier_size[i];
}/*FOR*/
/* flatten the tiers to keep manipulation later on simple. */
PROTECT(flattened = allocVector(STRSXP, nnodes));
for (i = 0, k = 0; i < ntiers; i++) {
temp = VECTOR_ELT(nodes, i);
for (j = 0; j < tier_size[i]; j++)
SET_STRING_ELT(flattened, k++, STRING_ELT(temp, j));
}/*FOR*/
}/*THEN*/
else {
/* "node" is a character vector, which means that each node is in its own tier
* and that there is no need to flatted it. */
flattened = nodes;
nnodes = LENGTH(nodes);
for (i = 0; i < ntiers; i++)
tier_size[i] = 1;
/* the blacklist is the one resulting from a complete node ordering. */
narcs = ntiers * (ntiers - 1) / 2;
}/*ELSE*/
/* allocate the return value. */
PROTECT(blacklist = allocMatrix(STRSXP, narcs, 2));
for (k = 0, i = 0; k < nnodes; k++) {
temp = STRING_ELT(flattened, k);
if (*debuglevel > 0)
Rprintf("* current node is %s in tier %d.\n", CHAR(temp), i + 1);
for (j = tier_start + tier_size[i]; j < nnodes; j++) {
if (*debuglevel)
Rprintf(" > blacklisting %s -> %s\n", CHAR(STRING_ELT(flattened, j)), CHAR(temp));
SET_STRING_ELT(blacklist, cur, STRING_ELT(flattened, j));
SET_STRING_ELT(blacklist, cur + narcs, temp);
cur++;
}/*FOR*/
if (k >= tier_start + tier_size[i] - 1)
tier_start += tier_size[i++];
if (i == ntiers)
break;
}
/* allocate, initialize and set the column names. */
finalize_arcs(blacklist);
if (!isString(nodes))
UNPROTECT(2);
else
UNPROTECT(1);
return blacklist;
}/*TIERS*/