More work on and testing off extension mechanism. Updated docs.

Author: gustavdelius

DESCRIPTION

@@ -40,7 +40,7 @@ LinkingTo: Rcpp
 Depends:
     R (>= 3.1)
 Suggests:
-    testthat,
+    testthat (>= 2.1.0),
     vdiffr,
     roxygen2,
     knitr,

NAMESPACE

@@ -130,6 +130,7 @@ export(plotlyYield)
 export(plotlyYieldGear)
 export(power_law_pred_kernel)
 export(project)
+export(removeComponent)
 export(retune_erepro)
 export(setColours)
 export(setComponent)

R/extension.R

@@ -1,5 +1,10 @@
 #' Set own rate function to replace mizer rate function
 #' 
+#' If the way mizer calculates a fundamental rate entering the model is
+#' not flexible enough for you (for example if you need to introduce time
+#' dependence) then you can write your own functions for calculating that
+#' rate and use `setRateFunction()` to register it with mizer.
+#' 
 #' At each time step during a simulation with the [project()] function, mizer
 #' needs to calculate the instantaneous values of the various rates. By
 #' default it calls the [mizerRates()] function which creates a list with the
@@ -17,24 +22,36 @@
 #' * `rdi` from [mizerRDI()]
 #' * `rdd` from [BevertonHoltRDD()]
 #' 
-#' You can modify these in two ways.
+#' For each of these you can substitute your own function. So for example if
+#' you have written your own function for calculating the total mortality
+#' rate and have called it `myMort` and have a mizer model stored in a
+#' MizerParams object called `params` that you want to run with your new
+#' mortality rate, then you would call
+#' ```
+#' params <- setRateFunction(params, "Mort", "myMort")
+#' ```
+#' In some extreme cases you may need to swap out the entire `mizerRates()`
+#' function for your own function called `myRates()`. That you can do with
+#' ```
+#' params <- setRateFunction(params, "Rates", "myRates")
+#' ```
 #' 
-#' @param params A `MizerParams` object
+#' @param params A MizerParams object
 #' @param rate Name of the rate for which a new function is to be set.
 #' @param fun Name of the function to use to calculate the rate.
+#' @return For `setRateFunction()`: An updated MizerParams object
 #' @export
