tests/testthat/test-extension.R

params <- NS_params
e <- globalenv()
e$test_dyn <- function(params, ...) {
    111
}
e$nt <- function(params, t, ...) {
    params@initial_n * t
}
e$resource_encounter <- function(params, n, n_pp, n_other, ...) {
    mizerEncounter(params, n = n, n_pp = n_other$resource, ...)
}
e$semichemostat <- function(params, n_other, rates, dt, component, ...) {
    c <- params@other_params[[component]]
    interaction <- params@species_params$interaction_resource
    mort <- as.vector(interaction  %*% rates$pred_rate)
    tmp <- c$rate * c$capacity / (c$rate + mort)
    return(tmp - (tmp - n_other[[component]]) * exp(-(c$rate + mort) * dt))
}

# setRateFunction works ----
test_that("setRateFunction works", {
    expect_error(setRateFunction(params, rate = "wrong", fun = "sum"),
               "The `rate` argument must be one of")
    xxx <- "xx"
    expect_error(setRateFunction(params, rate = "Mort", fun = "xxx"),
                 "`fun` should be a function")
    p <- setRateFunction(params, "Mort", "mizerMort")
    expect_identical(params@rates_funcs, p@rates_funcs)
    p <- setRateFunction(params, rate = "EGrowth", fun = "test_dyn")
    expect_identical(p@rates_funcs[["EGrowth"]], "test_dyn")
    r <- mizerRates(p, n = initialN(p), 
                    n_pp = initialNResource(p), 
                    n_other = initialNOther(p),
                    effort = 0,
                    rates_fns = lapply(p@rates_funcs, get))
    expect_identical(r$e_growth, 111)
})

test_that("Time is passed correctly to rate functions", {
    params@rates_funcs$Encounter <- "nt"
    expect_identical(getEncounter(params, t = 2), nt(params, 2))
    params@rates_funcs$FeedingLevel <- "nt"
    expect_identical(getFeedingLevel(params, time_range = 2), nt(params, 2))
    
    gears <- unique(as.character(gear_params(params)$gear))
    effort <- array(0, dim = c(3, 4), 
                    dimnames = list(time = 2020:2022,
                                    gear = gears))
    sim <- project(params, effort = effort, dt = 1)
    expect_identical(getFeedingLevel(sim, time_range = 2021:2022)[1, , ],
                     nt(params, 2021))
    #TODO: extend this
})

# getRateFunction works ----
test_that("getRateFunction works", {
    expect_error(getRateFunction(params, "test"),
        "The `rate` argument must be one of")
    all <- getRateFunction(params)
    expect_type(all, "list")
    expect_named(all)
    expect_identical(all$Rates, "mizerRates")
    expect_identical(getRateFunction(params, rate = "Mort"), "mizerMort")
})

# other_params ----
test_that("We can set and get other params", {
    expect_length(other_params(params), 0)
    expect_error(other_params(params) <- 5,
                 "other_params should be a named list")
    expect_error(other_params(params) <- list(5),
                 "other_params should be a named list")
    other_params(params)$test <- 5
    expect_identical(other_params(params)$test, 5)
    other_params(params)$test <- NULL
    expect_length(other_params(params), 0)
    expect_null(other_params(params)$test)
})

