Some fixes to validate output

nlmixr2 · Oct 20, 2022 · ac3b0e9 · ac3b0e9
1 parent 2986307
commit ac3b0e9
Show file tree

Hide file tree

Showing 4 changed files with 53 additions and 53 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,7 +1,7 @@
 Package: nlmixr2extra
 Title: Nonlinear Mixed Effects Models in Population PK/PD, Extra Support
     Functions
-Version: 2.0.7
+Version: 2.0.7.9000
 Authors@R: c(
     person("Matthew", "Fidler", email="[email protected]", role = c("aut", "cre"),
            comment = c(ORCID = "0000-0001-8538-6691")),
@@ -57,4 +57,3 @@ NeedsCompilation: yes
 Roxygen: list(markdown = TRUE)
 RoxygenNote: 7.2.1
 LazyData: true
-
diff --git a/NEWS.md b/NEWS.md
@@ -1,3 +1,8 @@
+# nlmixr2extra (development version)
+
+* Use `assignInMyNamespace()` instead of using the global assignment
+  operator for the horseshoe prior
+
 # nlmixr2extra 2.0.7
 
 * Fix `cli` issues with the new `cli` 3.4+ release that will allow

diff --git a/R/bayesiancovsel.R b/R/bayesiancovsel.R
@@ -1,4 +1,3 @@
-
 #' Build formula for the brms from the fit 
 #' 
 #' 
@@ -20,18 +19,18 @@
 
 
   formula <- brms::bf(stats::as.formula(paste0(eta, " ~ a + b")),
-
-     stats::as.formula(paste0("a ~ ", paste(c("0", covarsVec), collapse = " + "))),
-
-     stats::as.formula(paste0("b ~ ", paste(c("1", inicovarsVec), collapse = " + "))),
-
-     nl = TRUE)
+                      
+                      stats::as.formula(paste0("a ~ ", paste(c("0", covarsVec), collapse = " + "))),
+                      
+                      stats::as.formula(paste0("b ~ ", paste(c("1", inicovarsVec), collapse = " + "))),
+                      
+                      nl = TRUE)
 
 
   if (!inherits(formula, c("brmsformula" ,"bform"))) {
     stop("BRMS Formula construction fails ")
   } else {
-  return(formula)  
+    return(formula)  
   }
 
 }
@@ -42,7 +41,6 @@
 #' @param p0 expected number of covariate terms, default 2
 #' @return Global shrinkage parameter
 #' @noRd 
-
 .calTau0 <- function(fit,covarsVec,p0=2){
   if (!inherits(fit, "nlmixr2FitCore")) {
     stop("'fit' needs to be a nlmixr2 fit")
@@ -51,17 +49,17 @@
     ui <- fit$finalUiEnv
   }
 
-checkmate::assert_character(covarsVec)
-D <- length(covarsVec)-1
-n <- nrow(nlme::getData(fit))
-# Global shrinkage parameter, equation 
-tau0 <- p0/(D-p0) / sqrt(n)
+  checkmate::assert_character(covarsVec)
+  D <- length(covarsVec)-1
+  n <- nrow(nlme::getData(fit))
+  # Global shrinkage parameter, equation 
+  tau0 <- p0/(D-p0) / sqrt(n)
 
-if (!is.finite(tau0)| tau0 < 0  ){tau0 <- 0.25}
+  if (!is.finite(tau0)| tau0 < 0  ){tau0 <- 0.25}
 
-tau0 
+  tau0 
 }
-  
+
 normal <- function(...){}
 horseshoe <- function(...){}
 #' @import utils 
@@ -75,16 +73,16 @@ utils::globalVariables("tau0")
 #' @noRd
 .horseshoePrior <- function(tau0){
 
-# Check if tau0 is valid 
-checkmate::assert_double(tau0)
+  # Check if tau0 is valid 
+  checkmate::assert_double(tau0)
 
-priorString <- c(brms::prior(horseshoe(df = 1, scale_global = tau0,df_global = 1), class ="b",nlpar = "a"),
-                              brms::prior(normal(0, 10), class = "b", nlpar = "b"))
+  priorString <- c(brms::prior(horseshoe(df = 1, scale_global = tau0,df_global = 1), class ="b",nlpar = "a"),
+                   brms::prior(normal(0, 10), class = "b", nlpar = "b"))
 
-# stan variable for parsing
-stanvars <- brms::stanvar(tau0, name='tau0')
+  # stan variable for parsing
+  stanvars <- brms::stanvar(tau0, name='tau0')
 
-return(list(priorString,stanvars))
+  return(list(priorString,stanvars))
 }
 
 
@@ -125,7 +123,7 @@ lasso <- function(...){}
 #' @noRd
 
 .fitbrmsModel <- function(fit,covarsVec,inicovarsVec=NULL,priorVar,warmup = 1000, iter = 2000, chains = 4,cores = 2,
-                        control = list(adapt_delta = 0.99, max_treedepth = 15),seed=1015){
+                          control = list(adapt_delta = 0.99, max_treedepth = 15),seed=1015){
 
 
   #Normalized covariate data
@@ -149,13 +147,13 @@ lasso <- function(...){}
   brms_models <- list()
 
   brms_models <- suppressWarnings(lapply(brms_formulas,brms::brm,data = combData,family = stats::gaussian(),prior =priorVar[[1]],
-                         stanvars = priorVar[[2]],warmup = warmup, iter = iter, chains = chains,cores = cores,
-                         control = control,seed=seed))
-   names(brms_models) <- etaVector
-return(brms_models)    
+                                         stanvars = priorVar[[2]],warmup = warmup, iter = iter, chains = chains,cores = cores,
+                                         control = control,seed=seed))
+  names(brms_models) <- etaVector
+  return(brms_models)    
 }
