/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret, n;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
/* if x has names, drop them, since they won't be ordered
if (!isNull(getAttrib(sx, R_NamesSymbol)))
setAttrib(sx, R_NamesSymbol, R_NilValue); */
indx_ret = asLogical(CADR(args));
n = LENGTH(x);
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
int i, *ix;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
PROTECT(indx = allocVector(INTSXP, n));
ix = INTEGER(indx);
for(i = 0; i < n; i++)
ix[i] = i+1;
if(x_int)
R_qsort_int_I(ivx, ix, 1, n);
else
R_qsort_I(vx, ix, 1, n);
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
}
else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
/* 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*/
double castelo_prior(SEXP beta, SEXP target, SEXP parents, SEXP children,
SEXP debug) {
int i = 0, k = 0, t = 0, nnodes = 0, cur_arc = 0;
int nbeta = LENGTH(VECTOR_ELT(beta, 0));
int *temp = NULL, *debuglevel = LOGICAL(debug), *aid = INTEGER(VECTOR_ELT(beta, 2));
double prior = 0, result = 0;
double *bkwd = REAL(VECTOR_ELT(beta, 4)), *fwd = REAL(VECTOR_ELT(beta, 3));
short int *adjacent = NULL;
SEXP nodes, try;
/* get the node labels. */
nodes = getAttrib(beta, install("nodes"));
nnodes = LENGTH(nodes);
/* match the target node. */
PROTECT(try = match(nodes, target, 0));
t = INT(try);
UNPROTECT(1);
/* find out which nodes are parents and which nodes are children. */
adjacent = allocstatus(nnodes);
PROTECT(try = match(nodes, parents, 0));
temp = INTEGER(try);
for (i = 0; i < LENGTH(try); i++)
adjacent[temp[i] - 1] = PARENT;
UNPROTECT(1);
PROTECT(try = match(nodes, children, 0));
temp = INTEGER(try);
for (i = 0; i < LENGTH(try); i++)
adjacent[temp[i] - 1] = CHILD;
UNPROTECT(1);
/* prior probabilities table lookup. */
for (i = t + 1; i <= nnodes; i++) {
/* compute the arc id. */
cur_arc = UPTRI3(t, i, nnodes);
/* look up the prior probability. */
for (/*k,*/ prior = ((double)1/3); k < nbeta; k++) {
/* arcs are ordered, so we can stop early in the lookup. */
if (aid[k] > cur_arc)
break;
if (aid[k] == cur_arc) {
switch(adjacent[i - 1]) {
case PARENT:
prior = bkwd[k];
break;
case CHILD:
prior = fwd[k];
break;
default:
prior = 1 - bkwd[k] - fwd[k];
}/*SWITCH*/
break;
}/*THEN*/
}/*FOR*/
if (*debuglevel > 0) {
switch(adjacent[i - 1]) {
case PARENT:
Rprintf(" > found arc %s -> %s, prior pobability is %lf.\n",
NODE(i - 1), NODE(t - 1), prior);
break;
case CHILD:
Rprintf(" > found arc %s -> %s, prior probability is %lf.\n",
NODE(t - 1), NODE(i - 1), prior);
break;
default:
Rprintf(" > no arc between %s and %s, prior probability is %lf.\n",
NODE(t - 1), NODE(i - 1), prior);
}/*SWITCH*/
}/*THEN*/
/* move to log-scale and divide by the non-informative log(1/3), so that
* the contribution of each arc whose prior has not been not specified by
* the user is zero; overflow is likely otherwise. */
result += log(prior / ((double)1/3));
}/*FOR*/
return result;
}/*CASTELO_PRIOR*/
/* complete a prior as per Castelo & Siebes. */
SEXP castelo_completion(SEXP prior, SEXP nodes) {
int i = 0, k = 0, cur = 0, narcs1 = 0, narcs2 = 0, nnodes = LENGTH(nodes);
int *m1 = NULL, *m2 = NULL, *und = NULL, *aid = NULL, *poset = NULL, *id = NULL;
double *d1 = NULL, *d2 = NULL, *p = NULL;
SEXP df, arc_id, undirected, a1, a2, match1, match2, prob;
SEXP result, colnames, from, to, nid, dir1, dir2;
/* compute numeric IDs for the arcs. */
a1 = VECTOR_ELT(prior, 0);
a2 = VECTOR_ELT(prior, 1);
narcs1 = LENGTH(a1);
PROTECT(match1 = match(nodes, a1, 0));
PROTECT(match2 = match(nodes, a2, 0));
m1 = INTEGER(match1);
m2 = INTEGER(match2);
PROTECT(arc_id = allocVector(INTSXP, narcs1));
aid = INTEGER(arc_id);
c_arc_hash(&narcs1, &nnodes, m1, m2, aid, NULL, TRUE);
/* duplicates correspond to undirected arcs. */
PROTECT(undirected = dupe(arc_id));
und = INTEGER(undirected);
/* extract the components from the prior. */
prob = VECTOR_ELT(prior, 2);
p = REAL(prob);
/* count output arcs. */
for (i = 0; i < narcs1; i++)
narcs2 += 2 - und[i];
narcs2 /= 2;
/* allocate the columns of the return value. */
PROTECT(from = allocVector(STRSXP, narcs2));
PROTECT(to = allocVector(STRSXP, narcs2));
PROTECT(nid = allocVector(INTSXP, narcs2));
id = INTEGER(nid);
PROTECT(dir1 = allocVector(REALSXP, narcs2));
d1 = REAL(dir1);
PROTECT(dir2 = allocVector(REALSXP, narcs2));
d2 = REAL(dir2);
/* sort the strength coefficients. */
poset = alloc1dcont(narcs1);
for (k = 0; k < narcs1; k++)
poset[k] = k;
R_qsort_int_I(aid, poset, 1, narcs1);
for (i = 0, k = 0; i < narcs1; i++) {
cur = poset[i];
#define ASSIGN(A1, A2, D1, D2) \
SET_STRING_ELT(from, k, STRING_ELT(A1, cur)); \
SET_STRING_ELT(to, k, STRING_ELT(A2, cur)); \
id[k] = aid[i]; \
D1[k] = p[cur]; \
if ((und[cur] == TRUE) && (i < narcs1 - 1)) \
D2[k] = p[poset[++i]]; \
else \
D2[k] = (1 - D1[k])/2;
/* copy the node labels. */
if (m1[cur] < m2[cur]) {
ASSIGN(a1, a2, d1, d2);
}/*THEN*/
else {
ASSIGN(a2, a1, d2, d1);
}/*ELSE*/
if (d1[k] + d2[k] > 1) {
UNPROTECT(9);
error("the probabilities for arc %s -> %s sum to %lf.",
CHAR(STRING_ELT(from, k)), CHAR(STRING_ELT(to, k)), d1[k] + d2[k]);
}/*THEN*/
/* move to the next arc. */
k++;
}/*FOR*/
/* set up the return value. */
PROTECT(result = allocVector(VECSXP, 5));
SET_VECTOR_ELT(result, 0, from);
SET_VECTOR_ELT(result, 1, to);
SET_VECTOR_ELT(result, 2, nid);
SET_VECTOR_ELT(result, 3, dir1);
SET_VECTOR_ELT(result, 4, dir2);
PROTECT(colnames = allocVector(STRSXP, 5));
SET_STRING_ELT(colnames, 0, mkChar("from"));
SET_STRING_ELT(colnames, 1, mkChar("to"));
SET_STRING_ELT(colnames, 2, mkChar("aid"));
SET_STRING_ELT(colnames, 3, mkChar("fwd"));
SET_STRING_ELT(colnames, 4, mkChar("bkwd"));
setAttrib(result, R_NamesSymbol, colnames);
PROTECT(df = minimal_data_frame(result));
UNPROTECT(12);
return df;
}/*CASTELO_COMPLETION*/
SEXP R_pncount(SEXP R_x, SEXP R_t, SEXP R_s, SEXP R_o, SEXP R_v) {
int i, j, c, f, l, k, n, nr, np, ni, e;
int *x, *o = NULL;
double s, t = 0;
SEXP px, ix, pt, it;
SEXP r, pr, ir, pl, il, rs, rc, rl, pi;
#ifdef _TIME_H
clock_t t5, t4, t3, t2, t1, t0;
t1 = t0 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
if (LOGICAL(R_o)[0] == TRUE)
Rprintf("reducing ... ");
else
Rprintf("preparing ... ");
}
#endif
if (!inherits(R_x, "ngCMatrix"))
error("'x' not of class ngCMatrix");
if (!inherits(R_t, "ngCMatrix"))
error("'t' not of class ngCMatrix");
if (INTEGER(GET_SLOT(R_x, install("Dim")))[0] !=
INTEGER(GET_SLOT(R_t, install("Dim")))[0])
error("the number of rows of 'x' and 't' do not conform");
if (TYPEOF(R_s) != LGLSXP)
error("'s' not of type logical");
if (TYPEOF(R_o) != LGLSXP)
error("'o' not of type logical");
if (TYPEOF(R_v) != LGLSXP)
error("'v' not of type logical");
nr = INTEGER(GET_SLOT(R_x, install("Dim")))[0];
px = GET_SLOT(R_x, install("p"));
ix = GET_SLOT(R_x, install("i"));
pt = GET_SLOT(R_t, install("p"));
it = GET_SLOT(R_t, install("i"));
pb = INTEGER(PROTECT(allocVector(INTSXP, nr+1)));
if (LOGICAL(R_o)[0] == TRUE) {
SEXP pz, iz;
o = INTEGER(PROTECT(allocVector(INTSXP, nr)));
memset(o, 0, sizeof(int) * nr);
for (k = 0; k < LENGTH(it); k++)
o[INTEGER(it)[k]]++;
memset(pb, 0, sizeof(int) * nr);
for (k = 0; k < LENGTH(ix); k++)
pb[INTEGER(ix)[k]] = 1;
n = c = 0;
for (k = 0; k < nr; k++) {
if (pb[k])
n += o[k];
else {
o[k] = -1;
c++;
}
pb[k] = k;
}
R_qsort_int_I(o, pb, 1, nr);
for (k = 0; k < nr; k++)
o[pb[k]] = (k < c) ? -1 : k;
PROTECT(iz = allocVector(INTSXP, LENGTH(ix)));
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
if (f == l)
continue;
for (k = f; k < l; k++)
INTEGER(iz)[k] = o[INTEGER(ix)[k]];
R_isort(INTEGER(iz)+f, l-f);
f = l;
}
ix = iz;
PROTECT(pz = allocVector(INTSXP, LENGTH(pt)));
PROTECT(iz = allocVector(INTSXP, n));
f = n = INTEGER(pz)[0] = 0;
for (i = 1; i < LENGTH(pt); i++) {
l = INTEGER(pt)[i];
if (f < l) {
for (k = f, f = n; k < l; k++)
if ((j = o[INTEGER(it)[k]]) > -1)
INTEGER(iz)[n++] = j;
R_isort(INTEGER(iz)+f, n-f);
f = l;
}
INTEGER(pz)[i] = n;
}
pt = pz;
ni = LENGTH(it);
it = iz;
if (LOGICAL(R_s)[0] == FALSE)
memcpy(o, pb, sizeof(int) * nr);
#ifdef _TIME_H
t1 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
Rprintf("%i indexes, dropped %i (%.2f) items [%.2fs]\n",
LENGTH(ix) + ni, c, 1 - (double) n / ni,
((double) t1 - t0) / CLOCKS_PER_SEC);
Rprintf("preparing ... ");
}
#endif
}
cpn = apn = npn = 0;
if (nb != NULL)
nbfree();
nb = (PN **) malloc(sizeof(PN *) * (nr+1));
if (nb == NULL)
error("pointer array allocation failed");
k = nr;
nb[k] = NULL;
while (k-- > 0)
nb[k] = pnadd(nb[k+1], &k, 1);
if (npn) {
nbfree();
error("node allocation failed");
}
np = ni = 0;
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
n = l-f;
if (n == 0)
continue;
x = INTEGER(ix)+f;
pnadd(nb[*x], x, n);
if (LOGICAL(R_s)[0] == FALSE && n > 1) {
if (n > 2) {
memcpy(pb, x, sizeof(int) * n);
for (k = 0; k < n-1; k++) {
if (k > 0) {
j = pb[0];
pb[0] = pb[k];
pb[k] = j;
}
pnadd(nb[pb[1]], pb+1, n-1);
}
}
np += n;
ni += n * (n-1);
}
if (npn) {
nbfree();
error("node allocation failed");
}
f = l;
R_CheckUserInterrupt();
}
#ifdef _TIME_H
t2 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
Rprintf("%i itemsets, created %i (%.2f) nodes [%.2fs]\n",
2 * np + LENGTH(px) - 1, apn, (double) apn / cpn,
((double) t2 - t1) / CLOCKS_PER_SEC);
Rprintf("counting ... ");
}
#endif
cpn = npn = 0;
f = 0;
for (i = 1; i < LENGTH(pt); i++) {
l = INTEGER(pt)[i];
n = l-f;
if (n == 0)
continue;
x = INTEGER(it)+f;
pncount(nb[*x], x, n);
f = l;
R_CheckUserInterrupt();
}
#ifdef _TIME_H
t3 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
Rprintf("%i transactions, processed %i (%.2f) nodes [%.2fs]\n",
LENGTH(pt) - 1, cpn, (double) npn / cpn,
((double) t3 - t2) / CLOCKS_PER_SEC);
Rprintf("writing ... ");
}
#endif
if (LOGICAL(R_s)[0] == TRUE) {
PROTECT(r = allocVector(INTSXP, LENGTH(px)-1));
/* warnings */
pl = il = pr = ir = rs = rc = rl = pi = (SEXP)0;
} else {
SEXP o, p;
PROTECT(r = allocVector(VECSXP, 6));
SET_VECTOR_ELT(r, 0, (o = NEW_OBJECT(MAKE_CLASS("ngCMatrix"))));
SET_SLOT(o, install("p"), (pl = allocVector(INTSXP, np+1)));
SET_SLOT(o, install("i"), (il = allocVector(INTSXP, ni)));
SET_SLOT(o, install("Dim"), (p = allocVector(INTSXP, 2)));
INTEGER(p)[0] = nr;
INTEGER(p)[1] = np;
SET_VECTOR_ELT(r, 1, (o = NEW_OBJECT(MAKE_CLASS("ngCMatrix"))));
SET_SLOT(o, install("p"), (pr = allocVector(INTSXP, np+1)));
SET_SLOT(o, install("i"), (ir = allocVector(INTSXP, np)));
SET_SLOT(o, install("Dim"), (p = allocVector(INTSXP, 2)));
INTEGER(p)[0] = nr;
INTEGER(p)[1] = np;
SET_VECTOR_ELT(r, 2, (rs = allocVector(REALSXP, np)));
SET_VECTOR_ELT(r, 3, (rc = allocVector(REALSXP, np)));
SET_VECTOR_ELT(r, 4, (rl = allocVector(REALSXP, np)));
SET_VECTOR_ELT(r, 5, (pi = allocVector(INTSXP, np)));
INTEGER(pl)[0] = INTEGER(pr)[0] = np = ni = 0;
t = (double) LENGTH(pt)-1;
}
cpn = npn = 0;
e = LENGTH(pt) - 1;
f = 0;
for (i = 1; i < LENGTH(px); i++) {
l = INTEGER(px)[i];
n = l-f;
if (n == 0) {
if (LOGICAL(R_s)[0] == TRUE)
INTEGER(r)[i-1] = e;
continue;
}
x = INTEGER(ix)+f;
c = pnget(nb[*x], x, n);
if (LOGICAL(R_s)[0] == TRUE)
INTEGER(r)[i-1] = c;
else if (n > 1) {
s = c / t;
memcpy(pb, x, sizeof(int) * n);
for (k = 0; k < n; k++) {
if (k > 0) {
j = pb[0];
pb[0] = pb[k];
pb[k] = j;
}
INTEGER(pi)[np] = i; /* itemset index */
REAL(rs)[np] = s;
REAL(rc)[np] = c / (double) pnget(nb[pb[1]], pb+1, n-1);
REAL(rl)[np] = REAL(rc)[np] / pnget(nb[pb[0]], pb, 1) * t;
INTEGER(ir)[np++] = pb[0];
INTEGER(pr)[np] = np;
for (j = 1; j < n; j++)
INTEGER(il)[ni++] = pb[j];
INTEGER(pl)[np] = ni;
}
}
f = l;
R_CheckUserInterrupt();
}
nbfree();
if (apn)
error("node deallocation imbalance %i", apn);
#ifdef _TIME_H
t4 = clock();
if (LOGICAL(R_v)[0] == TRUE) {
if (LOGICAL(R_s)[0] == FALSE)
Rprintf("%i rules, ", np);
else
Rprintf("%i counts, ", LENGTH(px)-1);
Rprintf("processed %i (%.2f) nodes [%.2fs]\n", cpn, (double) npn / cpn,
((double) t4 - t3) / CLOCKS_PER_SEC);
}
#endif
if (LOGICAL(R_o)[0] == TRUE) {
if (LOGICAL(R_s)[0] == FALSE) {
#ifdef _TIME_H
if (LOGICAL(R_v)[0] == TRUE)
Rprintf("recoding ... ");
#endif
f = 0;
for (i = 1; i < LENGTH(pl); i++) {
l = INTEGER(pl)[i];
if (f == l)
continue;
for (k = f; k < l; k++)
INTEGER(il)[k] = o[INTEGER(il)[k]];
R_isort(INTEGER(il)+f, l-f);
f = l;
}
for (k = 0; k < LENGTH(ir); k++)
INTEGER(ir)[k] = o[INTEGER(ir)[k]];
#ifdef _TIME_H
t5 = clock();
if (LOGICAL(R_v)[0] == TRUE)
Rprintf(" %i indexes [%.2fs]\n", LENGTH(il) + LENGTH(ir),
((double) t5 - t4) / CLOCKS_PER_SEC);
#endif
}
UNPROTECT(6);
}
else
UNPROTECT(2);
return r;
}
/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
indx_ret = asLogical(CADR(args));
R_xlen_t n = XLENGTH(x);
#ifdef LONG_VECTOR_SUPPORT
Rboolean isLong = n > INT_MAX;
#endif
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
#ifdef LONG_VECTOR_SUPPORT
if (isLong) {
PROTECT(indx = allocVector(REALSXP, n));
double *ix = REAL(indx);
for(R_xlen_t i = 0; i < n; i++) ix[i] = (double) (i+1);
if(x_int) R_qsort_int_R(ivx, ix, 1, n);
else R_qsort_R(vx, ix, 1, n);
} else
#endif
{
PROTECT(indx = allocVector(INTSXP, n));
int *ix = INTEGER(indx);
int nn = (int) n;
for(int i = 0; i < nn; i++) ix[i] = i+1;
if(x_int) R_qsort_int_I(ivx, ix, 1, nn);
else R_qsort_I(vx, ix, 1, nn);
}
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
} else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
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*/
SEXP rowRanks_Integer(SEXP x, int nrow, int ncol, int byrow) {
SEXP ans;
int ii, jj;
int *colOffset;
int *aa, *I;
int JJ, AA, nna;
int *rowData, *xx;
int current_max;
PROTECT(ans = allocMatrix(INTSXP, nrow, ncol));
rowData = (int *) R_alloc(ncol, sizeof(int));
I = (int *) R_alloc(ncol, sizeof(int));
colOffset = (int *) R_alloc(ncol, sizeof(int));
for (jj=0; jj < ncol; jj++) {
colOffset[jj] = (int) jj*nrow;
}
xx = INTEGER(x);
aa = INTEGER(ans);
for (ii=0; ii < nrow; ii++) {
nna = 0; // number of NA's in this row
for (jj=0; jj < ncol; jj++) {
rowData[jj] = xx[ii+colOffset[jj]];
if (rowData[jj] == NA_INTEGER)
nna++;
I[jj] = jj;
// Rprintf("%d %d: %d ", ii, jj, xx[ii+colOffset[jj]]);
}
// Rprintf("\n");
// Sort 'rowData' increasing with any NA_integer_'s first:
R_qsort_int_I(rowData, I, 1, ncol);
// The following does: rank(ties.method="max", na.last="keep")
JJ = ncol-1;
current_max = rowData[JJ];
AA = ii + colOffset[I[JJ]];
aa[AA] = (current_max == NA_INTEGER) ? NA_INTEGER : JJ+1-nna;
for (jj=ncol-2; jj>=nna; jj--) {
AA = ii + colOffset[I[jj]];
// Rprintf("%d %d %d: %d %d %d ", ii, jj, AA, I[jj], rowData[jj], current_max);
if (rowData[jj] != current_max) {
JJ = jj;
current_max = rowData[JJ];
}
aa[AA] = JJ+1-nna;
}
for (jj=nna-1; jj>=0; jj--) {
AA = ii + colOffset[I[jj]];
aa[AA] = NA_INTEGER;
}
// Rprintf("\n");
}
UNPROTECT(1);
return(ans);
}
