dev

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: dymiumCore
-Version: 0.1.9.9000
+Version: 0.1.9.9002
 Title: A Toolkit for Building a Dynamic Microsimulation Model for Integrated Urban Modelling
 Description: A modular microsimulation modelling framework for integrated urban modelling.
 Authors@R: c(
@@ -32,7 +32,7 @@ Imports:
     tryCatchLog (>= 1.1.0)
 Suggests:
     furrr (>= 0.1.0),
-    testthat (>= 2.1.0),
+    testthat (>= 3.0.0),
     fastmatch (>= 1.1.0),
     mlogit (>= 1.1.0),
     caret (>= 6.0.0),
@@ -118,3 +118,5 @@ Collate:
     'utils.R'
     'validate.R'
     'zzz.R'
+Config/testthat/parallel: true
+Config/testthat/edition: 3

NAMESPACE

@@ -18,6 +18,7 @@ S3method(predict,ModelMultinomialLogit)
 S3method(simulate_choice,Model)
 S3method(simulate_choice,WrappedModel)
 S3method(simulate_choice,data.frame)
+S3method(simulate_choice,dymium.choice_table)
 S3method(simulate_choice,glm)
 S3method(simulate_choice,list)
 S3method(simulate_choice,train)

NEWS.md

@@ -3,13 +3,16 @@
 ## New features
 
 - `ModelMultinomialLogit` and `ModelBinaryChoice` now have S3 `predict` and `summary` methods. Note that `ModelMultinomialLogit` requires `newdata` to be in the same format that is required by `mlogit`.
+- `Population$household_type()` now returns the number of members in household and remove individuals not belong to any household.
+- When calling `World$add()` and `name` is missing, it will see if the object has a `name` field, if it is a `Target` or a `Model`.
 
 ## Changes
 
 - closed #57
 - add a `name` argument to `Model`'s constructor function and expose it as an R6 active field. 
 - `World$add()` can now be used to add a named `Model` without providing the `name` argument.
 - `World$add()` gained a `replace` argument with `TRUE` as its default value. 
+- `Generic` now has an active `name` field which will equal to `NULL` if no name is given.
 
 ## Bug fixes
 

R/Entity-functions.R

@@ -137,7 +137,7 @@ impute_history <- function(entity, ids, event = NULL) {
 #' add_history(Ind, ids = sample(Ind$get_ids(), 10), event = "event1", time = 1)
 #' combine_histories(world)
 combine_histories <- function(x) {
-  checkmate::expect_r6(x, classes = "Container")
+  checkmate::assert_r6(x, classes = "Container")
   get_history(x) %>%
     purrr::keep(., ~ !is.null(.x)) %>%
     purrr::map2(.x = ., .y = names(.),

R/Generic.R

@@ -48,8 +48,11 @@ Generic <- R6Class(
   classname = "Generic",
   public = list(
 
-    initialize = function(...) {
-
+    initialize = function(name) {
+      if (!missing(name)) {
+        self$name <- name
+      }
+      invisible(self)
     },
 
     debug = function() {
@@ -126,6 +129,17 @@ Generic <- R6Class(
     }
   ),
 
+  active = list(
+    name = function(x) {
+      if (missing(x)) {
+        private$.name
+      } else {
+        checkmate::assert_string(x, null.ok = T, na.ok = FALSE)
+        private$.name <- x
+      }
+    }
+  ),
+
   private = list(
     .abstract = function(msg) {
       # this is a method for abstract methods
@@ -150,7 +164,9 @@ Generic <- R6Class(
       tag = character(),
       desc = character(),
       value = list()
-    )
+    ),
+
+    .name = NULL
 
   )
 )

R/Individual.R

@@ -295,8 +295,7 @@ Individual <- R6::R6Class(
       result <-
         private$get_relationship(ids, type = "children") %>%
         dt_group_and_sort(x = ., groupby_col = pid_col, group_col = "child_id", sort_order = ids)
-      checkmate::expect_set_equal(ids, result[['sort_col']], ordered = T,
-                                  info = "`ids` and the result are not equal.")
+      checkmate::assert_set_equal(ids, result[['sort_col']], ordered = TRUE)
       result[["group_col"]]
     },
 
@@ -307,8 +306,7 @@ Individual <- R6::R6Class(
         .[, living_together := self$living_together(self_ids = get(pid_col), target_ids = child_id)] %>%
         .[living_together == TRUE] %>%
         dt_group_and_sort(x = ., groupby_col = pid_col, group_col = "child_id", sort_order = ids)
-      checkmate::expect_set_equal(ids, result[['sort_col']], ordered = T,
-                                  info = "`ids` and the result are not equal.")
+      checkmate::assert_set_equal(ids, result[['sort_col']], ordered = TRUE)
       result[["group_col"]]
     },
 

R/MatchingMarket.R

@@ -99,8 +99,8 @@ MatchingMarket <- R6::R6Class(
                           grouping_vars = NULL,
                           max_market_size = 5000 ^ 2) {
       # CHECK INPUTS
-      checkmate::expect_data_table(agentset_A)
-      checkmate::expect_data_table(agentset_B)
+      checkmate::assert_data_table(agentset_A)
+      checkmate::assert_data_table(agentset_B)
 
       if (missing(id_col_A)) {
         stopifnot(uniqueN(agentset_A[, 1]) == nrow(agentset_A))

R/MatchingMarketOptimal.R

@@ -52,7 +52,7 @@ MatchingMarketOptimal <- R6::R6Class(
       parallel_wrapper <- function(...) {
         if (parallel) {
           stopifnot(requireNamespace('furrr'))
-          furrr::future_map_dfr(..., .options = furrr::future_options(globals = "self"))
+          furrr::future_map_dfr(..., .options = furrr::furrr_options(globals = "self"))
         } else {
           purrr::map_dfr(...)
         }

R/MatchingMarketStochastic.R

@@ -64,7 +64,7 @@ MatchingMarketStochastic <- R6::R6Class(
       parallel_wrapper <- function(...) {
         if (parallel) {
           stopifnot(requireNamespace('furrr'))
-          furrr::future_map_dfr(..., .options = furrr::future_options(globals = "self"))
+          furrr::future_map_dfr(..., .options = furrr::furrr_options(globals = "self"))
         } else {
           purrr::map_dfr(...)
         }

R/Model.R

@@ -100,8 +100,8 @@ Model <-
         checkmate::assert_function(preprocessing_fn, nargs = 1, null.ok = TRUE)
         self$preprocessing_fn <- preprocessing_fn
         self$set(x)
-        self$name <- name
-        invisible()
+        super$initialize(name = name)
+        invisible(self)
       },
       get = function() {
         private$.model
@@ -133,19 +133,10 @@ Model <-
           return(data.table::copy(private$.model))
         }
         get(".model", envir = private)
-      },
-      name = function(value) {
-        if (missing(value)) {
-          private$.name
-        } else {
-          checkmate::assert_string(value, null.ok = T, na.ok = FALSE)
-          private$.name <- value
-        }
       }
     ),
     private = list(
-      .model = NULL,
-      .name = NULL
+      .model = NULL
     )
   )
 

R/ModelMultinomialLogit.R

@@ -65,7 +65,7 @@ ModelMultinomialLogit <- R6::R6Class(
     #'  choice_id (`integer()`), linear_comb (`numeric()`), prob (`numeric()`). Note
     #'  that, 'linear_comb' stands for linear combination (i.e. $$B1 * x1 + B2 * x2$$).
     predict = function(newdata, chooser_id_col, choice_id_col) {
-      checkmate::expect_data_frame(newdata)
+      checkmate::assert_data_frame(newdata)
       data.table(chooser_id = newdata[[chooser_id_col]],
                  choice_id = newdata[[choice_id_col]],
                  linear_comb = private$.compute_linear_combination(newdata, chooser_id_col, choice_id_col)) %>%
@@ -76,7 +76,7 @@ ModelMultinomialLogit <- R6::R6Class(
   private = list(
     .compute_linear_combination = function(newdata, chooser_id_col, choice_id_col) {
       if (inherits(newdata, "dfidx")) {
-        checkmate::expect_names(x = names(newdata$idx),
+        checkmate::assert_names(x = names(newdata$idx),
                                 identical.to = c(chooser_id_col, choice_id_col))
       } else {
         newdata <-

R/Population.R

@@ -242,7 +242,9 @@ Population <- R6Class(
     leave_household = function(ind_ids) {
       # check that ids in ind_ids and their household ids exist
       stopifnot(self$get("Individual")$ids_exist(ids = ind_ids))
-      stopifnot(self$get("Household")$ids_exist(ids = self$get("Individual")$get_household_ids(ids = ind_ids)))
+      stopifnot(
+        self$get("Household")$ids_exist(
+          ids = self$get("Individual")$get_household_ids(ids = ind_ids)))
       # leave household
       self$get("Individual")$remove_household_id(ids = ind_ids)
       add_history(entity = self$get("Individual"),
@@ -286,6 +288,7 @@ Population <- R6Class(
         ), by = c(Ind$get_hid_col())] %>%
         # identify relationships
         .[, `:=`(
+          n_members = sapply(members, length),
           couple_hh = purrr::map2_lgl(members, partners, ~ {any(.y %in% .x)}),
           with_children = purrr::map2_lgl(members, parents, ~ {any(.y %in% .x)})
         )] %>%
@@ -304,7 +307,12 @@ Population <- R6Class(
           by.y = Ind$get_hid_col(),
           sort = FALSE,
           allow.cartesian = FALSE
-        )
+        ) %>%
+        # if there are individuals that don't belong to any household they would all
+        # be added into id:NA, so i thin
+        .[!is.na(id), ]
+
+
 
       checkmate::assert_character(household_type[["household_type"]], any.missing = FALSE)
 

R/Target.R

@@ -13,12 +13,16 @@
 #' @section Construction:
 #'
 #' ```
-#' Target$new(x)
+#' Target$new(x, name)
 #' ```
 #'
 #' * `x` :: any object that passes `check_target()`\cr
 #' A target object or `NULL`.
 #'
+#' * `name` :: `character(1)`\cr
+#' Name/Alias of the Target object. This will be used as the [Target] name when
+#' it gets added to a [World].
+#'
 #' @section Active Field (read-only):
 #'
 #'  * `data`:: a target object\cr
@@ -61,7 +65,7 @@ Target <- R6::R6Class(
   classname = "Target",
   inherit = dymiumCore::Generic,
   public = list(
-    initialize = function(x) {
+    initialize = function(x, name) {
       assert_target(x, null.ok = TRUE)
       if (is.data.frame(x)) {
         if (!"time" %in% names(x)) {
@@ -80,6 +84,7 @@ Target <- R6::R6Class(
       } else {
         private$.data <- x
       }
+      super$initialize(name = name)
       invisible(self)
     },
 

R/World.R

@@ -137,10 +137,11 @@ World <- R6::R6Class(
       )
 
       if (checkmate::test_r6(x, "World")) {
-        stop("Adding a World object is not permitted.")
+        stop("Adding a World object to another World object is not permitted.")
       }
 
-      if ((inherits(x, "Entity") | inherits(x, "Container")) & !inherits(x, "Model") & !inherits(x, "Target")) {
+      if ((inherits(x, "Entity") | inherits(x, "Container")) &
+          !inherits(x, "Model") & !inherits(x, "Target")) {
         stopifnot(x$is_dymium_class())
         if (!missing(name)) {
           lg$warn("The given `name` will be ignored since the object in x \\
@@ -150,11 +151,12 @@ World <- R6::R6Class(
         name <- class(x)[[1]]
       }
 
-      if (inherits(x, "Model") && !is.null(x$name)) {
-        name = x$name
+      if (missing(name) && !is.null(x$name) &&
+          (inherits(x, "Model") | inherits(x, "Target"))) {
+        name <- x$name
       }
 
-      # only allows letters and underscores
+      # only allows letters and underscores\
       checkmate::assert_string(name,
                                pattern = "^[a-zA-Z_]*$",
                                na.ok = FALSE,
@@ -197,10 +199,14 @@ World <- R6::R6Class(
 
       if (name_object_exists) {
         if (replace) {
-          lg$warn("Replacing the object named `{name}` of class `{.class_old}` \\
+          warn_msg =
+            glue::glue(
+              "Replacing the object named `{name}` of class `{.class_old}` \\
                   with `{.class_new}`.",
-                  .class_old = self$get(x = name)$class()[[1]],
-                  .class_new = class(x)[[1]])
+              .class_old = self$get(x = name)$class()[[1]],
+              .class_new = class(x)[[1]]
+            )
+          warning(warn_msg)
           self$remove(name)
         } else {
           stop(glue::glue("{name} already exists in {.listname}. Only one instance \\