/* 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*/