SEXP glm_mcmc(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SEXP Rprobinit, SEXP Rmodeldim,
SEXP modelprior, SEXP Rbestmodel, SEXP plocal,
SEXP BURNIN_Iterations,
SEXP Ra, SEXP Rb, SEXP Rs,
SEXP family, SEXP Rcontrol, SEXP Rlaplace
)
{
int nProtected = 0;
int nModels=LENGTH(Rmodeldim);
SEXP ANS = PROTECT(allocVector(VECSXP, 17)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 17)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP MCMCprobs= PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP counts = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP deviance = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;
double *probs, MH=0.0, prior_m=1.0, shrinkage_m, logmargy, postold, postnew;
int i, m, n, pmodel_old, *bestmodel;
int mcurrent, n_sure;
glmstptr *glmfamily;
glmfamily = make_glmfamily_structure(family);
//get dimsensions of all variables
int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
int k = LENGTH(modelprobs);
struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables.
probs = REAL(Rprobs);
n = sortvars(vars, probs, p);
for (i =n; i <p; i++) REAL(MCMCprobs)[vars[i].index] = probs[vars[i].index];
for (i =0; i <n; i++) REAL(MCMCprobs)[vars[i].index] = 0.0;
// fill in the sure things
int *model = ivecalloc(p);
for (i = n, n_sure = 0; i < p; i++) {
model[vars[i].index] = (int) vars[i].prob;
if (model[vars[i].index] == 1) ++n_sure;
}
GetRNGstate();
NODEPTR tree, branch;
tree = make_node(-1.0);
// Rprintf("For m=0, Initialize Tree with initial Model\n");
m = 0;
bestmodel = INTEGER(Rbestmodel);
INTEGER(modeldim)[m] = n_sure;
// Rprintf("Create Tree\n");
branch = tree;
CreateTree(branch, vars, bestmodel, model, n, m, modeldim);
int pmodel = INTEGER(modeldim)[m];
SEXP Rmodel_m = PROTECT(allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
//evaluate logmargy and shrinkage
SEXP glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Ra, Rb, Rs, Rlaplace));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q,Rintercept, m);
UNPROTECT(2);
int nUnique=0, newmodel=0;
double *real_model = vecalloc(n);
int *modelold = ivecalloc(p);
int old_loc = 0;
int new_loc;
pmodel_old = pmodel;
nUnique=1;
INTEGER(counts)[0] = 0;
postold = REAL(logmarg)[m] + log(REAL(priorprobs)[m]);
memcpy(modelold, model, sizeof(int)*p);
m = 0;
int *varin= ivecalloc(p);
int *varout= ivecalloc(p);
double problocal = REAL(plocal)[0];
while (nUnique < k && m < INTEGER(BURNIN_Iterations)[0]) {
memcpy(model, modelold, sizeof(int)*p);
pmodel = n_sure;
MH = GetNextModelCandidate(pmodel_old, n, n_sure, model, vars, problocal, varin, varout);
branch = tree;
newmodel= 0;
for (i = 0; i< n; i++) {
int bit = model[vars[i].index];
if (bit == 1) {
if (branch->one != NULL) branch = branch->one;
else newmodel = 1;
} else {
if (branch->zero != NULL) branch = branch->zero;
else newmodel = 1;
}
pmodel += bit;
}
if (pmodel == n_sure || pmodel == n + n_sure) {
MH = 1.0/(1.0 - problocal);
}
if (newmodel == 1) {
new_loc = nUnique;
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Ra, Rb, Rs, Rlaplace));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
postnew = logmargy + log(prior_m);
} else {
new_loc = branch->where;
postnew = REAL(logmarg)[new_loc] + log(REAL(priorprobs)[new_loc]);
}
MH *= exp(postnew - postold);
// Rprintf("MH new %lf old %lf\n", postnew, postold);
if (unif_rand() < MH) {
if (newmodel == 1) {
new_loc = nUnique;
insert_model_tree(tree, vars, n, model, nUnique);
INTEGER(modeldim)[nUnique] = pmodel;
//Rprintf("model %d: %d variables\n", m, pmodel);
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, nUnique);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q, Rintercept, nUnique);
UNPROTECT(2);
++nUnique;
}
old_loc = new_loc;
postold = postnew;
pmodel_old = pmodel;
memcpy(modelold, model, sizeof(int)*p);
} else {
if (newmodel == 1) UNPROTECT(2);
}
INTEGER(counts)[old_loc] += 1;
for (i = 0; i < n; i++) {
// store in opposite order so nth variable is first
real_model[n-1-i] = (double) modelold[vars[i].index];
REAL(MCMCprobs)[vars[i].index] += (double) modelold[vars[i].index];
}
m++;
}
for (i = 0; i < n; i++) {
REAL(MCMCprobs)[vars[i].index] /= (double) m;
}
// Compute marginal probabilities
mcurrent = nUnique;
// Rprintf("NumUnique Models Accepted %d \n", nUnique);
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
INTEGER(NumUnique)[0] = nUnique;
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
if (nUnique < nModels) {
SEXP modelspaceP = PROTECT(allocVector(VECSXP, nUnique));
for (i =0; i < nUnique; i++) {
SEXP model_temp = PROTECT(VECTOR_ELT(modelspace, i));
SET_ELEMENT(modelspaceP, i, model_temp);
UNPROTECT(1);
}
SET_VECTOR_ELT(ANS, 1, modelspaceP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 1, modelspace);
}
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
if (nUnique < nModels) {
SEXP logmargP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(logmargP)[i] = REAL(logmarg)[i];
}
SET_VECTOR_ELT(ANS, 2, logmargP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 2, logmarg);
}
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
if (nUnique < nModels) {
SEXP modelprobsP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(modelprobsP)[i] = REAL(modelprobs)[i];
}
SET_VECTOR_ELT(ANS, 3, modelprobsP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 3, modelprobs);
}
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
if (nUnique < nModels) {
SEXP priorprobsP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(priorprobsP)[i] = REAL(priorprobs)[i];
}
SET_VECTOR_ELT(ANS, 4, priorprobsP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 4, priorprobs);
}
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
if (nUnique < nModels) {
SEXP sampleprobsP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(sampleprobsP)[i] = REAL(sampleprobs)[i];
}
SET_VECTOR_ELT(ANS, 5, sampleprobsP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 5, sampleprobs);
}
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
if (nUnique < nModels) {
SEXP devianceP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(devianceP)[i] = REAL(deviance)[i];
}
SET_VECTOR_ELT(ANS, 6, devianceP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 6, deviance);
}
SET_STRING_ELT(ANS_names, 6, mkChar("deviance"));
if (nUnique < nModels) {
SEXP betaP = PROTECT(allocVector(VECSXP, nUnique));
for (i =0; i < nUnique; i++) {
SEXP beta_temp = PROTECT(VECTOR_ELT(beta, i));
SET_ELEMENT(betaP, i, beta_temp);
UNPROTECT(1);
}
SET_VECTOR_ELT(ANS, 7, betaP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 7, beta);
}
SET_STRING_ELT(ANS_names, 7, mkChar("coefficients"));
if (nUnique < nModels) {
SEXP seP = PROTECT(allocVector(VECSXP, nUnique));
for (i =0; i < nUnique; i++) {
SEXP se_temp = PROTECT(VECTOR_ELT(se, i));
SET_ELEMENT(seP, i, se_temp);
UNPROTECT(1);
}
SET_VECTOR_ELT(ANS, 8, seP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 8, se);
}
SET_STRING_ELT(ANS_names, 8, mkChar("se"));
if (nUnique < nModels) {
SEXP shrinkageP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(shrinkageP)[i] = REAL(shrinkage)[i];
}
SET_VECTOR_ELT(ANS, 9, shrinkageP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 9, shrinkage);
}
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
if (nUnique < nModels) {
SEXP modeldimP = PROTECT(allocVector(INTSXP, nUnique));
for (i =0; i < nUnique; i++) {
INTEGER(modeldimP)[i] = INTEGER(modeldim)[i];
}
SET_VECTOR_ELT(ANS, 10, modeldimP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 10, modeldim);
}
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
if (nUnique < nModels) {
SEXP R2P = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(R2P)[i] = REAL(R2)[i];
}
SET_VECTOR_ELT(ANS, 11, R2P);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 11, R2);
}
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
if (nUnique < nModels) {
SEXP countsP = PROTECT(allocVector(INTSXP, nUnique));
for (i =0; i < nUnique; i++) {
INTEGER(countsP)[i] = INTEGER(counts)[i];
}
SET_VECTOR_ELT(ANS, 12, countsP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 12, counts);
}
SET_STRING_ELT(ANS_names, 12, mkChar("freq"));
SET_VECTOR_ELT(ANS, 13, MCMCprobs);
SET_STRING_ELT(ANS_names, 13, mkChar("probs.MCMC"));
SET_VECTOR_ELT(ANS, 14, NumUnique);
SET_STRING_ELT(ANS_names, 14, mkChar("n.Unique"));
if (nUnique < nModels) {
SEXP QP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(QP)[i] = REAL(Q)[i];
}
SET_VECTOR_ELT(ANS, 15, QP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 15, Q);
}
SET_STRING_ELT(ANS_names, 15, mkChar("Q"));
if (nUnique < nModels) {
SEXP RinterceptP = PROTECT(allocVector(REALSXP, nUnique));
for (i =0; i < nUnique; i++) {
REAL(RinterceptP)[i] = REAL(Rintercept)[i];
}
SET_VECTOR_ELT(ANS, 16, RinterceptP);
UNPROTECT(1);
} else {
SET_VECTOR_ELT(ANS, 16, Rintercept);
}
SET_STRING_ELT(ANS_names, 16, mkChar("intercept"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
PutRNGstate();
UNPROTECT(nProtected);
//Rprintf("Return\n");
return(ANS);
}
SEXP glm_deterministic(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SEXP Rprobinit, SEXP Rmodeldim, SEXP modelprior, SEXP betaprior,
SEXP family, SEXP Rcontrol, SEXP Rlaplace) {
int nProtected = 0;
int nModels=LENGTH(Rmodeldim);
glmstptr * glmfamily;
glmfamily = make_glmfamily_structure(family);
betapriorptr *betapriorfamily;
betapriorfamily = make_betaprior_structure(betaprior, family);
// Rprintf("Allocating Space for %d Models\n", nModels) ;
SEXP ANS = PROTECT(allocVector(VECSXP, 14)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 14)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP deviance = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
double *probs,shrinkage_m,logmargy;
//get dimsensions of all variables
int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
int k = LENGTH(modelprobs);
struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables.
probs = REAL(Rprobs);
int n = sortvars(vars, probs, p);
Bit **models = cmatalloc(k,p);
int *model = (int *) R_alloc(p, sizeof(int));
k = topk(models, probs, k, vars, n, p);
/* now fit all top k models */
for (int m=0; m < k; m++) {
int pmodel = 0;
double pigamma = 1.0;
for (int j = 0; j < p; j++) {
model[j] = (int) models[m][j];
pmodel += (int) models[m][j];
pigamma *= (double)((int) models[m][j])*probs[j] +
(1.0 - (double)((int) models[m][j]))*(1.0 - probs[j]);
}
SEXP Rmodel_m = PROTECT(allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
//evaluate logmargy and shrinkage
SEXP glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
double prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
REAL(sampleprobs)[m] = pigamma;
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance,
R2, Q, Rintercept, m);
UNPROTECT(2);
}
compute_modelprobs(modelprobs, logmarg, priorprobs, k);
compute_margprobs_old(models, modelprobs, probs, k, p);
/* freechmat(models,k); */
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
SET_VECTOR_ELT(ANS, 2, logmarg);
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
SET_VECTOR_ELT(ANS, 3, modelprobs);
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
SET_VECTOR_ELT(ANS, 4, priorprobs);
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
SET_VECTOR_ELT(ANS, 5,sampleprobs);
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
SET_VECTOR_ELT(ANS, 6, deviance);
SET_STRING_ELT(ANS_names, 6, mkChar("deviance"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("mle"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));
SET_VECTOR_ELT(ANS, 9, shrinkage);
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
SET_VECTOR_ELT(ANS, 10, modeldim);
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
SET_VECTOR_ELT(ANS, 11, R2);
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
SET_VECTOR_ELT(ANS, 12, Q);
SET_STRING_ELT(ANS_names, 12, mkChar("Q"));
SET_VECTOR_ELT(ANS, 13, Rintercept);
SET_STRING_ELT(ANS_names, 13, mkChar("intercept"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
UNPROTECT(nProtected);
return(ANS);
}
SEXP glm_sampleworep(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SEXP Rprobinit, SEXP Rmodeldim,
SEXP modelprior, SEXP betaprior,SEXP Rbestmodel, SEXP plocal,
SEXP family, SEXP Rcontrol,
SEXP Rupdate, SEXP Rlaplace, SEXP Rparents) {
int nProtected = 0;
int nModels=LENGTH(Rmodeldim);
// Rprintf("Allocating Space for %d Models\n", nModels) ;
SEXP ANS = PROTECT(allocVector(VECSXP, 14)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 14)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP deviance = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
double *probs,logmargy, shrinkage_m;
int i;
glmstptr *glmfamily;
glmfamily = make_glmfamily_structure(family);
betapriorptr *betapriorfamily;
betapriorfamily = make_betaprior_structure(betaprior, family);
//get dimsensions of all variables
int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
int k = LENGTH(modelprobs);
int update = INTEGER(Rupdate)[0];
double eps = DBL_EPSILON;
double problocal = REAL(plocal)[0];
struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables.
probs = REAL(Rprobs);
int n = sortvars(vars, probs, p);
int *model = ivecalloc(p);
/* fill in the sure things */
for (i = n; i < p; i++) {
model[vars[i].index] = (int) vars[i].prob;
}
GetRNGstate();
NODEPTR tree, branch;
tree = make_node(vars[0].prob);
// Rprintf("For m=0, Initialize Tree with initial Model\n");
int m = 0;
int *bestmodel = INTEGER(Rbestmodel);
for (i = n; i < p; i++) {
model[vars[i].index] = bestmodel[vars[i].index];
INTEGER(modeldim)[m] += bestmodel[vars[i].index];
}
double *pigamma = vecalloc(p);
branch = tree;
CreateTree_with_pigamma(branch, vars, bestmodel, model, n, m, modeldim,pigamma, Rparents);
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
int pmodel = INTEGER(modeldim)[m];
SEXP Rmodel_m = PROTECT(allocVector(INTSXP,pmodel));
GetModel_m(Rmodel_m, model, p);
//evaluate logmargy and shrinkage
SEXP glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
double prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2, Q,Rintercept, m);
UNPROTECT(2);
int *modelwork= ivecalloc(p);
// sample models
for (m = 1; m < k && pigamma[0] < 1.0; m++) {
INTEGER(modeldim)[m] = 0.0;
for (i = n; i < p; i++) {
INTEGER(modeldim)[m] += model[vars[i].index];
}
branch = tree;
GetNextModel_swop(branch, vars, model, n, m, pigamma, problocal,
modeldim, bestmodel,Rparents);
/* Now subtract off the visited probability mass. */
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
/* Now get model specific calculations */
pmodel = INTEGER(modeldim)[m];
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
memset(INTEGER(Rmodel_m), 0, pmodel * sizeof(int));
GetModel_m(Rmodel_m, model, p);
glm_fit = PROTECT(glm_FitModel(X, Y, Rmodel_m, Roffset, Rweights,
glmfamily, Rcontrol, Rlaplace,
betapriorfamily));
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
logmargy = REAL(getListElement(getListElement(glm_fit, "lpy"),"lpY"))[0];
shrinkage_m = REAL(getListElement(getListElement(glm_fit, "lpy"),
"shrinkage"))[0];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel1(glm_fit, Rmodel_m, beta, se, modelspace, deviance, R2,Q,Rintercept, m);
UNPROTECT(2);
REAL(sampleprobs)[m] = pigamma[0];
//update best model
//update marginal inclusion probs
if (m > 1) {
double mod;
double rem = modf((double) m/(double) update, &mod);
if (rem == 0.0) {
int mcurrent = m;
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
if (update_probs(probs, vars, mcurrent, k, p) == 1) {
// Rprintf("Updating Model Tree %d \n", m);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
}
}
}
}
if (m < k) {
// resize if constraints have reduced the number of models
k = m;
SETLENGTH(modelspace, m);
SETLENGTH(logmarg, m);
SETLENGTH(modelprobs, m);
SETLENGTH(priorprobs, m);
SETLENGTH(sampleprobs, m);
SETLENGTH(beta, m);
SETLENGTH(se, m);
SETLENGTH(deviance, m);
SETLENGTH(Q, m);
SETLENGTH(Rintercept, m);
SETLENGTH(shrinkage, m);
SETLENGTH(modeldim, m);
SETLENGTH(R2, m);
}
compute_modelprobs(modelprobs, logmarg, priorprobs,k);
compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
SET_VECTOR_ELT(ANS, 2, logmarg);
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
SET_VECTOR_ELT(ANS, 3, modelprobs);
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
SET_VECTOR_ELT(ANS, 4, priorprobs);
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
SET_VECTOR_ELT(ANS, 5,sampleprobs);
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
SET_VECTOR_ELT(ANS, 6, deviance);
SET_STRING_ELT(ANS_names, 6, mkChar("deviance"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("mle"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));
SET_VECTOR_ELT(ANS, 9, shrinkage);
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
SET_VECTOR_ELT(ANS, 10, modeldim);
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
SET_VECTOR_ELT(ANS, 11, R2);
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
SET_VECTOR_ELT(ANS, 12, Q);
SET_STRING_ELT(ANS_names, 12, mkChar("Q"));
SET_VECTOR_ELT(ANS, 13, Rintercept);
SET_STRING_ELT(ANS_names, 13, mkChar("intercept"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
PutRNGstate();
UNPROTECT(nProtected);
return(ANS);
}
SEXP sampleworep_new(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit, SEXP Rmodeldim, SEXP incint, SEXP Ralpha,SEXP method, SEXP modelprior, SEXP Rupdate, SEXP Rbestmodel, SEXP Rbestmarg, SEXP plocal) {
int nProtected = 0;
SEXP RXwork = PROTECT(duplicate(X)); nProtected++;
SEXP RYwork = PROTECT(duplicate(Y)); nProtected++;
int nModels=LENGTH(Rmodeldim);
// Rprintf("Allocating Space for %d Models\n", nModels) ;
SEXP ANS = PROTECT(allocVector(VECSXP, 12)); ++nProtected;
SEXP ANS_names = PROTECT(allocVector(STRSXP, 12)); ++nProtected;
SEXP Rprobs = PROTECT(duplicate(Rprobinit)); ++nProtected;
SEXP R2 = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP shrinkage = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelspace = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP modeldim = PROTECT(duplicate(Rmodeldim)); ++nProtected;
SEXP beta = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP se = PROTECT(allocVector(VECSXP, nModels)); ++nProtected;
SEXP mse = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP modelprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP priorprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
double *Xwork, *Ywork, *wts, *probs, shrinkage_m, mse_m, R2_m, RSquareFull, logmargy;
int i;
//get dimsensions of all variables
int nobs = LENGTH(Y);
int p = INTEGER(getAttrib(X,R_DimSymbol))[1];
int k = LENGTH(modelprobs);
double alpha = REAL(Ralpha)[0];
int update = INTEGER(Rupdate)[0];
double eps = DBL_EPSILON;
double problocal = REAL(plocal)[0];
Ywork = REAL(RYwork);
Xwork = REAL(RXwork);
wts = REAL(Rweights);
double *XtXwork, *XtYwork,*XtX, *XtY, yty,SSY;
PrecomputeData(Xwork, Ywork, wts, &XtXwork, &XtYwork, &XtX, &XtY, &yty, &SSY, p, nobs);
struct Var *vars = (struct Var *) R_alloc(p, sizeof(struct Var)); // Info about the model variables.
probs = REAL(Rprobs);
int n = sortvars(vars, probs, p);
SEXP Rse_m = NULL, Rcoef_m = NULL;
RSquareFull = CalculateRSquareFull(XtY, XtX, XtXwork, XtYwork, Rcoef_m, Rse_m, p, nobs, yty, SSY);
int *model = ivecalloc(p);
/* fill in the sure things */
for (i = n; i < p; i++) {
model[vars[i].index] = (int) vars[i].prob;
}
GetRNGstate();
NODEPTR tree, branch;
tree = make_node(vars[0].prob);
// Rprintf("For m=0, Initialize Tree with initial Model\n");
int m = 0;
int *bestmodel = INTEGER(Rbestmodel);
for (i = n; i < p; i++) {
model[vars[i].index] = bestmodel[vars[i].index];
INTEGER(modeldim)[m] += bestmodel[vars[i].index];
}
double *pigamma = vecalloc(p);
branch = tree;
CreateTree_with_pigamma(branch, vars, bestmodel, model, n, m, modeldim,pigamma);
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
int pmodel = INTEGER(modeldim)[m];
SEXP Rmodel_m;
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
PROTECT(Rcoef_m = NEW_NUMERIC(pmodel));
PROTECT(Rse_m = NEW_NUMERIC(pmodel));
int *model_m = GetModel_m(Rmodel_m, model, p);
R2_m = FitModel(Rcoef_m, Rse_m, XtY, XtX, model_m, XtYwork, XtXwork, yty, SSY, pmodel, p, nobs, m, &mse_m);
gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
double prior_m = compute_prior_probs(model,pmodel,p, modelprior);
REAL(Rbestmarg)[0] = REAL(logmarg)[m];
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel(Rcoef_m, Rse_m, Rmodel_m, mse_m, R2_m, beta, se, modelspace, mse, R2, m);
//Rprintf("model %d max logmarg %lf\n", m, REAL(logmarg)[m]);
int *modelwork= ivecalloc(p);
for (m = 1; m < k; m++) {
for (i = n; i < p; i++) {
INTEGER(modeldim)[m] += model[vars[i].index];
}
branch = tree;
GetNextModel_swop(branch, vars, model, n, m, pigamma, problocal, modeldim, bestmodel);
/* Now subtract off the visited probability mass. */
branch=tree;
Substract_visited_probability_mass(branch, vars, model, n, m, pigamma,eps);
/* Now get model specific calculations */
pmodel = INTEGER(modeldim)[m];
PROTECT(Rmodel_m = allocVector(INTSXP,pmodel));
PROTECT(Rcoef_m = NEW_NUMERIC(pmodel));
PROTECT(Rse_m = NEW_NUMERIC(pmodel));
model_m = GetModel_m(Rmodel_m, model, p);
R2_m = FitModel(Rcoef_m, Rse_m, XtY, XtX, model_m, XtYwork, XtXwork, yty, SSY, pmodel, p, nobs, m, &mse_m);
gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull, SSY, &logmargy, &shrinkage_m);
prior_m = compute_prior_probs(model,pmodel,p, modelprior);
SetModel2(logmargy, shrinkage_m, prior_m, sampleprobs, logmarg, shrinkage, priorprobs, m);
SetModel(Rcoef_m, Rse_m, Rmodel_m, mse_m, R2_m, beta, se, modelspace, mse, R2,m);
REAL(sampleprobs)[m] = pigamma[0];
//update best model
if (REAL(logmarg)[m] > REAL(Rbestmarg)[0]) {
for (i=0; i < p; i++) {
bestmodel[i] = model[i];
}
REAL(Rbestmarg)[0] = REAL(logmarg)[m];
}
//update marginal inclusion probs
if (m > 1) {
double mod;
double rem = modf((double) m/(double) update, &mod);
if (rem == 0.0) {
int mcurrent = m;
compute_modelprobs(modelprobs, logmarg, priorprobs,mcurrent);
compute_margprobs(modelspace, modeldim, modelprobs, probs, mcurrent, p);
if (update_probs(probs, vars, mcurrent, k, p) == 1) {
// Rprintf("Updating Model Tree %d \n", m);
update_tree(modelspace, tree, modeldim, vars, k,p,n,mcurrent, modelwork);
}
}
}
}
compute_modelprobs(modelprobs, logmarg, priorprobs,k);
compute_margprobs(modelspace, modeldim, modelprobs, probs, k, p);
SET_VECTOR_ELT(ANS, 0, Rprobs);
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
SET_VECTOR_ELT(ANS, 2, logmarg);
SET_STRING_ELT(ANS_names, 2, mkChar("logmarg"));
SET_VECTOR_ELT(ANS, 3, modelprobs);
SET_STRING_ELT(ANS_names, 3, mkChar("postprobs"));
SET_VECTOR_ELT(ANS, 4, priorprobs);
SET_STRING_ELT(ANS_names, 4, mkChar("priorprobs"));
SET_VECTOR_ELT(ANS, 5,sampleprobs);
SET_STRING_ELT(ANS_names, 5, mkChar("sampleprobs"));
SET_VECTOR_ELT(ANS, 6, mse);
SET_STRING_ELT(ANS_names, 6, mkChar("mse"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("mle"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("mle.se"));
SET_VECTOR_ELT(ANS, 9, shrinkage);
SET_STRING_ELT(ANS_names, 9, mkChar("shrinkage"));
SET_VECTOR_ELT(ANS, 10, modeldim);
SET_STRING_ELT(ANS_names, 10, mkChar("size"));
SET_VECTOR_ELT(ANS, 11, R2);
SET_STRING_ELT(ANS_names, 11, mkChar("R2"));
setAttrib(ANS, R_NamesSymbol, ANS_names);
UNPROTECT(nProtected);
PutRNGstate();
return(ANS);
}
