tests/test-action_spawn-multipleoutputs.R

In lentinj/gadget3: Globally-Applicable Area Disaggregated General Ecosystem Toolbox V3

library(unittest)
if (!interactive()) options(warn=2, error = function() { sink(stderr()) ; traceback(3) ; q(status = 1) })

library(gadget3)

actions <- list()
area_names <- g3_areas(c('AA', 'BB', 'CC'))

st_imm_f <- g3_stock(c(species = "fish", maturity = 'imm', sex = 'f'), seq(5L, 25L, 5)) |>
  g3s_livesonareas(area_names["AA"]) |>
  g3s_age(1L, 5L)
st_imm_m <- g3_stock(c(species = "fish", maturity = 'imm', sex = 'm'), seq(5L, 25L, 5)) |>
  g3s_livesonareas(area_names["AA"]) |>
  g3s_age(1L, 5L)
st_mat <- g3_stock(c(species = "fish", maturity = 'mat'), seq(5L, 25L, 5)) |>
  g3s_livesonareas(area_names["AA"]) |>
  g3s_age(3L, 10L)

actions <- list(
  g3a_time(
    1980, 1995,
    step_lengths = c(6L, 6L)),
  g3a_initialconditions(st_imm_f, quote( 0 * stock__midlen ), quote( 0 * stock__midlen )),
  g3a_initialconditions(st_imm_m, quote( 0 * stock__midlen ), quote( 0 * stock__midlen )),
  g3a_initialconditions_normalcv(st_mat),
  g3a_spawn(
    st_mat,
    recruitment_f = g3a_spawn_recruitment_bevertonholt(
      mu = g3_parameterized('spawn_mu', value = 5, by_year = TRUE),
      lambda = g3_parameterized("spawn_lambda", value = 1, by_stock = TRUE) ),
    proportion_f = g3_suitability_exponentiall50(),
    weightloss_args = list(
        abs_loss = g3_parameterized("spawn.weightabsloss", value = 0),
        rel_loss = g3_parameterized("spawn.weightrelloss", value = 0) ),
    output_stocks = list(st_imm_f, st_imm_m),
    output_ratios = list(
      st_imm_f = quote( g3_param('spawn_ratio', value = 0.5) ),
      st_imm_m = quote( 1 - g3_param('spawn_ratio', value = 0.5) )),
    run_f = quote( cur_step == 1 ) ),
  g3a_age(st_imm_f),
  g3a_age(st_imm_m),
  g3a_age(st_mat) )

# Compile model
model_fn <- g3_to_r(c(actions, list(
  g3a_report_history(actions, c(
      '__offspringnum$',
      '__num$',
      '__wgt$' )))))
model_cpp <- g3_to_tmb(c(actions, list(
  g3a_report_history(actions, c(
      '__offspringnum$',
      '__num$',
      '__wgt$' )))))
  # model_cpp <- edit(model_cpp)

estimate_l50 <- g3_stock_def(st_mat, "midlen")[[length(g3_stock_def(st_mat, "midlen")) / 2]]

