R Under development (unstable) (2025-04-18 r88159 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2025 The R Foundation for Statistical Computing
Platform: x86_64-w64-mingw32/x64

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

> library(magrittr)
> library(unittest)
> 
> library(gadget3)
> 
> ############# Tests for parameter_template mode (old, should be removed)
> 
> actions <- list()
> area_names <- g3_areas(c("IXa"))
> 
> actions_time <- list(
+   g3a_time(
+     1979L, 2023L,
+     step_lengths = c(3L, 3L, 3L, 3L)),
+   NULL)
> actions <- c(actions, actions_time)
> 
> anch <- g3_stock("anch", seq(3L, 22L, 0.5)) |>
+   g3s_livesonareas(area_names["IXa"]) |>
+   g3s_age(0L, 3L)
> actions_anch <- list(
+   g3a_growmature(anch, g3a_grow_impl_bbinom(
+     maxlengthgroupgrowth = 38L)),
+   g3a_naturalmortality(anch),
+   g3a_initialconditions_normalparam(anch),
+   g3a_renewal_normalparam(anch,
+     run_step = NULL),
+   g3a_age(anch),
+   NULL)
> actions <- c(actions, actions_anch)
> 
> 
> model_code <- g3_to_tmb(actions)
> params.in <- attr(model_code, "parameter_template")
> 
> params.in[, 'optimise'] <- FALSE
> params.in[, 'lower'] <- NA
> params.in[, 'upper'] <- NA
> 
> ok(ut_cmp_identical(
+     g3l_bounds_penalty(params.in),
+     list()), "No penalty functions if nothing to optimise")
ok - No penalty functions if nothing to optimise
> 
> params.in[, 'optimise'] <- TRUE
> ok(ut_cmp_identical(
+     g3l_bounds_penalty(params.in),
+     list()), "No penalty functions if no lower/upper bounds")
ok - No penalty functions if no lower/upper bounds
> 
> params.in['anch.rec.1990', 'lower'] <- 4
> params.in['anch.rec.1991', 'lower'] <- 40
> ok(ut_cmp_identical(
+     g3l_bounds_penalty(params.in),
+     list()), "No penalty functions if no upper bounds")
ok - No penalty functions if no upper bounds
> 
> params.in['anch.rec.1990', 'upper'] <- 9
> params.in['anch.rec.1991', 'upper'] <- 99
> ok(ut_cmp_identical(lapply(g3l_bounds_penalty(params.in), deparse), list(
+     "010:g3l_bounds_penalty  :anch.rec.1990       " = c(
+         "~{",
+         "    debug_label(\"g3l_bounds_penalty for anch.rec.1990\")",
+         "    if (cur_time == 0) {", "        nll <- nll + 1 * ((logspace_add(1e+06 * (g3_param(\"anch.rec.1990\") - ",
+         "            9)/(9 - 4), 0) + logspace_add(1e+06 * (4 - g3_param(\"anch.rec.1990\"))/(9 - ",
+         "            4), 0))^2)",
+         "    }",
+         "}"),
+     "010:g3l_bounds_penalty  :anch.rec.1991       " = c("~{",
+         "    debug_label(\"g3l_bounds_penalty for anch.rec.1991\")",
+         "    if (cur_time == 0) {", "        nll <- nll + 1 * ((logspace_add(1e+06 * (g3_param(\"anch.rec.1991\") - ",
+         "            99)/(99 - 40), 0) + logspace_add(1e+06 * (40 - g3_param(\"anch.rec.1991\"))/(99 - ",
+         "            40), 0))^2)", 
+         "    }",
+     "}"))), "Generated code for 2 parameters")
ok - Generated code for 2 parameters
> 
> ############# Tests for actions mode
> 
> actions <- list(g3a_time(2000, 2000), list("555" = g3_formula({
+     # TMB will fail mysteriously if at least one parameter isn't optimisable
+     nll <- nll + g3_param('p0', value = 0, optimise = TRUE)
+     nll <- nll + g3_param('p.a')
+     nll <- nll + g3_param('pb')
+     nll <- nll + g3_param('pc')
+     nll <- nll + g3_param('pd', value = 0, lower = -10, upper = 10)
+ })))
> model_cpp <- g3_to_tmb(c(actions, list( g3l_bounds_penalty(actions) )))
> model_fn <- g3_to_r(c(actions, list( g3l_bounds_penalty(actions) )))
> 
> attr(model_cpp, 'parameter_template') |>
+     g3_init_val('p.a', 100.45) |>
+     g3_init_val('pb', 200) |>
+     g3_init_val('pc', 300.5342) |>
+     identity() -> params.in
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     sum(unlist(params.in$value)) ), "nll: TMB version with no bounds enabled")
ok - nll: TMB version with no bounds enabled
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> suppressWarnings(attr(model_cpp, 'parameter_template') |>
+     g3_init_val('p.a', 100, lower = 50, upper = 150) |>
+     g3_init_val('pb', 200) |>
+     g3_init_val('pc', 300) |>
+     identity() -> params.in)
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     sum(unlist(params.in$value)) ), "nll: TMB version, within bounds")
ok - nll: TMB version, within bounds
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> suppressWarnings(attr(model_cpp, 'parameter_template') |>
+     g3_init_val('p.a', 100, lower = 10, upper = 50) |>
+     g3_init_val('pb', 200) |>
+     g3_init_val('pc', 300) |>
+     identity() -> params.in)
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     1.6e12,
+     tolerance=1e1), "nll: TMB version, above bounds")
ok - nll: TMB version, above bounds
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> suppressWarnings(attr(model_cpp, 'parameter_template') |>
+     g3_init_val('p.a', 10, lower = 20, upper = 50) |>
+     g3_init_val('pb', 200) |>
+     g3_init_val('pc', 300) |>
+     identity() -> params.in)
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     1e+11,
+     tolerance=1e1), "nll: TMB version, outside bounds")
ok - nll: TMB version, outside bounds
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> suppressWarnings(attr(model_cpp, 'parameter_template') |>
+     g3_init_val('p.a', 10, lower = 20, upper = 50) |>
+     g3_init_val('pb', 90, lower = 20, upper = 50) |>
+     g3_init_val('pc', 300) |>
+     identity() -> params.in)
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     2e12,
+     tolerance=1e1), "nll: TMB version, 2 parameters outside bounds")
ok - nll: TMB version, 2 parameters outside bounds
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> suppressWarnings(attr(model_cpp, 'parameter_template') |>
+     g3_init_val('pd', 100) |>
+     identity() -> params.in)
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     2e12,
+     tolerance = 1e1 ), "nll: Outside initial bounds")
ok - nll: Outside initial bounds
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> suppressWarnings(attr(model_cpp, 'parameter_template') |>
+     g3_init_val('pd', 100, lower = NA, upper = NA) |>
+     identity() -> params.in)
> nll <- model_fn(params.in) ; r <- attributes(nll) ; nll <- as.vector(nll)
> ok(ut_cmp_equal(
+     nll,
+     sum(unlist(params.in$value)) ), "nll: Outside initial bounds, but we cleared them")
ok - nll: Outside initial bounds, but we cleared them
> gadget3:::ut_tmb_r_compare2(model_fn, model_cpp, params.in)
# skip: not running TMB tests
NULL
> 
> proc.time()
   user  system elapsed 
   2.40    0.18    2.57 
1..11
# Looks like you passed all 11 tests.