/* determine whether a graph is DAG or a PDAG/UG. */
SEXP is_dag(SEXP arcs, SEXP nnodes) {
int i = 0, nrows = length(arcs)/2, n = INT(nnodes);
int *a = INTEGER(arcs);
short int *checklist = NULL;
/* allocate and initialize the checklist. */
checklist = allocstatus(UPTRI_MATRIX(n));
for (i = 0; i < nrows; i++) {
if (checklist[UPTRI(a[CMC(i, 0, nrows)], a[CMC(i, 1, nrows)], n)] == 0) {
/* this arc is not present in the checklist; add it. */
checklist[UPTRI(a[CMC(i, 0, nrows)], a[CMC(i, 1, nrows)], n)] = 1;
}/*THEN*/
else {
/* this arc or its opposite already present in the checklist; the graph
* has at least an undirected arc, so return FALSE. */
return ScalarLogical(FALSE);
}/*THEN*/
}/*FOR*/
return ScalarLogical(TRUE);
}/*IS_DAG*/
/* determine which arcs are undirected. */
SEXP which_undirected(SEXP arcs, SEXP nodes) {
int i = 0, nrow = length(arcs)/2, nlvls = 0;
int *coords = NULL, *id = NULL;
SEXP result, labels, try, arc_id;
/* get the node labels from the arcs, or use those passed down from R. */
if (isNull(nodes))
PROTECT(labels = unique(arcs));
else
labels = nodes;
nlvls = length(labels);
/* match the node labels in the arc set. */
PROTECT(try = match(labels, arcs, 0));
coords = INTEGER(try);
/* initialize the checklist. */
PROTECT(arc_id = allocVector(INTSXP, nrow));
id = INTEGER(arc_id);
/* fill the checklist with the UPTRI() coordinates, which uniquely
* identify an arc modulo its direction. */
for (i = 0; i < nrow; i++)
id[i] = UPTRI(coords[i], coords[i + nrow], nlvls);
PROTECT(result = dupe(arc_id));
if (isNull(nodes))
UNPROTECT(4);
else
UNPROTECT(3);
return result;
}/*WHICH_UNDIRECTED*/
/* check neighbourhood sets and markov blankets for consistency.. */
SEXP bn_recovery(SEXP bn, SEXP strict, SEXP mb, SEXP debug, SEXP filter) {
int i = 0, j = 0, k = 0, n = 0, counter = 0;
short int *checklist = NULL, err = 0;
int *debuglevel = NULL, *checkmb = NULL, *nbrfilter = NULL;
SEXP temp, temp2, nodes, elnames = NULL, fixed;
/* get the names of the nodes. */
nodes = getAttrib(bn, R_NamesSymbol);
n = LENGTH(nodes);
/* allocate and initialize the checklist. */
checklist = allocstatus(UPTRI_MATRIX(n));
/* dereference the debug, mb and filter parameters. */
debuglevel = LOGICAL(debug);
checkmb = LOGICAL(mb);
nbrfilter = INTEGER(filter);
if (*debuglevel > 0) {
Rprintf("----------------------------------------------------------------\n");
if (*checkmb)
Rprintf("* checking consistency of markov blankets.\n");
else
Rprintf("* checking consistency of neighbourhood sets.\n");
}/*THEN*/
/* scan the structure to determine the number of arcs. */
for (i = 0; i < n; i++) {
if (*debuglevel > 0)
Rprintf(" > checking node %s.\n", NODE(i));
/* get the entry for the (neighbours|elements of the markov blanket)
of the node.*/
temp = getListElement(bn, (char *)NODE(i));
if (!(*checkmb))
temp = getListElement(temp, "nbr");
/* check each element of the array and identify which variable it
corresponds to. */
for (j = 0; j < LENGTH(temp); j++) {
for (k = 0; k < n; k++) {
/* increment the right element of checklist. */
if (!strcmp(NODE(k), (char *)CHAR(STRING_ELT(temp, j))))
checklist[UPTRI(i + 1, k + 1, n)]++;
}/*FOR*/
}/*FOR*/
}/*FOR*/
/* if A is a neighbour of B, B is a neighbour of A; therefore each entry in
* the checklist array must be equal to either zero (if the corresponding
* nodes are not neighbours) or two (if the corresponding nodes are neighbours).
* Any other value (typically one) is caused by an incorrect (i.e. asymmetric)
* neighbourhood structure. The same logic holds for the markov blankets. */
for (i = 0; i < n; i++)
for (j = i; j < n; j++) {
if ((checklist[UPTRI(i + 1, j + 1, n)] != 0) &&
(checklist[UPTRI(i + 1, j + 1, n)] != 2)) {
if (*debuglevel > 0) {
if (*checkmb)
Rprintf("@ asymmetry in the markov blankets for %s and %s.\n",
NODE(i), NODE(j));
else
Rprintf("@ asymmetry in the neighbourhood sets for %s and %s.\n",
NODE(i), NODE(j));
}/*THEN*/
err = 1;
}/*THEN*/
}/*FOR*/
/* no need to go on if the (neighbourhood sets|markov blankets) are symmetric;
* otherwise throw either an error or a warning according to the value of the
* strict parameter. */
if (!err) {
return bn;
}/*THEN*/
else if (isTRUE(strict)) {
if (*checkmb)
error("markov blankets are not symmetric.\n");
else
error("neighbourhood sets are not symmetric.\n");
}/*THEN*/
else {
if (*checkmb)
warning("markov blankets are not symmetric.\n");
else
warning("neighbourhood sets are not symmetric.\n");
}/*ELSE*/
/* build a correct structure to return. */
PROTECT(fixed = allocVector(VECSXP, n));
setAttrib(fixed, R_NamesSymbol, nodes);
if (!(*checkmb)) {
/* allocate colnames. */
PROTECT(elnames = allocVector(STRSXP, 2));
SET_STRING_ELT(elnames, 0, mkChar("mb"));
SET_STRING_ELT(elnames, 1, mkChar("nbr"));
}/*THEN*/
for (i = 0; i < n; i++) {
if (!(*checkmb)) {
/* allocate the "mb" and "nbr" elements of the node. */
PROTECT(temp = allocVector(VECSXP, 2));
SET_VECTOR_ELT(fixed, i, temp);
setAttrib(temp, R_NamesSymbol, elnames);
/* copy the "mb" part from the old structure. */
temp2 = getListElement(bn, (char *)NODE(i));
temp2 = getListElement(temp2, "mb");
SET_VECTOR_ELT(temp, 0, temp2);
}/*THEN*/
/* fix the neighbourhoods with an AND or an OR filter.
* AND means that both neighbours have to see each other
* to be neighbours, OR means that one neighbour at least
* as to see the other one for both to be neighbours. */
switch(*nbrfilter) {
case AND_FILTER:
/* rescan the checklist. */
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] == 2)
if (i != j)
counter++;
/* allocate and fill the "nbr" element. */
PROTECT(temp2 = allocVector(STRSXP, counter));
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] == 2)
if (i != j)
SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));
break;
case OR_FILTER:
/* rescan the checklist. */
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] >= 1)
if (i != j)
counter++;
/* allocate and fill the "nbr" element. */
PROTECT(temp2 = allocVector(STRSXP, counter));
for (j = 0; j < n; j++)
if (checklist[UPTRI(i + 1, j + 1, n)] >= 1)
if (i != j)
SET_STRING_ELT(temp2, --counter, STRING_ELT(nodes, j));
break;
}
if (*checkmb) {
SET_VECTOR_ELT(fixed, i, temp2);
UNPROTECT(1);
}/*THEN*/
else {
SET_VECTOR_ELT(temp, 1, temp2);
UNPROTECT(2);
}/*ELSE*/
}/*FOR*/
if (*checkmb)
UNPROTECT(1);
else
UNPROTECT(2);
return fixed;
}/*BN_RECOVERY*/
