Merge pull request #271 from weecology/model-controls-updates

Building out evaluation pipeline
weecology · Apr 21, 2022 · f20ffa5 · f20ffa5
2 parents 0c2f28a + 43801c8
commit f20ffa5
Show file tree

Hide file tree

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

diff --git a/NEWS.md b/NEWS.md
@@ -2,6 +2,15 @@
 
 Version numbers follow [Semantic Versioning](https://semver.org/).
 
+# [portalcasting 0.37.0](https://github.com/weecology/portalcasting/releases/tag/v0.37.0)
+*2022-04-21*
+
+### Building out evaluation pipeline
+* starting with what is already occurring, but formalizing as such as part of an `evaluate_casts` and `evaluate_cast` pair of functions
+* `evaluate_casts` function now works automatically to evaluate all the casts using `evaluate_cast`, generating the error table as it does when being used, but nothing is saved out or updated.
+* there is also no filter on evaluated casts by deafult, so the output from the forecasts without observations to evaluate is a table with a single row with NaN, and then they get wrapped up into the list. 
+  * no errors, just noteworthy
+
 # [portalcasting 0.36.0](https://github.com/weecology/portalcasting/releases/tag/v0.36.0)
 *2022-04-08*
 

diff --git a/R/create_dir.R b/R/create_dir.R
@@ -8,6 +8,8 @@
 #'
 #' @param settings \code{list} of controls for the directory, with defaults set in \code{\link{directory_settings}}.
 #'
+#' @param verbose \code{logical} indicator of whether or not to print out all of the information (and thus just the tidy messages).
+#'
 #' @return The \code{list} of directory settings \code{\link[base]{invisible}}-ly.
 #'
 #' @name directory creation
@@ -31,10 +33,9 @@ create_dir <- function(main     = ".",
          showWarnings = FALSE)
 
 
-  config <- write_directory_config(main     = main, 
-                                   settings = settings, 
-                                   quiet    = quiet)
+  write_directory_config(main     = main, 
+                         settings = settings, 
+                         quiet    = quiet)
+
 
-  invisible(config)
-
 }
diff --git a/R/directory_configuration_file.R b/R/directory_configuration_file.R
@@ -7,6 +7,8 @@
 #'
 #' @param quiet \code{logical} indicator if progress messages should be quieted.
 #'
+#' @param verbose \code{logical} indicator of whether or not to print out all of the information (and thus just the tidy messages).
+#'
 #' @param main \code{character} value of the name of the main component of the directory tree. Default value (\code{"."}) puts the forecasting directory in the present locations. Nesting the forecasting directory in a folder can be done by simply adding to the \code{main} input (see \code{Examples}).
 #'
 #' @param settings \code{list} of controls for the directory, with defaults set in \code{\link{directory_settings}} that should generally not need to be altered.
@@ -34,6 +36,7 @@ write_directory_config <- function (main     = ".",
 
   write_yaml(x    = config, 
              file = file.path(main, settings$files$directory_config))
+
   invisible(config)
 
 }
