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

@@ -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 = "[email protected]", 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'

NAMESPACE

@@ -31,6 +31,7 @@ export(Network)
 export(Pipeline)
 export(Population)
 export(SupportedTransitionModels)
+export(Target)
 export(Transition)
 export(TransitionClassification)
 export(TransitionRegression)
@@ -41,13 +42,15 @@ 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)
 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)

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
 

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- "
+ )
+ )
  }
  ),
 

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
+ )
+
+)

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
 #'

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)