Merge pull request #155 from weecology/juniper_active

v0.13.0
weecology · Oct 13, 2019 · 8bc504d · 8bc504d
2 parents c2aa46a + 91e3076
commit 8bc504d
Show file tree

Hide file tree

Showing 10 changed files with 127 additions and 35 deletions.
diff --git a/DESCRIPTION b/DESCRIPTION
@@ -1,6 +1,6 @@
 Package: portalcasting
 Title: Functions Used in Predicting Portal Rodent Dynamics
-Version: 0.12.1
+Version: 0.13.0
 Authors@R: c(
     person(c("Juniper", "L."), "Simonis",
       email = "[email protected]", role = c("aut", "cre"),

diff --git a/NAMESPACE b/NAMESPACE
@@ -27,6 +27,7 @@ export(check_args)
 export(clear_tmp)
 export(climate_dl_control)
 export(combine_hist_and_cast)
+export(control_list_arg)
 export(covariate_models)
 export(create)
 export(create_dir)

diff --git a/NEWS.md b/NEWS.md
@@ -2,6 +2,21 @@
 
 Version numbers follow [Semantic Versioning](https://semver.org/).
 
+# [portalcasting 0.13.0](https://github.com/weecology/portalcasting/releases/tag/v0.13.0)
+*2019-10-12*
+
+### Full writing of `control_files` in model scripts
+* Previously, the controls list for the files in the model scripts was taken from the environment in which the script was run, which opens the script to everything, which is undesirable.
+* After the need to include a control list for runjags models forced an explicit writing of the list inputs, the code was available to transfer to the files control list.
+* This does mean that the function calls in the scripts are now super long and explicit, but that's ok.
+* To avoid super long model script lines (where event default inputs are repeated in the list functions), a function `control_list_arg` was made to generalize what was coded up from the runjags list for use also with the files control list. This function writes a script component that only includes arguments to the list function that are different from the formal definition. 
+
+# portalcasting 0.12.1
+*2019-10-12*
+
+### Fixes to the pkgdown site
+* rmarkdown v1.16.0 has some issues with rendering images, so forcing use of v1.16.1 for now.
+* Inclusion of new functions in reference list.
 
 # [portalcasting 0.12.0](https://github.com/weecology/portalcasting/releases/tag/v0.12.0)
 *2019-10-11*

diff --git a/R/args.R b/R/args.R
@@ -91,9 +91,13 @@
 #'   \code{filename_moons}, 
 #'   \code{freq}, 
 #'   \code{jags_model},  
-#'   \code{level}, 
+#'   \code{level},
+#'   \code{list_function}, 
 #'   \code{main}, 
-#'   \code{method} (if not \code{NULL}, must be \code{"unwtavg"}),
+#'   \code{method} (if not \code{NULL}, must be \code{"unwtavg"}, 
+#'    \code{"unwtavg"}, \code{"rjags"}, \code{"simple"}, 
+#'    \code{"interruptible"}, \code{"parallel"}, \code{"rjparallel"},
+#'    \code{"background"}, \code{"bgparallel"}, or \code{"snow"}),
 #'   \code{model} (inputted values are checked via 
 #'    \code{\link{verify_models}}), 
 #'   \code{name}, 
@@ -174,6 +178,7 @@
 #'  be \code{NA}:
 #'   \code{control_climate_dl},
 #'   \code{control_files},
+#'   \code{control_list},
 #'   \code{control_model},
 #'   \code{control_runjags},
 #'   \code{controls_models},
@@ -586,8 +591,9 @@ check_arg_list <- function(){
     controls_rodents = arg_list(),
     control_runjags = arg_list(),
     control_files = arg_list(),
+    control_list= arg_list(),
     covariates = arg_df(),
-    covariatesTF = arg_logical(),
+    covariatesTF = arg_logical(), 
     data_name = arg_character(),
     data = arg_character(length = NULL),
     data_set = arg_character(),
@@ -632,6 +638,7 @@ check_arg_list <- function(){
     lead_time  = arg_nonnegintnum(),
     lev = arg_intnum(),
     level = arg_character(),
+    list_function = arg_character(),
     lon = arg_numeric(),
     main = arg_character(),
     max_E = arg_nonnegintnum(vals = avail_max_Es),

diff --git a/R/portalcast.R b/R/portalcast.R
@@ -212,7 +212,7 @@ cast <- function(main = ".", models = prefab_models(), end_moon = NULL,
     model_running_message(model = model, quiet = quiet,
                           arg_checks = arg_checks)
     run_status <- tryCatch(
-                     source(model, local = TRUE),
+                     source(model),
                      error = function(x){NA}                     
                   )
     model_done_message(model = model, run_status = run_status, quiet = quiet,

diff --git a/R/prepare_models.R b/R/prepare_models.R
@@ -262,6 +262,9 @@ prefab_models <- function(){
 #'  \code{model_template} creates the \code{character}-valued
 #'  text for a model script to be housed in the model directory, as written
 #'  out by \code{write_model}. \cr \cr
+#'  \code{control_list_arg} creates the \code{character}-valued
+#'  text for a specific list argument into model function within a model
+#'  script to be housed in the model directory.
 #'
 #' @param main \code{character} value of the name of the main component of
 #'  the directory tree. 
@@ -306,16 +309,25 @@ prefab_models <- function(){
 #' @param control_runjags \code{list} of arguments passed to 
 #'  \code{\link[runjags]{run.jags}} via \code{\link{runjags_control}}.
 #'
+#' @param control_list \code{list} of arguments passed to 
+#'  \code{list_function}.
+#'
+#' @param list_function \code{character} value name of the function to 
+#'  send \code{control_list} arguments to within the model script.
+#'
 #' @return \code{write_mode} \code{\link{write}}s the model script out
 #'  and returns \code{NULL}. \cr \cr
 #'  \code{model_template}: \code{character}-valued text for a model script 
-#'  to be housed in the model directory
+#'  to be housed in the model directory. \cr \cr
+#'  \code{control_list_arg}: \code{character}-valued text for part of a 
+#'  model script. \cr \cr
 #'
 #' @examples
 #'  \donttest{
 #'   create_dir()
 #'   write_model("AutoArima")
 #'   model_template()
+#'   control_list_arg(runjags_control(nchains = 3), "runjags_control")
 #'  }
 #'
 #' @export
@@ -414,7 +426,6 @@ model_template <- function(name = NULL, data_sets = NULL,
                               arg_checks = arg_checks)[[name]]$data_sets)
   return_if_null(data_sets)
   main_arg <- paste0(', main = "', main, '"')
-  control_files_arg <- paste0(', control_files = control_files')
   quiet_arg <- paste0(', quiet = ', quiet)
   verbose_arg <- paste0(', verbose = ', verbose)
   arg_checks_arg <- paste0(', arg_checks = ', arg_checks)
@@ -426,31 +437,14 @@ model_template <- function(name = NULL, data_sets = NULL,
   if (!is.null(max_E)){
     max_E_arg <- paste0(', max_E = ', max_E)
   }
-  control_runjags_arg <- NULL
-  if (!is.null(control_runjags)){
-    nvals <- length(control_runjags)
-    list_vals <- NULL
-    for(i in 1:nvals){
-      val_name <- names(control_runjags)[1]
-      val_value <- control_runjags[[1]]
-      if(is.character(val_value)){
-        val_value <- paste0('"', val_value, '"')
-      }
-      list_vals <- paste0(val_name, ' = ', val_value)
-    }
-    if(nvals > 1){
-      for(i in 2:nvals){
-        val_name <- names(control_runjags)[i]
-        val_value <- control_runjags[[i]]
-        if(is.character(val_value)){
-          val_value <- paste0('"', val_value, '"')
-        }
-        list_vals <- paste0(list_vals, ', ', val_name, ' = ', val_value)
-      }
-    }
-    control_runjags_arg <- paste0(', control_runjags = runjags_control(', 
-                                 list_vals, ')')
-  }
+  control_runjags_arg <- control_list_arg(control_list = control_runjags,
+                                          list_function = "runjags_control",
+                                          arg_checks = arg_checks)
+
+  control_files_arg <- control_list_arg(control_list = control_files,
+                                        list_function = "files_control",
+                                        arg_checks = arg_checks)
+
   ds_args <- paste0('data_set = "', data_sets, '"')
   nds <- length(data_sets)
   out <- NULL
@@ -471,6 +465,51 @@ model_template <- function(name = NULL, data_sets = NULL,
 }
 
 
+
+
+#' @rdname write_model
+#'
+#' @export
+#'
+control_list_arg <- function(control_list = NULL, list_function = NULL,
+                             arg_checks = TRUE){                             
+  return_if_null(control_list)
+  return_if_null(list_function)
+
+  list_name <- paste(strsplit(list_function, "_")[[1]][2:1], collapse = "_")
+  nvals <- length(control_list)
+  val_values <- rep(NA, nvals)
+  for(i in 1:nvals){
+    val_name <- names(control_list)[i]
+    val_value <- control_list[[i]]
+    formal_value <- formals(eval(parse(text = list_function)))[[val_name]]
+
+    if(!identical(val_value, formal_value)){
+      if(is.character(val_value)){
+        val_value <- paste0('"', val_value, '"')
+      }
+      if(is.null(val_value)){
+        val_value <- "NULL"
+      }
+      val_values[i] <- val_value
+    }
+  }
+  update_values <- which(is.na(val_values) == FALSE)
+  nupdate_values <- length(update_values)
+  val_texts <- NULL
+  if(nupdate_values > 0){
+    val_text <- rep(NA, nupdate_values)
+    update_val_names <- names(control_list)[update_values]
+    update_val_values <- val_values[update_values]
+    for(i in 1:nupdate_values){
+      val_text[i] <- paste0(update_val_names[i], ' = ', update_val_values[i])
+    }
+    val_texts <- paste0(val_text, collapse = ', ')
+  }
+  paste0(', ', list_name, ' = ', list_function, '(', val_texts, ')')
+}
+
+
 #' @title Create a control list for a model
 #'
 #' @description Provides a ready-to-use template for the 

diff --git a/_pkgdown.yml b/_pkgdown.yml
@@ -146,6 +146,7 @@ reference:
       - model_controls
       - write_model
       - model_template
+      - control_list_arg
       - prefab_models
   - title: "Prefabricated models"
     desc: "Functions used to run the prefab models"

diff --git a/man/argument_checking.Rd b/man/argument_checking.Rd
diff --git a/man/write_model.Rd b/man/write_model.Rd
diff --git a/tests/testthat/test-09-prepare_models.R b/tests/testthat/test-09-prepare_models.R
@@ -81,3 +81,11 @@ test_that("model_template", {
   expect_equal(length(temp2), 4)
 
 })
+
+test_that("control_list_arg", {
+  expect_is(control_list_arg(runjags_control(nchains = 3), "runjags_control"),
+            "character")
+  expect_is(control_list_arg(runjags_control(nchains = NULL), 
+                             "runjags_control"),
+            "character")
+})