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); }