SEXP deterministic(SEXP Y, SEXP X, SEXP Rprobinit, SEXP Rmodeldim, SEXP incint, SEXP Ralpha, SEXP method, SEXP modelprior)
{
SEXP RXwork = PROTECT(duplicate(X)), RYwork = PROTECT(duplicate(Y));
int nProtected = 2;
int nModels=LENGTH(Rmodeldim);
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;
SEXP Rse_m, Rcoef_m, Rmodel_m;
double *Xwork, *Ywork, *coefficients,*probs,
SSY, yty, ybar, mse_m, *se_m, pigamma,
R2_m, RSquareFull, alpha, logmarg_m, shrinkage_m;
double *XtX, *XtY, *XtXwork, *XtYwork;
double one, zero;
int inc, p2;
int nobs, p, k, i, j, m, n, l, pmodel, *xdims, *model_m, *model;
char uplo[] = "U", trans[]="T";
Bit **models;
struct Var *vars; /* Info about the model variables. */
/* get dimsensions of all variables */
nobs = LENGTH(Y);
xdims = INTEGER(getAttrib(X,R_DimSymbol));
p = xdims[1];
k = LENGTH(modelprobs);
Ywork = REAL(RYwork);
Xwork = REAL(RXwork);
XtX = (double *) R_alloc(p * p, sizeof(double));
XtXwork = (double *) R_alloc(p * p, sizeof(double));
XtY = vecalloc(p);
XtYwork = vecalloc(p);
/* create X matrix */
for (j=0, l=0; j < p; j++) {
for (i = 0; i < p; i++) {
XtX[j*p + i] = 0.0;}
}
p2 = p*p;
one = 1.0; zero = 0.0; ybar = 0.0; SSY = 0.0; yty = 0.0;
inc = 1;
F77_NAME(dsyrk)(uplo, trans, &p, &nobs, &one, &Xwork[0], &nobs, &zero, &XtX[0], &p);
yty = F77_NAME(ddot)(&nobs, &Ywork[0], &inc, &Ywork[0], &inc);
for (i = 0; i< nobs; i++) {
ybar += Ywork[i];
}
ybar = ybar/ (double) nobs;
SSY = yty - (double) nobs* ybar *ybar;
F77_NAME(dgemv)(trans, &nobs, &p, &one, &Xwork[0], &nobs, &Ywork[0], &inc, &zero, &XtY[0],&inc);
alpha = REAL(Ralpha)[0];
vars = (struct Var *) R_alloc(p, sizeof(struct Var));
probs = REAL(Rprobs);
n = sortvars(vars, probs, p);
/* Make space for the models and working variables. */
models = cmatalloc(k,p);
model = (int *) R_alloc(p, sizeof(int));
k = topk(models, probs, k, vars, n, p);
/* Fit Full model */
if (nobs <= p) {RSquareFull = 1.0;}
else {
Rcoef_m = NEW_NUMERIC(p); PROTECT(Rcoef_m);
Rse_m = NEW_NUMERIC(p); PROTECT(Rse_m);
coefficients = REAL(Rcoef_m); se_m = REAL(Rse_m);
memcpy(coefficients, XtY, p*sizeof(double));
memcpy(XtXwork, XtX, p2*sizeof(double));
memcpy(XtYwork, XtY, p*sizeof(double));
mse_m = yty;
cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, p, nobs);
/* olsreg(Ywork, Xwork, coefficients, se_m, &mse_m, &p, &nobs, pivot,qraux,work,residuals,effects,v, betaols); */
RSquareFull = 1.0 - (mse_m * (double) ( nobs - p))/SSY;
UNPROTECT(2);
}
/* now fit all top k models */
for (m=0; m < k; m++) {
pmodel = 0;
pigamma = 1.0;
for (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]);
}
REAL(sampleprobs)[m] = pigamma;
INTEGER(modeldim)[m] = pmodel;
Rmodel_m = NEW_INTEGER(pmodel); PROTECT(Rmodel_m);
model_m = INTEGER(Rmodel_m);
for (j = 0, l=0; j < p; j++) {
if (models[m][j]) {
model_m[l] = j;
l +=1; }
}
INTEGER(modeldim)[m] = pmodel;
SET_ELEMENT(modelspace, m, Rmodel_m);
UNPROTECT(1);
Rcoef_m = NEW_NUMERIC(pmodel); PROTECT(Rcoef_m);
Rse_m = NEW_NUMERIC(pmodel); PROTECT(Rse_m);
coefficients = REAL(Rcoef_m);
se_m = REAL(Rse_m);
for (j=0, l=0; j < pmodel; j++) {
XtYwork[j] = XtY[model_m[j]];
for ( i = 0; i < pmodel; i++) {
XtXwork[j*pmodel + i] = XtX[model_m[j]*p + model_m[i]];
}
}
mse_m = yty;
memcpy(coefficients, XtYwork, sizeof(double)*pmodel);
cholreg(XtYwork, XtXwork, coefficients, se_m, &mse_m, pmodel, nobs);
/* olsreg(Ywork, Xwork, coefficients, se_m, &mse_m, &pmodel, &nobs, pivot,qraux,work,residuals,effects,v, betaols); */
R2_m = 1.0 - (mse_m * (double) ( nobs - pmodel))/SSY;
SET_ELEMENT(beta, m, Rcoef_m);
SET_ELEMENT(se, m, Rse_m);
REAL(R2)[m] = R2_m;
REAL(mse)[m] = mse_m;
gexpectations(p, pmodel, nobs, R2_m, alpha, INTEGER(method)[0], RSquareFull,
SSY, &logmarg_m, &shrinkage_m);
REAL(logmarg)[m] = logmarg_m;
REAL(priorprobs)[m] = compute_prior_probs( model, pmodel,p, modelprior);
REAL(shrinkage)[m] = shrinkage_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, mse);
SET_STRING_ELT(ANS_names, 6, mkChar("mse"));
SET_VECTOR_ELT(ANS, 7, beta);
SET_STRING_ELT(ANS_names, 7, mkChar("ols"));
SET_VECTOR_ELT(ANS, 8, se);
SET_STRING_ELT(ANS_names, 8, mkChar("ols.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);
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);
}
