get hyperpar from params

.gitignore

@@ -5,6 +5,8 @@ inst/website
 ^plant.Rcheck$
 .Rproj.user
 src/*.o.tmp
+src/*.o
+src/*.so
 tmp*
 .vscode
 scrap.R

NAMESPACE

@@ -89,6 +89,8 @@ export(splinefun_loglog)
 export(strategy)
 export(strategy_default)
 export(strategy_list)
+export(hyperpar)
+export(param_hyperpar)
 export(trait_matrix)
 export(validate)
 export(viable_fitness)

R/fitness.R

@@ -13,7 +13,7 @@
 ##' production per capita.
 ##' @author Rich FitzJohn
 ##' @export
-fitness_landscape <- function(trait_matrix, p, hyperpar, raw_seed_rain=FALSE) {
+fitness_landscape <- function(trait_matrix, p, hyperpar=param_hyperpar(p), raw_seed_rain=FALSE) {
   n_residents <- length(p$strategies)
   p_with_mutants <- expand_parameters(trait_matrix, p, hyperpar)
   scm <- run_scm(p_with_mutants,
@@ -64,7 +64,6 @@ carrying_capacity <- function(trait_matrix, p, seed_rain=1,
     ## names.
     p <- expand_parameters(trait_matrix(x, traits),
                            remove_residents(p),
-                           hyperpar,
                            mutant=FALSE)
     p$seed_rain <- seed_rain
     equilibrium_seed_rain(p)$seed_rain

R/strategy_support.R

@@ -12,6 +12,14 @@ make_hyperpar <- function(type) {
          stop("Unknown type ", type))
 }
 
+param_hyperpar <- function(parameters) {
+  type <- attr(parameters$strategy_default, "class")
+  switch(type,
+         FF16_Strategy=FF16_hyperpar,
+         FF16r_Strategy=FF16r_hyperpar,
+         stop("Unknown type ", type))
+}
+
 ##' @rdname Hyperparameter_functions
 ##' @export
 # if you update this function (even syntactic changes) update the function update_smc_support in the scaffolder

R/util_model.R

@@ -9,7 +9,7 @@
 ##'   will be applied.
 ##'
 ##' @export
-strategy_list <- function(x, parameters, hyperpar) {
+strategy_list <- function(x, parameters, hyperpar=param_hyperpar(parameters)) {
   if (!is.matrix(x)) {
     stop("Invalid type x -- expected a matrix")
   }
@@ -27,13 +27,13 @@ strategy_list <- function(x, parameters, hyperpar) {
 
 ##' @export
 ##' @rdname strategy_list
-strategy_default <- function(parameters, hyperpar) {
-  strategy(trait_matrix(1, "a")[, -1, drop=FALSE], parameters)
+strategy_default <- function(parameters, hyperpar=param_hyperpar(parameters)) {
+  strategy(trait_matrix(1, "a")[, -1, drop=FALSE], parameters, hyperpar)
 }
 
 ##' @export
 ##' @rdname strategy_list
-strategy <- function(x, parameters, hyperpar) {
+strategy <- function(x, parameters, hyperpar=param_hyperpar(parameters)) {
   if (nrow(x) != 1L) {
     stop("Expected a single type")
   }
@@ -42,7 +42,7 @@ strategy <- function(x, parameters, hyperpar) {
 
 ##' @rdname strategy_list
 ##' @export
-plant_list <- function(x, parameters, hyperpar) {
+plant_list <- function(x, parameters, hyperpar=parram_hyperpar(parameters)) {
   if (!inherits(parameters, "Parameters")) {
     stop("parameters must be a 'Parameters' object")
   }
@@ -79,7 +79,7 @@ trait_matrix <- function(x, trait_name) {
 ##' density).
 ##' @author Rich FitzJohn
 ##' @export
-expand_parameters <- function(trait_matrix, p, hyperpar, mutant=TRUE) {
+expand_parameters <- function(trait_matrix, p, hyperpar=param_hyperpar(p), mutant=TRUE) {
   if (length(mutant) != 1L) {
     stop("mutant must be scalar")
   }

tests/testthat/test-build-schedule.R

@@ -1,15 +1,12 @@
 context("Build_schedule")
 
 strategy_types <- get_list_of_strategy_types()
-hyperpar_functions <- get_list_of_hyperpar_functions()
 
 test_that("Corner case", {
-  for (i in 1:length(strategy_types)) {
-    st <- names(strategy_types)[[i]]
-    hyperpar <- hyperpar_functions[[i]]
-    p <- scm_base_parameters(st)
+  for (x in names(strategy_types)) {
+    p <- scm_base_parameters(x)
     expect_error(build_schedule(p), "no residents")
-    p <- expand_parameters(trait_matrix(0.1, "lma"), p, hyperpar)
+    p <- expand_parameters(trait_matrix(0.1, "lma"), p)
     expect_error(build_schedule(p), "no residents")
   }
 })

tests/testthat/test-plant-runner.R

@@ -1,7 +1,6 @@
 context("PlantRunner")
 
 strategy_types <- get_list_of_strategy_types()
-hyperpar_functions <- get_list_of_hyperpar_functions()
 
 test_that("PlantRunner", {
   for (x in names(strategy_types)) {
@@ -204,7 +203,7 @@ test_that("grow_plant_to_time", {
 
 test_that("Sensible behaviour on integration failure", {
   pl <- FF16_Plant()
-  hyperpar <- make_FF16_hyperpar()
+  hyperpar <- FF16_hyperpar
 
   env <- fixed_environment("FF16", 1)
   sizes <- seq_range(c(pl$state("height"), 50), 50)

tests/testthat/test-scm-support.R

@@ -55,8 +55,8 @@ test_that("collect / make_patch", {
 test_that("expand_parameters", {
   hyperpar <- make_FF16_hyperpar()
   p0 <- scm_base_parameters()
-  p1 <- expand_parameters(trait_matrix(0.1, "lma"), p0, hyperpar, FALSE)
+  p1 <- expand_parameters(trait_matrix(0.1, "lma"), p0, mutant=FALSE)
   ## This will trigger rebuilding the times:
   p1$cohort_schedule_max_time <- 100
-  expect_silent(p2 <- expand_parameters(trait_matrix(0.2, "lma"), p1, hyperpar, FALSE))
+  expect_silent(p2 <- expand_parameters(trait_matrix(0.2, "lma"), p1, mutant=FALSE))
 })

tests/testthat/test-scm.R

@@ -1,7 +1,6 @@
 context("SCM")
 
 strategy_types <- get_list_of_strategy_types()
-hyperpar_functions <- get_list_of_hyperpar_functions()
 
 test_that("Ported from tree1", {
   for (x in names(strategy_types)) {
@@ -231,11 +230,9 @@ test_that("schedule setting", {
   ## })
 
 test_that("Seed rain & error calculations correct", {
-  for (i in 1:length(strategy_types)) {
-    x = names(strategy_types)[[i]]
-    hyperpar = hyperpar_functions[[i]]
+  for (x in names(strategy_types)) {
     p0 <- scm_base_parameters(x)
-    p1 <- expand_parameters(trait_matrix(0.08, "lma"), p0, hyperpar, FALSE)
+    p1 <- expand_parameters(trait_matrix(0.08, "lma"), p0, mutant=FALSE)
 
     scm <- run_scm(p1)
     expect_is(scm, sprintf("SCM<%s,%s_Env>", x, x))