R Under development (unstable) (2024-03-18 r86148 ucrt) -- "Unsuffered Consequences"
Copyright (C) 2024 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)
> 
> actions <- list()
> expecteds <- new.env(parent = emptyenv())
> 
> # Do some tests directly first
> do_lookup <- function(df, cur_vals) {
+     # Add a derived total_weight field, with values pasted together
+     df$total_weight <- do.call(paste, df)
+     lookup_f <- g3_timeareadata('l', df)
+     # Bodge g3_global first
+     environment(lookup_f)$l__lookup <- g3_eval(attr(environment(lookup_f)$l__lookup, 'g3_global_init_val'))
+     g3_eval(lookup_f, cur_vals)
+ }
> 
> ok(ut_cmp_identical(
+     do_lookup(expand.grid(age=1:3, area=4), list(age=3, area=3)),
+     0), "age/area: Outside area, no match")
ok - age/area: Outside area, no match
> ok(ut_cmp_identical(
+     do_lookup(expand.grid(age=1:3, area=4), list(age=3, area=4)),
+     "3 4"), "age/area: Inside area")
ok - age/area: Inside area
> ok(ut_cmp_identical(
+     do_lookup(expand.grid(age=1:3, year=2000:2004, step=1:2), list(age=3, cur_year=2000, cur_step=2)),
+     "3 2000 2"), "age/year/step matches")
ok - age/year/step matches
> 
> ###############################################################################
> 
> area <- 1L
> cur_step <- 1L
> cur_year <- 1980L
> 
> tad_lookup <- g3_timeareadata('tad', read.table(header = TRUE, text = "
+ year	step	area	total_weight
+ 1983	1	1	198311
+ 1983	2	1	198321
+ 1984	1	1	198411
+ 1984	2	1	198421
+ 1983	1	2	198312
+ 1983	2	2	198322
+ 1984	1	2	198412
+ 1984	2	2	198422
+ "))
> 
> tad_lookup_1 <- 0
> tad_lookup_2 <- 0
> tad_lookup_3 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('tad_lookup')
+     cur_year <- 1983 ; cur_step <- 1 ; area <- 1
+     tad_lookup_1 <- lookup_f
+     REPORT(tad_lookup_1)
+ 
+     cur_year <- 1984 ; cur_step <- 2 ; area <- 1
+     tad_lookup_2 <- lookup_f
+     REPORT(tad_lookup_2)
+ 
+     # NB: 2008 not in table
+     cur_year <- 2008 ; cur_step <- 2 ; area <- 1
+     tad_lookup_3 <- lookup_f
+     REPORT(tad_lookup_3)
+ 
+ }, list(lookup_f = tad_lookup)))
> expecteds$tad_lookup_1 <- 198311
> expecteds$tad_lookup_2 <- 198421
> expecteds$tad_lookup_3 <- 0
> 
> # Check a lookup with a single value in it still works
> single_lookup <- gadget3:::g3_intlookup('single_lookup', c(1), c(100))
> single_lookup_rv_1 <- 0
> single_lookup_rv_2 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('single_lookup')
+     single_lookup_rv_1 <- lookup_rv_1_f
+     single_lookup_rv_2 <- lookup_rv_2_f
+     REPORT(single_lookup_rv_1)
+     REPORT(single_lookup_rv_2)
+ }, list(
+     lookup_rv_1_f = single_lookup('getdefault', ~1, 99),
+     lookup_rv_2_f = single_lookup('getdefault', ~2, 99))))
> expecteds$single_lookup_rv_1 <- 100
> expecteds$single_lookup_rv_2 <- 99
> 
> # Single-area form works as expected
> single_area_lookup <- g3_timeareadata('single_area_lookup', read.table(header = TRUE, text = "
+ year	step	area	total_weight
+ 1983	1	1	198311
+ 1983	2	1	198321
+ 1984	1	1	198411
+ "))
> 
> single_area_1 <- 0
> single_area_2 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('single_area_lookup')
+     cur_year <- 1983 ; cur_step <- 1 ; area <- 1
+     single_area_1 <- lookup_f
+     REPORT(single_area_1)
+     cur_year <- 1983 ; cur_step <- 1 ; area <- 2
+     single_area_2 <- lookup_f
+     REPORT(single_area_2)
+ }, list(lookup_f = single_area_lookup)))
> expecteds$single_area_1 <- 198311
> expecteds$single_area_2 <- 0
> 
> # Single-area lookup form works as expected
> single_named_area_lookup <- g3_timeareadata('single_named_area_lookup', read.table(header = TRUE, text = "
+ year	step	area	total_weight
+ 1983	1	b	198311
+ 1983	2	b	198321
+ 1984	1	b	198411
+ "), areas = c(a=1,b=2,c=3))
> 
> single_named_area_1 <- 0
> single_named_area_2 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('single_named_area_lookup')
+     cur_year <- 1983 ; cur_step <- 1 ; area <- 1
+     single_named_area_1 <- lookup_f
+     REPORT(single_named_area_1)
+     cur_year <- 1983 ; cur_step <- 2 ; area <- 2
+     single_named_area_2 <- lookup_f
+     REPORT(single_named_area_2)
+ }, list(lookup_f = single_named_area_lookup)))
> expecteds$single_named_area_1 <- 0
> expecteds$single_named_area_2 <- 198321
> 
> # no-area form works as expected
> no_area_lookup <- g3_timeareadata('no_area_lookup', read.table(header = TRUE, text = "
+ year	step	total_weight
+ 1983	1	198311
+ 1983	2	198321
+ 1984	1	198411
+ "))
> 
> no_area_1 <- 0
> no_area_2 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('no_area_lookup')
+     cur_year <- 1983 ; cur_step <- 1 ; area <- 1
+     no_area_1 <- lookup_f
+     REPORT(no_area_1)
+     cur_year <- 1983 ; cur_step <- 2 ; area <- 2
+     no_area_2 <- lookup_f
+     REPORT(no_area_2)
+ }, list(lookup_f = no_area_lookup)))
> expecteds$no_area_1 <- 198311
> expecteds$no_area_2 <- 198321
> 
> # no-step
> no_step_lookup <- g3_timeareadata('no_step_lookup', read.table(header = TRUE, text = "
+ year	area	total_weight
+ 1983	1	19831
+ 1983	2	19832
+ 1984	3	19843
+ "))
> 
> no_step_1 <- 0
> no_step_2 <- 0
> no_step_3 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('no_step_lookup')
+     cur_year <- 1984 ; cur_step <- 1 ; area <- 3
+     no_step_1 <- lookup_f
+     REPORT(no_step_1)
+     cur_year <- 1984 ; cur_step <- 2 ; area <- 3
+     no_step_2 <- lookup_f
+     REPORT(no_step_2)
+     cur_year <- 1984 ; cur_step <- 3 ; area <- 2
+     no_step_2 <- lookup_f
+     REPORT(no_step_3)
+ }, list(lookup_f = no_step_lookup)))
> expecteds$no_step_1 <- 19843
> expecteds$no_step_2 <- 19843
> expecteds$no_step_3 <- 0
> 
> # "Simple" (i.e. mapping to a vector) lookups should return defaults
> simple_vec_idx <- 0L
> simple_vec_lookup <- gadget3:::g3_intlookup('simple_vec_lookup', c(1, 2, 3), c(2, 3, 4))('getdefault', ~simple_vec_idx, -1L)
> simple_vec_1 <- 0
> simple_vec_2 <- 0
> simple_vec_3 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('simple_vec_lookup')
+ 
+     simple_vec_idx <- -1L # NB: Out of bounds of what a vector can do in R
+     simple_vec_1 <- lookup_f
+     REPORT(simple_vec_1)
+ 
+     simple_vec_idx <- 3L
+     simple_vec_2 <- lookup_f
+     REPORT(simple_vec_2)
+ 
+     simple_vec_idx <- 4L
+     simple_vec_3 <- lookup_f
+     REPORT(simple_vec_3)
+ }, list(lookup_f = simple_vec_lookup)))
> expecteds$simple_vec_1 <- -1
> expecteds$simple_vec_2 <- 4
> expecteds$simple_vec_3 <- -1
> 
> # Make sure we can have zero / negative values in a lookup
> zero_key_idx <- 0L
> zero_key_lookup <- gadget3:::g3_intlookup('zero_key_lookup', c(0, -1, 1), c(2, 3, 4))('getdefault', ~zero_key_idx, -1L)
> zero_key_1 <- 0
> zero_key_2 <- 0
> zero_key_3 <- 0
> actions <- c(actions, gadget3:::f_substitute(~{
+     comment('zero_key_lookup')
+ 
+     zero_key_idx <- 0L
+     zero_key_1 <- lookup_f
+     REPORT(zero_key_1)
+ 
+     zero_key_idx <- -1L
+     zero_key_2 <- lookup_f
+     REPORT(zero_key_2)
+ 
+     zero_key_idx <- 2L
+     zero_key_3 <- lookup_f
+     REPORT(zero_key_3)
+ }, list(lookup_f = zero_key_lookup)))
> expecteds$zero_key_1 <- 2
> expecteds$zero_key_2 <- 3
> expecteds$zero_key_3 <- -1
> 
> ###############################################################################
> 
> nll <- 0.0
> actions <- c(actions, ~{
+     comment('done')
+     nll <- nll + g3_param('rv')
+     return(nll)
+ })
> params <- list(rv=0)
> 
> # Compile model
> model_fn <- g3_to_r(actions, trace = FALSE)
> model_cpp <- g3_to_tmb(actions, trace = FALSE)
> # model_fn <- edit(model_fn)
> if (nzchar(Sys.getenv('G3_TEST_TMB'))) {
+     # model_cpp <- edit(model_cpp)
+     model_tmb <- g3_tmb_adfun(model_cpp, params, compile_flags = c("-O0", "-g"))
+ } else {
+     writeLines("# skip: not compiling TMB model")
+ }
# skip: not compiling TMB model
> 
> # Compare everything we've been told to compare
> result <- model_fn(params)
> # str(attributes(result), vec.len = 10000)
> for (n in ls(expecteds)) {
+     ok(ut_cmp_equal(attr(result, n), expecteds[[n]]), n)
+ }
ok - no_area_1
ok - no_area_2
ok - no_step_1
ok - no_step_2
ok - no_step_3
ok - simple_vec_1
ok - simple_vec_2
ok - simple_vec_3
ok - single_area_1
ok - single_area_2
ok - single_lookup_rv_1
ok - single_lookup_rv_2
ok - single_named_area_1
ok - single_named_area_2
ok - tad_lookup_1
ok - tad_lookup_2
ok - tad_lookup_3
ok - zero_key_1
ok - zero_key_2
ok - zero_key_3
> param_template <- attr(model_cpp, "parameter_template")
> param_template$value <- params[param_template$switch]
> gadget3:::ut_tmb_r_compare(model_fn, model_tmb, param_template)
# skip: not running TMB tests
> 
> proc.time()
   user  system elapsed 
   0.54    0.10    0.64 
# Looks like you passed all 23 tests.