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