# components ----
test_that("We can set, get and remove components", {
    expect_error(setComponent(params, "test", 1),
                 '"dynamics_fun" is missing')
    p <- setComponent(params, "test", 1, 
                      dynamics_fun = "test_dyn",
                      encounter_fun = "test_dyn",
                      mort_fun = "test_dyn",
                      component_params = list(a = 2))
    expect_identical(p@other_dynamics, list(test = "test_dyn"))
    expect_identical(p@other_encounter, list(test = "test_dyn"))
    expect_identical(p@other_mort, list(test = "test_dyn"))
    expect_identical(p@other_params, list(test = list(a = 2)))
    comp <- getComponent(p, "test")
    expect_mapequal(comp, list(initial_value = 1,
                               encounter_fun = "test_dyn",
                               dynamics_fun = "test_dyn",
                               mort_fun = "test_dyn",
                               component_params = list(a = 2)))
    all <- getComponent(p)
    expect_type(all, "list")
    expect_identical(all$test, comp)
    p2 <- setComponent(p, "test2", 2, 
                      dynamics_fun = "test_dyn",
                      mort_fun = "test_dyn")
    all2 <- getComponent(p2)
    expect_length(all2, 2)
    expect_length(all2$test2, 5)
    expect_null(all2$test2$encounter_fun)
    p <- setComponent(p2, "test2", 1, "test_dyn", mort_fun = NULL)
    expect_null(getComponent(p, "test2")$mort_fun)
    expect_error(removeComponent(p2, "test3"),
                 "There is no component named test3")
    expect_null(getComponent(p2, "test3"))
    p1 <- removeComponent(p2, "test")
    d <- getComponent(p1, "test2")
    expect_length(p1@other_dynamics, 1)
    expect_length(p1@other_encounter, 0)
})

# initial values ----
test_that("We can set and get initial values for MizerParams", {
    p <- setComponent(params, "test", 1, 
                      dynamics_fun = "test_dyn")
    expect_identical(initialNOther(p), list(test = 1))
    p <- setComponent(p, "test", list(a = 1, b = 2), 
                      dynamics_fun = "test_dyn")
    expect_identical(initialNOther(p), list(test = list(a = 1, b = 2)))
    initialNOther(p)$test <- 3
    expect_identical(initialNOther(p), list(test = 3))
    expect_error(initialNOther(p)$test2 <- 3,
                 "The following components do not exist: test2")
    p <- setComponent(p, "test2", 2, 
                      dynamics_fun = "test_dyn")
    expect_identical(initialNOther(p), list(test = 3, test2 = 2))
    expect_error(initialNOther(p) <- list(test = 4),
                 "Missing values for components test2")
    initialNOther(p)$test <- 4
    expect_identical(initialNOther(p)$test, 4)
    # test that we can get initial values from MizerSim object
    sim <- project(p, t_max = 0.2, t_save = 0.1)
    expect_identical(initialNOther(sim)$test, 4)
})

# encounter and mortality functions are called ----
test_that("encounter and mortality functions are called", {
    e <- getEncounter(params)
    m <- getMort(params)
    p <- setComponent(params, "test", 1, 
                      dynamics_fun = "test_dyn",
                      encounter_fun = "test_dyn",
                      mort_fun = "test_dyn")
    expect_identical(getEncounter(p), e + 111)
    p <- setComponent(params, "test", 1, 
                      dynamics_fun = "test_dyn",
                      mort_fun = "test_dyn")
    expect_identical(getMort(p), m + 111)
})

test_that("We can access simulation results", {
    p <- setComponent(params, "test", 1, 
                      dynamics_fun = "test_dyn",
                      encounter_fun = "test_dyn",
                      mort_fun = "test_dyn")
    sim <- project(p, t_max = 0.2, t_save = 0.1)
    expect_identical(finalNOther(sim), list("test" = 111))
    expect_identical(NOther(sim)[2, ], list(111))
    expect_identical(NOther(sim)[1, ], list(1))
})

test_that("component can mimic resource", {
    params <- NS_params
    initialNResource(params) <- initialNResource(params) / 10
    component_params <- list(capacity = params@cc_pp,
                             rate = params@rr_pp)
    params2 <- params %>% 
        setComponent("resource",
                     initial_value = initialNResource(params),
                     dynamics_fun = "semichemostat",
                     component_params = component_params) %>% 
        setRateFunction("Encounter", "resource_encounter")
    sim <- project(params, t_max = 0.1, t_save = 0.1, effort = 0)
    sim2 <- project(params2, t_max = 0.1, t_save = 0.1, effort = 0)
    expect_identical(finalNResource(sim2), finalNOther(sim2)$resource)
    expect_identical(finalNResource(sim), finalNResource(sim2))
    expect_identical(finalN(sim), finalN(sim2))
})

Try the mizer package in your browser

Any scripts or data that you put into this service are public.

mizer documentation built on April 26, 2023, 5:12 p.m.