diff --git a/R/scm_support.R b/R/scm_support.R index 33001ac2..8a15a49e 100644 --- a/R/scm_support.R +++ b/R/scm_support.R @@ -89,7 +89,7 @@ scm_base_parameters <- function(type="FF16", env=environment_type(type)) { ##' issue #138) ##' @author Rich FitzJohn ##' @export -run_scm_collect <- function(p, include_competition_effect=FALSE) { +run_scm_collect <- function(p, state = NULL, include_competition_effect=FALSE) { collect_default <- function(scm) { scm$state } @@ -105,10 +105,31 @@ run_scm_collect <- function(p, include_competition_effect=FALSE) { ret$competition_effect <- competition_effect ret } + collect <- if (include_competition_effect) collect_competition_effect else collect_default + types <- extract_RcppR6_template_types(p, "Parameters") - scm <- do.call('SCM', types)(p) + + if(!is.null(state)) { + i = ncol(x$species[[1]]) + + if(state$time != 0) + message("Solver must start from 0, resetting initial state time") + + # append zeros to introduction schedule and initialise using defaults + times <- scm$cohort_schedule$all_times[1] + times[[1]] <- c(rep(0, i), times[[1]][-1]) + scm$set_cohort_schedule_times(times) + + # this initialises the right number of cohorts but has the + # unintended effect of setting `next_event` to start at t1 + scm$run_next() + + # now set state and set start time to t1 + scm$set_state(times[[1]][i+1], state$species[[1]], n = i, env = state$env) + } + res <- list(collect(scm)) while (!scm$complete) { diff --git a/tests/testthat/test-initial-size-distribution.R b/tests/testthat/test-initial-size-distribution.R new file mode 100644 index 00000000..10adb6ad --- /dev/null +++ b/tests/testthat/test-initial-size-distribution.R @@ -0,0 +1,60 @@ +context("Initial size distribution") + +# using SCM collect to generate starting conditions +p0 <- scm_base_parameters("FF16") +p0$patch_type = 'fixed' + +p1 <- expand_parameters(trait_matrix(0.0825, "lma"), p0, FF16_hyperpar,FALSE) +p1$birth_rate <- 20 + +out <- run_scm_collect(p1) + +# select a time slice +i = 120 +x <- scm_state(i, out) + +test_that("Set patch state", { + # editable patch object + types <- extract_RcppR6_template_types(p1, "Parameters") + patch <- do.call('Patch', types)(p1) + + expect_equal(patch$size, 1) # species + expect_equal(patch$species[[1]]$size, 0) # cohorts + + patch$introduce_new_cohort(species_index = 1) + expect_equal(patch$species[[1]]$size, 1) # cohorts + + patch$set_state(x$time, x$species[[1]], n = i, x$env) + expect_equal(patch$species[[1]]$size, 120) +}) + +test_that("Set SCM state", { + types <- extract_RcppR6_template_types(p1, "Parameters") + scm <- do.call('SCM', types)(p1) + + # update introduction schedule + times <- scm$cohort_schedule$all_times[1] + expect_equal(length(times[[1]]), 141) + + times[[1]] <- c(rep(0, i), times[[1]][-1]) + + scm$set_cohort_schedule_times(times) + expect_equal(length(scm$cohort_schedule$all_times[1][[1]]), i + 141 - 1) + + # update patch state + expect_equal(scm$patch$species[[1]]$size, 0) + + scm$set_state(0, x$species[[1]], n = 120, x$env) + expect_equal(scm$patch$species[[1]]$size, 120) +}) + + +test_that("Set SCM state and collect", { + y <- run_scm_collect(p1, x) + + # check fitness + expect_equal(y$net_reproduction_ratios, 143.7165, tolerance = 0.0001) + + # check # states, time steps, cohorts + expect_equal(dim(y$species[[1]]), c(7, 141, 260)) +}) \ No newline at end of file