feat: revamp the simulation clock

DESCRIPTION

@@ -81,6 +81,7 @@ Collate:
     'Network.R'
     'Population.R'
     'Pipeline.R'
+    'Target.R'
     'Transition.R'
     'TransitionClassification.R'
     'TransitionRegression.R'
@@ -89,6 +90,7 @@ Collate:
     'alignment.R'
     'checkmate.R'
     'checks.R'
+    'clock.R'
     'constants.R'
     'create-world.R'
     'data.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

@@ -2,13 +2,15 @@
 
 ## 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.table(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)

R/World.R

@@ -299,7 +299,7 @@ World <- R6::R6Class(
     },
 
     get_time = function(x) {
-      get("sim_time", envir = .DMevn)
+      getOption("dymium.simulation_clock")
     },
 
     get_info = function() {
@@ -310,7 +310,7 @@ World <- R6::R6Class(
     # @param x An integer value.
     set_time = function(x) {
       checkmate::assert_integerish(x, lower = 0, len = 1)
-      assign("sim_time", as.integer(x), envir = .DMevn)
+      options(dymium.simulation_clock = x)
       invisible()
     },