tests/test-init_val.R
In gadget-framework/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)
default_pt <- function (sn) data.frame(
switch = sn,
value = I(as.list( rep(NA, length(sn)) )),
lower = NA,
upper = NA,
parscale = NA,
optimise = FALSE,
random = FALSE)
name_spec_matched <- function (name_spec, all_names) {
l <- as.list(rep(0, length(all_names)))
names(l) <- all_names
out <- unlist(g3_init_val(l, name_spec, value = 1))
out <- names(out[out == 1])
if (length(out) == 0) return(NULL) # So we can compare to c()
out
}
# Set single value with likely-default options
iv_options <- function (sn, ...) {
as.list(g3_init_val(default_pt(sn), sn, ...))
}
sample_names = c(
paste('ling', 'imm', 'm', sep = "."),
paste('ling', 'mat', 'm', sep = "."),
paste('ling', 'imm', 'm', 0:3, sep = "."),
paste('ling', 'mat', 'm', 0:5, sep = "."),
paste('ling', 'imm', 'init', 0:3, sep = "."),
paste('ling', 'mat', 'init', 0:5, sep = "."),
paste('ling', 'imm', 'rec', 0:3, sep = "."),
paste('ling', 'mat', 'rec', 0:5, sep = "."),
NULL)
#### name_spec matching behaviour
ok(ut_cmp_equal(
suppressWarnings(name_spec_matched('ling.imm', sample_names)),
c()), "Partial matches do nothing")
ok(ut_cmp_equal(
suppressWarnings(name_spec_matched('imm.m', sample_names)),
c()), "Partial matches do nothing")
ok(ut_cmp_equal(
name_spec_matched('ling.imm.m', sample_names),
c('ling.imm.m')), "Partial matches do nothing (but do match whole)")
ok(ut_cmp_equal(
name_spec_matched('moo(c)', c("moo(c)", "mooc")),
c('moo(c)')), "Regex in parts escaped")
ok(ut_cmp_equal(name_spec_matched('ling.imm.*.*', sample_names), c(
'ling.imm.m.0', 'ling.imm.m.1', 'ling.imm.m.2', 'ling.imm.m.3',
'ling.imm.init.0', 'ling.imm.init.1', 'ling.imm.init.2', 'ling.imm.init.3',
'ling.imm.rec.0', 'ling.imm.rec.1', 'ling.imm.rec.2', 'ling.imm.rec.3',
NULL)), "* matches strings and numeric")
ok(ut_cmp_equal(name_spec_matched('ling.*m*.*.1', sample_names), c(
'ling.imm.m.1', 'ling.mat.m.1',
'ling.imm.init.1', 'ling.mat.init.1',
'ling.imm.rec.1', 'ling.mat.rec.1',
NULL)), "* matches variable lengths")
ok(ut_cmp_equal(
name_spec_matched('ling.m*t.m*.1', sample_names),
c('ling.mat.m.1')), "* can be used to partially match")
ok(ut_cmp_equal(name_spec_matched('ling.*m*.*.1', sample_names), c(
'ling.imm.m.1', 'ling.mat.m.1',
'ling.imm.init.1', 'ling.mat.init.1',
'ling.imm.rec.1', 'ling.mat.rec.1',
NULL)), "* can be used to match multiple times")
ok(ut_cmp_equal(
name_spec_matched('ling.imm.m.#', sample_names),
c('ling.imm.m.0', 'ling.imm.m.1', 'ling.imm.m.2', 'ling.imm.m.3')), "# matches numeric field")
ok(ut_cmp_equal(
suppressWarnings(name_spec_matched('ling.imm.#.1', sample_names)),
c()), "# ignores non-numeric")
ok(ut_cmp_equal(name_spec_matched('ling.*m*.i*t|rec.#', sample_names), c(
'ling.imm.init.0', 'ling.imm.init.1', 'ling.imm.init.2', 'ling.imm.init.3',
'ling.mat.init.0', 'ling.mat.init.1', 'ling.mat.init.2', 'ling.mat.init.3', 'ling.mat.init.4', 'ling.mat.init.5',
'ling.imm.rec.0', 'ling.imm.rec.1', 'ling.imm.rec.2', 'ling.imm.rec.3',
'ling.mat.rec.0', 'ling.mat.rec.1', 'ling.mat.rec.2', 'ling.mat.rec.3', 'ling.mat.rec.4', 'ling.mat.rec.5',
NULL)), "Pipe scoped to work within section, wildcards work within")
ok(ut_cmp_equal(
name_spec_matched('moo.[2-18]', paste0("moo.", 1:40)),
paste0("moo.", seq(2, 18))), "Range match 2--18 (but not 20)")
out <- as.list(rep(0, 10))
names(out) <- paste0('moo.', seq_along(out) - 1)
ok(ut_cmp_equal(g3_init_val(out, 'moo.[3-7]', 13:17), list(
"moo.0" = 0,
"moo.1" = 0,
"moo.2" = 0,
"moo.3" = 13,
"moo.4" = 14,
"moo.5" = 15,
"moo.6" = 16,
"moo.7" = 17,
"moo.8" = 0,
"moo.9" = 0)), "Can apply values with a vector")
#### data.frame option handling
ok(ut_cmp_equal(iv_options('x', value = 4), list(
switch = "x",
value = I(list(4)),
lower = NA,
upper = NA,
parscale = NA,
optimise = FALSE,
random = FALSE)), "Optimise stays off by default")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 4), list(
switch = "x",
value = I(list(4)),
lower = 4,
upper = NA,
parscale = NA,
optimise = FALSE,
random = FALSE)), "Optimise stays off with lower set")
ok(ut_cmp_equal(iv_options('x', value = 4, upper = 8), list(
switch = "x",
value = I(list(4)),
lower = NA,
upper = 8,
parscale = NA,
optimise = FALSE,
random = FALSE)), "Optimise stays off with upper set")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 2, upper = 8), list(
switch = "x",
value = I(list(4)),
lower = 2,
upper = 8,
parscale = 6,
optimise = TRUE,
random = FALSE)), "Lower & upper turn optimise on, set parscale")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 2, upper = 8, optimise = FALSE), list(
switch = "x",
value = I(list(4)),
lower = 2,
upper = 8,
parscale = 6,
optimise = FALSE,
random = FALSE)), "Lower & upper turn optimise on, can be forced off again")
ok(ut_cmp_equal(iv_options('x', value = 4, optimise = TRUE), list(
switch = "x",
value = I(list(4)),
lower = NA,
upper = NA,
parscale = NA,
optimise = TRUE,
random = FALSE)), "Can turn on optimise without bounds")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 2, upper = 8, random = TRUE), list(
switch = "x",
value = I(list(4)),
lower = 2,
upper = 8,
parscale = 6,
optimise = FALSE,
random = TRUE)), "random = TRUE --> optimise = FALSE (as you can't have both)")
ok(ut_cmp_equal(iv_options('x', value = 10, spread = 0.5), list(
switch = "x",
value = I(list(10)),
lower = 5,
upper = 15,
parscale = 10,
optimise = TRUE,
random = FALSE)), "spread sets lower/upper bounds")
ok(ut_cmp_equal(iv_options('x', value = -1, spread = 0.2), list(
switch = "x",
value = I(list(-1)),
lower = -1.2,
upper = -0.8,
parscale = 0.4,
optimise = TRUE,
random = FALSE)), "spread on a negative number still sets lower/upper bounds correctly")
#### auto_exp
pt <- default_pt(c('moo.1', 'moo.1_exp', 'baa.2', 'baa.2_exp', 'oink.1', 'oink.1_exp'))
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', 4, auto_exponentiate = TRUE)$value,
I(list(4, log(4), NA, NA, 4, log(4)))), "log() values that are in _exp columns")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', lower = 22, auto_exponentiate = TRUE)$lower,
c(22, log(22), NA, NA, 22, log(22))), "Can auto_exp lower")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', upper = 22, auto_exponentiate = TRUE)$upper,
c(22, log(22), NA, NA, 22, log(22))), "Can auto_exp upper")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', 4, auto_exponentiate = FALSE)$value,
I(list(4, NA, NA, NA, 4, NA))), "Can disable auto_exponentiate, values aren't matched")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1_exp', 8, auto_exponentiate = TRUE)$value,
I(list(NA, 8, NA, NA, NA, 8))), "Manual _exp matching still works, no log()")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1_exp', 8, auto_exponentiate = FALSE)$value,
I(list(NA, 8, NA, NA, NA, 8))), "Manual _exp matching still works")
#### Warning
cmp_contains <- function (a, b) {
if (grepl(a, b, fixed = TRUE)) return(TRUE)
return(c(a, " not in ", b))
}
captureWarning <- function (x) {
tryCatch(
list(x, warning = ""),
warning = function (w) list(suppressWarnings(x), warning = w$message))
}
pt <- default_pt(c('moo.1', 'moo.1_exp', 'baa.2', 'baa.2_exp', 'oink.1', 'oink.1_exp'))
out <- captureWarning(g3_init_val(pt, "neigh.#", value = 9))
ok(ut_cmp_identical(pt, out[[1]]), "Non-matching g3_init_val makes no modification")
ok(cmp_contains("neigh.#", out$warning), "name_spec in warning output")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(5, 15, 15, 5), lower = 10, upper = 20) )
ok(cmp_contains("below lower bound: moo.1, oink.1_exp", out$warning), "Params below lower bound")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(5, 15, 5, 15), lower = 10, upper = 20) )
ok(cmp_contains("below lower bound: moo.1, oink.1", out$warning), "Params below lower bound")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(25, 15, 15, 25), lower = 10, upper = 20) )
ok(cmp_contains("above upper bound: moo.1, oink.1_exp", out$warning), "Params above upper bound")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(25, 15, 25, 15), lower = 10, upper = 20) )
ok(cmp_contains("above upper bound: moo.1, oink.1", out$warning), "Params above upper bound")
#### test with a real parameter template
actions <- list( g3a_time(1980L, 2000L), g3_formula(
quote(d + e + f + g + h + i),
d = g3_parameterized('par.years', value = 0, by_year = TRUE),
e = g3_parameterized('par.yrs.exp', value = 0, by_year = TRUE, exponentiate = TRUE),
f = g3_parameterized('pare', value = 1),
g = g3_parameterized('par.a', value = 2),
h = g3_parameterized('par.b', value = 3, exponentiate = TRUE),
i = g3_parameterized('par.lu', value = 9, exponentiate = TRUE),
x = NA) )
params.in <- attr(g3_to_tmb(actions), 'parameter_template')
params.in <- g3_init_val(params.in, 'par.years.#', value = 99, optimise = FALSE)
params.in <- g3_init_val(params.in, 'par.yrs.exp.#', value = 100, optimise = FALSE)
params.in <- g3_init_val(params.in, 'par.yrs.exp.1999', value = 9, optimise = FALSE)
params.in <- g3_init_val(params.in, 'par.years.[1986-1994]', value = 11:19, lower = 1:9, upper = 101:109)
params.in <- g3_init_val(params.in, 'par.a|b', value = 100, spread = 0.1)
params.in <- g3_init_val(params.in, 'par.lu', value = 1000, spread = 0.1)
params.in.R <- attr(g3_to_r(actions), 'parameter_template')
params.in.R <- g3_init_val(params.in.R, 'par.years.#', value = 99)
params.in.R <- g3_init_val(params.in.R, 'par.yrs.exp.#', value = 100)
params.in.R <- g3_init_val(params.in.R, 'par.yrs.exp.1999', value = 9)
params.in.R <- g3_init_val(params.in.R, 'par.years.[1986-1994]', value = 11:19)
params.in.R <- g3_init_val(params.in.R, 'par.a|b', value = 100)
params.in.R <- g3_init_val(params.in.R, 'par.lu', value = 1000, spread = 0.1)
ok(ut_cmp_equal(params.in$value, I(list(
retro_years = 0, project_years = 0,
par.years.1980 = 99, par.years.1981 = 99, par.years.1982 = 99, par.years.1983 = 99, par.years.1984 = 99, par.years.1985 = 99,
par.years.1986 = 11L, par.years.1987 = 12L, par.years.1988 = 13L,
par.years.1989 = 14L, par.years.1990 = 15L, par.years.1991 = 16L,
par.years.1992 = 17L, par.years.1993 = 18L, par.years.1994 = 19L,
par.years.1995 = 99, par.years.1996 = 99, par.years.1997 = 99, par.years.1998 = 99,
par.years.1999 = 99, par.years.2000 = 99,
par.yrs.exp.1980_exp = log(100), par.yrs.exp.1981_exp = log(100), par.yrs.exp.1982_exp = log(100),
par.yrs.exp.1983_exp = log(100), par.yrs.exp.1984_exp = log(100), par.yrs.exp.1985_exp = log(100),
par.yrs.exp.1986_exp = log(100), par.yrs.exp.1987_exp = log(100), par.yrs.exp.1988_exp = log(100),
par.yrs.exp.1989_exp = log(100), par.yrs.exp.1990_exp = log(100), par.yrs.exp.1991_exp = log(100),
par.yrs.exp.1992_exp = log(100), par.yrs.exp.1993_exp = log(100), par.yrs.exp.1994_exp = log(100),
par.yrs.exp.1995_exp = log(100), par.yrs.exp.1996_exp = log(100), par.yrs.exp.1997_exp = log(100),
par.yrs.exp.1998_exp = log(100), par.yrs.exp.1999_exp = log(9), par.yrs.exp.2000_exp = log(100),
pare = 1,
par.a = 100,
par.b_exp = log(100),
par.lu_exp = log(1000) ))), "params.in$value: Applied vector, wildcard, auto_exp")
ok(ut_cmp_equal(structure(params.in$lower, names = params.in$switch), c(
retro_years = NA, project_years = NA,
par.years.1980 = NA, par.years.1981 = NA, par.years.1982 = NA, par.years.1983 = NA,
par.years.1984 = NA, par.years.1985 = NA,
par.years.1986 = 1, par.years.1987 = 2, par.years.1988 = 3,
par.years.1989 = 4, par.years.1990 = 5, par.years.1991 = 6,
par.years.1992 = 7, par.years.1993 = 8, par.years.1994 = 9,
par.years.1995 = NA, par.years.1996 = NA, par.years.1997 = NA,
par.years.1998 = NA, par.years.1999 = NA, par.years.2000 = NA,
par.yrs.exp.1980_exp = NA, par.yrs.exp.1981_exp = NA, par.yrs.exp.1982_exp = NA,
par.yrs.exp.1983_exp = NA, par.yrs.exp.1984_exp = NA, par.yrs.exp.1985_exp = NA,
par.yrs.exp.1986_exp = NA, par.yrs.exp.1987_exp = NA, par.yrs.exp.1988_exp = NA,
par.yrs.exp.1989_exp = NA, par.yrs.exp.1990_exp = NA, par.yrs.exp.1991_exp = NA,
par.yrs.exp.1992_exp = NA, par.yrs.exp.1993_exp = NA, par.yrs.exp.1994_exp = NA,
par.yrs.exp.1995_exp = NA, par.yrs.exp.1996_exp = NA, par.yrs.exp.1997_exp = NA,
par.yrs.exp.1998_exp = NA, par.yrs.exp.1999_exp = NA, par.yrs.exp.2000_exp = NA,
pare = NA,
par.a = 90,
par.b_exp = log(90),
par.lu_exp = log(900) )), "params.in$lower: Applied vector, auto_exp")
ok(ut_cmp_equal(structure(params.in$upper, names = params.in$switch), c(
retro_years = NA, project_years = NA, par.years.1980 = NA,
par.years.1981 = NA, par.years.1982 = NA, par.years.1983 = NA,
par.years.1984 = NA, par.years.1985 = NA,
par.years.1986 = 101, par.years.1987 = 102, par.years.1988 = 103,
par.years.1989 = 104, par.years.1990 = 105, par.years.1991 = 106,
par.years.1992 = 107, par.years.1993 = 108, par.years.1994 = 109,
par.years.1995 = NA,
par.years.1996 = NA, par.years.1997 = NA, par.years.1998 = NA,
par.years.1999 = NA, par.years.2000 = NA,
par.yrs.exp.1980_exp = NA, par.yrs.exp.1981_exp = NA, par.yrs.exp.1982_exp = NA,
par.yrs.exp.1983_exp = NA, par.yrs.exp.1984_exp = NA, par.yrs.exp.1985_exp = NA,
par.yrs.exp.1986_exp = NA, par.yrs.exp.1987_exp = NA, par.yrs.exp.1988_exp = NA,
par.yrs.exp.1989_exp = NA, par.yrs.exp.1990_exp = NA, par.yrs.exp.1991_exp = NA,
par.yrs.exp.1992_exp = NA, par.yrs.exp.1993_exp = NA, par.yrs.exp.1994_exp = NA,
par.yrs.exp.1995_exp = NA, par.yrs.exp.1996_exp = NA, par.yrs.exp.1997_exp = NA,
par.yrs.exp.1998_exp = NA, par.yrs.exp.1999_exp = NA, par.yrs.exp.2000_exp = NA,
pare = NA,
par.a = 110,
par.b_exp = log(110),
par.lu_exp = log(1100) )), "params.in$upper: Applied vector, auto_exp")
ok(ut_cmp_equal(
params.in['par.lu_exp', 'parscale'],
diff(c(params.in['par.lu_exp', 'lower'], params.in['par.lu_exp', 'upper'])),
tolerance = sqrt(.Machine$double.eps)), "params.in$parscale: par.lu_exp used log lower/upper")
gadget-framework/gadget3 documentation built on June 13, 2025, 5:06 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
library(unittest)
if (!interactive()) options(warn=2, error = function() { sink(stderr()) ; traceback(3) ; q(status = 1) })
library(gadget3)
default_pt <- function (sn) data.frame(
switch = sn,
value = I(as.list( rep(NA, length(sn)) )),
lower = NA,
upper = NA,
parscale = NA,
optimise = FALSE,
random = FALSE)
name_spec_matched <- function (name_spec, all_names) {
l <- as.list(rep(0, length(all_names)))
names(l) <- all_names
out <- unlist(g3_init_val(l, name_spec, value = 1))
out <- names(out[out == 1])
if (length(out) == 0) return(NULL) # So we can compare to c()
out
}
# Set single value with likely-default options
iv_options <- function (sn, ...) {
as.list(g3_init_val(default_pt(sn), sn, ...))
}
sample_names = c(
paste('ling', 'imm', 'm', sep = "."),
paste('ling', 'mat', 'm', sep = "."),
paste('ling', 'imm', 'm', 0:3, sep = "."),
paste('ling', 'mat', 'm', 0:5, sep = "."),
paste('ling', 'imm', 'init', 0:3, sep = "."),
paste('ling', 'mat', 'init', 0:5, sep = "."),
paste('ling', 'imm', 'rec', 0:3, sep = "."),
paste('ling', 'mat', 'rec', 0:5, sep = "."),
NULL)
#### name_spec matching behaviour
ok(ut_cmp_equal(
suppressWarnings(name_spec_matched('ling.imm', sample_names)),
c()), "Partial matches do nothing")
ok(ut_cmp_equal(
suppressWarnings(name_spec_matched('imm.m', sample_names)),
c()), "Partial matches do nothing")
ok(ut_cmp_equal(
name_spec_matched('ling.imm.m', sample_names),
c('ling.imm.m')), "Partial matches do nothing (but do match whole)")
ok(ut_cmp_equal(
name_spec_matched('moo(c)', c("moo(c)", "mooc")),
c('moo(c)')), "Regex in parts escaped")
ok(ut_cmp_equal(name_spec_matched('ling.imm.*.*', sample_names), c(
'ling.imm.m.0', 'ling.imm.m.1', 'ling.imm.m.2', 'ling.imm.m.3',
'ling.imm.init.0', 'ling.imm.init.1', 'ling.imm.init.2', 'ling.imm.init.3',
'ling.imm.rec.0', 'ling.imm.rec.1', 'ling.imm.rec.2', 'ling.imm.rec.3',
NULL)), "* matches strings and numeric")
ok(ut_cmp_equal(name_spec_matched('ling.*m*.*.1', sample_names), c(
'ling.imm.m.1', 'ling.mat.m.1',
'ling.imm.init.1', 'ling.mat.init.1',
'ling.imm.rec.1', 'ling.mat.rec.1',
NULL)), "* matches variable lengths")
ok(ut_cmp_equal(
name_spec_matched('ling.m*t.m*.1', sample_names),
c('ling.mat.m.1')), "* can be used to partially match")
ok(ut_cmp_equal(name_spec_matched('ling.*m*.*.1', sample_names), c(
'ling.imm.m.1', 'ling.mat.m.1',
'ling.imm.init.1', 'ling.mat.init.1',
'ling.imm.rec.1', 'ling.mat.rec.1',
NULL)), "* can be used to match multiple times")
ok(ut_cmp_equal(
name_spec_matched('ling.imm.m.#', sample_names),
c('ling.imm.m.0', 'ling.imm.m.1', 'ling.imm.m.2', 'ling.imm.m.3')), "# matches numeric field")
ok(ut_cmp_equal(
suppressWarnings(name_spec_matched('ling.imm.#.1', sample_names)),
c()), "# ignores non-numeric")
ok(ut_cmp_equal(name_spec_matched('ling.*m*.i*t|rec.#', sample_names), c(
'ling.imm.init.0', 'ling.imm.init.1', 'ling.imm.init.2', 'ling.imm.init.3',
'ling.mat.init.0', 'ling.mat.init.1', 'ling.mat.init.2', 'ling.mat.init.3', 'ling.mat.init.4', 'ling.mat.init.5',
'ling.imm.rec.0', 'ling.imm.rec.1', 'ling.imm.rec.2', 'ling.imm.rec.3',
'ling.mat.rec.0', 'ling.mat.rec.1', 'ling.mat.rec.2', 'ling.mat.rec.3', 'ling.mat.rec.4', 'ling.mat.rec.5',
NULL)), "Pipe scoped to work within section, wildcards work within")
ok(ut_cmp_equal(
name_spec_matched('moo.[2-18]', paste0("moo.", 1:40)),
paste0("moo.", seq(2, 18))), "Range match 2--18 (but not 20)")
out <- as.list(rep(0, 10))
names(out) <- paste0('moo.', seq_along(out) - 1)
ok(ut_cmp_equal(g3_init_val(out, 'moo.[3-7]', 13:17), list(
"moo.0" = 0,
"moo.1" = 0,
"moo.2" = 0,
"moo.3" = 13,
"moo.4" = 14,
"moo.5" = 15,
"moo.6" = 16,
"moo.7" = 17,
"moo.8" = 0,
"moo.9" = 0)), "Can apply values with a vector")
#### data.frame option handling
ok(ut_cmp_equal(iv_options('x', value = 4), list(
switch = "x",
value = I(list(4)),
lower = NA,
upper = NA,
parscale = NA,
optimise = FALSE,
random = FALSE)), "Optimise stays off by default")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 4), list(
switch = "x",
value = I(list(4)),
lower = 4,
upper = NA,
parscale = NA,
optimise = FALSE,
random = FALSE)), "Optimise stays off with lower set")
ok(ut_cmp_equal(iv_options('x', value = 4, upper = 8), list(
switch = "x",
value = I(list(4)),
lower = NA,
upper = 8,
parscale = NA,
optimise = FALSE,
random = FALSE)), "Optimise stays off with upper set")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 2, upper = 8), list(
switch = "x",
value = I(list(4)),
lower = 2,
upper = 8,
parscale = 6,
optimise = TRUE,
random = FALSE)), "Lower & upper turn optimise on, set parscale")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 2, upper = 8, optimise = FALSE), list(
switch = "x",
value = I(list(4)),
lower = 2,
upper = 8,
parscale = 6,
optimise = FALSE,
random = FALSE)), "Lower & upper turn optimise on, can be forced off again")
ok(ut_cmp_equal(iv_options('x', value = 4, optimise = TRUE), list(
switch = "x",
value = I(list(4)),
lower = NA,
upper = NA,
parscale = NA,
optimise = TRUE,
random = FALSE)), "Can turn on optimise without bounds")
ok(ut_cmp_equal(iv_options('x', value = 4, lower = 2, upper = 8, random = TRUE), list(
switch = "x",
value = I(list(4)),
lower = 2,
upper = 8,
parscale = 6,
optimise = FALSE,
random = TRUE)), "random = TRUE --> optimise = FALSE (as you can't have both)")
ok(ut_cmp_equal(iv_options('x', value = 10, spread = 0.5), list(
switch = "x",
value = I(list(10)),
lower = 5,
upper = 15,
parscale = 10,
optimise = TRUE,
random = FALSE)), "spread sets lower/upper bounds")
ok(ut_cmp_equal(iv_options('x', value = -1, spread = 0.2), list(
switch = "x",
value = I(list(-1)),
lower = -1.2,
upper = -0.8,
parscale = 0.4,
optimise = TRUE,
random = FALSE)), "spread on a negative number still sets lower/upper bounds correctly")
#### auto_exp
pt <- default_pt(c('moo.1', 'moo.1_exp', 'baa.2', 'baa.2_exp', 'oink.1', 'oink.1_exp'))
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', 4, auto_exponentiate = TRUE)$value,
I(list(4, log(4), NA, NA, 4, log(4)))), "log() values that are in _exp columns")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', lower = 22, auto_exponentiate = TRUE)$lower,
c(22, log(22), NA, NA, 22, log(22))), "Can auto_exp lower")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', upper = 22, auto_exponentiate = TRUE)$upper,
c(22, log(22), NA, NA, 22, log(22))), "Can auto_exp upper")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1', 4, auto_exponentiate = FALSE)$value,
I(list(4, NA, NA, NA, 4, NA))), "Can disable auto_exponentiate, values aren't matched")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1_exp', 8, auto_exponentiate = TRUE)$value,
I(list(NA, 8, NA, NA, NA, 8))), "Manual _exp matching still works, no log()")
ok(ut_cmp_equal(
g3_init_val(pt, '*.1_exp', 8, auto_exponentiate = FALSE)$value,
I(list(NA, 8, NA, NA, NA, 8))), "Manual _exp matching still works")
#### Warning
cmp_contains <- function (a, b) {
if (grepl(a, b, fixed = TRUE)) return(TRUE)
return(c(a, " not in ", b))
}
captureWarning <- function (x) {
tryCatch(
list(x, warning = ""),
warning = function (w) list(suppressWarnings(x), warning = w$message))
}
pt <- default_pt(c('moo.1', 'moo.1_exp', 'baa.2', 'baa.2_exp', 'oink.1', 'oink.1_exp'))
out <- captureWarning(g3_init_val(pt, "neigh.#", value = 9))
ok(ut_cmp_identical(pt, out[[1]]), "Non-matching g3_init_val makes no modification")
ok(cmp_contains("neigh.#", out$warning), "name_spec in warning output")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(5, 15, 15, 5), lower = 10, upper = 20) )
ok(cmp_contains("below lower bound: moo.1, oink.1_exp", out$warning), "Params below lower bound")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(5, 15, 5, 15), lower = 10, upper = 20) )
ok(cmp_contains("below lower bound: moo.1, oink.1", out$warning), "Params below lower bound")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(25, 15, 15, 25), lower = 10, upper = 20) )
ok(cmp_contains("above upper bound: moo.1, oink.1_exp", out$warning), "Params above upper bound")
out <- captureWarning( g3_init_val(pt, "moo|oink.#", value = c(25, 15, 25, 15), lower = 10, upper = 20) )
ok(cmp_contains("above upper bound: moo.1, oink.1", out$warning), "Params above upper bound")
#### test with a real parameter template
actions <- list( g3a_time(1980L, 2000L), g3_formula(
quote(d + e + f + g + h + i),
d = g3_parameterized('par.years', value = 0, by_year = TRUE),
e = g3_parameterized('par.yrs.exp', value = 0, by_year = TRUE, exponentiate = TRUE),
f = g3_parameterized('pare', value = 1),
g = g3_parameterized('par.a', value = 2),
h = g3_parameterized('par.b', value = 3, exponentiate = TRUE),
i = g3_parameterized('par.lu', value = 9, exponentiate = TRUE),
x = NA) )
params.in <- attr(g3_to_tmb(actions), 'parameter_template')
params.in <- g3_init_val(params.in, 'par.years.#', value = 99, optimise = FALSE)
params.in <- g3_init_val(params.in, 'par.yrs.exp.#', value = 100, optimise = FALSE)
params.in <- g3_init_val(params.in, 'par.yrs.exp.1999', value = 9, optimise = FALSE)
params.in <- g3_init_val(params.in, 'par.years.[1986-1994]', value = 11:19, lower = 1:9, upper = 101:109)
params.in <- g3_init_val(params.in, 'par.a|b', value = 100, spread = 0.1)
params.in <- g3_init_val(params.in, 'par.lu', value = 1000, spread = 0.1)
params.in.R <- attr(g3_to_r(actions), 'parameter_template')
params.in.R <- g3_init_val(params.in.R, 'par.years.#', value = 99)
params.in.R <- g3_init_val(params.in.R, 'par.yrs.exp.#', value = 100)
params.in.R <- g3_init_val(params.in.R, 'par.yrs.exp.1999', value = 9)
params.in.R <- g3_init_val(params.in.R, 'par.years.[1986-1994]', value = 11:19)
params.in.R <- g3_init_val(params.in.R, 'par.a|b', value = 100)
params.in.R <- g3_init_val(params.in.R, 'par.lu', value = 1000, spread = 0.1)
ok(ut_cmp_equal(params.in$value, I(list(
retro_years = 0, project_years = 0,
par.years.1980 = 99, par.years.1981 = 99, par.years.1982 = 99, par.years.1983 = 99, par.years.1984 = 99, par.years.1985 = 99,
par.years.1986 = 11L, par.years.1987 = 12L, par.years.1988 = 13L,
par.years.1989 = 14L, par.years.1990 = 15L, par.years.1991 = 16L,
par.years.1992 = 17L, par.years.1993 = 18L, par.years.1994 = 19L,
par.years.1995 = 99, par.years.1996 = 99, par.years.1997 = 99, par.years.1998 = 99,
par.years.1999 = 99, par.years.2000 = 99,
par.yrs.exp.1980_exp = log(100), par.yrs.exp.1981_exp = log(100), par.yrs.exp.1982_exp = log(100),
par.yrs.exp.1983_exp = log(100), par.yrs.exp.1984_exp = log(100), par.yrs.exp.1985_exp = log(100),
par.yrs.exp.1986_exp = log(100), par.yrs.exp.1987_exp = log(100), par.yrs.exp.1988_exp = log(100),
par.yrs.exp.1989_exp = log(100), par.yrs.exp.1990_exp = log(100), par.yrs.exp.1991_exp = log(100),
par.yrs.exp.1992_exp = log(100), par.yrs.exp.1993_exp = log(100), par.yrs.exp.1994_exp = log(100),
par.yrs.exp.1995_exp = log(100), par.yrs.exp.1996_exp = log(100), par.yrs.exp.1997_exp = log(100),
par.yrs.exp.1998_exp = log(100), par.yrs.exp.1999_exp = log(9), par.yrs.exp.2000_exp = log(100),
pare = 1,
par.a = 100,
par.b_exp = log(100),
par.lu_exp = log(1000) ))), "params.in$value: Applied vector, wildcard, auto_exp")
ok(ut_cmp_equal(structure(params.in$lower, names = params.in$switch), c(
retro_years = NA, project_years = NA,
par.years.1980 = NA, par.years.1981 = NA, par.years.1982 = NA, par.years.1983 = NA,
par.years.1984 = NA, par.years.1985 = NA,
par.years.1986 = 1, par.years.1987 = 2, par.years.1988 = 3,
par.years.1989 = 4, par.years.1990 = 5, par.years.1991 = 6,
par.years.1992 = 7, par.years.1993 = 8, par.years.1994 = 9,
par.years.1995 = NA, par.years.1996 = NA, par.years.1997 = NA,
par.years.1998 = NA, par.years.1999 = NA, par.years.2000 = NA,
par.yrs.exp.1980_exp = NA, par.yrs.exp.1981_exp = NA, par.yrs.exp.1982_exp = NA,
par.yrs.exp.1983_exp = NA, par.yrs.exp.1984_exp = NA, par.yrs.exp.1985_exp = NA,
par.yrs.exp.1986_exp = NA, par.yrs.exp.1987_exp = NA, par.yrs.exp.1988_exp = NA,
par.yrs.exp.1989_exp = NA, par.yrs.exp.1990_exp = NA, par.yrs.exp.1991_exp = NA,
par.yrs.exp.1992_exp = NA, par.yrs.exp.1993_exp = NA, par.yrs.exp.1994_exp = NA,
par.yrs.exp.1995_exp = NA, par.yrs.exp.1996_exp = NA, par.yrs.exp.1997_exp = NA,
par.yrs.exp.1998_exp = NA, par.yrs.exp.1999_exp = NA, par.yrs.exp.2000_exp = NA,
pare = NA,
par.a = 90,
par.b_exp = log(90),
par.lu_exp = log(900) )), "params.in$lower: Applied vector, auto_exp")
ok(ut_cmp_equal(structure(params.in$upper, names = params.in$switch), c(
retro_years = NA, project_years = NA, par.years.1980 = NA,
par.years.1981 = NA, par.years.1982 = NA, par.years.1983 = NA,
par.years.1984 = NA, par.years.1985 = NA,
par.years.1986 = 101, par.years.1987 = 102, par.years.1988 = 103,
par.years.1989 = 104, par.years.1990 = 105, par.years.1991 = 106,
par.years.1992 = 107, par.years.1993 = 108, par.years.1994 = 109,
par.years.1995 = NA,
par.years.1996 = NA, par.years.1997 = NA, par.years.1998 = NA,
par.years.1999 = NA, par.years.2000 = NA,
par.yrs.exp.1980_exp = NA, par.yrs.exp.1981_exp = NA, par.yrs.exp.1982_exp = NA,
par.yrs.exp.1983_exp = NA, par.yrs.exp.1984_exp = NA, par.yrs.exp.1985_exp = NA,
par.yrs.exp.1986_exp = NA, par.yrs.exp.1987_exp = NA, par.yrs.exp.1988_exp = NA,
par.yrs.exp.1989_exp = NA, par.yrs.exp.1990_exp = NA, par.yrs.exp.1991_exp = NA,
par.yrs.exp.1992_exp = NA, par.yrs.exp.1993_exp = NA, par.yrs.exp.1994_exp = NA,
par.yrs.exp.1995_exp = NA, par.yrs.exp.1996_exp = NA, par.yrs.exp.1997_exp = NA,
par.yrs.exp.1998_exp = NA, par.yrs.exp.1999_exp = NA, par.yrs.exp.2000_exp = NA,
pare = NA,
par.a = 110,
par.b_exp = log(110),
par.lu_exp = log(1100) )), "params.in$upper: Applied vector, auto_exp")
ok(ut_cmp_equal(
params.in['par.lu_exp', 'parscale'],
diff(c(params.in['par.lu_exp', 'lower'], params.in['par.lu_exp', 'upper'])),
tolerance = sqrt(.Machine$double.eps)), "params.in$parscale: par.lu_exp used log lower/upper")
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.