Skip to content

Commit

Permalink
avoid calls to SETLENGTH in lm_sampleworep.c and glm_sampleworep.c Is…
Browse files Browse the repository at this point in the history 
…sue #82 as non-API function
  • Loading branch information
@merliseclyde
merliseclyde committed Sep 15, 2024
1 parent 8f91d01 commit 312acfc
Show file tree
Hide file tree
Showing 5 changed files with 90 additions and 32 deletions.
2 changes: 1 addition & 1 deletion R/bas_lm.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -628,7 +628,7 @@ bas.lm <- function(formula,
}

if (is.null(n.models)) {
n.models <- min(2^p, 2^19)
n.models <- min(2^p, 2^16)
}
if (is.null(MCMC.iterations)) {
MCMC.iterations <- as.integer(n.models * 10)
Expand Down
2 changes: 0 additions & 2 deletions src/bas.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -53,7 +53,6 @@ struct Node {
};



/* Subroutines. */

double CalculateRSquareFull(double *XtY, double *XtX, double *XtXwork, double *XtYwork,
Expand Down Expand Up @@ -349,7 +348,6 @@ SEXP glm_bas(SEXP RX, SEXP RY, glmstptr * family, SEXP Roffset, SEXP Rweights, S

SEXP gglm_lpy(SEXP RX, SEXP RY,SEXP Rcoef, SEXP Rmu, SEXP Rdeviance, SEXP Rweights, glmstptr * glmfamily, betapriorptr * betapriorfamily, SEXP Rlaplace);



// issue 38
static inline int lessThanOne(double a)
Expand Down
60 changes: 47 additions & 13 deletions src/glm_sampleworep.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -31,6 +31,36 @@ SEXP glm_sampleworep(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SEXP Q = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP Rintercept = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;

PROTECT_INDEX R2_idx;
PROTECT_WITH_INDEX(R2, &R2_idx);
PROTECT_INDEX shrinkage_idx;
PROTECT_WITH_INDEX(shrinkage, &shrinkage_idx);
PROTECT_INDEX modelspace_idx;
PROTECT_WITH_INDEX(modelspace, &modelspace_idx);
PROTECT_INDEX modeldim_idx;
PROTECT_WITH_INDEX(modeldim, &modeldim_idx);
// PROTECT_INDEX rank_idx;
// PROTECT_WITH_INDEX(rank, &rank_idx);
PROTECT_INDEX beta_idx;
PROTECT_WITH_INDEX(beta, &beta_idx);
PROTECT_INDEX se_idx;
PROTECT_WITH_INDEX(se, &se_idx);
PROTECT_INDEX deviance_idx;
PROTECT_WITH_INDEX(deviance, &deviance_idx);
PROTECT_INDEX modelprobs_idx;
PROTECT_WITH_INDEX(modelprobs, &modelprobs_idx);
PROTECT_INDEX priorprobs_idx;
PROTECT_WITH_INDEX(priorprobs, &priorprobs_idx);
PROTECT_INDEX logmarg_idx;
PROTECT_WITH_INDEX(logmarg, &logmarg_idx);
PROTECT_INDEX sampleprobs_idx;
PROTECT_WITH_INDEX(sampleprobs, &sampleprobs_idx);
PROTECT_INDEX Q_idx;
PROTECT_WITH_INDEX(R2, &Q_idx);
PROTECT_INDEX Rintercept_idx;
PROTECT_WITH_INDEX(Rintercept, &Rintercept_idx);


double *probs,logmargy, shrinkage_m;
int i;

Expand Down Expand Up @@ -155,19 +185,23 @@ SEXP glm_sampleworep(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
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);

REPROTECT(logmarg= Rf_lengthgets(logmarg, m), logmarg_idx);
REPROTECT(modelprobs= Rf_lengthgets(modelprobs, m), modelprobs_idx);
REPROTECT(priorprobs= Rf_lengthgets(priorprobs, m), priorprobs_idx);
REPROTECT(sampleprobs= Rf_lengthgets(sampleprobs, m), sampleprobs_idx);
REPROTECT(deviance = Rf_lengthgets(deviance, m), deviance_idx);
REPROTECT(shrinkage = Rf_lengthgets(shrinkage, m), shrinkage_idx);
REPROTECT(modeldim= Rf_lengthgets(modeldim, m), modeldim_idx);
REPROTECT(R2= Rf_lengthgets(R2, m), R2_idx);
REPROTECT(se= Rf_lengthgets(se, m), se_idx);
// REPROTECT(rank = Rf_lengthgets(rank, m), rank_idx);
REPROTECT(modelspace = Rf_lengthgets(modelspace, m), modelspace_idx);
REPROTECT(beta = Rf_lengthgets(beta, m), beta_idx);
REPROTECT(se= Rf_lengthgets(se, m), se_idx);
REPROTECT(Q= Rf_lengthgets(Q, m), Q_idx);
REPROTECT(Rintercept= Rf_lengthgets(Rintercept, m), Rintercept_idx);

}

compute_modelprobs(modelprobs, logmarg, priorprobs,k);
Expand Down
56 changes: 42 additions & 14 deletions src/lm_sampleworep.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,8 @@ deterministic sampling. ML 6/97. */
extern 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 plocal, SEXP Rparents, SEXP Rpivot, SEXP Rtol) {
SEXP Rbestmodel, SEXP plocal, SEXP Rparents,
SEXP Rpivot, SEXP Rtol) {
int nProtected = 0;
SEXP RXwork = PROTECT(duplicate(X)); nProtected++;
SEXP RYwork = PROTECT(duplicate(Y)); nProtected++;
Expand All @@ -48,6 +49,31 @@ extern SEXP sampleworep_new(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit,
SEXP logmarg = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;

PROTECT_INDEX R2_idx;
PROTECT_WITH_INDEX(R2, &R2_idx);
PROTECT_INDEX shrinkage_idx;
PROTECT_WITH_INDEX(shrinkage, &shrinkage_idx);
PROTECT_INDEX modelspace_idx;
PROTECT_WITH_INDEX(modelspace, &modelspace_idx);
PROTECT_INDEX modeldim_idx;
PROTECT_WITH_INDEX(modeldim, &modeldim_idx);
PROTECT_INDEX rank_idx;
PROTECT_WITH_INDEX(rank, &rank_idx);
PROTECT_INDEX beta_idx;
PROTECT_WITH_INDEX(beta, &beta_idx);
PROTECT_INDEX se_idx;
PROTECT_WITH_INDEX(se, &se_idx);
PROTECT_INDEX mse_idx;
PROTECT_WITH_INDEX(mse, &mse_idx);
PROTECT_INDEX modelprobs_idx;
PROTECT_WITH_INDEX(modelprobs, &modelprobs_idx);
PROTECT_INDEX priorprobs_idx;
PROTECT_WITH_INDEX(priorprobs, &priorprobs_idx);
PROTECT_INDEX logmarg_idx;
PROTECT_WITH_INDEX(logmarg, &logmarg_idx);
PROTECT_INDEX sampleprobs_idx;
PROTECT_WITH_INDEX(sampleprobs, &sampleprobs_idx);

double *Xwork, *Ywork, *wts, *probs, shrinkage_m, mse_m, R2_m, RSquareFull, Rbestmarg, logmargy;
int i, *model_m, *bestmodel, rank_m;

Expand Down Expand Up @@ -219,19 +245,21 @@ extern SEXP sampleworep_new(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit,

if (m < k) { // resize
k = m;
SETLENGTH(modelspace, m);
SETLENGTH(logmarg, m);
SETLENGTH(modelprobs, m);
SETLENGTH(priorprobs, m);
SETLENGTH(sampleprobs, m);
SETLENGTH(beta, m);
SETLENGTH(se, m);
SETLENGTH(mse, m);
SETLENGTH(shrinkage, m);
SETLENGTH(modeldim, m);
SETLENGTH(R2, m);
SETLENGTH(rank, m);
// Rprintf("m %d k %d", m, LENGTH(modelprobs));

REPROTECT(logmarg= Rf_lengthgets(logmarg, m), logmarg_idx);
REPROTECT(modelprobs= Rf_lengthgets(modelprobs, m), modelprobs_idx);
REPROTECT(priorprobs= Rf_lengthgets(priorprobs, m), priorprobs_idx);
REPROTECT(sampleprobs= Rf_lengthgets(sampleprobs, m), sampleprobs_idx);
REPROTECT(mse = Rf_lengthgets(mse, m), mse_idx);
REPROTECT(shrinkage = Rf_lengthgets(shrinkage, m), shrinkage_idx);
REPROTECT(modeldim= Rf_lengthgets(modeldim, m), modeldim_idx);
REPROTECT(R2= Rf_lengthgets(R2, m), R2_idx);
REPROTECT(se= Rf_lengthgets(se, m), se_idx);
REPROTECT(rank = Rf_lengthgets(rank, m), rank_idx);
REPROTECT(modelspace = Rf_lengthgets(modelspace, m), modelspace_idx);
REPROTECT(beta = Rf_lengthgets(beta, m), beta_idx);
REPROTECT(se= Rf_lengthgets(se, m), se_idx);

}


Expand Down
2 changes: 0 additions & 2 deletions src/mem.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -51,5 +51,3 @@ return x;
}
return elmt;
}


0 comments on commit 312acfc

Please sign in to comment.