for (spawn_ratio in runif(5)) ok_group(paste0("spawn_ratio: ", spawn_ratio), {
  attr(model_fn, 'parameter_template') |>
    g3_init_val("fish_imm_m.Linf", g3_stock_def(st_mat, "midlen")[[1]]) |>
    g3_init_val("fish_imm_f.Linf", g3_stock_def(st_mat, "midlen")[[3]]) |>
    g3_init_val("fish_mat.Linf", g3_stock_def(st_mat, "midlen")[[5]]) |>
    g3_init_val("*.walpha", 0.01, optimise = FALSE) |>
    g3_init_val("*.wbeta", 3, optimise = FALSE) |>

    g3_init_val("*.*.l50", estimate_l50, spread = 0.25) |>
    g3_init_val("spawn_ratio", spawn_ratio) |>

    identity() -> params

  r <- attributes(model_fn(params))
  num_spawn <- colSums(r$hist_fish_mat__offspringnum, dims = 3)
  num_m <- colSums(r$hist_fish_imm_m__num, dims = 3)
  num_f <- colSums(r$hist_fish_imm_f__num, dims = 3)

  # Make sure lengthgroup structure varies between m & f (i.e. used appropriate Linfs)
  for (t in dimnames(r$hist_fish_imm_m__num)$time) {
    ok(ut_cmp_identical(
        names(which.max(r$hist_fish_imm_m__num[,1,1,time = t])),
        "5:10"), paste0("r$hist_fish_imm_m__num[,1,1,time = ", t, "]: Shortest lengthgroup most populated"))
    ok(ut_cmp_identical(
        names(which.max(r$hist_fish_imm_f__num[,1,1,time = t])),
        "10:15"), paste0("r$hist_fish_imm_f__num[,1,1,time = ", t, "]: Second lengthgroup most populated"))
  }

  ok(ut_cmp_equal(
    cumsum(num_spawn * (1 - spawn_ratio)),
    num_m,
    tolerance = 1e-8), "hist_fish_imm_m__num: Cumulative proportion of __offspringnum")
  ok(ut_cmp_equal(
    cumsum(num_spawn * spawn_ratio),
    num_f,
    tolerance = 1e-8), "hist_fish_imm_f__num: Cumulatve proportion of __offspringnum")

    gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params)
})

ok_group("weightloss") ################
attr(model_fn, 'parameter_template') |>
  g3_init_val("fish_imm_m.Linf", g3_stock_def(st_mat, "midlen")[[1]]) |>
  g3_init_val("fish_imm_f.Linf", g3_stock_def(st_mat, "midlen")[[3]]) |>
  g3_init_val("fish_mat.Linf", g3_stock_def(st_mat, "midlen")[[5]]) |>
  g3_init_val("*.walpha", 1, optimise = FALSE) |>
  g3_init_val("*.wbeta", 1, optimise = FALSE) |>

  g3_init_val("*.*.l50", estimate_l50, spread = 0.25) |>
  g3_init_val("spawn_ratio", spawn_ratio) |>
  g3_init_val('spawn.weightabsloss', 0.2) |>

  identity() -> params
r <- sapply(attributes(model_fn(params)), drop)

# NB: We can't check spawn.weightabsloss = 0, since inaccuracy in ratio_log_vec() makes a mess

ok(ut_cmp_equal(round(diff(colSums(r$hist_fish_mat__wgt[,8,])), 1)[seq(1, 31, by = 2)], c(
    "1980-02" = 0,
    "1981-02" = 0,
    "1982-02" = 0,
    "1983-02" = 0,
    "1984-02" = 0,
    "1985-02" = 0,
    "1986-02" = 0,
    "1987-02" = 0,
    "1988-02" = 0,
    "1989-02" = 0,
    "1990-02" = 0,
    "1991-02" = 0,
    "1992-02" = 0,
    "1993-02" = 0,
    "1994-02" = 0,
    "1995-02" = 0 )), "r$hist_fish_mat__wgt[,8,]: No weightloss outside spawning steps")
ok(ut_cmp_equal(round(diff(colSums(r$hist_fish_mat__wgt[,8,])), 1)[seq(2, 30, by = 2)], c(
    "1981-01" = -0.4,
    "1982-01" = -0.5,
    "1983-01" = -0.5,
    "1984-01" = -0.5,
    "1985-01" = -0.4,
    "1986-01" = -0.3,
    "1987-01" = -0.2,
    "1988-01" = -0.4,
    "1989-01" = -0.4,
    "1990-01" = -0.4,
    "1991-01" = -0.4,
    "1992-01" = -0.4,
    "1993-01" = -0.4,
    "1994-01" = -0.4,
    "1995-01" = -0.4 )), "r$hist_fish_mat__wgt[,8,]: Total weight loss roughly 0.4 (first lengthgroup not spawning, half of remaining 4 spawning)")

gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params)