-  
-  
+
+
 
 #' Create Summary data frame from the BRMS models
 #' 
@@ -165,27 +163,25 @@ return(brms_models)
 
 .brmSummarydf <- function(all_models){
 
-# Check if the model list is named   
+  # Check if the model list is named   
 
-checkmate::assert_list(all_models,min.len = 1,names = "named")
+  checkmate::assert_list(all_models,min.len = 1,names = "named")
 
-# Construct data frame of estimates by adding eta and covariate column 
+  # Construct data frame of estimates by adding eta and covariate column 
 
-dfsList <- a <- lapply(names(all_models),function(x) {
-  data.frame(eta=x,covariate= gsub("a_|b_","",rownames(summary(all_models[[x]])$fixed)),
-             summary(all_models[[x]])$fixed,row.names = NULL)})
+  dfsList <- a <- lapply(names(all_models),function(x) {
+    data.frame(eta=x,covariate= gsub("a_|b_","",rownames(summary(all_models[[x]])$fixed)),
+               summary(all_models[[x]])$fixed,row.names = NULL)})
 
-# Merge Estimates for all eta parameters
+  # Merge Estimates for all eta parameters
 
-summaryDf <- do.call("rbind", dfsList)
-summaryDf <- summaryDf[!(summaryDf$covariate=="Intercept"),]
+  summaryDf <- do.call("rbind", dfsList)
+  summaryDf <- summaryDf[!(summaryDf$covariate=="Intercept"),]
 
-return(summaryDf)
+  return(summaryDf)
 }
 
-
-utils::globalVariables("<<-")
-`<<-` <- NULL 
+tau0 <- NULL
 
 #' Create Horseshoe summary posterior estimates 
 #' @param fit compiled rxode2 nlmir2 model fit  
@@ -234,15 +230,14 @@ utils::globalVariables("<<-")
 #' #Issue Should be fixed by uninstalling and re-installing rstan
 #'
 #' }
-
 horseshoeSummardf <- function(fit,covarsVec,...){
 
   if (!inherits(fit, "nlmixr2FitCore")) {
     stop("'fit' needs to be a nlmixr2 fit")
   }
   checkmate::assert_character(covarsVec)
   # Global shrinkage prior estimate
-  tau0 <<- .calTau0 (fit,covarsVec,p0=2)
+  assignInMyNamespace("tau0", .calTau0 (fit,covarsVec,p0=2))
   # Get prior String
   priorString <- .horseshoePrior(tau0)
   # Fit BRMS models
@@ -303,7 +298,6 @@ horseshoeSummardf <- function(fit,covarsVec,...){
 #' #brms sometimes may throw a Error in sink(type = “output”)
 #' #Issue Should be fixed by uninstalling and re-installing rstan
 #' }
-
 lassoSummardf <- function(fit,covarsVec,...){
 
   if (!inherits(fit, "nlmixr2FitCore")) {
@@ -317,8 +311,8 @@ lassoSummardf <- function(fit,covarsVec,...){
   # Fit BRMS models
 
   .lassoModels <-.fitbrmsModel(fit,covarsVec,priorVar = priorString,inicovarsVec=NULL,
-                                  warmup = 1000, iter = 2000, chains = 4,cores = 2,
-                                  control = list(adapt_delta = 0.99, max_treedepth = 15),seed=1015)
+                               warmup = 1000, iter = 2000, chains = 4,cores = 2,
+                               control = list(adapt_delta = 0.99, max_treedepth = 15),seed=1015)
 
   # Extract Summary of models
   lassoSummary <-  .brmSummarydf(.lassoModels)

diff --git a/R/lassocov.R b/R/lassocov.R
@@ -589,7 +589,9 @@ adaptivelassoCoefficients <- function(fit,varsVec,covarsVec,catvarsVec,constrain
 #'
 #' lassoDf <- regularmodel(fit,varsVec,covarsVec,catvarsVec, lassotype='adjusted')
 #' }
-regularmodel <- function(fit,varsVec,covarsVec,catvarsVec,constraint=1e-08,lassotype='regular',stratVar = NULL,...) {
+regularmodel <- function(fit,varsVec,covarsVec,catvarsVec,constraint=1e-08,
+                         lassotype=c("regular", "adaptive", "adjusted"),
+                         stratVar = NULL,...) {
 
   if (!inherits(fit, "nlmixr2FitCore")) {
     stop("'fit' needs to be a nlmixr2 fit")
@@ -601,7 +603,7 @@ regularmodel <- function(fit,varsVec,covarsVec,catvarsVec,constraint=1e-08,lasso
   checkmate::assert_character(covarsVec)
   checkmate::assert_character(varsVec)
   checkmate::assert_double(constraint)
-
+  lassotype <- match.arg(lassotype)
 
   if (lassotype=="regular") {
     .coefValues <- lassoCoefficients(fit,varsVec,covarsVec,catvarsVec,constraint=1e-08,stratVar = NULL,...)