Pass state to SCM collect

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) {

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))
+})