From 7996476f65d751ec2e88da3280df36ebc46e60d7 Mon Sep 17 00:00:00 2001 From: merliseclyde Date: Sun, 15 Sep 2024 17:07:27 -0400 Subject: [PATCH] updated glm_mcmc.c and lm_mcmc.c to avoid use of SETLENGTH (issue #82) --- cran-comments.md | 19 +++----------- src/glm_mcmc.c | 64 +++++++++++++++++++++++++++++++++++++----------- src/lm_mcmc.c | 56 +++++++++++++++++++++++++++++++++--------- 3 files changed, 98 insertions(+), 41 deletions(-) diff --git a/cran-comments.md b/cran-comments.md index eb7bfffc..adc84cab 100644 --- a/cran-comments.md +++ b/cran-comments.md @@ -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 @@ -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 diff --git a/src/glm_mcmc.c b/src/glm_mcmc.c index 03ae5aa9..f75a42f9 100644 --- a/src/glm_mcmc.c +++ b/src/glm_mcmc.c @@ -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; @@ -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); diff --git a/src/lm_mcmc.c b/src/lm_mcmc.c index 351eb75f..e9715fa5 100644 --- a/src/lm_mcmc.c +++ b/src/lm_mcmc.c @@ -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; @@ -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"));