From f4f412980b0936d1ede1a01656f39dfd54accf6e Mon Sep 17 00:00:00 2001 From: Rafael Schouten Date: Wed, 12 Aug 2020 23:08:16 +1000 Subject: [PATCH] get hyperpar from params --- .gitignore | 2 ++ NAMESPACE | 2 ++ R/fitness.R | 3 +-- R/strategy_support.R | 8 ++++++++ R/util_model.R | 12 ++++++------ tests/testthat/test-build-schedule.R | 9 +++------ tests/testthat/test-plant-runner.R | 3 +-- tests/testthat/test-scm-support.R | 4 ++-- tests/testthat/test-scm.R | 7 ++----- 9 files changed, 27 insertions(+), 23 deletions(-) diff --git a/.gitignore b/.gitignore index e8c08df2..e20dfc7d 100644 --- a/.gitignore +++ b/.gitignore @@ -5,6 +5,8 @@ inst/website ^plant.Rcheck$ .Rproj.user src/*.o.tmp +src/*.o +src/*.so tmp* .vscode scrap.R diff --git a/NAMESPACE b/NAMESPACE index f34b58de..d503e4fb 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/fitness.R b/R/fitness.R index 60b980bf..69d8dd39 100644 --- a/R/fitness.R +++ b/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 diff --git a/R/strategy_support.R b/R/strategy_support.R index 6ffe8c80..21361f07 100644 --- a/R/strategy_support.R +++ b/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 diff --git a/R/util_model.R b/R/util_model.R index 51abf2e5..5089bd24 100644 --- a/R/util_model.R +++ b/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") } diff --git a/tests/testthat/test-build-schedule.R b/tests/testthat/test-build-schedule.R index e1c2e57c..3296afb2 100644 --- a/tests/testthat/test-build-schedule.R +++ b/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") } }) diff --git a/tests/testthat/test-plant-runner.R b/tests/testthat/test-plant-runner.R index ae4356d6..5256fb55 100644 --- a/tests/testthat/test-plant-runner.R +++ b/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) diff --git a/tests/testthat/test-scm-support.R b/tests/testthat/test-scm-support.R index 5cbb9bf5..b5751b8b 100644 --- a/tests/testthat/test-scm-support.R +++ b/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)) }) diff --git a/tests/testthat/test-scm.R b/tests/testthat/test-scm.R index 206e64ef..5d778990 100644 --- a/tests/testthat/test-scm.R +++ b/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))