/* sort the nodes in topological order. */
void topological_sort(SEXP fitted, int *poset, int nnodes) {
int i = 0;
SEXP roots, node_depth;
PROTECT(roots = root_nodes(fitted, FALSESEXP));
PROTECT(node_depth = topological_ordering(fitted, roots, FALSESEXP, FALSESEXP));
for (i = 0; i < nnodes; i++)
poset[i] = i;
R_qsort_int_I(INTEGER(node_depth), poset, 1, nnodes);
UNPROTECT(2);
}/*TOPOLOGICAL_SORT*/
SEXP rbn_expand_fix(SEXP fix, SEXP nodes, int *nnodes) {
int i = 0, *f = NULL;
SEXP result, fixed_nodes, try;
/* get the names of the nodes that are fixed. */
fixed_nodes = getAttrib(fix, R_NamesSymbol);
/* match the names with the nodes in the network. */
PROTECT(try = match(nodes, fixed_nodes, 0));
f = INTEGER(try);
/* allocate the return value. */
PROTECT(result = allocVector(VECSXP, *nnodes));
setAttrib(result, R_NamesSymbol, nodes);
for (i = 0; i < LENGTH(fixed_nodes); i++)
SET_VECTOR_ELT(result, f[i] - 1, VECTOR_ELT(fix, i));
UNPROTECT(2);
return result;
}/*RBN_EXPAND_FIX*/
/* generate random observations from a bayesian network. */
SEXP rbn_master(SEXP fitted, SEXP n, SEXP fix, SEXP debug) {
int *num = INTEGER(n), *poset = NULL, *debuglevel = LOGICAL(debug), type = 0;
int has_fixed = (TYPEOF(fix) != LGLSXP);
int i = 0, k = 0, cur = 0, nnodes = LENGTH(fitted), nparents = 0;
const char *cur_class = NULL;
SEXP result, nodes, roots, node_depth, cpt, coefs, sd, parents, parent_vars, false;
SEXP cur_node, cur_fixed;
/* set up a logical variable to be used in the following calls. */
PROTECT(false = allocVector(LGLSXP, 1));
LOGICAL(false)[0] = FALSE;
/* allocate and initialize the return value. */
PROTECT(result = allocVector(VECSXP, nnodes));
nodes = getAttrib(fitted, R_NamesSymbol);
setAttrib(result, R_NamesSymbol, nodes);
/* order the nodes according to their depth in the graph. */
PROTECT(roots = root_nodes(fitted, false));
PROTECT(node_depth = schedule(fitted, roots, false, false));
poset = alloc1dcont(nnodes);
for (i = 0; i < nnodes; i++)
poset[i] = i;
R_qsort_int_I(INTEGER(node_depth), poset, 1, nnodes);
/* unprotect roots and node_depth, they are not needed any more. */
UNPROTECT(2);
if (has_fixed)
PROTECT(fix = rbn_expand_fix(fix, nodes, &nnodes));
if (*debuglevel > 0) {
Rprintf("* partial node ordering is:");
for (i = 0; i < nnodes; i++)
Rprintf(" %s", NODE(poset[i]));
Rprintf(".\n");
}/*THEN*/
/* initialize the random number generator. */
GetRNGstate();
for (i = 0; i < nnodes; i++) {
/* get the index of the node we have to generate random observations from,
* its conditional probability table/regression parameters and the number
* of its parents. */
cur = poset[i];
cur_node = VECTOR_ELT(fitted, cur);
cur_class = CHAR(STRING_ELT(getAttrib(cur_node, R_ClassSymbol), 0));
parents = getListElement(cur_node, "parents");
nparents = LENGTH(parents);
/* check whether the value of the node is fixed, and if so retrieve it from
* the list. */
if (has_fixed)
cur_fixed = VECTOR_ELT(fix, cur);
else
cur_fixed = R_NilValue;
/* find out whether the node corresponds to an ordered factor or not. */
if (strcmp(cur_class, "bn.fit.onode") == 0) {
cpt = getListElement(cur_node, "prob");
type = ORDINAL;
}/*THEN*/
else if (strcmp(cur_class, "bn.fit.dnode") == 0) {
cpt = getListElement(cur_node, "prob");
type = CATEGORICAL;
}/*THEN*/
else if (strcmp(cur_class, "bn.fit.gnode") == 0) {
coefs = getListElement(cur_node, "coefficients");
sd = getListElement(cur_node, "sd");
type = GAUSSIAN;
}/*THEN*/
/* generate the random observations for the current node. */
if (nparents == 0) {
if (*debuglevel > 0) {
if (cur_fixed != R_NilValue)
Rprintf("* node %s is fixed.\n", NODE(cur));
else
Rprintf("* simulating node %s, which doesn't have any parent.\n",
NODE(cur));
}/*THEN*/
switch(type) {
case CATEGORICAL:
rbn_discrete_root(result, cur, cpt, num, FALSE, cur_fixed);
break;
case ORDINAL:
rbn_discrete_root(result, cur, cpt, num, TRUE, cur_fixed);
break;
case GAUSSIAN:
rbn_gaussian(result, cur, NULL, coefs, sd, num, cur_fixed);
break;
}/*SWITCH*/
}/*THEN*/
else {
if (*debuglevel > 0) {
if (cur_fixed != R_NilValue) {
Rprintf("* node %s is fixed, ignoring parents.\n", NODE(cur));
}/*THEN*/
else {
Rprintf("* simulating node %s with parents ", NODE(cur));
for (k = 0; k < nparents - 1; k++)
Rprintf("%s, ", CHAR(STRING_ELT(parents, k)));
Rprintf("%s.\n", CHAR(STRING_ELT(parents, nparents - 1)));
}/*ELSE*/
}/*THEN*/
PROTECT(parent_vars = dataframe_column(result, parents, false));
switch(type) {
case CATEGORICAL:
rbn_discrete_cond(result, nodes, cur, parent_vars, cpt, num, FALSE, cur_fixed);
break;
case ORDINAL:
rbn_discrete_cond(result, nodes, cur, parent_vars, cpt, num, TRUE, cur_fixed);
break;
case GAUSSIAN:
rbn_gaussian(result, cur, parent_vars, coefs, sd, num, cur_fixed);
break;
}/*SWITCH*/
UNPROTECT(1);
}/*ELSE*/
}/*FOR*/
PutRNGstate();
/* add the labels to the return value. */
minimal_data_frame(result);
UNPROTECT(2 + has_fixed);
return result;
}/*RBN_MASTER*/
