Skip to content

Commit

Permalink
updated glm_mcmc.c and lm_mcmc.c to avoid use of SETLENGTH (issue #82)
Browse files Browse the repository at this point in the history
  • Loading branch information
@merliseclyde
merliseclyde committed Sep 15, 2024
1 parent a09a9cc commit 7996476
Show file tree
Hide file tree
Showing 3 changed files with 98 additions and 41 deletions.
19 changes: 4 additions & 15 deletions cran-comments.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,9 @@

## Submission reason

- Removed legacy definitions of ‘PI’ and ‘Free’ and replaced with‘M_PI’ and ‘R_Free’ to comply with ‘STRICT_R_HEADERS’ so that package not removed 9/23/2024
- Removed legacy definitions of ‘PI’ and ‘Free’ and replaced with‘M_PI’ and ‘R_Free’ to comply with ‘STRICT_R_HEADERS’ (issue #81) to prevent package removal after 9/23/2024

- Removed non-API calls to SETLENGTH (issue #82)

## Test environments

Expand All @@ -18,21 +20,8 @@
## R CMD check results for this submission

* Mmac, Windows, Ubunto, Debian
0 error | 0 warnings | 1 notes

Found non-API call to R: 'SETLENGTH'

Compiled code should not call non-API entry points in R.

Work in progress (issue #82) as it requires additional memory management, writing objects to dis or memory mapped data kto allow creation of temporary objects with a shorter length before copying the copying the contents to the new location and inserting in the return list object and freeing the rest of the memory at function return.

files in src:
- lm_mcmc.c
- lm_amcmc.c
- glm_mcmc.c
- glm_amcmc.c
0 error | 0 warnings | 0 notes

(Object length of unique elements from MCMC is random and )

## Reverse Dependencies

Expand Down
64 changes: 50 additions & 14 deletions src/glm_mcmc.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -32,6 +32,38 @@ SEXP glm_mcmc(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,

SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;

PROTECT_INDEX counts_idx;
PROTECT_WITH_INDEX(counts, &counts_idx);
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, MH=0.0, prior_m=1.0, shrinkage_m, logmargy, postold, postnew;
int i, m, n, pmodel_old, *bestmodel;
int mcurrent, n_sure;
Expand Down Expand Up @@ -198,20 +230,24 @@ SEXP glm_mcmc(SEXP Y, SEXP X, SEXP Roffset, SEXP Rweights,
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));

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

}

SET_VECTOR_ELT(ANS, 1, modelspace);
Expand Down
56 changes: 44 additions & 12 deletions src/lm_mcmc.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -35,6 +35,34 @@ SEXP mcmc_new(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit, SEXP Rmodeldim,
SEXP sampleprobs = PROTECT(allocVector(REALSXP, nModels)); ++nProtected;
SEXP NumUnique = PROTECT(allocVector(INTSXP, 1)); ++nProtected;

PROTECT_INDEX counts_idx;
PROTECT_WITH_INDEX(counts, &counts_idx);
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, MH=0.0, prior_m=1.0,
R2_m, RSquareFull, logmargy, postold, postnew;
Expand Down Expand Up @@ -247,19 +275,23 @@ SEXP mcmc_new(SEXP Y, SEXP X, SEXP Rweights, SEXP Rprobinit, SEXP Rmodeldim,
SET_STRING_ELT(ANS_names, 0, mkChar("probne0"));

if (nUnique < nModels) {
SETLENGTH(modelspace, nUnique);
SETLENGTH(logmarg, nUnique);
SETLENGTH(modelprobs, nUnique);
SETLENGTH(priorprobs, nUnique);
SETLENGTH(sampleprobs, nUnique);
nModels = nUnique;
SETLENGTH(counts, nUnique);
SETLENGTH(beta, nUnique);
SETLENGTH(se, nUnique);
SETLENGTH(mse, nUnique);
SETLENGTH(shrinkage, nUnique);
SETLENGTH(modeldim, nUnique);
SETLENGTH(R2, nUnique);
SETLENGTH(rank, nUnique);
REPROTECT(counts= Rf_lengthgets(counts, nUnique), counts_idx);
REPROTECT(logmarg= Rf_lengthgets(logmarg, nUnique), logmarg_idx);
REPROTECT(modelprobs= Rf_lengthgets(modelprobs, nUnique), modelprobs_idx);
REPROTECT(priorprobs= Rf_lengthgets(priorprobs, nUnique), priorprobs_idx);
REPROTECT(sampleprobs= Rf_lengthgets(sampleprobs, nUnique), sampleprobs_idx);
REPROTECT(mse = Rf_lengthgets(mse, nUnique), mse_idx);
REPROTECT(shrinkage = Rf_lengthgets(shrinkage, nUnique), shrinkage_idx);
REPROTECT(modeldim= Rf_lengthgets(modeldim, nUnique), modeldim_idx);
REPROTECT(R2= Rf_lengthgets(R2, nUnique), R2_idx);
REPROTECT(se= Rf_lengthgets(se, nUnique), se_idx);
REPROTECT(rank = Rf_lengthgets(rank, nUnique), rank_idx);
REPROTECT(modelspace = Rf_lengthgets(modelspace, nUnique), modelspace_idx);
REPROTECT(beta = Rf_lengthgets(beta, nUnique), beta_idx);
REPROTECT(se= Rf_lengthgets(se, nUnique), se_idx);

}
SET_VECTOR_ELT(ANS, 1, modelspace);
SET_STRING_ELT(ANS_names, 1, mkChar("which"));
Expand Down

0 comments on commit 7996476

Please sign in to comment.