-setRateFunction <- function(params, rate = "Rates", fun) {
+setRateFunction <- function(params, rate, fun) {
     assert_that(is(params, "MizerParams"),
                 is.string(rate),
-                is.string(fun),
-                is.function(get(fun)))
+                is.string(fun))
     if (!(rate %in% names(params@rates_funcs))) {
         stop("The `rate` argument must be one of ", 
              toString(names(params@rates_funcs)), ".")
     }
-    f <- get0(fun, mode = "function")
-    if (is.null(f)) {
-        stop(fun, " should be a function")
+    if (!exists(fun, mode = "function")) {
+        stop("`fun` should be a function, ", 
+             fun, " is of class ", class(fun), ".")
     }
     # TODO: put some code to test that the function has the right kind of
     # arguments
@@ -45,12 +62,15 @@ setRateFunction <- function(params, rate = "Rates", fun) {
 }
 
 #' @rdname setRateFunction
+#' @return For `getRateFunction()`: The name of the registered rate function for
+#'   the requested `rate`, or the list of all rate functions if called without
+#'   `rate` argument.
 #' @export
-getRateFunction <- function(params, rate = "Rates") {
+getRateFunction <- function(params, rate) {
     assert_that(is(params, "MizerParams"),
                 is.string(rate))
     validObject(params)
-    if (rate == "All") {
+    if (missing(rate)) {
         return(params@rates_funcs)
     }
     if (!(rate %in% names(params@rates_funcs))) {
@@ -62,58 +82,101 @@ getRateFunction <- function(params, rate = "Rates") {
 
 #' Add a dynamical ecosystem component
 #' 
+#' By default, mizer models any number of size-resolved consumer species
+#' and a single size-resolved plankton spectrum. Your model may require
+#' additional components, like for example detritus or carrion or multiple
+#' resources or .... This function allows you to set up such components.
+#' 
+#' If you set a component with a new name, the new component will be added
+#' to the existing components. If you set a component with an existing name,
+#' that component will be overwritten. You can remove a component with
+#' `removeComponent()`.
+#' 
 #' @param params A MizerParams object
 #' @param component Name of the component
 #' @param initial_value Initial value of the component
 #' @param dynamics_fun Name of function to calculate value at the next time step
 #' @param encounter_fun Name of function to calculate contribution to encounter
-#'   rate
-#' @param pred_mort_fun Name of function to calculate contribution to the
-#'   predation mortality rate.
+#'   rate. Optional.
+#' @param mort_fun Name of function to calculate contribution to the
+#'   mortality rate. Optional.
 #' @param component_params Named list of parameters needed by the component
-#'   functions.
-#' @return For `setComponent`: The updated MizerParams object
+#'   functions. Optional.
+#' @return The updated MizerParams object
 #' @export
 setComponent <- function(params, component, initial_value,
-                         encounter_fun, pred_mort_fun,  
-                         dynamics_fun, component_params) {
+                         dynamics_fun, 
+                         encounter_fun, mort_fun,  
+                         component_params) {
     assert_that(is(params, "MizerParams"),
                 is.string(component),
                 is.string(dynamics_fun),
-                is.string(encounter_fun),
-                is.string(mortality_fun),
-                is.function(get0(dynamics_fun)),
-                is.function(get0(encounter_fun)),
-                is.function(get0(mortality_fun)),
-                is.list(component_params))
+                is.function(get0(dynamics_fun)))
     params@other_dynamics[[component]] <- dynamics_fun
-    params@other_pred_mort[[component]] <- pred_mort_fun
-    params@other_encounter[[component]] <- encounter_fun
-    params@other_params[[component]] <- component_params
-    initialNOther(params)[[component]] <- initial_value
+    params@initial_n_other[[component]] <- initial_value
+    # TODO: Add checks that the functions have the right arguments and
+    # return values
+    if (!missing(mort_fun)) {
+        if (!is.null(mort_fun) && !is.function(get0(mort_fun))) {
+            stop("`mort_fun` needs to be NULL or a function.")
+        }
+        params@other_mort[[component]] <- mort_fun
+    }
+    if (!missing(encounter_fun)) {
+        if (!is.null(encounter_fun) && !is.function(get0(encounter_fun))) {
+            stop("`encounter_fun` needs to be NULL or a function.")
+        }
+        params@other_encounter[[component]] <- encounter_fun
+    }
+    if (!missing(component_params)) {
+        if (!is.null(component_params) && 
+            (!is.list(component_params) || is.null(names(component_params)))) {
+            stop("`component_params` needs to be NULL or a named list.")
+        }
+        params@other_params[[component]] <- component_params
+    }
+    params
 }
 
+#' @rdname setComponent
+#' @export
+removeComponent <- function(params, component) {
+    if (!component %in% names(params@other_dynamics)) {
+        stop("There is no component named ", component)
+    }
+    params@other_dynamics[[component]] <- NULL
+    params@other_encounter[[component]] <- NULL
+    params@other_mort[[component]] <- NULL
+    params@other_params[[component]] <- NULL
+    params@initial_n_other[[component]] <- NULL
+    params
+}
+
+
 #' Get information about other ecosystem components
 #' 
 #' @param params A MizerParams object
 #' @param component Name of the component of interest. If missing, a list of
 #'   all components will be returned.
-#' @return For `getComponent`: A list with the entries `initial_value`, `dynamics_fun`,
-#'   `encounter_fun`, `morality_fun`, `component_params`. If `component` is
+#' @return A list with the entries `initial_value`, `dynamics_fun`,
+#'   `encounter_fun`, `mort_fun`, `component_params`. If `component` is
 #'   missing, then a list of lists for all components is returned.
-#' @rdname setComponent
 #' @export
 getComponent <- function(params, component) {
     if (missing(component)) {
-        lapply(names(params@other_dynamics),
-               function(x) getComponent(params, x))
+        l <- lapply(names(params@other_dynamics),
+                    function(x) getComponent(params, x))
+        names(l) <- names(params@other_dynamics)
+        return(l)
+    }
+    if (!component %in% names(params@other_dynamics)) {
+        stop("There is no component named ", component)
     }
-    comp_list <- list(
-        initial_value = initialNOther(params)[[component]],
-        component_params = params@other_params[[component]],
-        dynamics_fun = params@other_dynamics[[component]],
-        mortality_fun = params@other_mort[[component]],
-        encounter_fun = params@other_encounter[[component]]
+    list(initial_value = initialNOther(params)[[component]],
+         dynamics_fun = params@other_dynamics[[component]],
+         mort_fun = params@other_mort[[component]],
+         encounter_fun = params@other_encounter[[component]],
+         component_params = params@other_params[[component]]
     )
 }
 
@@ -128,6 +191,15 @@ getComponent <- function(params, component) {
 `initialNOther<-` <- function(params, value) {
     assert_that(is(params, "MizerParams"),
                 is.list(value))
+    components <- names(params@other_dynamics)
+    missing <- !(names(value) %in% components)
+    if (any(missing)) {
+        stop("The following components do not exist: ", names(value)[missing])
+    }
+    extra <- !(components %in% names(value))
+    if (any(extra)) {
+        stop("Missing values for components ", components[extra])
+    }
     params@initial_n_other <- value
     params
 }

R/project_methods.R

@@ -236,7 +236,7 @@ mizerEncounter <- function(params, n, n_pp, n_other, ...) {
         encounter <- encounter + 
             do.call(fun_name, 
                     list(params = params,
-                         n = n, n_pp = n_pp, n_other = n_other))
+                         n = n, n_pp = n_pp, n_other = n_other, ...))
     }
 
     return(encounter)
@@ -444,15 +444,15 @@ mizerFMort <- function(params, effort, ...) {
 #' @export
 #' @family mizer rate functions
 mizerMort <- function(params, n, n_pp, n_other, f_mort, pred_mort, ...){
-    pred_mort <- pred_mort + params@mu_b + f_mort
+    mort <- pred_mort + params@mu_b + f_mort
     # Add contributions from other components
     for (fun_name in params@other_mort) {
-        pred_mort <- pred_mort + 
+        mort <- mort + 
             do.call(fun_name, 
                     list(params = params,
-                         n = n, n_pp = n_pp, n_other = n_other))
+                         n = n, n_pp = n_pp, n_other = n_other, ...))
     }
-    return(pred_mort)
+    return(mort)
 }
 
 

R/rate_functions.R

@@ -567,15 +567,10 @@ getMort <- function(params,
              nrow(params@species_params), ") x no. size bins (",
              length(params@w), ")")
     }
-    
-    z <- pred_mort + params@mu_b + f_mort
-    # Add contributions from other components
-    for (fun_name in params@other_mort) {
-        z <- z + 
-            do.call(fun_name, 
-                    list(params = params,
-                         n = n, n_pp = n_pp, n_other = n_other))
-    }
+  
+    f <- get(params@rates_funcs$Mort)
+    z <- f(params, n = n, n_pp = n_pp, n_other = n_other, 
+           f_mort = f_mort, pred_mort = pred_mort)
     dimnames(z) <- list(prey = dimnames(params@initial_n)$sp,
                         w_prey = dimnames(params@initial_n)$w)
     return(z)

R/setFishing.R

@@ -237,6 +237,7 @@ getInitialEffort <- function(params) {
 #' @param gear_params Gear parameter data frame
 #' @param species_params Species parameter data frame
 #' @return A valid gear parameter data frame
+#' @concept helper
 validGearParams <- function(gear_params, species_params) {
     assert_that(is.data.frame(gear_params),
                 is.data.frame(species_params))

R/species_params.R

@@ -223,6 +223,7 @@ get_ks_default <- function(params) {
 #' 
 #' @param species_params The user-supplied species parameter data frame
 #' @return A valid species parameter data frame
+#' @concept("helper")
 validSpeciesParams <- function(species_params) {
     assert_that(is.data.frame(species_params))