Changed slot srr to hold the name of the stock recruitment function…

… rather than the function itself, see #91 (#100)

NAMESPACE

@@ -102,6 +102,7 @@ export(set_trait_model)
 export(sigmoid_length)
 export(sigmoid_weight)
 export(srrBevertonHolt)
+export(srrConstant)
 export(srrNone)
 export(srrRicker)
 export(srrSheperd)

NEWS.md

@@ -101,6 +101,8 @@ can graze. (#46)
 
 ## Other new features
 
+* New `upgradeParams()` can upgrade MizerParams objects from previous versions 
+  of mizer so they work with the new version.
 * `project()` now shows a progress bar while a simulation is running. Can be
   turned off with `progress_bar = FALSE` argument.
 * New `getDiet()` calculates the diet of predators. (#43)
@@ -219,6 +221,8 @@ can graze. (#46)
     predator/prey ratio.
   + Added slot `plankton_dynamics` to allow user to specify alternative
     plankton dynamics.
+  + Changed slot `srr` to hold the name of the stock recruitment function rather
+    than the function itself, see #91.
   + Added slots `resource_dynamics` and `resource_params`.
   + Added slot `initial_B` for the initial biomasses of the resources.
 * Changes to MizerSim class:
@@ -243,6 +247,8 @@ can graze. (#46)
   `all.sizes = TRUE`.
 * When no gear is specified for a species, the default is `knife_edge_gear`
   rather than the species name.
+* The stock recruitment function is now specified by giving the name of the
+  function, rather than the function itself.
 
 
 # mizer 1.0.1

R/MizerParams-class.R

@@ -181,10 +181,28 @@ validMizerParams <- function(object) {
     }
 
     # SRR
-    # Must have two arguments: rdi amd species_params
-    if (!isTRUE(all.equal(names(formals(object@srr)), c("rdi", "species_params")))) {
-        msg <- "Arguments of srr function must be 'rdi' and 'species_params'"
+    if (!is.string(object@srr)) {
+        msg <- "srr needs to be specified as a string giving the name of the function"
         errors <- c(errors, msg)
+    } else {
+        if (!exists(object@srr)) {
+            msg <- paste0("The stock-recruitment function ",
+                          object@srr,
+                          "does not exist.")
+            errors <- c(errors, msg)
+        } else {
+            srr <- get(object@srr)
+            if (!is.function(srr)) {
+                msg <- "The specified srr is not a function."
+                errors <- c(errors, msg)
+            } else {
+                # Must have two arguments: rdi amd species_params
+                if (!isTRUE(all.equal(names(formals(srr)), c("rdi", "species_params")))) {
+                    msg <- "Arguments of srr function must be 'rdi' and 'species_params'"
+                    errors <- c(errors, msg)
+                }
+            }
+        }
     }
 
     # Should not have legacy r_max column (has been renamed to R_max)
@@ -284,8 +302,9 @@ validMizerParams <- function(object) {
 #'   See \code{\link{set_multispecies_model}} for details.
 #' @slot interaction The species specific interaction matrix, \eqn{\theta_{ij}}.
 #'   Changed with \code{\link{setInteraction}}.
-#' @slot srr Function to calculate the realised (density dependent) recruitment.
-#'   Has two arguments which are rdi and species_params.
+#' @slot srr String holding the name of the function to calculate the realised
+#'   (density dependent) recruitment. The function should have two arguments
+#'   which are rdi and species_params.
 #' @slot selectivity An array (gear x species x w) that holds the selectivity of
 #'   each gear for species and size, \eqn{S_{g,i,w}}. Changed with 
 #'   \code{\link{setFishing}}.
@@ -357,7 +376,7 @@ setClass(
         initial_B = "numeric",
         species_params = "data.frame",
         interaction = "array",
-        srr  = "function",
+        srr  = "character",
         selectivity = "array",
         catchability = "array",
         n = "numeric",
@@ -670,7 +689,7 @@ emptyParams <- function(species_params,
         initial_n_pp = vec1,
         species_params = species_params,
         interaction = interaction,
-        srr = srrBevertonHolt,
+        srr = "srrBevertonHolt",
         resource_dynamics = list(),
         plankton_dynamics = plankton_semichemostat,
         resource_params = list(),
@@ -779,7 +798,7 @@ set_multispecies_model <- function(species_params,
                                    # setReproduction
                                    maturity = NULL,
                                    repro_prop = NULL,
-                                   srr = srrBevertonHolt,
+                                   srr = "srrBevertonHolt",
                                    # setPlankton
                                    r_pp = 10,
                                    w_pp_cutoff = 10,
@@ -1655,7 +1674,7 @@ setBMort <- function(params, mu_b = NULL, z0pre = 0.6, z0exp = params@n - 1) {
 #' 
 #' To calculate the density-dependent rate of larvae production, mizer puts the
 #' the density-independent rate of egg production through a "stock-recruitment"
-#' function. The result is returned by \code{\link{getRDD}}. The
+#' function. The result is returned by \code{\link{getRDD}}. The name of the
 #' stock-recruitment function is specified by the \code{srr} argument. The
 #' default is the Beverton-Holt function \code{\link{srrBevertonHolt}}, which
 #' requires an \code{R_max} column in the species_params data frame giving the
@@ -1672,7 +1691,7 @@ setBMort <- function(params, mu_b = NULL, z0pre = 0.6, z0exp = params@n - 1) {
 #'   proportion of consumed energy that a mature individual allocates to
 #'   reproduction for each species at size. If not supplied, a default is set as
 #'   described in the section "Setting reproduction".
-#' @param srr The stock recruitment function. Defaults to 
+#' @param srr The name of the stock recruitment function. Defaults to 
 #'   \code{\link{srrBevertonHolt}}.
 #' 
 #' @return The MizerParams object.
@@ -1681,7 +1700,9 @@ setBMort <- function(params, mu_b = NULL, z0pre = 0.6, z0exp = params@n - 1) {
 setReproduction <- function(params, maturity = NULL, repro_prop = NULL,
                             srr = params@srr) {
     assert_that(is(params, "MizerParams"),
-                is.function(srr))
+                is.string(srr),
+                exists(srr),
+                is.function(get(srr)))
     species_params <- params@species_params
 
     # Check maximum sizes
@@ -1791,12 +1812,13 @@ setReproduction <- function(params, maturity = NULL, repro_prop = NULL,
     params <- set_species_param_default(params, "erepro", 1)
     assert_that(all(params@species_params$erepro > 0))
 
-    # srr must have two arguments: rdi amd species_params
+    # srr function must have two arguments: rdi amd species_params
+    srr_fn <- get(srr)
     if (!isTRUE(all.equal(names(formals(srr)), c("rdi", "species_params")))) {
         stop("Arguments of srr function must be 'rdi' and 'species_params'")
     }
     params@srr <- srr
-    if (identical(params@srr, srrBevertonHolt)) {
+    if (identical(params@srr, "srrBevertonHolt")) {
 
         # for legacy reasons (R_max used to be called r_max):
         if ("r_max" %in% names(params@species_params)) {
@@ -2309,6 +2331,12 @@ updateInitial <- function(params, effort = 1) {
 #' @return The upgraded MizerParams object
 #' @export
 upgradeParams <- function(params) {
+
+    if (is.function(params@srr)) {
+        params@srr <- "srrBevertonHolt"
+        warning('The stock recruitment function has been set to "srrBevertonHolt".')
+    }
+
     if (.hasSlot(params, "metab")) {
         metab <- params@metab
     } else {
@@ -2472,6 +2500,22 @@ srrNone <- function(rdi, species_params) {
     return(rdi)
 }
 
+
+#' Set the recruitment function for constant recruitment
+#' 
+#' Simply returns the value from `species_params$constant_recruitment`
+#' 
+#' @param rdi Vector of egg production rates \eqn{R_p} for all species.
+#' @param species_params A species parameter dataframe. Must contain a column
+#'   `constant_recruitment`.
+#'   
+#' @return Vector `species_params$constant_recruitment`
+#' @export
+#' @family stock-recruitment functions
+srrConstant <- function(rdi, species_params){
+    return(species_params$constant_recruitment)
+}
+
 #' Set a species parameter to a default value
 #'
 #' If the species parameter does not yet exist in the species parameter data

R/project_methods.R

@@ -103,7 +103,8 @@ getRates <- function(params, n = params@initial_n,
     r$rdi <- getRDI(params, n = n, n_pp = n_pp, B = B, 
                     e_repro = r$e_repro, sex_ratio = sex_ratio)
     # R_i
-    r$rdd <- params@srr(rdi = r$rdi, species_params = params@species_params)
+    r$rdd <- do.call(params@srr,
+                     list(rdi = r$rdi, species_params = params@species_params))
 
     return(r)
 }
@@ -1077,8 +1078,8 @@ getRDD <- function(params, n = params@initial_n,
                    n_pp = params@initial_n_pp,
                    B = params@initial_B, sex_ratio = 0.5,
                    rdi = getRDI(params, n = n, n_pp = n_pp, B = B, sex_ratio = sex_ratio)) {
-    rdd <- params@srr(rdi = rdi, species_params = params@species_params)
-    return(rdd)
+    return(do.call(params@srr,
+                   list(rdi = rdi, species_params = params@species_params)))
 }
 
 #' Get_time_elements

R/wrapper_functions.R

@@ -152,14 +152,10 @@ set_community_model <- function(max_w = 1e6,
         constant_recruitment = recruitment * rec_mult, # to be used in the SRR
         stringsAsFactors = FALSE
     )
-    # Set the recruitment function for constant recruitment
-    constant_recruitment <- function(rdi, species_params){
-        return(species_params$constant_recruitment)
-    }
     com_params <- set_multispecies_model(com_params_df, p = p, n = n, q = q, lambda = lambda, 
                               kappa = kappa, min_w = min_w,
                               w_pp_cutoff = w_pp_cutoff, r_pp = r_pp, ...)
-    com_params@srr <- constant_recruitment
+    com_params@srr <- "srrConstant"
     com_params@psi[] <- 0 # Need to force to be 0. Can try setting w_mat but 
                           # due to slope still not 0
     # Set w_mat to NA for clarity - it is not actually being used
@@ -1377,7 +1373,7 @@ retuneReproductionEfficiency <- function(params,
         }
     }
     params@species_params$erepro <- eff
-    return(setReproduction(params, srr = srrNone))
+    return(setReproduction(params, srr = "srrNone"))
 }
 
 #' Set maximum recruitment
@@ -1397,7 +1393,7 @@ setRmax <- function(params, rfac) {
                 is.numeric(rfac),
                 length(rfac) %in% c(1, nrow(params@species_params)),
                 all(rfac > 1))
-    if (params@srr != srrNone) {
+    if (params@srr != "srrNone") {
         stop("setRmax can only be applied to params objects using the identity",
              "stock-recruitment function.")
     }
@@ -1497,8 +1493,8 @@ steady <- function(params, effort = 1, t_max = 100, t_per = 7.5, tol = 10^(-2),
     }
 
     # Force the recruitment to stay at the current level
-    rdd <- getRDD(p)
-    p@srr <- function(rdi, species_params) {rdd}
+    p@species_params$constant_recruitment <- getRDD(p)
+    p@srr <- "srrConstant"
     old_rdi <- getRDI(p)
     # Force resources to stay at current level
     old_resource_dynamics <- p@resource_dynamics

_pkgdown.yml

@@ -139,10 +139,7 @@ reference:
   - plankton_semichemostat
   - carrion_dynamics
   - detritus_dynamics
-  - srrBevertonHolt
-  - srrRicker
-  - srrSheperd
-  - srrNone
+  - starts_with("srr")
 - title: Internal helper functions
   contents:
 # The following should list all functions with @concept helper