int initForcings(SEXP flist) {
SEXP Tvec, Fvec, Ivec, initforc;
int i, j, isForcing = 0;
init_func_type *initforcings;
initforc = getListElement(flist, "ModelForc");
if (!isNull(initforc)) {
Tvec = getListElement(flist, "tmat");
Fvec = getListElement(flist, "fmat");
Ivec = getListElement(flist, "imat");
nforc = LENGTH(Ivec)-2; /* nforc, fvec, ivec = globals */
i = LENGTH(Fvec);
fvec = (double *) R_alloc((int) i, sizeof(double));
for (j = 0; j < i; j++) fvec[j] = REAL(Fvec)[j];
tvec = (double *) R_alloc((int) i, sizeof(double));
for (j = 0; j < i; j++) tvec[j] = REAL(Tvec)[j];
i = LENGTH (Ivec)-1; /* last element: the interpolation method...*/
ivec = (int *) R_alloc(i, sizeof(int));
for (j = 0; j < i; j++) ivec[j] = INTEGER(Ivec)[j];
fmethod = INTEGER(Ivec)[i];
initforcings = (init_func_type *) R_ExternalPtrAddr(initforc);
initforcings(Initdeforc);
isForcing = 1;
}
return(isForcing);
}
R_Calldata buildRCallSpheres(SEXP R_param,SEXP R_cond) {
int nprotect=0;
R_Calldata d = Calloc(1,R_Calldata_s);
d->call = R_NilValue;
PROTECT(d->fname = getListElement( R_cond, "rdist")); ++nprotect;
PROTECT(d->rho = getListElement( R_cond, "rho" )); ++nprotect;
PROTECT(d->args = getListElement( R_param,"radii")); ++nprotect;
PROTECT(d->label = getListElement( R_cond, "label")); ++nprotect;
/* radii distribution */
const char *ftype = CHAR(STRING_ELT(d->fname, 0));
if ( !std::strcmp( ftype, "rlnorm") ||
!std::strcmp( ftype, "rbeta" ) ||
!std::strcmp( ftype, "rgamma") ||
!std::strcmp( ftype, "runif" ) ||
!std::strcmp( ftype, "const" ))
{;
} else {
PROTECT(d->call = getCall(d->fname,d->args,d->rho)); ++nprotect;
}
d->nprotect = nprotect;
d->isPerfect = asLogical(getListElement( R_cond, "perfect" ));
return d;
}
/* get the number of parameters of the whole network (continuous case). */
SEXP nparams_gnet(SEXP graph, SEXP debug) {
int i = 0, node_params = 0, *res = NULL, *debuglevel = LOGICAL(debug);
SEXP result, nodes = R_NilValue, temp = getListElement(graph, "nodes");
/* allocate and initialize the result. */
PROTECT(result = allocVector(INTSXP, 1));
res = INTEGER(result);
res[0] = 0;
if (*debuglevel > 0)
nodes = getAttrib(temp, R_NamesSymbol);
/* add one parameter for each regressor, which means one for each
* parent for each node plus the intercept. */
for (i = 0; i < LENGTH(temp); i++) {
node_params = LENGTH(getListElement(VECTOR_ELT(temp, i), "parents")) + 1;
if (*debuglevel > 0)
Rprintf("* node %s has %d parameter(s).\n", NODE(i), node_params);
/* update the return value. */
res[0] += node_params;
}/*FOR*/
UNPROTECT(1);
return(result);
}/*NPARAMS_GNET*/
SEXP helloworld(SEXP A_in, SEXP B_in, SEXP exogvar) {
printf("Hello World\n");
int nProtected = 0;
SEXP retval;
PROTECT(retval = allocVector(REALSXP,2));
++nProtected;
A = REAL(A_in)[0];
B = INTEGER(B_in)[0];
AA = REAL(getListElement(exogvar,"A"))[0];
BB = INTEGER(getListElement(exogvar,"B"))[0];
printf("A/B = %f\n",A/B);
printf("BB/AA = %3f\n",BB/AA);
REAL(retval)[0] = A/B;
REAL(retval)[1] = BB/AA;
SEXP dim;
PROTECT(dim = allocVector(INTSXP,2));
++nProtected;
INTEGER(dim)[0] = 2;
INTEGER(dim)[1] = 1;
setAttrib(retval, R_DimSymbol, dim);
UNPROTECT(nProtected);
return(retval);
}
double intrinsic_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double a, b, s, r, v, theta,n, logmarglik, p;
a = REAL(getListElement(hyperparams, "alpha"))[0];
b = REAL(getListElement(hyperparams, "beta"))[0];
s = REAL(getListElement(hyperparams, "s"))[0];
r = REAL(getListElement(hyperparams, "r"))[0];
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
v = (n + p + 1.0)/(p + 1);
theta = (n + p + 1.0)/n;
logmarglik = loglik_mle + M_LN_SQRT_2PI - 0.5* logdet_Iintercept;
if (p >= 1.0) {
logmarglik += lbeta((a + p) / 2.0, b / 2.0)
+ log(HyperTwo(b/2.0, r, (a + b + p)/2.0, (s+W)/(2.0*v), 1.0 - theta))
-.5*p*log(v) -.5*W/v
- lbeta(a / 2.0, b / 2.0)
- log(HyperTwo(b/2.0, r, (a + b)/2.0, s/(2.0*v), 1.0 - theta));
}
return(logmarglik);
}
SEXP r_make_dt_obj_cont(SEXP cache, SEXP r_ic, SEXP r_br) {
SEXP info = getListElement(cache, "info");
int
neq = INTEGER(getListElement(info, "ny"))[0],
np = INTEGER(getListElement(info, "np"))[0];
/* Initial conditions and branches functions */
DtIcFun ic = (DtIcFun) R_ExternalPtrAddr(r_ic);
DtBrFun br = (DtBrFun) R_ExternalPtrAddr(r_br);
/* Return object */
dt_obj_cont *obj;
SEXP extPtr;
obj = (dt_obj_cont *)Calloc(1, dt_obj_cont);
obj->neq = neq;
obj->n_out = LENGTH(getListElement(cache, "len"));
obj->np = np;
obj->root = INTEGER(getListElement(cache, "root"))[0];
obj->ic = ic;
obj->br = br;
/* Set up storage */
obj->init = (double *)Calloc(obj->n_out * neq, double);
obj->base = (double *)Calloc(obj->n_out * neq, double);
obj->lq = (double *)Calloc(obj->n_out, double);
/* Set up tips and internal branches */
dt_cont_setup_tips(obj, cache);
dt_cont_setup_internal(obj, cache);
extPtr = R_MakeExternalPtr(obj, R_NilValue, R_NilValue);
R_RegisterCFinalizer(extPtr, dt_obj_cont_finalize);
return extPtr;
}
double intrinsic_glm_shrinkage(SEXP hyperparams, int pmodel, double W, int Laplace ) {
double a, b, s, r, v, theta, n, p, u, shrinkage;
a = REAL(getListElement(hyperparams, "alpha"))[0];
b = REAL(getListElement(hyperparams, "beta"))[0];
s = REAL(getListElement(hyperparams, "s"))[0];
r = REAL(getListElement(hyperparams, "r"))[0];
n = REAL(getListElement(hyperparams, "n"))[0];
p = (double) pmodel;
v = (n + p + 1.0)/(p + 1);
theta = (n + p + 1.0)/n;
shrinkage = 1.0;
if (p >= 1.0) {
u = exp(-log(v)
+ lbeta((a + p) / 2.0 + 1.0, b / 2.0)
+ log(HyperTwo(b/2.0, r, (a +b+p)/2.0 + 1.0, (s+W)/(2.0*v), 1.0-theta))
- lbeta((a+p) / 2.0, b/2.0)
- log(HyperTwo(b/2.0, r, (a + p+ b)/2.0, (s+W)/(2.0*v), 1.0 - theta)));
shrinkage = 1.0 - u;
}
return(shrinkage);
}
SEXP influence(SEXP mqr, SEXP do_coef, SEXP e, SEXP stol)
{
SEXP qr = getListElement(mqr, "qr"), qraux = getListElement(mqr, "qraux");
int n = nrows(qr), k = asInteger(getListElement(mqr, "rank"));
int docoef = asLogical(do_coef);
double tol = asReal(stol);
SEXP hat = PROTECT(allocVector(REALSXP, n));
double *rh = REAL(hat);
SEXP coefficients;
if(docoef) coefficients = PROTECT(allocMatrix(REALSXP, n, k));
else coefficients = PROTECT(allocVector(REALSXP, 0));
SEXP sigma = PROTECT(allocVector(REALSXP, n));
F77_CALL(lminfl)(REAL(qr), &n, &n, &k, &docoef, REAL(qraux),
REAL(e), rh, REAL(coefficients), REAL(sigma), &tol);
for (int i = 0; i < n; i++) if (rh[i] > 1. - tol) rh[i] = 1.;
SEXP ans = PROTECT(allocVector(VECSXP, docoef ? 4 : 3));
SEXP nm = allocVector(STRSXP, docoef ? 4 : 3);
setAttrib(ans, R_NamesSymbol, nm);
int m = 0;
SET_VECTOR_ELT(ans, m, hat);
SET_STRING_ELT(nm, m++, mkChar("hat"));
if (docoef) {
SET_VECTOR_ELT(ans, m, coefficients);
SET_STRING_ELT(nm, m++, mkChar("coefficients"));
}
SET_VECTOR_ELT(ans, m, sigma);
SET_STRING_ELT(nm, m++, mkChar("sigma"));
SET_VECTOR_ELT(ans, m, e);
SET_STRING_ELT(nm, m, mkChar("wt.res"));
UNPROTECT(4);
return ans;
}
STGM::Spheres convert_C_Spheres(SEXP R_spheres) {
SEXP R_tmp, R_ctr;
int id=0,
N=length(R_spheres);
STGM::Spheres spheres;
spheres.reserve(N);
double r=0;
int interior=1;
const char *label = "N";
for(int i=0; i<N; i++) {
PROTECT(R_tmp = VECTOR_ELT(R_spheres,i));
PROTECT(R_ctr = AS_NUMERIC( getListElement( R_tmp, "center")));
id = asInteger (AS_INTEGER( getListElement( R_tmp, "id")));
r = asReal(getListElement( R_tmp, "r"));
if(!isNull(getAttrib(R_tmp, install("label"))))
label = translateChar(asChar(getAttrib(R_tmp, install("label"))));
if(!isNull(getAttrib(R_tmp, install("interior"))))
interior = asLogical(getAttrib(R_tmp, install("interior")));
spheres.push_back(STGM::CSphere(REAL(R_ctr)[0],REAL(R_ctr)[1],REAL(R_ctr)[2],r,id,label,interior));
UNPROTECT(2);
}
return spheres;
}
/* get the number of parameters of the whole network (discrete case). */
SEXP nparams_dnet(SEXP graph, SEXP data, SEXP real, SEXP debug) {
int i = 0, j = 0, nnodes = 0;
int *index = NULL, *r = LOGICAL(real), *debuglevel = LOGICAL(debug);
double node_params = 0;
double *res = NULL, *nlevels = NULL;
SEXP nodes, node_data, parents, try, result;
/* get nodes' number and data. */
node_data = getListElement(graph, "nodes");
nodes = getAttrib(node_data, R_NamesSymbol);
nnodes = LENGTH(node_data);
/* get the level count for each node. */
nlevels = alloc1dreal(nnodes);
for (i = 0; i < nnodes; i++)
nlevels[i] = NLEVELS2(data, i);
/* allocate and initialize the return value. */
PROTECT(result = allocVector(REALSXP, 1));
res = REAL(result);
res[0] = 0;
/* for each node... */
for (i = 0; i < nnodes; i++) {
/* reset the parameter counter. */
node_params = 1;
/* match the parents of the node. */
parents = getListElement(VECTOR_ELT(node_data, i), "parents");
PROTECT(try = match(nodes, parents, 0));
index = INTEGER(try);
/* compute the number of configurations. */
for (j = 0; j < LENGTH(try); j++)
node_params *= nlevels[index[j] - 1];
UNPROTECT(1);
/* multiply by the number of free parameters. */
if (*r > 0)
node_params *= nlevels[i] - 1;
else
node_params *= nlevels[i];
if (*debuglevel > 0)
Rprintf("* node %s has %.0lf parameter(s).\n", NODE(i), node_params);
/* update the return value. */
res[0] += node_params;
}/*FOR*/
UNPROTECT(1);
return result;
}/*NPARAMS_DNET*/
/* get the number of parameters of the whole network (mixed case, also handles
* discrete and Gaussian networks). */
SEXP nparams_cgnet(SEXP graph, SEXP data, SEXP debug) {
int i = 0, j = 0, nnodes = 0, debuglevel = isTRUE(debug);
int *nlevels = NULL, *index = NULL, ngp = 0;
double nconfig = 0, node_params = 0, all_params = 0;
SEXP nodes = R_NilValue, node_data, parents, temp;
/* get nodes' number and data. */
node_data = getListElement(graph, "nodes");
nnodes = length(node_data);
nodes = getAttrib(node_data, R_NamesSymbol);
/* cache the number of levels of each variables (zero = continuous). */
nlevels = Calloc1D(nnodes, sizeof(int));
for (i = 0; i < nnodes; i++) {
temp = VECTOR_ELT(data, i);
if (TYPEOF(temp) == INTSXP)
nlevels[i] = NLEVELS(temp);
}/*FOR*/
for (i = 0; i < nnodes; i++) {
/* extract the parents of the node and match them. */
parents = getListElement(VECTOR_ELT(node_data, i), "parents");
PROTECT(temp = match(nodes, parents, 0));
index = INTEGER(temp);
/* compute the number of regressors and of configurations. */
for (j = 0, ngp = 0, nconfig = 1; j < length(parents); j++) {
if (nlevels[index[j] - 1] == 0)
ngp++;
else
nconfig *= nlevels[index[j] - 1];
}/*FOR*/
/* compute the overall number of parameters as regressors plus intercept
* times configurations. */
node_params = nconfig * (nlevels[i] == 0 ? ngp + 1 : nlevels[i] - 1);
if (debuglevel > 0)
Rprintf("* node %s has %.0lf parameter(s).\n", NODE(i), node_params);
/* update the return value. */
all_params += node_params;
UNPROTECT(1);
}/*FOR*/
Free1D(nlevels);
return ScalarReal(all_params);
}/*NPARAMS_CGNET*/
/* compute the number of parameters of the model. */
SEXP fitted_nparams(SEXP bn, SEXP debug) {
int i = 0, j = 0, node_params = 0, nnodes = LENGTH(bn);
int *res = NULL, *debuglevel = LOGICAL(debug);
SEXP result, nodes = R_NilValue, node_data, temp;
/* allocate, dereference and initialize the return value. */
PROTECT(result = allocVector(INTSXP, 1));
res = INTEGER(result);
res[0] = 0;
if (*debuglevel > 0)
nodes = getAttrib(bn, R_NamesSymbol);
for (i = 0; i < nnodes; i++) {
/* get the node's data. */
node_data = VECTOR_ELT(bn, i);
/* get its probability distribution (if discrete). */
temp = getListElement(node_data, "prob");
if (!isNull(temp)) {
/* reset the parameters' counter for this node. */
node_params = 1;
/* get the dimensions of the conditional probability table. */
temp = getAttrib(temp, R_DimSymbol);
/* compute the number of parameters. */
for (j = 1; j < LENGTH(temp); j++)
node_params *= INTEGER(temp)[j];
node_params *= INTEGER(temp)[0] - 1;
}/*THEN*/
else {
/* this is a continuous node, so it's a lot easier. */
node_params = LENGTH(getListElement(node_data, "coefficients"));
}/*ELSE*/
if (*debuglevel > 0)
Rprintf("* node %s has %d parameter(s).\n", NODE(i), node_params);
res[0] += node_params;
}/*FOR*/
UNPROTECT(1);
return result;
}/*FITTED_NPARAMS*/
void Graph::setNodelist(SEXP preGraph)
{
std::vector<std::vector<int> > prepNodelist;
VectsxpToVector(getListElement(preGraph,"edges"), prepNodelist);
if(dbg) Rprintf("Restoring given edges...");
nodelist.clear();
for(int i=0;i<(int) prepNodelist.size();i++)
nodelist.push_back(prepNodelist.at(i));
par = REAL(getListElement(preGraph,"parameters"))[0];
given = 1;
if(dbg) Rprintf("ok. ");
}
// used with glm_*.c
void SetModel1(SEXP Rfit, SEXP Rmodel_m,
SEXP beta, SEXP se, SEXP modelspace,
SEXP deviance, SEXP R2, SEXP Q, SEXP Rintercept, int m) {
SET_ELEMENT(beta, m, getListElement(getListElement(Rfit, "fit"),"coefficients"));
SET_ELEMENT(se, m, getListElement(getListElement(Rfit, "fit"),"se"));
SET_ELEMENT(modelspace, m, Rmodel_m);
REAL(R2)[m] = NA_REAL;
REAL(deviance)[m] = REAL(getListElement(getListElement(Rfit, "fit"),"deviance"))[0];
REAL(Q)[m] = REAL(getListElement(getListElement(Rfit, "lpy"),"Q"))[0];
REAL(Rintercept)[m] = REAL(getListElement(getListElement(Rfit, "lpy"),"intercept"))[0];
};
void OMVIdistance::setParameters(SEXP params){
OMdistance::setParameters(params);
int indelmethod = INTEGER(getListElement(params, "indelmethod"))[0];
if(indelmethod==0){
indelCalc= new VaryingIndelCalculator(REAL(getListElement(params, "indels")));
}else if(indelmethod==1){
indelCalc= new OMlocIndelCalculator(REAL(getListElement(params, "timecost"))[0]*maxscost, REAL(getListElement(params, "localcost"))[0], this->scost, this->alphasize);
} else {
indelCalc= new OMlocIndelCalculatorMin(REAL(getListElement(params, "timecost"))[0]*maxscost, REAL(getListElement(params, "localcost"))[0], this->scost, this->alphasize);
}
//timecost = REAL(getListElement(params, "timecost"))[0]*maxscost;
//localcost = REAL(getListElement(params, "localcost"))[0];
}
static void unpackVector(SEXP dv, int * out_len, double ** out_ptr)
{
SEXP len, d_ptr;
len = getListElement(dv, "length");
if(isNull(len) || (asInteger(len) <= 0))
error("ardblas: unpackVector: improperly formatted gpu vector");
*out_len = asInteger(len);
d_ptr = getListElement(dv, "device.pointer");
if(isNull(d_ptr) || !R_ExternalPtrAddr(d_ptr))
error("ardblas: unpackVector: improperly formatted gpu vector");
*out_ptr = R_ExternalPtrAddr(d_ptr);
}
/* Dirichlet posterior probabilities (covers BDe and K2 scores). */
double dirichlet_node(SEXP target, SEXP x, SEXP data, SEXP iss, SEXP prior,
SEXP beta, SEXP experimental, int sparse, int debuglevel) {
char *t = (char *)CHAR(STRING_ELT(target, 0));
double prob = 0, prior_prob = 0;
SEXP nodes, node_t, data_t, exp_data, parents, parent_vars, config;
/* get the node cached information. */
nodes = getListElement(x, "nodes");
node_t = getListElement(nodes, t);
/* get the parents of the node. */
parents = getListElement(node_t, "parents");
/* extract the node's column from the data frame. */
data_t = c_dataframe_column(data, target, TRUE, FALSE);
/* extract the list of eperimental data. */
exp_data = c_dataframe_column(experimental, target, TRUE, FALSE);
/* compute the prior probability component for the node. */
prior_prob = graph_prior_prob(prior, target, node_t, beta, debuglevel);
if (length(parents) == 0) {
prob = dpost(data_t, iss, exp_data);
}/*THEN*/
else {
/* generate the configurations of the parents. */
PROTECT(parent_vars = c_dataframe_column(data, parents, FALSE, FALSE));
PROTECT(config = c_configurations(parent_vars, TRUE, !sparse));
/* compute the marginal likelihood. */
prob = cdpost(data_t, config, iss, exp_data);
UNPROTECT(2);
}/*ELSE*/
if (debuglevel > 0) {
Rprintf(" > (log)prior probability is %lf.\n", prior_prob);
Rprintf(" > (log)posterior density is %lf.\n", prob);
}/*THEN*/
/* add the (log)prior to the marginal (log)likelihood to get the (log)posterior. */
prob += prior_prob;
return prob;
}/*DIRICHLET_NODE*/
/* get the number of parameters of a single node (discrete case). */
SEXP nparams_dnode(SEXP graph, SEXP node, SEXP data, SEXP real) {
int i = 0, j = 0, length_nodes = 0, *r = LOGICAL(real);
double *nlevels = NULL;
SEXP temp, names, result;
/* get the entry for the parents of the node.*/
temp = getListElement(graph, "nodes");
temp = getListElement(temp, (char *)CHAR(STRING_ELT(node, 0)));
temp = getListElement(temp, "parents");
/* get the column names from the data set and the length of the
relevant vectors. */
names = getAttrib(data, R_NamesSymbol);
length_nodes = LENGTH(temp);
/* allocate and initialize the result. */
PROTECT(result = allocVector(REALSXP, 1));
nlevels = REAL(result);
*nlevels = 1;
/* sum (multiply, actually) up the levels. */
for (i = 0; i < LENGTH(names); i++) {
for (j = 0; j < length_nodes; j++) {
/* this is a parent. */
if (!strcmp(CHAR(STRING_ELT(names, i)), CHAR(STRING_ELT(temp, j)))) {
*nlevels *= NLEVELS2(data, i);
}/*THEN*/
}/*FOR*/
/* this is the node. */
if (!strcmp(CHAR(STRING_ELT(names, i)), CHAR(STRING_ELT(node, 0)))) {
*nlevels *= NLEVELS2(data, i) - 1 * (*r);
}/*THEN*/
}/*FOR*/
UNPROTECT(1);
return result;
}/*NPARAMS_DNODE*/
double testBF_prior_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept,
int Laplace ) {
double g, logmarglik, loglik_null, z;
g = REAL(getListElement(hyperparams, "g"))[0];
loglik_null = REAL(getListElement(hyperparams, "loglik_null"))[0];
// pmodel is 0 for null model
z = -2.0*(loglik_mle - loglik_null);
logmarglik = - 0.5* (((double) pmodel)*(log(1.0 + g)) + z*g/(1.0 + g));
// Rprintf("z = %lf p = %d \n", z, pmodel );
return(logmarglik);
}
/* return the size of the arc set. */
SEXP num_arcs(SEXP bn) {
int i = 0, is_fitted = 0, *res = NULL;
char *element = NULL;
SEXP nodes, node_data, temp, result;
/* get to the nodes' data. */
nodes = getListElement(bn, "nodes");
/* check whether this is a "bn.fit" or "bn" object. */
is_fitted = isNull(nodes);
/* set the parameters for the object structure. */
if (is_fitted) {
nodes = bn;
element = "parents";
}/*THEN*/
else {
element = "nbr";
}/*ELSE*/
/* allocate and initialize the result. */
PROTECT(result = allocVector(INTSXP, 1));
res = INTEGER(result);
*res = 0;
for (i = 0; i < LENGTH(nodes); i++) {
/* get the parents/children of this node. */
node_data = VECTOR_ELT(nodes, i);
temp = getListElement(node_data, element);
*res += LENGTH(temp);
}/*FOR*/
/* summing up the neighbours counts each arc twice, dedeuplicate. */
if (!is_fitted)
*res /= 2;
UNPROTECT(1);
return result;
}/*NUM_ARCS*/
/* 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*/
static void getRSLRADispOption( SEXP OPTS ) {
SEXP str_value_sexp;
if (TYPEOF((str_value_sexp = getListElement(OPTS, "disp"))) == STRSXP) {
Log::str2DispLevel(CHAR(STRING_ELT(str_value_sexp, 0)));
}
}
static void getRSLRAMethodOption( OptimizationOptions *popt, SEXP OPTS ) {
SEXP str_val_sexp;
if (TYPEOF((str_val_sexp = getListElement(OPTS, "method"))) == STRSXP) {
popt->str2Method(CHAR(STRING_ELT(str_val_sexp, 0)));
}
}
/* get the number of parameters of a single node (continuous case). */
SEXP nparams_gnode(SEXP graph, SEXP node) {
char *name = (char *)CHAR(STRING_ELT(node, 0));
SEXP temp, result;
temp = getListElement(graph, "nodes");
temp = getListElement(temp, name);
temp = getListElement(temp, "parents");
PROTECT(result = allocVector(INTSXP, 1));
INT(result) = LENGTH(temp) + 1;
UNPROTECT(1);
return result;
}/*NPARAMS_GNODE*/
/* predict the value of a gaussian node without parents. */
SEXP gpred(SEXP fitted, SEXP data, SEXP debug) {
int i = 0, *ndata = INTEGER(data), *debuglevel = LOGICAL(debug);
double *mean = NULL, *res = NULL;
SEXP result;
/* get the (only) coefficient of the linear regression. */
mean = REAL(getListElement(fitted, "coefficients"));
/* allocate and initialize the return value. */
PROTECT(result = allocVector(REALSXP, *ndata));
res = REAL(result);
/* copy the mean in the return value. */
for (i = 0; i < *ndata; i++)
res[i] = *mean;
if (*debuglevel > 0) {
Rprintf(" > prediction for all observations is %lf.\n", *mean);
}/*THEN*/
UNPROTECT(1);
return result;
}/*GPRED*/
double graph_prior_prob(SEXP prior, SEXP target, SEXP cache, SEXP beta,
int debuglevel) {
double *b = NULL, prob = 0;
const char *pr = NULL;
SEXP parents, children;
/* check which prior should be computed, and use the uniform one
* if none is specified.*/
if (prior == R_NilValue)
return 0;
else
pr = CHAR(STRING_ELT(prior, 0));
/* match the label of the prior. */
if (strcmp(pr, "uniform") == 0) {
/* constant prior, log(1) = 0 for backward compatibility. */
prob = 0;
}/*THEN*/
else if (strcmp(pr, "vsp") == 0) {
parents = getListElement(cache, "parents");
/* variable selection prior, each arc has independent beta probability
* fo inclusion. */
b = REAL(beta);
prob = length(parents) * log(*b / (1 - *b));
}/*THEN*/
else if (strcmp(pr, "cs") == 0) {
parents = getListElement(cache, "parents");
children = getListElement(cache, "children");
/* completed prior from Castelo and Siebes. */
if (beta == R_NilValue)
prob = 0;
else
prob = castelo_prior(beta, target, parents, children, debuglevel);
}/*THEN*/
return prob;
}/*GRAPH_PRIOR_PROB*/
SEXP glm_FitModel(SEXP RX, SEXP RY, SEXP Rmodel_m, //input data
SEXP Roffset, SEXP Rweights, glmstptr * glmfamily, SEXP Rcontrol,
SEXP Rlaplace, betapriorptr * betapriorfamily) { //parameters
int nprotected = 0;
int *model_m = INTEGER(Rmodel_m);
int pmodel = LENGTH(Rmodel_m);
//subset the data and call the model fitting function
int n = INTEGER(getAttrib(RX,R_DimSymbol))[0];
double *X = REAL(RX);
SEXP RXnow=PROTECT(allocMatrix(REALSXP, n , pmodel)); nprotected++;
double *Xwork = REAL(RXnow);
for (int j=0; j < pmodel; j++) { //subsetting matrix
int model_m_j = model_m[j];
memcpy(Xwork + j * n, X + model_m_j*n, sizeof(double)*n);
}
SEXP glm_fit = PROTECT(glm_bas(RXnow, RY, glmfamily, Roffset, Rweights, Rcontrol));
nprotected++;
//extract mu and coef and evaluate the function
SEXP Rmu = PROTECT(duplicate(getListElement(glm_fit, "mu"))); nprotected++;
SEXP Rcoef = PROTECT(duplicate(getListElement(glm_fit, "coefficients")));nprotected++;
SEXP RXnow_noIntercept=PROTECT(allocMatrix(REALSXP, n , pmodel-1)); nprotected++;
if (pmodel > 1) {
double *Xwork_noIntercept = REAL(RXnow_noIntercept);
memcpy(Xwork_noIntercept, Xwork + n, sizeof(double)*n*(pmodel-1));
}
SEXP Rlpy = PROTECT(gglm_lpy(RXnow_noIntercept, RY, Rcoef, Rmu,
glmfamily, betapriorfamily, Rlaplace));
nprotected++;
SEXP ANS = PROTECT(allocVector(VECSXP, 2)); nprotected++;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 2)); nprotected++;
SET_VECTOR_ELT(ANS, 0, glm_fit);
SET_VECTOR_ELT(ANS, 1, Rlpy);
SET_STRING_ELT(ANS_names, 0, mkChar("fit"));
SET_STRING_ELT(ANS_names, 1, mkChar("lpy"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
UNPROTECT(nprotected);
return(ANS);
}
double IC_glm_logmarg(SEXP hyperparams, int pmodel, double W,
double loglik_mle, double logdet_Iintercept, int Laplace ) {
double penalty, logmarglik;
penalty = REAL(getListElement(hyperparams, "penalty"))[0];
logmarglik = loglik_mle - .5*penalty*pmodel;
return(logmarglik);
}
scs_int getIntFromListWithDefault(SEXP list, const char *str, scs_int def) {
SEXP val = getListElement(list, str);
if (val == R_NilValue) {
return def;
}
val = coerceVector(val, INTSXP);
return INTEGER(val)[0];
}
SEXP graph_prior_prob(SEXP prior, SEXP target, SEXP cache, SEXP beta,
SEXP debug) {
double *b = NULL;
const char *pr = CHAR(STRING_ELT(prior, 0));
SEXP prob, parents, children;
/* allocate the return value. */
PROTECT(prob = allocVector(REALSXP, 1));
/* match the label of the prior. */
if (strcmp(pr, "uniform") == 0) {
/* constant prior, log(1) = 0 for backward compatibility. */
NUM(prob) = 0;
}/*THEN*/
else if (strcmp(pr, "vsp") == 0) {
parents = getListElement(cache, "parents");
/* variable selection prior, each arc has independent beta probability
* fo inclusion. */
b = REAL(beta);
NUM(prob) = LENGTH(parents) * log(*b / (1 - *b));
}/*THEN*/
else if (strcmp(pr, "cs") == 0) {
parents = getListElement(cache, "parents");
children = getListElement(cache, "children");
/* completed prior from Castelo and Siebes. */
if (beta == R_NilValue)
NUM(prob) = 0;
else
NUM(prob) = castelo_prior(beta, target, parents, children, debug);
}/*THEN*/
UNPROTECT(1);
return prob;
}/*GRAPH_PRIOR_PROB*/
