From 87794dd65109b9b70bdcf358b4591f63b6baff70 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Tue, 28 Jan 2020 19:52:56 +1100 Subject: [PATCH] feat: dynamic target in TransitionClassification (#53) * feat: add dynamic target #52 * test: fix check_target * feat: add print format for Target * test: fix Target * feat: use Target in the inner working of Transition * feat: add print format for Generic * feat: check_target knows Target * test: update TransitionClassifiication * fix: Target did not accept NULL * docs: update man * docs: update news * test: fix check_target test * docs: export Target * fix: checkmate::makeExpectation is missing makeExpectation is imported to be used internally in our customised checkmate functions * docs: fix wrong alias of Target * test: fix Target tests * docs: fix Target example * docs: fix Target example in man * Increment version number * docs: update pkgdown --- DESCRIPTION | 3 +- NAMESPACE | 7 ++ NEWS.md | 12 +- R/Generic.R | 13 ++ R/Target.R | 115 ++++++++++++++++++ R/Transition.R | 41 ++++--- R/TransitionClassification.R | 27 ++-- R/checkmate.R | 86 +++++++++++++ R/dymiumCore-package.R | 1 + _pkgdown.yml | 13 +- man/Target.Rd | 60 +++++++++ man/Transition.Rd | 5 + man/TransitionClassification.Rd | 26 ++-- man/check_target.Rd | 47 +++++++ tests/testthat/test-Target.R | 13 ++ .../testthat/test-TransitionClassification.R | 63 ++++++++++ tests/testthat/test-checkmate.R | 26 ++++ 17 files changed, 507 insertions(+), 51 deletions(-) create mode 100644 R/Target.R create mode 100644 man/Target.Rd create mode 100644 man/check_target.Rd create mode 100644 tests/testthat/test-Target.R create mode 100644 tests/testthat/test-checkmate.R diff --git a/DESCRIPTION b/DESCRIPTION index bcb3988d..277f6dfd 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,7 +1,7 @@ Package: dymiumCore Type: Package Title: The core functions of a Dynamic Microsimulation framework for Integrated Urban Models -Version: 0.1.2.9000 +Version: 0.1.3 Authors@R: c( person("Amarin", "Siripanich", email = "amarin@dymium.org", role = c("aut", "cre")), person("Taha", "Rashidi", role = c("aut"))) @@ -81,6 +81,7 @@ Collate: 'Network.R' 'Population.R' 'Pipeline.R' + 'Target.R' 'Transition.R' 'TransitionClassification.R' 'TransitionRegression.R' diff --git a/NAMESPACE b/NAMESPACE index 29d03d9e..b27b6671 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -31,6 +31,7 @@ export(Network) export(Pipeline) export(Population) export(SupportedTransitionModels) +export(Target) export(Transition) export(TransitionClassification) export(TransitionRegression) @@ -41,6 +42,7 @@ export(alignment) export(assert_entity) export(assert_entity_ids) export(assert_required_models) +export(assert_target) export(assert_transition_supported_model) export(assign_reference) export(check_entity) @@ -48,6 +50,7 @@ export(check_entity_ids) export(check_module) export(check_module_version) export(check_required_models) +export(check_target) export(check_transition_supported_model) export(combine_histories) export(create_scenario) @@ -60,6 +63,7 @@ export(element_wise_expand_lists) export(expect_entity) export(expect_entity_ids) export(expect_required_models) +export(expect_target) export(expect_transition_supported_model) export(get_active_scenario) export(get_all_module_files) @@ -85,6 +89,7 @@ export(set_active_scenario) export(test_entity) export(test_entity_ids) export(test_required_models) +export(test_target) export(test_transition_supported_model) export(trans) export(unnest_datatable) @@ -94,6 +99,8 @@ export(use_module_readme) export(validate_linkages) import(R6) import(data.table) +importFrom(checkmate,makeExpectation) +importFrom(checkmate,vname) importFrom(cli,cli_alert_danger) importFrom(cli,cli_alert_info) importFrom(cli,cli_li) diff --git a/NEWS.md b/NEWS.md index 8a2101cd..7634a713 100644 --- a/NEWS.md +++ b/NEWS.md @@ -1,14 +1,16 @@ -# dymiumCore (development version) +# dymiumCore 0.1.3 ## NEW FEATURES -1. Added a `plot_relationship` method to `Household`. This uses `visNetwork` for plotting (added to Suggests). See #48 for its implementation detail. +1. Add a `plot_relationship` method to `Household`. This uses `visNetwork` for plotting (added to Suggests). See #48 for its implementation detail. 2. `inspect` now has a verbose option. 3. `Transition` no longer removes the `NA` reponses when target is used. -4. Added a `replace` method to `World` which basically `remove` and `add` in one call. -5. Moved `$subset_ids()` from `Agent` to `Entity`. +4. Add a `replace` method to `World` which basically `remove` and `add` in one call. +5. Move `$subset_ids()` from `Agent` to `Entity`. 6. `download_module()` and `set_active_scenario()` now have a `.basedir` argument which sets the base directory where their files will be created at. By default this is the root folder of the currently active R project (if you are using RStudio) which is determined by `here::here()`. -7. Renamed `use_scenario` to `create_scenario` and `active_scenario` to `get_active_scenario`. +7. Rename `use_scenario` to `create_scenario` and `active_scenario` to `get_active_scenario`. +8. `TransitionClassification`'s target argument now accepts a dynamic target, see issue [#52] https://github.com/dymium-org/dymiumCore/issues/52. +9. Add a `Target` R6 class which acts as a wrapper for different types of target and make them work consistently in the `Transition` classes. ## BUG FIXES diff --git a/R/Generic.R b/R/Generic.R index c307c3a5..8f478b67 100644 --- a/R/Generic.R +++ b/R/Generic.R @@ -99,6 +99,19 @@ Generic <- R6Class( class = function() { class(self)[[1]] + }, + + print = function(...) { + dots <- list(...) + .class_inheritance <- glue::glue_collapse(class(self), sep = " <- ") + message( + glue::glue( + "Class: {class(self)[[1]]}", + "Inheritance: {.class_inheritance}", + "{dots[[1]]}", + .sep = "\n- " + ) + ) } ), diff --git a/R/Target.R b/R/Target.R new file mode 100644 index 00000000..5450898d --- /dev/null +++ b/R/Target.R @@ -0,0 +1,115 @@ +#' @title Target +#' +#' @usage NULL +#' @include Generic.R +#' @format [R6::R6Class] object inheriting [Generic]. +#' +#' @description +#' +#' `Target` is to be used within `TransitionClassification` or supply to event +#' functions. If the target is dynamic then its `get` will return its target +#' value at the current time or its closest time to the current time. +#' +#' @section Construction: +#' +#' ``` +#' Target$new(x) +#' ``` +#' +#' * `x` :: any object that passes `check_target()`\cr +#' A target object or `NULL`. +#' +#' @section Active Field (read-only): +#' +#' * `data`:: a target object\cr +#' A target object. +#' +#' * `dynamic`:: `logical(1)`\cr +#' A logical flag which indicates whether the target object is dynamic or not. +#' +#' @section Public Methods: +#' +#' * `get(time = .get_sim_time())`\cr +#' (`integer(1)`) -> a named `list()`\cr +#' Get a alignment target as a named list. +#' +#' @aliases Targets +#' @export +#' +#' @examples +#' +#' # static target +#' TrgtStatic <- Target$new(list(yes = 10)) +#' TrgtStatic$data +#' TrgtStatic$dynamic +#' TrgtStatic$get() +#' +#' # dynamic target +#' target_dynamic <- data.frame(time = 1:10, yes = 1:10) +#' TrgtDynamic <- Target$new(list(yes = 10)) +#' TrgtDynamic$data +#' TrgtDynamic$dynamic +#' +#' # if the `time` argument in `get()` is not specified then it will rely on +#' # the time step from the simulation clock from `.get_sim_time()`. +#' TrgtDynamic$get() +#' TrgtDynamic$get(1) +#' TrgtDynamic$get(10) +Target <- R6::R6Class( + classname = "Target", + inherit = dymiumCore::Generic, + public = list( + initialize = function(x) { + assert_target(x, null.ok = TRUE) + if (is.data.frame(x)) { + if (!is.data.table(x)) { + private$.data <- as.data.table(x) + } else { + private$.data <- data.table::copy(x) + } + if ("time" %in% names(x)) { + private$.dynamic <- TRUE + } + } + private$.data <- x + return(invisible(self)) + }, + + get = function(time = .get_sim_time()) { + if (private$.dynamic) { + closest_time_index <- which.min(abs(private$.data[['time']] - time)) + return(as.list(private$.data[closest_time_index, -c("time")])) + } + if (is.data.table(private$.data)) { + return(copy(private$.data)) + } + return(private$.data) + }, + + print = function() { + msg <- glue::glue("dynamic: {private$.dynamic}") + if (private$.dynamic) { + period <- c(min(private$.data[["time"]]), + max(private$.data[["time"]])) + msg <- glue::glue(msg, + "period: {period[1]} to {period[2]}", .sep = "\n- ") + } + super$print(msg) + } + ), + + active = list( + data = function() { + base::get(".data", envir = private) + }, + dynamic = function() { + base::get(".dynamic", envir = private) + } + ), + + private = list( + .data = NULL, + .dynamic = FALSE + ) + +) diff --git a/R/Transition.R b/R/Transition.R index b0ed9666..ccb780e8 100644 --- a/R/Transition.R +++ b/R/Transition.R @@ -7,6 +7,12 @@ #' Note that, to swap the run order of `filter()` and `mutate()` you need to change the #' `mutate_first` public field to `TRUE`. #' +#' @note +#' +#' `target` can be static or dynamic depending on the data structure of it. A static +#' target can be a named list or an integer value depending its usage in each +#' event function. +#' #' @section Construction: #' #' ``` @@ -82,13 +88,13 @@ Transition <- R6Class( # checks checkmate::assert_class(x, c("Agent")) checkmate::assert_subset(class(model)[[1]], choices = SupportedTransitionModels()) - checkmate::assert_list(target, any.missing = FALSE, types = 'integerish', names = 'strict', null.ok = TRUE) + dymiumCore::assert_target(target, null.ok = TRUE) checkmate::assert_integerish(targeted_agents, lower = 1, any.missing = FALSE, null.ok = TRUE) # store inputs private$.AgtObj <- x private$.model <- model - private$.target <- target + private$.target <- Target$new(target)$get() private$.targeted_agents <- targeted_agents # run the steps ------ @@ -245,22 +251,11 @@ Transition <- R6Class( simulate = function() { # expect a vector + lg$warn("Transition is not meant not be used directly! It only gives an incorrect \\ + simulation result for internal testing purposes! Please use \\ + TransitionClassification or TransitonRegression instead.") response <- rep(1, nrow(private$.sim_data)) # dummy - # response <- switch( - # EXPR = class(private$.model)[[1]], - # "train" = simulate_train(self, private), - # "data.table" = simulate_datatable(self, private), - # "list" = simulate_list(self, private), - # "NULL" = simulate_numeric(self, private), - # stop( - # glue::glue( - # "{class(self)[[1]]} class doesn't have an implementation of {class(private$.model)} \\ - # class. Please kindly request this in dymiumCore's Github issue or send in a PR! :)" - # ) - # ) - # ) - response }, @@ -337,9 +332,21 @@ Transition <- R6Class( ) ) - # Functions --------------------------------------------------------------- +.pick_target <- function(target) { + if (!is.data.frame(target)) { + return(target) + } + if (!is.data.table(target)) { + target <- as.data.table(target) + } + current_sim_time <- .get_sim_time() + + index_closest_time <- which.min(abs(target[['time']] - current_sim_time)) + + return(as.list(target[index_closest_time, -c("time")])) +} #' Get all object classes that are supported by Transition #' diff --git a/R/TransitionClassification.R b/R/TransitionClassification.R index 375e7cf4..4f3eff51 100644 --- a/R/TransitionClassification.R +++ b/R/TransitionClassification.R @@ -21,6 +21,19 @@ #' #' To get the simulation result use `$get_result()`. #' +#' @note +#' +#' `target` is used ensures that the aggregate outcome of the transition matches +#' a macro-level outcome as defined in `target`. This is known as 'alignment' see, +#' Li, J., & O'Donoghue, C. (2012). Evaluating binary alignment +#' methods in microsimulation models. For example, in a transition where the probabilistic +#' model predicts only two outcomes, a binary model, "yes" and "no". If the target +#' is a list of yes = 10 and no = 20 (i.e. `r list(yes = 10, no = 20)`), this will +#' ensure that there will be 10 decision makers whom select 'yes' and 20 decision makers +#' that select 'no'. However, this doesn't mean that all decision makers have +#' an equal odd of select 'yes' or 'no', the odd is still to be determined by the given +#' probalistic model. See [alignment] for more detail. +#' #' @section Construction: #' #' ``` @@ -35,17 +48,9 @@ #' #' * `target` :: a named `list()`\cr #' (Default as NULL). -#' A named list where the names of its elements correspond to the choices and -#' the values are the number of agents to choose those choices. This ensure that -#' the aggregate outcome of the transition matches a macro target. This is known -#' as 'alignment' see, Li, J., & O'Donoghue, C. (2012). Evaluating binary alignment -#' methods in microsimulation models. For example, in a transition where the probabilistic -#' model predicts only two outcomes, a binary model, "yes" and "no". If the target -#' is a list of yes = 10 and no = 20 (i.e. `r list(yes = 10, no = 20)`), this will -#' ensure that there will be 10 decision makers whom select 'yes' and 20 decision makers -#' that select 'no'. However, this doesn't mean that all decision makers have -#' an equal odd of select 'yes' or 'no', the odd is still to be determined by the given -#' probalistic model. See [alignment] for more detail. +#' `Target` or A named list where its names is a subset of to the choices in `model` +#' to be selected and its values are the number of agents to choose those choices. +#' See the note section for more details. #' #' * `targeted_agent` :: `integer()`\cr #' (Default as NULL) diff --git a/R/checkmate.R b/R/checkmate.R index 8c441fbd..3f111c85 100644 --- a/R/checkmate.R +++ b/R/checkmate.R @@ -171,3 +171,89 @@ test_required_models <- checkmate::makeTestFunction(check_required_models) #' @inheritParams checkmate::makeExpectation #' @rdname check_required_models expect_required_models <- checkmate::makeExpectationFunction(check_required_models) + +#' Check if argument is a valid target object +#' +#' A target object is either a named list that contains integer values (static target) or a +#' data.frame that contains a 'time' column and other response columns (dynamic target). The type of +#' of the target depends on its usage. +#' +#' Here is an example of a static target `list(yes=10, no=20)`. Here is an example +#' of a dynamic target `data.frame(time = c(1,2,3), yes = c(10,11,12), no = c(20,21,22)`. +#' +#' @param x any object to check +#' @param null.ok default as TRUE +#' +#' @return TRUE if `x` is a valid target object else throws an error. +#' +#' @export +check_target <- function(x, null.ok = TRUE) { + + if (is.null(x)) { + if (null.ok) { + return(TRUE) + } else { + msg = "`x` cannot be NULL." + return(msg) + } + } + + checkmate::assert( + checkmate::check_list( + x = x, + any.missing = FALSE, + types = c('integerish'), + names = 'strict', + null.ok = FALSE + ), + checkmate::check_data_frame( + x = x, + any.missing = FALSE, + min.cols = 2, + col.names = "strict", + null.ok = null.ok + ), + checkmate::check_r6( + x = x, + classes = c("Target", "Generic"), + null.ok = null.ok + ) + ) + + if (is.data.frame(x)) { + checkmate::assert_names( + x = names(x), + type = "strict", + must.include = "time" + ) + + checkmate::assert_integerish( + x$time, + lower = 1, + any.missing = FALSE, + min.len = 1, + null.ok = FALSE, + unique = TRUE, + .var.name = "`time` column" + ) + + } + + return(TRUE) +} + +#' @export +#' @param add [checkmate::AssertCollection]\cr +#' Collection to store assertions. See [checkmate::AssertCollection]. +#' @inheritParams checkmate::makeAssertion +#' @rdname check_target +assert_target <- checkmate::makeAssertionFunction(check_target) + +#' @export +#' @rdname check_target +test_target <- checkmate::makeTestFunction(check_target) + +#' @export +#' @inheritParams checkmate::makeExpectation +#' @rdname check_target +expect_target <- checkmate::makeExpectationFunction(check_target) diff --git a/R/dymiumCore-package.R b/R/dymiumCore-package.R index 5ec0b0cb..9fc5c86b 100644 --- a/R/dymiumCore-package.R +++ b/R/dymiumCore-package.R @@ -11,6 +11,7 @@ #' @name dymiumCore #' @import R6 #' @import data.table +#' @importFrom checkmate makeExpectation vname #' @importFrom glue glue glue_col glue_collapse #' @importFrom fs path dir_create path_ext_remove path_ext path_ext_set #' @importFrom usethis use_template use_directory diff --git a/_pkgdown.yml b/_pkgdown.yml index 92246945..c2bef77a 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -30,6 +30,13 @@ reference: - Population - pop_register - household_formation +- title: Transitions & Alignment + contents: + - matches("^Transition.") + - trans + - SupportedTransitionModels + - Target + - alignment - title: Logging contents: - add_history @@ -38,12 +45,6 @@ reference: - plot_history - inspect - get_log -- title: Transitions - contents: - - matches("^Transition.") - - trans - - SupportedTransitionModels - - alignment - title: Extra classes contents: - starts_with("Match") diff --git a/man/Target.Rd b/man/Target.Rd new file mode 100644 index 00000000..afe8190a --- /dev/null +++ b/man/Target.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/Target.R +\name{Target} +\alias{Target} +\alias{Targets} +\title{Target} +\format{\link[R6:R6Class]{R6::R6Class} object inheriting \link{Generic}.} +\description{ +\code{Target} is to be used within \code{TransitionClassification} or supply to event +functions. If the target is dynamic then its \code{get} will return its target +value at the current time or its closest time to the current time. +} +\section{Construction}{ +\preformatted{Target$new(x) +} +\itemize{ +\item \code{x} :: any object that passes \code{check_target()}\cr +A target object or \code{NULL}. +} +} + +\section{Active Field (read-only)}{ + +\itemize{ +\item \code{data}:: a target object\cr +A target object. +\item \code{dynamic}:: \code{logical(1)}\cr +A logical flag which indicates whether the target object is dynamic or not. +} +} + +\section{Public Methods}{ + +\itemize{ +\item \code{get(time = .get_sim_time())}\cr +(\code{integer(1)}) -> a named \code{list()}\cr +Get a alignment target as a named list. +} +} + +\examples{ + +# static target +TrgtStatic <- Target$new(list(yes = 10)) +TrgtStatic$data +TrgtStatic$dynamic +TrgtStatic$get() + +# dynamic target +target_dynamic <- data.frame(time = 1:10, yes = 1:10) +TrgtDynamic <- Target$new(list(yes = 10)) +TrgtDynamic$data +TrgtDynamic$dynamic + +# if the `time` argument in `get()` is not specified then it will rely on +# the time step from the simulation clock from `.get_sim_time()`. +TrgtDynamic$get() +TrgtDynamic$get(1) +TrgtDynamic$get(10) +} diff --git a/man/Transition.Rd b/man/Transition.Rd index 812bea2b..ad2dbb1c 100644 --- a/man/Transition.Rd +++ b/man/Transition.Rd @@ -9,6 +9,11 @@ Work flow: \code{initialise()} -> \code{filter()} -> \code{mutate()} -> \code{si Note that, to swap the run order of \code{filter()} and \code{mutate()} you need to change the \code{mutate_first} public field to \code{TRUE}. } +\note{ +\code{target} can be static or dynamic depending on the data structure of it. A static +target can be a named list or an integer value depending its usage in each +event function. +} \section{Construction}{ \preformatted{Transition$new(x, model, target = NULL, targeted_agents = NULL) } diff --git a/man/TransitionClassification.Rd b/man/TransitionClassification.Rd index a10b978f..9302f74e 100644 --- a/man/TransitionClassification.Rd +++ b/man/TransitionClassification.Rd @@ -43,6 +43,18 @@ To get the simulation result use \verb{$get_result()}. Create a \link{TransitionClassification} object. } +\note{ +\code{target} is used ensures that the aggregate outcome of the transition matches +a macro-level outcome as defined in \code{target}. This is known as 'alignment' see, +Li, J., & O'Donoghue, C. (2012). Evaluating binary alignment +methods in microsimulation models. For example, in a transition where the probabilistic +model predicts only two outcomes, a binary model, "yes" and "no". If the target +is a list of yes = 10 and no = 20 (i.e. \verb{r list(yes = 10, no = 20)}), this will +ensure that there will be 10 decision makers whom select 'yes' and 20 decision makers +that select 'no'. However, this doesn't mean that all decision makers have +an equal odd of select 'yes' or 'no', the odd is still to be determined by the given +probalistic model. See \link{alignment} for more detail. +} \section{Construction}{ \preformatted{TransitionClassification$new(x, model, target = NULL, targeted_agents = NULL) } @@ -53,17 +65,9 @@ An \link{Entity} object or its inheritances. A model object to be used to simulate transition. \item \code{target} :: a named \code{list()}\cr (Default as NULL). -A named list where the names of its elements correspond to the choices and -the values are the number of agents to choose those choices. This ensure that -the aggregate outcome of the transition matches a macro target. This is known -as 'alignment' see, Li, J., & O'Donoghue, C. (2012). Evaluating binary alignment -methods in microsimulation models. For example, in a transition where the probabilistic -model predicts only two outcomes, a binary model, "yes" and "no". If the target -is a list of yes = 10 and no = 20 (i.e. \verb{r list(yes = 10, no = 20)}), this will -ensure that there will be 10 decision makers whom select 'yes' and 20 decision makers -that select 'no'. However, this doesn't mean that all decision makers have -an equal odd of select 'yes' or 'no', the odd is still to be determined by the given -probalistic model. See \link{alignment} for more detail. +\code{Target} or A named list where its names is a subset of to the choices in \code{model} +to be selected and its values are the number of agents to choose those choices. +See the note section for more details. \item \code{targeted_agent} :: \code{integer()}\cr (Default as NULL) An integer vector that contains agents' ids of the \link{Entity} in \code{x} to undergo diff --git a/man/check_target.Rd b/man/check_target.Rd new file mode 100644 index 00000000..3bd8f876 --- /dev/null +++ b/man/check_target.Rd @@ -0,0 +1,47 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/checkmate.R +\name{check_target} +\alias{check_target} +\alias{assert_target} +\alias{test_target} +\alias{expect_target} +\title{Check if argument is a valid target object} +\usage{ +check_target(x, null.ok = TRUE) + +assert_target(x, null.ok = TRUE, .var.name = checkmate::vname(x), add = NULL) + +test_target(x, null.ok = TRUE) + +expect_target(x, null.ok = TRUE, info = NULL, label = vname(x)) +} +\arguments{ +\item{x}{any object to check} + +\item{null.ok}{default as TRUE} + +\item{.var.name}{[\code{character(1)}]\cr +The custom name for \code{x} as passed to any \code{assert*} function. +Defaults to a heuristic name lookup.} + +\item{add}{\link[checkmate:AssertCollection]{checkmate::AssertCollection}\cr +Collection to store assertions. See \link[checkmate:AssertCollection]{checkmate::AssertCollection}.} + +\item{info}{[\code{character(1)}]\cr +See \code{\link[testthat]{expect_that}}} + +\item{label}{[\code{character(1)}]\cr +See \code{\link[testthat]{expect_that}}} +} +\value{ +TRUE if \code{x} is a valid target object else throws an error. +} +\description{ +A target object is either a named list that contains integer values (static target) or a +data.frame that contains a 'time' column and other response columns (dynamic target). The type of +of the target depends on its usage. +} +\details{ +Here is an example of a static target \code{list(yes=10, no=20)}. Here is an example +of a dynamic target \verb{data.frame(time = c(1,2,3), yes = c(10,11,12), no = c(20,21,22)}. +} diff --git a/tests/testthat/test-Target.R b/tests/testthat/test-Target.R new file mode 100644 index 00000000..98feb3fe --- /dev/null +++ b/tests/testthat/test-Target.R @@ -0,0 +1,13 @@ +test_that("Target", { + Tgt <- Target$new(list(yes = 10)) + expect_equal(Tgt$data, list(yes = 10)) + expect_equal(Tgt$get(), list(yes = 10)) + expect_false(Tgt$dynamic) + + target_dynamic <- data.table::data.table(time = 1:10, yes = 10) + TgtDy <- Target$new(target_dynamic) + expect_equal(TgtDy$get(), list(yes = 10)) + expect_equal(TgtDy$data, target_dynamic) + expect_true(TgtDy$dynamic) + expect_target(TgtDy) +}) diff --git a/tests/testthat/test-TransitionClassification.R b/tests/testthat/test-TransitionClassification.R index 95b73c8d..2f9a6ab5 100644 --- a/tests/testthat/test-TransitionClassification.R +++ b/tests/testthat/test-TransitionClassification.R @@ -241,3 +241,66 @@ test_that("update", { checkmate::assert_character(names(table(Ind$get_attr("test"))), min.len = 1, unique = TRUE, null.ok = FALSE) }) + +test_that("dynamic target", { + + create_toy_world() + + model <- list(yes = 0.10, no = 0.90) + + dynamic_target <- + data.table( + time = c(1:10), + yes = sample(1:20, 10, replace = TRUE), + no = sample(1:20, 10, replace = TRUE) + ) + + TargetDynamic <- + data.table::data.table( + time = c(1:10), + yes = sample(1:20, 10, replace = TRUE), + no = sample(1:20, 10, replace = TRUE) + ) %>% + Target$new(.) + + event_dynamic_target <- function(world, model, target) { + + Ind <- world$get("Individual") + + DynamicTrans <- TransitionClassification$new(Ind, model, target) + + remove_ids <- DynamicTrans$get_result()[response == "yes", id] + + if (length(remove_ids) > 0) { + Ind$remove(ids = remove_ids) + } + + return(world) + } + + Ind <- world$get("Individual") + + n_ind_before <- Ind$n() + + for (i in 1:10) { + world$start_iter(time_step = i, unit = "year") %>% + event_dynamic_target(., model, target = dynamic_target) + } + + n_ind_after <- Ind$n() + + expect_true(n_ind_after + sum(dynamic_target$yes) == n_ind_before) + + # bad target, `nooo` is not a valid response + dynamic_target <- + data.table( + time = c(1:10), + yes = sample(1:20, 10, replace = TRUE), + no = sample(1:20, 10, replace = TRUE), + nooo = sample(1:20, 10, replace = TRUE) + ) + + expect_error(TransitionClassification$new(world$entities$Individual, model, dynamic_target), + regexp = "Must be a subset of set \\{yes,no\\}.") + +}) diff --git a/tests/testthat/test-checkmate.R b/tests/testthat/test-checkmate.R new file mode 100644 index 00000000..2ee8ee8d --- /dev/null +++ b/tests/testthat/test-checkmate.R @@ -0,0 +1,26 @@ +test_that("check_target", { + + expect_true(check_target(NULL)) + + expect_error(check_target(1)) + + expect_error(assert_target(1)) + + expect_error(assert_target(list(1))) + + expect_true(check_target(list(yes = 1))) + + expect_error(check_target(data.frame(1))) + + expect_error(check_target(data.frame(time = 1:10))) + + expect_error(check_target(data.frame(time = 1:10))) + + expect_error(check_target(data.frame(time = rep(1, 10))), + regexp = "Must have at least 2 cols, but has 1") + + expect_error(check_target(data.frame(time = paste(1:10)))) + + expect_true(check_target(data.frame(time = 1:10, yes = 1:10))) + +})