PopED + babelmixr2 for windows

DESCRIPTION

@@ -32,7 +32,8 @@ Suggests:
     gridExtra,
     covr,
     devtools,
-    mrgsolve
+    mrgsolve,
+    babelmixr2
 Authors@R: c(
     person("Andrew C.","Hooker", email="[email protected]", 
       role=c("aut","cre","trl","cph"),

NEWS.md

@@ -1,3 +1,7 @@
+# PopED development verson
+
+* Make parallelization work with `babelmixr2` models on windows (#79)
+
 # PopED 0.7.0
 
 * `create.poped.database()` now uses a better method of identifying the total number of parameters of each type (bpop, d, sigma, etc.) in a user defined model parameter function (the `ff_fun` argument in `create.poped.database()`) (#73).

R/Doptim.R

@@ -73,7 +73,7 @@ Doptim <- function(poped.db,ni, xt, model_switch, x, a, bpopdescr,
                    iter_tot=poped.db$settings$iNumSearchIterationsIfNotLineSearch,
                    iter_max=10,
                    ...){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
 
   ## update poped.db with options supplied in function
   called_args <- match.call()

R/LEDoptim.R

@@ -52,6 +52,7 @@ LEDoptim <- function(poped.db,
                      laplace.fim=FALSE, 
                      use_RS=poped.db$settings$bUseRandomSearch,
                      ...){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #+++++++++++++++++++++  D CONTINUOUS VARIABLE OPTIMIZATION FUNCTION
 
   # ------------- downsizing of general design

R/LinMatrixH.R

@@ -23,13 +23,15 @@
 ## Function translated automatically using 'matlab.to.r()'
 ## Author: Andrew Hooker
 
-LinMatrixH <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,poped.db){
+LinMatrixH <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,
+poped.db){
   #----------Model linearization with respect to epsilon.
   #
   # size of return is (samples per individual x number of epsilons) 
   #
   # derivative of model w$r.t. eps eval at e=0
   #
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   NumEPS = size(poped.db$parameters$sigma,1)
   if((NumEPS==0)){
     y=0
@@ -61,6 +63,7 @@ LinMatrixH <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,poped.db){
 #' @keywords internal
 #' 
 gradf_eps <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,num_eps,poped.db){
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #----------Model linearization with respect to epsilon.
   #
   # size of return is (samples per individual x number of epsilons)

R/LinMatrixL.R

@@ -22,7 +22,7 @@
 ## Author: Andrew Hooker
 
 LinMatrixL <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,poped.db){
-
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   if((poped.db$parameters$NumRanEff==0)){
     y=0
   } else {

R/LinMatrixLH.R

@@ -20,6 +20,7 @@
 ## Author: Andrew Hooker
 
 LinMatrixLH <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,NumEPS,poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #----------Model linearization with respect to epsilon.
   #
   # size of return is (samples per individual x (number of sigma x number of omega)) 
@@ -56,6 +57,8 @@ LinMatrixLH <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,NumEPS,poped
 
 #Helper function to get the hessian for the AD derivative
 new_ferror_file <- function(model_switch,deriv_vec,xt_ind,x,a,bpop,bocc_ind,poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
+
   fg0=feval(poped.db$model$fg_pointer,x,a,bpop,deriv_vec(1:poped.db$parameters$NumRanEff),bocc_ind) #Interaction
   returnArgs <- feval(poped.db$model$ferror_pointer,model_switch,xt_ind,fg0,deriv_vec(poped.db$parameters$NumRanEff+1:length(deriv_vec)),poped.db) 
   f_error <- returnArgs[[1]]

R/LinMatrixL_occ.R

@@ -18,6 +18,7 @@
 ## Author: Andrew Hooker
 
 LinMatrixL_occ <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,iCurrentOcc,poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #
   # size: (samples per individual x number of iovs)
   #

R/RS_opt.R

@@ -73,7 +73,7 @@ RS_opt <- function(poped.db,
                        out_file=NULL,
                        compute_inv=TRUE,
                        ...){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2    
 
   # Only get inputs that are needed, not double inputs
   # needed inputs to function: get first then run function

R/a_line_search.R

@@ -48,6 +48,7 @@ a_line_search <- function(poped.db,
                           opt_samps=poped.db$settings$optsw[1],
                           opt_inds=poped.db$settings$optsw[5],
                           ls_step_size=poped.db$settings$ls_step_size){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
 
   optsw <- cbind(opt_samps,opt_xt,opt_x,opt_a,opt_inds)
   # 

R/blockexp.R

@@ -25,7 +25,8 @@
 blockexp <- function(fn,poped.db,e_flag=FALSE,
                      opt_xt=poped.db$settings$optsw[2],opt_a=poped.db$settings$optsw[4],opt_x=poped.db$settings$optsw[4],
                      opt_samps=poped.db$settings$optsw[1],opt_inds=poped.db$settings$optsw[5]){
-
+
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   fprintf(fn,'==============================================================================\n')
   fprintf(fn,'Model description : %s \n',poped.db$settings$modtit)
   fprintf(fn,'\n')
@@ -155,6 +156,8 @@ blockexp <- function(fn,poped.db,e_flag=FALSE,
 }
 
 print_params <- function (params,name_str, fn, poped.db, param_sqrt=FALSE,head_txt=NULL,matrix_elements=F,e_flag=FALSE) {
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
+
   if(is.null(head_txt)) head_txt <- "Parameter Values"
   uncer_txt <- ""
   if(e_flag) uncer_txt <- " (Uncertainty Distribution)"

R/blockfinal.R

@@ -31,6 +31,7 @@ blockfinal <- function(fn,fmf,dmf,groupsize,ni,xt,x,a,model_switch,bpop,d,docc,s
                        compute_inv=TRUE,out_file=NULL,trflag=TRUE,footer_flag=TRUE,
                        run_time = NULL,
                        ...){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   time_value <- NULL
 
   if(!trflag) return(invisible() ) 

R/blockheader.R

@@ -37,6 +37,7 @@ blockheader <- function(poped.db,name="Default",iter=NULL,
                           header_flag=TRUE,
                           ...)
 {
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   # BLOCKHEADER_2
   #   filename to write to is 
   #   poped.db$settings$strOutputFilePath,poped.db$settings$strOutputFileName,NAME,iter,poped.db$settings$strOutputFileExtension

R/blockopt.R

@@ -20,7 +20,8 @@
 ## Author: Andrew Hooker
 
 blockopt <- function(fn,poped.db,opt_method=""){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
+
   if(any(opt_method==c("RS","SG","DO"))){
     fprintf(fn,'==============================================================================\n')
     fprintf(fn,'Optimization Settings\n\n')
@@ -50,4 +51,4 @@ blockopt <- function(fn,poped.db,opt_method=""){
     fprintf(fn,"\n")
   }
   return( ) 
-}
+}

R/blockother.R

@@ -2,6 +2,7 @@
 ## Author: Andrew Hooker
 
 blockother <- function(fn,poped.db,d_switch=poped.db$settings$d_switch){
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   fprintf(fn,'==============================================================================\n')
   fprintf(fn,'Criterion Specification\n\n')
 

R/calc_ofv_and_fim.R

@@ -47,7 +47,9 @@ calc_ofv_and_fim <- function (poped.db,
                               ofv_fun = poped.db$settings$ofv_fun,
                               evaluate_fim = TRUE,
                               ...) {
-
+
+
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   ## compute the OFV
   if((ofv==0)){
     if(d_switch){ 
@@ -177,4 +179,4 @@ calc_ofv_and_fim <- function (poped.db,
     fim <- fmf
   }
   return(list(ofv=ofv,fim=fim)) 
-}
+}

R/convert_variables.R

@@ -16,6 +16,7 @@
 ## Author: Andrew Hooker
 
 convert_variables <- function(poped.db){
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
     design = poped.db$design
     design_space = poped.db$design_space
 

R/create_ofv.R

@@ -15,7 +15,7 @@ create_ofv <- function(poped.db,
                        ofv_fun = poped.db$settings$ofv_fun,
                        transform_parameters=T,
                        ...){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2  
   #------------ update poped.db with options supplied in function
   called_args <- match.call()
   default_args <- formals()

R/d2fimdalpha2.R

@@ -1,4 +1,5 @@
 d2fimdalpha2 <- function(alpha, model_switch,groupsize,ni,xtoptn,xoptn,aoptn,bpopdescr,ddescr,covd,sigma,docc,poped.db,ha){  
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   bpop=bpopdescr[,2,drop=F]
   bpop[bpopdescr[,1,drop=F]!=0]=alpha[1:sum(bpopdescr[,1,drop=F]!=0)]
   d=ddescr[,2,drop=F]

R/dfimdalpha.R

@@ -1,5 +1,6 @@
 
 dfimdalpha <- function(alpha, model_switch,groupsize,ni,xtoptn,xoptn,aoptn,bpopdescr,ddescr,covd,sigma,docc,poped.db,ha){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   bpop=bpopdescr[,2,drop=F]
   bpop[bpopdescr[,1,drop=F]!=0]=alpha[1:sum(bpopdescr[,1,drop=F]!=0)]
   d=ddescr[,2,drop=F]
@@ -33,4 +34,4 @@ dfimdalpha <- function(alpha, model_switch,groupsize,ni,xtoptn,xoptn,aoptn,bpopd
   }
   return(list( grad= grad,fim =fim )) 
 }
-
+

R/downsizing_general_design.R

@@ -24,6 +24,7 @@
 
 
 downsizing_general_design <- function(poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   # ------------- downsizing of general design
 
   ni=poped.db$design$ni[1:poped.db$design$m,,drop=F]

R/ed_laplace_ofv.R

@@ -492,6 +492,7 @@ calc_k <- function(alpha, model_switch,groupsize,ni,xtoptn,xoptn,aoptn,bpopdescr
   if(return_gradient){
 
     comp_grad_1 <- function(alpha, model_switch, groupsize, ni, xtoptn, xoptn, aoptn, bpopdescr, ddescr, covd, sigma, docc, poped.db, grad_p) {
+      start_parallel_env$babelmixr2 <- poped.db$babelmixr2
       returnArgs <- dfimdalpha(alpha,model_switch,groupsize,ni,xtoptn,xoptn,aoptn,bpopdescr,ddescr,covd,sigma,docc,poped.db,1e-6) 
       d_fim <- returnArgs[[1]]
       fim <- returnArgs[[2]]

R/ed_mftot.R

@@ -27,6 +27,7 @@
 
 ed_mftot <- function(model_switch,groupsize,ni,xtoptn,xoptn,aoptn,bpopdescr,ddescr,covd,sigma,docc,poped.db,
                      calc_fim=TRUE,...){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #+++++++++++++++++++++++ ED OFV(MF) VALUE
   s=0
   s1=0

R/evaluate.e.ofv.fim.R

@@ -45,7 +45,7 @@ evaluate.e.ofv.fim <- function(poped.db,
                                use_laplace=poped.db$settings$iEDCalculationType, 
                                laplace.fim=FALSE, 
                                ...){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   ## update poped.db with options supplied in function
   called_args <- match.call()
   default_args <- formals()

R/evaluate.fim.R

@@ -71,7 +71,7 @@ evaluate.fim <- function(poped.db,
                          groupsize=NULL,
                          deriv.type = NULL,
                          ...){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2  
 
   if(is.null(bpop.val)) bpop.val <- poped.db$parameters$param.pt.val$bpop
   if(is.null(d_full)) d_full <- poped.db$parameters$param.pt.val$d

R/evaluate_design.R

@@ -12,6 +12,7 @@
 #' @family evaluate_design
 
 evaluate_design <- function(poped.db, ...) {
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   out <- calc_ofv_and_fim(poped.db,...)
   if(is.null(out$fim)){
     out$rse <- NULL
@@ -23,4 +24,4 @@ evaluate_design <- function(poped.db, ...) {
     colnames(out$fim) <- names(out$rse)
   }
   return(out)
-}
+}

R/evaluate_fim_map.R

@@ -37,7 +37,7 @@ evaluate_fim_map <- function(poped.db,
                       num_sim_ids = 1000,
                       use_purrr = FALSE,
                       shrink_mat=F){
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   # if (poped.db$design$m > 1) {
   #   warning("Shrinkage should only be computed for a single arm, please adjust your script accordingly.")
   # }
@@ -176,4 +176,4 @@ evaluate_fim_map <- function(poped.db,
   return(out_df)
 
 
-}
+}

R/evaluate_power.R

@@ -38,6 +38,7 @@
 evaluate_power <- function(poped.db, bpop_idx, h0=0, alpha=0.05, power=0.80, twoSided=TRUE, 
                            find_min_n=TRUE,
                            fim=NULL, out=NULL,...) {
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   # If two-sided then halve the alpha
   if (twoSided == TRUE) alpha = alpha/2
 
@@ -85,4 +86,4 @@ evaluate_power <- function(poped.db, bpop_idx, h0=0, alpha=0.05, power=0.80, two
   }
 
   return(out)
-}
+}

R/get_all_params.R

@@ -20,6 +20,7 @@
 ## Author: Andrew Hooker
 
 get_all_params <- function(poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #Return all params (in a vector all) with the specified order above
 
   #bpop = poped.db$parameters$bpop[,2,drop=F] 

R/get_cv.R

@@ -1,4 +1,5 @@
 get_cv <- function(param_vars,poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #Return the RSE,CV of parameters
   ## Author: Andrew Hooker
   params_all <-  get_all_params(poped.db)[[8]] 
@@ -62,7 +63,7 @@ get_rse <- function (fim, poped.db,
                      prior_fim = poped.db$settings$prior_fim,
                      #pseudo_on_fail = FALSE,
                      ...) {
-
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2  
   ## update poped.db with options supplied in function
   called_args <- match.call()
   default_args <- formals()

R/get_fim_size.R

@@ -2,6 +2,7 @@
 ## Author: Andrew Hooker
 
 get_fim_size <- function(poped.db){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #Returns the size of FIM, i$e. col or row size
   numnotfixed_bpop = sum(poped.db$parameters$notfixed_bpop)
   numnotfixed_d    = sum(poped.db$parameters$notfixed_d)

R/get_unfixed_params.R

@@ -15,7 +15,7 @@
 #' @export
 #' @keywords internal
 get_unfixed_params <- function(poped.db,params=NULL){
-
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   if(is.null(params)){
     bpop = poped.db$parameters$bpop[,2,drop=F]
     d = poped.db$parameters$d[,2,drop=F]

R/grad_bpop.R

@@ -2,6 +2,7 @@
 ## Author: Andrew Hooker
 
 grad_bpop <- function(func,select_par,nout,model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,d,sigma,docc,poped.db,subset=poped.db$parameters$notfixed_bpop, offdiag = FALSE){
+  start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   #----------Model linearization with respect to pop parameters
   #
   # use helper function to check for/include EBEs
@@ -13,7 +14,7 @@ grad_bpop <- function(func,select_par,nout,model_switch,xt_ind,x,a,bpop,b_ind,bo
 
 # helper for m2
 helper_v_EBE <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,d,sigma,docc,poped.db) {
-
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   if((poped.db$settings$bCalculateEBE)){
     #zeros(size(b_ind)[1],size(b_ind)[2])
     b_ind_x = ind_estimates(poped.db$mean_data,bpop,d,sigma,t(b_ind),(poped.db$settings$iApproximationMethod==2),FALSE,model_switch,xt_ind,x,a,b_ind,bocc_ind,poped.db)
@@ -28,7 +29,7 @@ helper_v_EBE <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,d,sigma,doc
 
 # helper for m1
 helper_LinMatrix <- function(model_switch,xt_ind,x,a,bpop,b_ind,bocc_ind,d,sigma,docc,poped.db) {
-
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   epsi0 = zeros(1,length(poped.db$parameters$notfixed_sigma))
 
   # create linearized model

R/graddetmf.R

@@ -3,6 +3,7 @@
 
 graddetmf <- function(model_switch,aX,groupsize,ni,xt,x,a,bpop,d,sigma,docc,poped.db,lndet=FALSE,gradxt=FALSE){
 
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   n = get_fim_size(poped.db)
   m=size(ni,1)
   if (gradxt == FALSE) {

R/graddetmf_ext.R

@@ -2,7 +2,7 @@
 ## Author: Andrew Hooker
 
 graddetmf_ext <- function(model_switch,aX,groupsize,ni,xt,x,a,bpop,d,sigma,docc,poped.db,lndet=FALSE,gradxt=FALSE){
-
+    start_parallel_env$babelmixr2 <- poped.db$babelmixr2
   n = get_fim_size(poped.db)
   m=size(ni,1)
   if (gradxt==FALSE) {