@@ -69,7 +72,8 @@ read_directory_config <- function (main     = ".",
 #'
 update_directory_config <- function (main     = ".", 
                                      settings = directory_settings(), 
-                                     quiet    = FALSE){
+                                     quiet    = FALSE,
+                                     verbose  = FALSE){
 
   config <- read_directory_config(main     = main, 
                                   settings = settings,
@@ -85,14 +89,13 @@ update_directory_config <- function (main     = ".",
 
     config$raw$PortalData_version <- scan(file  = file.path(main, settings$subs$resources, "PortalData", "version.txt"),
                                           what  = "character", 
-                                          quiet = TRUE)
+                                          quiet = !verbose)
 
   }
 
-
-
   write_yaml(x    = config, 
              file = file.path(main, settings$files$directory_config))
+
   invisible(config)
 
 }

diff --git a/R/evaluate.R b/R/evaluate.R
@@ -1,5 +1,3 @@
-
-
 #' @title Evaluate Forecasts
 #'
 #' @description Evaluate forecasts in the directory, based on id or group, or (if \code{cast_ids = NULL} and \code{cast_groups = NULL}, the default) \code{evaluate_casts} will evaluate all and (if \code{cast_id = NULL} and \code{cast_group = NULL}, the default), \code{evaluate_cast} will evaluate the most recent cast.
@@ -8,32 +6,54 @@
 #'
 #' @param settings \code{list} of controls for the directory, with defaults set in \code{\link{directory_settings}} that should generally not need to be altered.
 #'
-#' @param cast_group,cast_groups \code{integer} (or integer \code{numeric}) value(s) of the cast group(s) to evaluate, as indexed within the directory in the \code{casts} sub folder. See the casts metadata file (\code{casts_metadata.csv}) for summary information. \cr
-#'  \code{cast_group} can only be a single value, whereas \code{cast_groups} can be multiple.
-#'
 #' @param cast_id,cast_ids \code{integer} (or integer \code{numeric}) value(s) representing the casts of interest for evaluating, as indexed within the directory in the \code{casts} sub folder. See the casts metadata file (\code{casts_metadata.csv}) for summary information. \cr
 #'  \code{cast_id} can only be a single value, whereas \code{cast_ids} can be multiple.
 #'
 #' @param quiet \code{logical} indicator if progress messages should be quieted.
 #'
 #' @param verbose \code{logical} indicator of whether or not to print out all of the information (and thus just the tidy messages).
 #'
-#' @return \code{NULL}, \code{\link[base]{invisible}}-ly.
+#' @return A \code{data.frame}, or \code{list} of \code{data.frame}s.
 #'
 #' @name evaluate forecasts
 #'
 #' @export
 #'
-evaluate_casts <- function (main        = ".", 
-                            settings    = directory_settings(), 
-                            cast_groups = NULL, 
-                            cast_ids    = NULL,
-                            quiet       = FALSE, 
-                            verbose     = FALSE) {
+evaluate_casts <- function (main     = ".", 
+                            settings = directory_settings(), 
+                            cast_ids = NULL,
+                            quiet    = FALSE, 
+                            verbose  = FALSE) {
+
+
+  casts_to_evaluate <- select_casts(main     = main, 
+                                    settings = settings,
+                                    cast_ids = cast_ids)
+
+  if (NROW(casts_to_evaluate) == 0) {
+
+    stop("no casts available for request")
 
+  } else {
 
+    cast_ids  <- casts_to_evaluate$cast_id
+    ncast_ids <- length(cast_ids)
 
-  invisible()
+  }
+
+  out <- named_null_list(element_names = cast_ids)
+
+  for (i in 1:ncast_ids) {
+
+    out[[i]] <- evaluate_cast(main     = main,
+                              settings = settings,
+                              cast_id  = cast_ids[i],
+                              quiet    = quiet,
+                              verbose  = verbose)
+
+  }
+
+  out
 
 }
 
@@ -42,16 +62,43 @@ evaluate_casts <- function (main        = ".",
 #'
 #' @export
 #'
-evaluate_cast <- function (main       = ".", 
-                           settings   = directory_settings(), 
-                           cast_group = NULL, 
-                           cast_id    = NULL,
-                           quiet      = FALSE, 
-                           verbose    = FALSE) {
+evaluate_cast <- function (main     = ".", 
+                           settings = directory_settings(), 
+                           cast_id  = NULL,
+                           quiet    = FALSE, 
+                           verbose  = FALSE) {
+
+  return_if_null(cast_id)
+
+  model_cast     <- read_model_cast(main     = main,
+                                    cast_id  = cast_id,
+                                    settings = settings)
+  casts_metadata <- read_casts_metadata(main     = main,
+                                       settings = settings)
+  cast_model     <- casts_metadata$model[casts_metadata$cast_id == cast_id]
 
+  cast_model_controls <- model_controls(main     = main,
+                                        models   = cast_model,
+                                        settings = settings)[[cast_model]]
+  cast_model_response <- cast_model_controls$response
 
+  cast_tab <- read_cast_tab(main     = main, 
+                            settings = settings,
+                            cast_id  = cast_id)
 
-  invisible()
+  cast_tab <- add_obs_to_cast_tab(main     = main,  
+                                  settings = settings,
+                                  cast_tab = cast_tab)
+  cast_tab <- add_err_to_cast_tab(main     = main,  
+                                  settings = settings,
+                                  cast_tab = cast_tab)
+  cast_tab <- add_lead_to_cast_tab(main     = main,  
+                                   settings = settings,
+                                   cast_tab = cast_tab)
+  cast_tab <- add_covered_to_cast_tab(main     = main,  
+                                      settings = settings,
+                                      cast_tab = cast_tab)
+  measure_cast_level_error(cast_tab = cast_tab)
 
 }
 

diff --git a/R/portalcast.R b/R/portalcast.R
@@ -46,6 +46,11 @@ portalcast <- function (main       = ".",
                         quiet      = FALSE,
                         verbose    = FALSE){
 
+#
+# the datasets here should come from the models selected
+#  and not as an argument ... or? maybe not? idk. think this out.
+# 
+
   return_if_null(models)
 
   messageq(message_break(), "\nPreparing directory for casting\n", message_break(), "\nThis is portalcasting v", packageDescription("portalcasting", fields = "Version"), "\n", message_break(), quiet = quiet)

diff --git a/R/prepare_models.R b/R/prepare_models.R
@@ -1,6 +1,6 @@
 #' @title Read and Write Model Control Lists
 #'
-#' @description Input/Output functions for model control lists.
+#' @description Input/output functions for model control lists.
 #'
 #' @param quiet \code{logical} indicator controlling if messages are printed.
 #'
@@ -75,6 +75,10 @@ write_model_controls <- function (main               = ".",
 }
 
 
+
+
+
+
 #' @title Write Model Function Script into Directory
 #'
 #' @description Writes a model's function as a script into the defined directory for use in forecasting. \cr \cr \code{model} can be input as a \code{character} string, symbol (backquoted name), or \code{function}, as \code{\link{match.fun}}

diff --git a/R/process_casts.R b/R/process_casts.R
@@ -221,8 +221,8 @@ add_obs_to_cast_tab <- function (main     = ".",
 #' @export
 #'
 read_cast_tab <- function (main     = ".", 
-                           settings = directory_settings(), 
-                           cast_id  = NULL) {
+                           cast_id  = NULL, 
+                           settings = directory_settings()) {
 
   if (is.null(cast_id) ){
 
@@ -257,8 +257,8 @@ read_cast_tab <- function (main     = ".",
 #' @export
 #'
 read_cast_tabs <- function (main     = ".", 
-                            settings = directory_settings(), 
-                            cast_ids  = NULL) {
+                            cast_ids  = NULL, 
+                            settings = directory_settings()) {
 
   if (is.null(cast_ids)) {
 
@@ -269,18 +269,18 @@ read_cast_tabs <- function (main     = ".",
   }
 
   cast_tab <- read_cast_tab(main     = main,
-                            settings = settings,
-                            cast_id  = cast_ids[1])
+                            cast_id  = cast_ids[1],
+                            settings = settings)
   ncasts   <- length(cast_ids)
 
 
   if (ncasts > 1) {
 
     for (i in 2:ncasts) {
 
-      cast_tab_i <- read_cast_tab(main     = main, 
-                                  settings = settings,
-                                  cast_id  = cast_ids[i])
+      cast_tab_i <- read_cast_tab(main     = main,
+                                  cast_id  = cast_ids[i], 
+                                  settings = settings)
 
       cast_tab   <- rbind(cast_tab, cast_tab_i)
 
@@ -297,8 +297,8 @@ read_cast_tabs <- function (main     = ".",
 #' @export
 #'
 read_cast_metadata <- function (main     = ".", 
-                                settings = directory_settings(), 
-                                cast_id  = NULL) {
+                                cast_id  = NULL, 
+                                settings = directory_settings()) {
 
   if (is.null(cast_id)) {
 
@@ -326,8 +326,8 @@ read_cast_metadata <- function (main     = ".",
 #' @export
 #'
 read_model_fit <- function (main     = ".", 
-                            settings = directory_settings(), 
-                            cast_id  = NULL) {
+                            cast_id  = NULL, 
+                            settings = directory_settings()) {
 
   if (is.null(cast_id)) {
 
@@ -356,8 +356,8 @@ read_model_fit <- function (main     = ".",
 #' @export
 #'
 read_model_cast <- function (main     = ".", 
-                             settings = directory_settings(), 
-                             cast_id  = NULL) {
+                             cast_id  = NULL, 
+                             settings = directory_settings()) {
 
   if (is.null(cast_id)) {
 
@@ -367,17 +367,32 @@ read_model_cast <- function (main     = ".",
 
   }
 
-  lpath <- paste0("cast_id_", cast_id, "_model_casts.json")
-  cpath <- file.path(main, settings$subs$forecasts, lpath)
+  lpath_json  <- paste0("cast_id_", cast_id, "_model_casts.json")
+  cpath_json  <- file.path(main, settings$subs$forecasts, lpath_json)
 
-  if (!file.exists(cpath)) {
+  lpath_RData <- paste0("cast_id_", cast_id, "_model_casts.RData")
+  cpath_RData  <- file.path(main, settings$subs$forecasts, lpath_RData)
 
-    stop("cast_id does not have a model_casts file")
+  if (!file.exists(cpath_json)) {
 
-  }
+    if (!file.exists(cpath_RData)) {
 
-  read_in_json <- fromJSON(readLines(cpath))
-  unserializeJSON(read_in_json)
+      stop("cast_id does not have a model_casts file")
+
+    } else {
+
+      model_casts <- NULL
+      load(cpath_RData)
+      model_casts
+
+    }
+
+  } else {
+
+    read_in_json <- fromJSON(readLines(cpath_json))
+    unserializeJSON(read_in_json)
+
+  }
 
 }
 
@@ -483,12 +498,12 @@ select_casts <- function (main           = ".",
 #'    of the model (across multiple species, for example). 
 #'   \item \code{"model_fits"}: saved out as a serialized \code{JSON} file 
 #'    via \code{\link[jsonlite]{serializeJSON}} and 
-#'    \code{\link[jsonlite]{write_json}}, so quite flexible with respect to 
+#'    \code{\link[jsonlite:read_json]{write_json}}, so quite flexible with respect to 
 #'    specific object structure. Saving out a \code{list} of the actual model
 #'    fit/return objects means that models do not need to be refit later.
 #'   \item \code{"model_casts"}: saved out as a serialized \code{JSON} file 
 #'    via \code{\link[jsonlite]{serializeJSON}} and 
-#'    \code{\link[jsonlite]{write_json}}, so quite flexible with respect to 
+#'    \code{\link[jsonlite:read_json]{write_json}}, so quite flexible with respect to 
 #'    specific object structure. Is used to save \code{list}s
 #'    of predictions across multiple instances of the model.
 #'  }

diff --git a/R/rodent_species.R b/R/rodent_species.R
@@ -109,10 +109,9 @@ rodent_species <- function (set   = NULL,
 
     stop ("`type` must be `NULL`, 'all', 'base', or 'eval'")    
 
-
   }
 
-  if (nadot) {
+  if (total) {
 
     out_abb[which(out_abb == "NA")] <- "NA."