From 0602258ed2bdffb3827c0ac3870dbdd62b575d56 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 16 Aug 2020 16:43:08 +1000 Subject: [PATCH 01/38] add a test for Population --- R/Population.R | 4 +++- tests/testthat/test-Population.R | 12 ++++++++++++ 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/R/Population.R b/R/Population.R index a19d4f32..7140fab0 100644 --- a/R/Population.R +++ b/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"), diff --git a/tests/testthat/test-Population.R b/tests/testthat/test-Population.R index f915d682..cdc0b388 100644 --- a/tests/testthat/test-Population.R +++ b/tests/testthat/test-Population.R @@ -180,3 +180,15 @@ test_that("`household_type` of two random hid vectors of the same set be equipva all(table(Pop$household_type(hid = sample(1:100))) == table(Pop$household_type(hid = sample(1:100)))) ) }) + +# $leave_household ------------- +test_that("Population$leave_household()", { + create_toy_world() + Pop <- world$get("Population") + Ind <- world$get("Individual") + ind_ids <- sample(Ind$get_ids(), 10) + Pop$leave_household(ind_ids) + # Once individuals left households they cannot be leaving households again + expect_error(Pop$leave_household(ind_ids), + regexp = "Contains missing values") +}) From 209b1bc1b4faf6ef3d6c123364e4a6ac3a42e120 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Thu, 3 Sep 2020 22:21:36 +1000 Subject: [PATCH 02/38] feat: support a choice data.frame in simulate_choice --- NAMESPACE | 1 + R/simulate_choice.R | 77 +++++++++++++++++++++++++-- man/create_choice_table.Rd | 17 ++++++ man/simulate_choice.Rd | 5 +- tests/testthat/test-simulate-choice.R | 26 +++++++-- 5 files changed, 117 insertions(+), 9 deletions(-) create mode 100644 man/create_choice_table.Rd diff --git a/NAMESPACE b/NAMESPACE index 69b8daa9..0207e406 100644 --- a/NAMESPACE +++ b/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) diff --git a/R/simulate_choice.R b/R/simulate_choice.R index d7b293d6..0d595bb6 100644 --- a/R/simulate_choice.R +++ b/R/simulate_choice.R @@ -22,7 +22,7 @@ simulate_choice.train <- function(model, newdata, target = NULL, ...) { checkmate::assert_true(model$modelType == "Classification") probs <- predict(model, newdata, type = "prob") - simulate_choice(probs, target) + simulate_choice(create_choice_table(probs), target) } #' @rdname simulate_choice @@ -56,7 +56,7 @@ simulate_choice.glm <- function(model, newdata, target = NULL, ...) { {data.table::data.table(x1 = ., x2 = 1 - .)} %>% data.table::setnames(choices) - simulate_choice(probs, target) + simulate_choice(create_choice_table(probs), target) } #' @rdname simulate_choice @@ -96,12 +96,72 @@ simulate_choice.WrappedModel <- function(model, newdata, target = NULL, ...) { } else { probs <- mlr::getPredictionProbabilities(pred) } - simulate_choice(probs, target) + simulate_choice(create_choice_table(probs), target) } #' @rdname simulate_choice #' @export -simulate_choice.data.frame <- function(model, target = NULL, ...) { +simulate_choice.data.frame <- function(model, newdata, target = NULL, ...) { + + # convert to data.table + if (!is.data.table(model)) { + checkmate::assert_data_frame(model, min.rows = 1) + model <- as.data.table(model) + } + + if (!is.data.table(newdata)) { + checkmate::assert_data_frame(newdata, min.rows = 1) + newdata <- as.data.table(newdata) + } + + if (!xor("prob" %in% names(model), "probs" %in% names(model))) { + stop("`model` should contains a numeric probability column named `prob` in a binary", + " choice case or `probs` in a multiple choice case.") + } + + match_vars <- + names(model)[!names(model) %in% c("prob", "probs", "choices")] + + checkmate::assert_names(names(newdata), must.include = match_vars) + + if ("prob" %in% names(model)) { + probs <- + merge(newdata, model, match_vars, sort = FALSE) %>% + .[, .(yes = prob, no = 1 - prob)] + } + + if ("probs" %in% names(model)) { + if (!"choices" %in% names(model)) { + stop("`model` is missing a list column named `choices`.") + } + stop("`model` with multiple choices has not been developed yet :(.") + } + + if (nrow(probs) < nrow(newdata)) { + stop("There are less prediction results than `newdata`.") + } + + if (nrow(probs) > nrow(newdata)) { + stop("There are more prediction results than `newdata`.") + } + + # check cases + checkmate::assert_data_table( + probs, + types = 'double', + min.cols = 2, + any.missing = FALSE, + null.ok = FALSE, + col.names = 'unique' + ) + + simulate_choice(create_choice_table(probs), target) + +} + +#' @rdname simulate_choice +#' @export +simulate_choice.dymium.choice_table <- function(model, target = NULL, ...) { probs <- model checkmate::assert_data_frame( probs, @@ -123,3 +183,12 @@ simulate_choice.data.frame <- function(model, target = NULL, ...) { } } +#' prepend dymium.choice_table +#' +#' @param x any object. +#' +#' @return `x` +create_choice_table = function(x) { + class(x) <- c("dymium.choice_table", class(x)) + x +} diff --git a/man/create_choice_table.Rd b/man/create_choice_table.Rd new file mode 100644 index 00000000..b49b89b2 --- /dev/null +++ b/man/create_choice_table.Rd @@ -0,0 +1,17 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/simulate_choice.R +\name{create_choice_table} +\alias{create_choice_table} +\title{prepend dymium.choice_table} +\usage{ +create_choice_table(x) +} +\arguments{ +\item{x}{any object.} +} +\value{ +\code{x} +} +\description{ +prepend dymium.choice_table +} diff --git a/man/simulate_choice.Rd b/man/simulate_choice.Rd index dbf2150d..1dc1fca3 100644 --- a/man/simulate_choice.Rd +++ b/man/simulate_choice.Rd @@ -8,6 +8,7 @@ \alias{simulate_choice.Model} \alias{simulate_choice.WrappedModel} \alias{simulate_choice.data.frame} +\alias{simulate_choice.dymium.choice_table} \title{Simulate a choice situation} \usage{ simulate_choice(model, ...) @@ -22,7 +23,9 @@ simulate_choice(model, ...) \method{simulate_choice}{WrappedModel}(model, newdata, target = NULL, ...) -\method{simulate_choice}{data.frame}(model, target = NULL, ...) +\method{simulate_choice}{data.frame}(model, newdata, target = NULL, ...) + +\method{simulate_choice}{dymium.choice_table}(model, target = NULL, ...) } \arguments{ \item{model}{a \link{Model} object or an object in \code{\link[=SupportedTransitionModels]{SupportedTransitionModels()}}.} diff --git a/tests/testthat/test-simulate-choice.R b/tests/testthat/test-simulate-choice.R index 5a54babf..e76722a2 100644 --- a/tests/testthat/test-simulate-choice.R +++ b/tests/testthat/test-simulate-choice.R @@ -27,11 +27,29 @@ test_that("simulate_choice.train multilabels works", { test_that("simulate_choice.data.frame works", { n_rows <- 10 + + # this used to work in commit:0602258ed2bdffb3827c0ac3870dbdd62b575d56, but now is defunct probs <- data.frame(yes = runif(n_rows), no = runif(n_rows), maybe = runif(n_rows)) - checkmate::expect_character(simulate_choice(probs), - pattern = "yes|no|maybe", - any.missing = FALSE, - len = n_rows) + expect_error(simulate_choice(probs)) + + model <- data.frame(age = c(0:99, 0:99), + sex = c(rep('male', 100), rep('female', 100)), + prob = 0.05) + checkmate::expect_character( + simulate_choice(model, newdata = toy_individuals), + pattern = "yes|no", len = nrow(toy_individuals) + ) + checkmate::expect_character( + simulate_choice(as.data.table(model), newdata = toy_individuals), + pattern = "yes|no", len = nrow(toy_individuals) + ) + + model <- data.frame(age = 1, + sex = "female", + prob = 0.05) + expect_error(simulate_choice(model, newdata = toy_individuals), + regexp = "There are less prediction results than") + }) test_that("simulate_choice.WrappedModel from mlr works", { From 4591a5306052ed9107a874b371d87bd5dc49aa22 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:17:00 +1000 Subject: [PATCH 03/38] feat: Population$household_type now returns more fields --- NEWS.md | 1 + R/Population.R | 8 +++++++- 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index afacc55f..df6ecf89 100644 --- a/NEWS.md +++ b/NEWS.md @@ -3,6 +3,7 @@ ## 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. ## Changes diff --git a/R/Population.R b/R/Population.R index 7140fab0..03024c33 100644 --- a/R/Population.R +++ b/R/Population.R @@ -288,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)}) )] %>% @@ -306,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) From ff87b01cb8b9ee933ac9998f5921c4302e4feec8 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:20:30 +1000 Subject: [PATCH 04/38] Generic gains an active `name` field --- NEWS.md | 1 + R/Generic.R | 22 +++++++++++++++++++--- R/Model.R | 15 +++------------ R/Target.R | 9 +++++++-- man/Target.Rd | 5 ++++- 5 files changed, 34 insertions(+), 18 deletions(-) diff --git a/NEWS.md b/NEWS.md index df6ecf89..7a5bb358 100644 --- a/NEWS.md +++ b/NEWS.md @@ -11,6 +11,7 @@ - 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 diff --git a/R/Generic.R b/R/Generic.R index b0aff8f2..e6fe478a 100644 --- a/R/Generic.R +++ b/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 ) ) diff --git a/R/Model.R b/R/Model.R index a420f682..cfdc004b 100644 --- a/R/Model.R +++ b/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 ) ) diff --git a/R/Target.R b/R/Target.R index a4381a75..af891846 100644 --- a/R/Target.R +++ b/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) }, diff --git a/man/Target.Rd b/man/Target.Rd index 512cdf7b..b419ff48 100644 --- a/man/Target.Rd +++ b/man/Target.Rd @@ -13,11 +13,14 @@ 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) +\preformatted{Target$new(x, name) } \itemize{ \item \code{x} :: any object that passes \code{check_target()}\cr A target object or \code{NULL}. +\item \code{name} :: \code{character(1)}\cr +Name/Alias of the Target object. This will be used as the \link{Target} name when +it gets added to a \link{World}. } } From 02397e03c0ad6840c9c3bb353e166cccde4b5226 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:20:43 +1000 Subject: [PATCH 05/38] refactor codes --- R/transition-fnc.R | 2 +- tests/testthat/test-Model.R | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/R/transition-fnc.R b/R/transition-fnc.R index a76e2e56..aa8929cf 100644 --- a/R/transition-fnc.R +++ b/R/transition-fnc.R @@ -221,7 +221,6 @@ transition <- #' @export get_transition <- function(world, entity, model, target = NULL, targeted_ids = NULL, preprocessing_fn = NULL) { - checkmate::assert_r6(world, classes = "World") if(!checkmate::test_string(entity, na.ok = FALSE)) { @@ -254,6 +253,7 @@ get_transition <- function(world, entity, model, target = NULL, targeted_ids = N model$preprocessing_fn(e_data) } e_data <- dymiumCore::normalise_derived_vars(e_data) + # early return if no data if (nrow(e_data) == 0) { return(data.table(id = integer(), response = character())) } diff --git a/tests/testthat/test-Model.R b/tests/testthat/test-Model.R index 81b944c5..728966ca 100644 --- a/tests/testthat/test-Model.R +++ b/tests/testthat/test-Model.R @@ -1,7 +1,6 @@ test_that("Model initialisation", { m <- Model$new(list(x = 1), name = "model") expect_true(m$name == "model") - m <- Model$new(list(x = 1)) expect_null(m$null) }) From 12a139c3ddd9c749342c73dd0a7dfea6283fdf7f Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:21:14 +1000 Subject: [PATCH 06/38] test: remove makeModel's predict test for now --- tests/testthat/test-makeModel.R | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/tests/testthat/test-makeModel.R b/tests/testthat/test-makeModel.R index 6b3d8eb0..cad50ed2 100644 --- a/tests/testthat/test-makeModel.R +++ b/tests/testthat/test-makeModel.R @@ -7,6 +7,10 @@ test_that("makeModel", { checkmate::expect_numeric(predict(Mod, newdata = toy_individuals), finite = T, any.missing = FALSE) checkmate::expect_numeric(summary(Mod), names = "named") + # binary choice model without the dependent variable in newdata + # predict(Mod, newdata = toy_individuals[, -"sex"]) + # predict(Mod) + # mlogit model mlogit_model <- create_mlogit_model() Mod <- makeModel(mlogit_model) From 9d5dd3c835fca17d80e2a1e2136e515fbeae220c Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:23:06 +1000 Subject: [PATCH 07/38] update error msg in World$add() --- R/World.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/R/World.R b/R/World.R index 66323b6c..3c5bcdc3 100644 --- a/R/World.R +++ b/R/World.R @@ -137,7 +137,7 @@ 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")) { From f9f9ae37b8e34fc23954b9021e32eb6b67e5fa16 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:25:27 +1000 Subject: [PATCH 08/38] update world$add() --- NEWS.md | 1 + R/World.R | 2 +- 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/NEWS.md b/NEWS.md index 7a5bb358..b6fec862 100644 --- a/NEWS.md +++ b/NEWS.md @@ -4,6 +4,7 @@ - `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 diff --git a/R/World.R b/R/World.R index 3c5bcdc3..9dc8932a 100644 --- a/R/World.R +++ b/R/World.R @@ -150,7 +150,7 @@ World <- R6::R6Class( name <- class(x)[[1]] } - if (inherits(x, "Model")) { + if (missing(name) & (inherits(x, "Model") | inherits(x, "Target"))) { name <- x$name } From 2f4e980514d2a3c78b7aa4da647db66b3256bf7f Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:25:37 +1000 Subject: [PATCH 09/38] refactor: World --- R/World.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/R/World.R b/R/World.R index 9dc8932a..7f8a29b6 100644 --- a/R/World.R +++ b/R/World.R @@ -140,7 +140,8 @@ World <- R6::R6Class( 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 \\ From 40aecd5250331498776297f4003d447046666d01 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Fri, 18 Sep 2020 22:26:06 +1000 Subject: [PATCH 10/38] test: update World --- tests/testthat/test-World.R | 52 +++++++++++++++++++++++++------------ 1 file changed, 36 insertions(+), 16 deletions(-) diff --git a/tests/testthat/test-World.R b/tests/testthat/test-World.R index c1ef3f06..abf1b97e 100644 --- a/tests/testthat/test-World.R +++ b/tests/testthat/test-World.R @@ -1,4 +1,7 @@ test_that("add", { + + lg$set_threshold("warn") + w <- World$new() # add container @@ -7,23 +10,26 @@ test_that("add", { pid_col = c("pid"), hid_col = "hid")) - expect_warning(w$add( - Population$new( - ind_data = toy_individuals, - hh_data = toy_households, - pid_col = c("pid"), - hid_col = "hid" - ) - ), regexp = "^Replacing ") + expect_output( + w$add( + Population$new( + ind_data = toy_individuals, + hh_data = toy_households, + pid_col = c("pid"), + hid_col = "hid" + ) + ), + regexp = "Replacing the object named" + ) # add entities w$add(Agent$new(toy_individuals, "pid")) w$add(Firm$new(toy_individuals, "pid")) expect_length(w$entities, 4) - expect_warning(w$add(Individual$new(toy_individuals, "pid")), - "^Replacing") - expect_warning(w$add(Household$new(toy_households, "hid")), - "^Replacing") + expect_output(w$add(Individual$new(toy_individuals, "pid")), + "Replacing the object named") + expect_output(w$add(Household$new(toy_households, "hid")), + "Replacing the object named") # add model w$add(list(x = 1), "testModel") @@ -33,8 +39,11 @@ test_that("add", { w$add(Model$new(list(x = 1), "namedModel")) w$add(list(x = 1), "namedModel") - # add world ? - expect_error(w$add(w), regexp = "Adding a World object is not permitted.") + # a world within another world is not permitted + expect_error( + w$add(w), + regexp = "Adding a World object to another World object is not permitted." + ) }) @@ -119,10 +128,21 @@ test_that("active fields", { }) test_that("add target", { - t <- Target$new(x = list(yes = 10, no = 20)) w <- World$new() + + # name using the name arg + t <- Target$new(x = list(yes = 10, no = 20)) w$add(x = t, name = "a_target") - expect_error(w$add(x = t, name = "a_target")) + expect_target(w$targets[["a_target"]], null.ok = FALSE) + expect_output(w$add(x = t, name = "a_target"), regexp = "Replacing the object named") + + # unnamed target + expect_error(w$add(x = t), regexp = "Must be of type 'string', not 'NULL'.") + + # named target + t <- Target$new(x = list(yes = 10, no = 20), name = "a_target") + expect_output(w$add(x = t), regexp = "Replacing the object named") + expect_target(w$targets[["a_target"]], null.ok = FALSE) }) test_that("set_scale", { From 2d4bf8b1110429e43c10e985c481909eb0100f92 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 8 Nov 2020 22:13:35 +1100 Subject: [PATCH 11/38] test: run testthat unit tests in parallel with v3.0.0 --- DESCRIPTION | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 12987cab..457a75a8 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -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 From a383492dd960fca1b8a983348b6928a1d01eae46 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 8 Nov 2020 22:15:18 +1100 Subject: [PATCH 12/38] fix: replaced future_options with furrr_options --- R/MatchingMarketOptimal.R | 2 +- R/MatchingMarketStochastic.R | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/R/MatchingMarketOptimal.R b/R/MatchingMarketOptimal.R index 5f65fe7d..3cb4ffa4 100644 --- a/R/MatchingMarketOptimal.R +++ b/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(...) } diff --git a/R/MatchingMarketStochastic.R b/R/MatchingMarketStochastic.R index d11b53f2..8f1b44d0 100644 --- a/R/MatchingMarketStochastic.R +++ b/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(...) } From e23de67973c6a5f5202b64fc51610672446c3f87 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 8 Nov 2020 22:24:15 +1100 Subject: [PATCH 13/38] refactor: simulate_choice --- R/simulate_choice.R | 26 +++++++++----------------- man/sample_choice_table.Rd | 21 +++++++++++++++++++++ man/simulate_choice.Rd | 4 +++- tests/testthat/test-simulate-choice.R | 2 +- 4 files changed, 34 insertions(+), 19 deletions(-) create mode 100644 man/sample_choice_table.Rd diff --git a/R/simulate_choice.R b/R/simulate_choice.R index 0d595bb6..e1ad9be6 100644 --- a/R/simulate_choice.R +++ b/R/simulate_choice.R @@ -137,49 +137,41 @@ simulate_choice.data.frame <- function(model, newdata, target = NULL, ...) { stop("`model` with multiple choices has not been developed yet :(.") } - if (nrow(probs) < nrow(newdata)) { - stop("There are less prediction results than `newdata`.") - } - - if (nrow(probs) > nrow(newdata)) { - stop("There are more prediction results than `newdata`.") - } - # check cases checkmate::assert_data_table( probs, types = 'double', min.cols = 2, + nrows = nrow(newdata), any.missing = FALSE, null.ok = FALSE, col.names = 'unique' ) simulate_choice(create_choice_table(probs), target) - } #' @rdname simulate_choice +#' @param choice_table a `choice_table` object, created by `create_choice_table()`. #' @export -simulate_choice.dymium.choice_table <- function(model, target = NULL, ...) { - probs <- model +simulate_choice.dymium.choice_table <- function(choice_table, target = NULL, ...) { checkmate::assert_data_frame( - probs, + choice_table, types = 'double', min.cols = 2, any.missing = FALSE, null.ok = FALSE, col.names = 'unique' ) - if (!is.data.table(probs)) { - setDT(probs) + if (!is.data.table(choice_table)) { + setDT(choice_table) } - choices <- names(probs) + choices <- names(choice_table) # random draw choices if (!is.null(target)) { - alignment(probs, target) + alignment(choice_table, target) } else { - purrr::pmap_chr(probs, ~ sample_choice(choices, 1, prob = (list(...)))) + purrr::pmap_chr(choice_table, ~ sample_choice(choices, 1, prob = (list(...)))) } } diff --git a/man/sample_choice_table.Rd b/man/sample_choice_table.Rd new file mode 100644 index 00000000..d25a8b24 --- /dev/null +++ b/man/sample_choice_table.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/simulate_choice.R +\name{sample_choice_table} +\alias{sample_choice_table} +\title{Sample a choice table} +\usage{ +sample_choice_table(x, target = NULL, ...) +} +\arguments{ +\item{x}{a \code{choice_table} object.} + +\item{target}{a \link{Target} object.} + +\item{...dots}{} +} +\value{ +a character vector. +} +\description{ +Sample a choice table +} diff --git a/man/simulate_choice.Rd b/man/simulate_choice.Rd index 1dc1fca3..864960e3 100644 --- a/man/simulate_choice.Rd +++ b/man/simulate_choice.Rd @@ -25,7 +25,7 @@ simulate_choice(model, ...) \method{simulate_choice}{data.frame}(model, newdata, target = NULL, ...) -\method{simulate_choice}{dymium.choice_table}(model, target = NULL, ...) +\method{simulate_choice}{dymium.choice_table}(choice_table, target = NULL, ...) } \arguments{ \item{model}{a \link{Model} object or an object in \code{\link[=SupportedTransitionModels]{SupportedTransitionModels()}}.} @@ -36,6 +36,8 @@ simulate_choice(model, ...) \item{target}{a \link{Target} object or a named list this is for aligning the simulation outcome to an external target.} + +\item{choice_table}{a \code{choice_table} object, created by \code{create_choice_table()}.} } \value{ a character vector diff --git a/tests/testthat/test-simulate-choice.R b/tests/testthat/test-simulate-choice.R index e76722a2..af9b5a87 100644 --- a/tests/testthat/test-simulate-choice.R +++ b/tests/testthat/test-simulate-choice.R @@ -48,7 +48,7 @@ test_that("simulate_choice.data.frame works", { sex = "female", prob = 0.05) expect_error(simulate_choice(model, newdata = toy_individuals), - regexp = "There are less prediction results than") + regexp = "Assertion on 'probs' failed") }) From ef07fc23007ceb0b3c9cb1e3431df840d36f8cf6 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 8 Nov 2020 22:25:52 +1100 Subject: [PATCH 14/38] feat(World): output a warning when add() replaces an existing object. --- R/World.R | 10 +++++++--- tests/testthat/test-World.R | 10 +++++----- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/R/World.R b/R/World.R index d6059a83..3b5d158f 100644 --- a/R/World.R +++ b/R/World.R @@ -199,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 \\ diff --git a/tests/testthat/test-World.R b/tests/testthat/test-World.R index 1cc50a42..b15552b9 100644 --- a/tests/testthat/test-World.R +++ b/tests/testthat/test-World.R @@ -13,7 +13,7 @@ test_that("add", { # change to capture the warning messages lg$set_threshold("warn") - expect_output(w$add( + expect_warning(w$add( Population$new( ind_data = toy_individuals, hh_data = toy_households, @@ -26,9 +26,9 @@ test_that("add", { w$add(Agent$new(toy_individuals, "pid")) w$add(Firm$new(toy_individuals, "pid")) expect_length(w$entities, 4) - expect_output(w$add(Individual$new(toy_individuals, "pid")), + expect_warning(w$add(Individual$new(toy_individuals, "pid")), "Replacing") - expect_output(w$add(Household$new(toy_households, "hid")), + expect_warning(w$add(Household$new(toy_households, "hid")), "Replacing") lg$set_threshold("fatal") @@ -137,14 +137,14 @@ test_that("add target", { w$add(x = t, name = "a_target") expect_target(w$targets[["a_target"]], null.ok = FALSE) - expect_output(w$add(x = t, name = "a_target"), regexp = "Replacing the object named") + expect_warning(w$add(x = t, name = "a_target"), regexp = "Replacing the object named") # unnamed target expect_error(w$add(x = t), regexp = "argument \"name\" is missing, with no default") # named target t <- Target$new(x = list(yes = 10, no = 20), name = "a_target") - expect_output(w$add(x = t), regexp = "Replacing the object named") + expect_warning(w$add(x = t), regexp = "Replacing the object named") expect_target(w$targets[["a_target"]], null.ok = FALSE) checkmate::expect_r6(w$targets$a_target, "Target") }) From 9aa0d22598bef00c7a0d5776242308ccb385fc69 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 16:05:09 +1100 Subject: [PATCH 15/38] closed #77 --- DESCRIPTION | 2 +- NAMESPACE | 2 -- R/MatchingMarketOptimal.R | 6 ++++++ R/dymiumCore-package.R | 1 - 4 files changed, 7 insertions(+), 4 deletions(-) diff --git a/DESCRIPTION b/DESCRIPTION index 457a75a8..14fa3428 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -18,7 +18,6 @@ Imports: R6 (>= 2.3.0), data.table (>= 1.13.0), checkmate (>= 1.9.4), - matchingR (>= 1.3.0), magrittr, purrr (>= 0.3.0), lgr (>= 0.3.3), @@ -31,6 +30,7 @@ Imports: rlang (>= 0.4.0), tryCatchLog (>= 1.1.0) Suggests: + matchingR (>= 1.3.0), furrr (>= 0.1.0), testthat (>= 3.0.0), fastmatch (>= 1.1.0), diff --git a/NAMESPACE b/NAMESPACE index 0207e406..9ee855f9 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -162,8 +162,6 @@ importFrom(magrittr,"%>%") importFrom(magrittr,freduce) importFrom(magrittr,functions) importFrom(magrittr,set_colnames) -importFrom(matchingR,galeShapley.collegeAdmissions) -importFrom(matchingR,galeShapley.marriageMarket) importFrom(purrr,flatten_int) importFrom(purrr,map) importFrom(purrr,map2) diff --git a/R/MatchingMarketOptimal.R b/R/MatchingMarketOptimal.R index 3cb4ffa4..7f5e9c67 100644 --- a/R/MatchingMarketOptimal.R +++ b/R/MatchingMarketOptimal.R @@ -38,6 +38,12 @@ MatchingMarketOptimal <- R6::R6Class( optimal_A = TRUE, by_group = FALSE, parallel = FALSE) { + + if (!requireNamespace("matchingR", quietly = TRUE)) { + stop("Package \"matchingR\" needed for this function to work. Please install it.", + call. = FALSE) + } + method <- match.arg(method) checkmate::assert_flag(one_sided, na.ok = FALSE, null.ok = FALSE) checkmate::assert_flag(optimal_A, na.ok = FALSE, null.ok = FALSE) diff --git a/R/dymiumCore-package.R b/R/dymiumCore-package.R index dd2f04f9..d3efe535 100644 --- a/R/dymiumCore-package.R +++ b/R/dymiumCore-package.R @@ -20,7 +20,6 @@ #' @importFrom here here #' @importFrom magrittr freduce functions set_colnames #' @importFrom purrr flatten_int map map_lgl map2 map2_int map2_dfr walk walk2 -#' @importFrom matchingR galeShapley.marriageMarket galeShapley.collegeAdmissions #' @importFrom utils packageVersion download.file #' @keywords internal "_PACKAGE" From 136fd7553e52cd5be92ca2d560e15dc37b9bba15 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 16:35:46 +1100 Subject: [PATCH 16/38] removed all module-related files --- DESCRIPTION | 2 - NAMESPACE | 10 -- R/module.R | 233 ----------------------------- R/usethis.R | 174 --------------------- inst/templates/README.Rmd | 12 -- inst/templates/constants.R | 15 -- inst/templates/event-no-comments.R | 15 -- inst/templates/event.R | 115 -------------- inst/templates/helpers.R | 14 -- inst/templates/logger.R | 30 ---- inst/templates/module-README.Rmd | 130 ---------------- inst/templates/test.R | 13 -- man-roxygen/repo-arg.R | 1 - man/check_module.Rd | 25 ---- man/check_module_version.Rd | 28 ---- man/download_module.Rd | 47 ------ man/get_all_module_files.Rd | 24 --- man/get_module_files.Rd | 26 ---- man/get_module_versions.Rd | 25 ---- man/get_modules.Rd | 23 --- man/use_event.Rd | 37 ----- man/use_module.Rd | 36 ----- man/use_module_readme.Rd | 21 --- tests/testthat/test-module.R | 31 ---- 24 files changed, 1087 deletions(-) delete mode 100644 R/module.R delete mode 100644 R/usethis.R delete mode 100644 inst/templates/README.Rmd delete mode 100644 inst/templates/constants.R delete mode 100644 inst/templates/event-no-comments.R delete mode 100644 inst/templates/event.R delete mode 100644 inst/templates/helpers.R delete mode 100644 inst/templates/logger.R delete mode 100644 inst/templates/module-README.Rmd delete mode 100644 inst/templates/test.R delete mode 100644 man-roxygen/repo-arg.R delete mode 100644 man/check_module.Rd delete mode 100644 man/check_module_version.Rd delete mode 100644 man/download_module.Rd delete mode 100644 man/get_all_module_files.Rd delete mode 100644 man/get_module_files.Rd delete mode 100644 man/get_module_versions.Rd delete mode 100644 man/get_modules.Rd delete mode 100644 man/use_event.Rd delete mode 100644 man/use_module.Rd delete mode 100644 man/use_module_readme.Rd delete mode 100644 tests/testthat/test-module.R diff --git a/DESCRIPTION b/DESCRIPTION index 14fa3428..3e675c74 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -103,14 +103,12 @@ Collate: 'data.R' 'dymiumCore-package.R' 'makeModel.R' - 'module.R' 'mutate-entity.R' 'population-register.R' 'scenario.R' 'sim.R' 'simulate_choice.R' 'transition-fnc.R' - 'usethis.R' 'utils-class.R' 'utils-event.R' 'utils-pipe.R' diff --git a/NAMESPACE b/NAMESPACE index 9ee855f9..cfa8e7ef 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -73,8 +73,6 @@ export(assert_target) export(assert_transition_supported_model) export(check_entity) export(check_entity_ids) -export(check_module) -export(check_module_version) export(check_required_models) export(check_subset2) export(check_target) @@ -85,7 +83,6 @@ export(create_toy_population) export(create_toy_world) export(dm_get_model) export(dm_save) -export(download_module) export(dsample) export(element_wise_expand_lists) export(expect_entity) @@ -96,13 +93,9 @@ export(expect_target) export(expect_transition_supported_model) export(extract_data) export(get_active_scenario) -export(get_all_module_files) export(get_history) export(get_log) export(get_models) -export(get_module_files) -export(get_module_versions) -export(get_modules) export(get_sim_time) export(get_supported_models) export(get_transition) @@ -133,9 +126,6 @@ export(test_target) export(test_transition_supported_model) export(transition) export(unnest_dt) -export(use_event) -export(use_module) -export(use_module_readme) export(validate_linkages) export(which_max_n) export(which_min_n) diff --git a/R/module.R b/R/module.R deleted file mode 100644 index 811bee0e..00000000 --- a/R/module.R +++ /dev/null @@ -1,233 +0,0 @@ -dymiumModulesRepo <- "dymium-org/dymiumModules" - -#' Download a module from a repository. -#' -#' @description -#' -#' Download and extract a module to the 'modules' folder in the active working directory. -#' If you are using an RStudio project then it will be saved in the 'modules' folder -#' of your project. If the 'modules' folder does not exist, it will be created. -#' -#' @param name name of the module. -#' @param version the version of the module to download. If not given, the latest version will -#' be downloaded. -#' @param force A logical value. force download even though the module already exists locally. -#' @param remove_download a logical value whether to delete the downloaded zip file or not. -#' @param .basedir :: `character(1)`\cr -#' The base directory that the downloaded module will be saved at. [here::here()] is -#' used to provide the default value which is is the root folder of the active RStudio project. -#' @template repo-arg -#' -#' @return path to the module. -#' -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' # download an test module. -#' download_modules('test', version = '0.0.1') -#' } -#' -download_module <- function(name, repo = dymiumModulesRepo, version, force = FALSE, remove_download = FALSE, .basedir = here::here()) { - modules_path <- fs::path(.basedir, "modules") - usethis::use_directory('modules') - all_module_files <- get_all_module_files() - all_versions <- extract_module_versions(name = name, filenames = all_module_files) - if (missing(version)) { - cli::cli_alert_warning("The argument 'version' was not specified. The latest \\ - version of the module '{.strong {name}}' will be downloaded.") - version <- max(numeric_version(all_versions, strict = TRUE)) - cli::cli_alert_info("The latest version of module '{.strong {name}}' is '{version}'.") - } else { - check_version(version, all_versions, name = name) - } - module_filename <- paste0(name, "_", version) - if (isFALSE(force) && fs::dir_exists(fs::path(modules_path, module_filename))) { - cli::cli_alert_danger("'{.strong {module_filename}}' already exists in \\ - directory: '{modules_path}'. Since `force` is FALSE \\ - the module will not be overwritten.") - } - if (force) { - cli::cli_alert_warning("Force overwriting the module if already exists.") - } - module_download_url <- - paste0("https://github.com/", repo, "/raw/master/modules/", name, "/", module_filename, ".zip") - tmp_module_path <- fs::path(modules_path, "temp-module.zip") - utils::download.file(url = module_download_url, destfile = tmp_module_path, overwrite = FALSE, cacheOK = FALSE) - utils::unzip(zipfile = tmp_module_path, exdir = fs::path(modules_path, name), overwrite = FALSE) - if (remove_download) { - fs::file_delete(path = tmp_module_path) - } - cli::cli_alert_success("'{.strong {name}}' module version {.strong {version}} was successfully downloaded \\ - and added to directory: '{modules_path}'") - invisible() -} - -#' Check if a module exists in a remote repository -#' -#' @param name name of the module to check. -#' @template repo-arg -#' -#' @return a logical value. -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' check_module('test') -#' } -check_module <- function(name, repo = dymiumModulesRepo) { - checkmate::assert_character(name, any.missing = FALSE, len = 1, null.ok = FALSE) - checkmate::test_subset(name, choices = get_modules(), empty.ok = FALSE) -} - -#' Check the existence of a module version. -#' -#' @param name name of the module. -#' @param version a character. For example, if you would like to check -#' for version 0.1.0 type it as a character '0.1.0'. -#' -#' @template repo-arg -#' -#' @return a logical value -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' check_module_version('test', version = '0.0.1') -#' } -check_module_version <- function(name, repo = dymiumModulesRepo, version) { - all_versions <- get_module_versions(name = name, repo = repo) - res <- checkmate::test_subset(version, choices = all_versions) - return(check_version(version, all_versions, name = name)) -} - -check_version <- function(x, versions, name = "this") { - res <- checkmate::test_subset(x, choices = versions) - if (!res) { - cli::cli_alert_warning("{.strong {name}} module doesn't have a version {.strong {x}}.") - if (length(versions) != 0) { - cli::cli_alert_info("These are the available versions of {.strong {name}} module:") - cli::cli_li(items = sort(versions)) - } - stop(glue::glue("The requested version of {name} module doesn't exist.")) - } - return(res) -} - -extract_module_versions <- function(name, filenames) { - versions <- .filter_zip_versions(x = filenames, name = name) - if (length(versions) == 0) { - stop(glue("'{name}' module has no available versions.")) - } - return(versions) -} - -#' Get all version numbers of a module -#' -#' @param name name of the module. -#' @template repo-arg -#' -#' @return a character vector. -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' get_module_versions("demography") -#' } -get_module_versions <- function(name, repo = dymiumModulesRepo) { - module_files <- get_module_files(name = name, repo = repo) - versions <- .filter_zip_versions(x = module_files, name = name) - if (length(versions) == 0) { - stop(glue("'{name}' module has no available versions.")) - } - return(versions) -} - -.filter_zip_versions <- function(x, name) { - x %>% - gsub(pattern = paste0("modules/", name, "/"), replacement = "", x = .) %>% - grep(paste0("^", name, ".+.zip"), x = ., value = TRUE) %>% - gsub(pattern = paste0(name, "_"), replacement = "", x = .) %>% - gsub(pattern = "\\.zip", replacement = "", x = .) %>% - sort() -} - -#' Get the names of available modules from a remote repository -#' -#' @template repo-arg -#' -#' @return a character vector. -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' get_modules() -#' } -get_modules <- function(repo = dymiumModulesRepo) { - all_files <- get_all_module_files(repo = repo) - available_modules <- grep(paste0("^modules/"), all_files, value = TRUE) %>% - # replace everything after the second back slash with -1 - gsub("^([^/]*/[^/]*/).*$","-1", .) %>% - gsub("modules/", "", .) %>% - grep(pattern = "-1", x = ., value = TRUE, invert = TRUE) - return(available_modules) -} - -#' Get all files from a module -#' -#' @param name name of the module. -#' @template repo-arg -#' -#' @return a character vector. -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' get_module_files("demography") -#' } -#' -get_module_files <- function(name, repo = dymiumModulesRepo) { - checkmate::assert_character(name, len = 1, null.ok = FALSE, any.missing = FALSE) - if (!checkmate::test_subset(name, choices = get_modules(repo = repo), empty.ok = FALSE)) { - stop(glue::glue("'{name}' module doesn't exists in the '{repo}' repository.")) - } - module_files <- get_all_module_files(repo = repo) %>% - grep(name, x = ., value = T) - return(module_files) -} - -#' Get all files from all modules in a repository. -#' -#' @template repo-arg -#' -#' @return a character vector. -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' get_all_module_files("dymium-org/dymiumModules") -#' } -#' -get_all_module_files <- function(repo = dymiumModulesRepo) { - checkmate::assert_character(repo, len = 1, null.ok = FALSE, any.missing = FALSE) - apiurl <- paste0("https://api.github.com/repos/", repo, "/git/trees/master?recursive=1") - pat <- Sys.getenv("GITHUB_PAT") - request <- if (identical(pat, "")) { - httr::GET(apiurl) - } else { - cli::cli_alert_info("Using GitHub PAT from envvar GITHUB_PAT") - httr::GET(apiurl, config = list(httr::config(token = pat))) - } - request <- httr::GET(apiurl) - httr::stop_for_status(request) - all_module_files <- unlist(lapply(httr::content(request)$tree, "[", "path"), use.names = FALSE) %>% - grep("^modules/", x = ., value = TRUE) - return(all_module_files) -} diff --git a/R/usethis.R b/R/usethis.R deleted file mode 100644 index e1d4d2b5..00000000 --- a/R/usethis.R +++ /dev/null @@ -1,174 +0,0 @@ -#' Create an event. -#' -#' @description -#' -#' This function creates an event script from the provided event template inside -#' a module along with a testtthat test script. -#' -#' @param name Name of the event. -#' @param module Name of the module folder to add a event file to. The function -#' looks for a folder inside the `modules` folder at the root folder of the active -#' R project. If the module folder is not found or has not been created this will -#' return an error. -#' @param with_comments a logical value. If `TRUE` the generated event script will contain -#' comments about what each component inside the script does and some recommendations -#' for the user to follow when authoring an event. For advance users, you may not need -#' this hence you may specify `FALSE`. If missing, it will be prompted in the console -#' for you to decide. -#' -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' # Note: running this will create a folder called "modules" and a sub-folder -#' # to your working directory within the folder called "demography" -#' use_module(name = "demography") -#' -#' # create an event called 'birth' inside the 'demography' module. -#' use_event(name = "birth", module = 'demography') -#' } -use_event <- function(name, module, with_comments) { - .check_file_name(name) - - if (!has_module(module)) { - stop(glue("A module called '{module}' doesn't exist. Please make \\ - sure the module has been created with `dymiumCore::use_module('{module}')` \\ - before using this function.")) - } - - event_path <- fs::path("modules", module, .slug(name, "R")) - module_path <- fs::path("modules", module) - - if (missing(with_comments)) { - with_comments <- c(FALSE, TRUE)[utils::menu(choices = c("No", "Yes"), - title = "Do you want to have authors' comments in the event script?")] - } else { - checkmate::assert_logical(with_comments, len = 1, null.ok = FALSE) - } - - template <- ifelse(with_comments, "event.R", "event-no-comments.R") - - usethis::use_template(template = template, - save_as = event_path, - data = list(module_path = module_path, - event = name, - module = module), - package = "dymiumCore") - - invisible(event_path) -} - -#' Create and setup a module folder. -#' -#' @description -#' This function creates a new module inside the modules folder of an active r project. -#' If the 'modules' folder doesn't exist it will create it then adds a new folder -#' with the name as specified in the `name` argument inside the 'modules' folder. -#' R scripts to be used across the module will be added which contain the following: -#' -#' * a lgr logger script, -#' * a script that contains constant values, and -#' * a script for storing helper functions. -#' -#' Since dymium modules use the 'modules' and 'checkmate' packages, if these -#' packages are not installed the function will ask whether you would like to -#' install them or not. -#' -#' Note that, to add event functions to a module see [use_event]. -#' -#' @param name Name of the module. -#' -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' # Note: running this will create a folder called "modules" and a sub-folder -#' # to your working directory within the folder called "demography" -#' use_module(name = "demography") -#' } -use_module <- function(name) { - .check_file_name(name) - - required_pkgs <- c("modules", "lgr", "checkmate", "here", "R6") - sapply(required_pkgs, check_pkg_installed) - - module_path <- fs::path("modules", name) - - if (has_module(name)) { - stop(glue("The module {name} already exists at {module_path}.")) - } - - usethis::use_directory("modules", ignore = TRUE) - usethis::use_directory(module_path) - - usethis::use_template( - template = "module-README.rmd", - save_as = fs::path(module_path, "README.rmd"), - data = list(module_path = module_path, - module = name), - package = "dymiumCore" - ) - usethis::use_template( - template = "logger.R", - save_as = fs::path(module_path, "logger.R"), - data = list(module_path = module_path, - module = name), - package = "dymiumCore" - ) - usethis::use_template( - template = "constants.R", - save_as = fs::path(module_path, "constants.R"), - data = list(module_path = module_path, - module = name), - package = "dymiumCore" - ) - usethis::use_template( - template = "helpers.R", - save_as = fs::path(module_path, "helpers.R"), - data = list(module_path = module_path, - module = name), - package = "dymiumCore" - ) - - invisible(module_path) -} - -#' Add a README rmarkdown file to an existing module -#' -#' @param name name of an existing module -#' -#' @return NULL -#' @export -#' -#' @examples -#' -#' \dontrun{ -#' # this assumes that you have a module named 'demography' -#' use_module_readme(name = "demography") -#' } -use_module_readme <- function(name) { - module_path <- fs::path("modules", name) - if (!has_module(name)) { - stop(glue("The module {name} doesn't exists at {module_path}.")) - } - usethis::use_template( - template = "module-README.rmd", - save_as = fs::path(module_path, "README.rmd"), - data = list(module_path = module_path, - module = name), - package = "dymiumCore" - ) -} - -check_pkg_installed <- function(pkg) { - if (!requireNamespace(pkg, quietly = TRUE)) { - stop(glue("Package '{pkg}' required. Please install before re-trying.")) - } -} - -has_module <- function(name) { - path <- fs::path("modules", name) - fs::file_exists(path) -} diff --git a/inst/templates/README.Rmd b/inst/templates/README.Rmd deleted file mode 100644 index af1b51f0..00000000 --- a/inst/templates/README.Rmd +++ /dev/null @@ -1,12 +0,0 @@ ---- -title: "Untitled" -output: github_document ---- - -```{r setup, include=FALSE} -knitr::opts_chunk$set(echo = TRUE) -``` - -# Developer instruction - -To remove all comments from an R script use `formatR::tidy_source(x, comments = FALSE)`. diff --git a/inst/templates/constants.R b/inst/templates/constants.R deleted file mode 100644 index 9d84e17f..00000000 --- a/inst/templates/constants.R +++ /dev/null @@ -1,15 +0,0 @@ -# Constant values to be used within the module can be declared here. -# -# To use these constants inside your event script you may import the constants script -# as the following 'constants <- modules::import('{{{module_path}}}/constants.R')'. -# -# The following codes are examples of how you may declare your constants. -modules::export('MYFIRST_CONSTANT') # must export your constants, individually. -MYFIRST_CONSTANT <- list() -MYFIRST_CONSTANT$SOMEVALUE1 <- 'VALUE1' -MYFIRST_CONSTANT$SOMEVALUE2 <- 'VALUE2' - -modules::export('MYSECOND_CONSTANT') # must export your constants, individually. -MYSECOND_CONSTANT <- list() -MYSECOND_CONSTANT$SOMEVALUE1 <- 'VALUE1' -MYSECOND_CONSTANT$SOMEVALUE2 <- 'VALUE2' diff --git a/inst/templates/event-no-comments.R b/inst/templates/event-no-comments.R deleted file mode 100644 index c691714b..00000000 --- a/inst/templates/event-no-comments.R +++ /dev/null @@ -1,15 +0,0 @@ -modules::import("dymiumCore") -modules::import("checkmate") -modules::expose(here::here("{{{module_path}}}/logger.R")) -constants <- modules::use(here::here("{{{module_path}}}/constants.R")) -helpers <- modules::use(here::here("{{{module_path}}}/helpers.R")) -modules::export("^run$|^REQUIRED_MODELS$") -REQUIRED_MODELS <- NULL -run <- function(world, model = NULL, target = NULL, time_steps = NULL) { - if (!dymiumCore::is_scheduled(time_steps)) { - return(invisible(world)) - } - lg$info("Running {{{event}}}") - model <- pick_models(model, world, REQUIRED_MODELS) - invisible(world) -} diff --git a/inst/templates/event.R b/inst/templates/event.R deleted file mode 100644 index e18d5aab..00000000 --- a/inst/templates/event.R +++ /dev/null @@ -1,115 +0,0 @@ -# It is recommended to assign this module in your run script to a variable -# called: 'event_{{{module}}}_{{{event}}}' -# for example: -# event_{{{module}}}_{{{event}}} <- modules::use('modules/{{{module}}}/{{{event}}}.R') - -# default setup, you may edit the below import statments to match your requirements. -modules::import('dymiumCore') -modules::import('checkmate') -modules::expose(here::here('{{{module_path}}}/logger.R')) # import lgr's logger. To use the logger use 'lg' (default logger's name). -constants <- modules::use(here::here('{{{module_path}}}/constants.R')) -helpers <- modules::use(here::here('{{{module_path}}}/helpers.R')) - -modules::export('^run$|^REQUIRED_MODELS$') # default exported functions - - -# Required models --------------------------------------------------------- -# NOTE: The names of the required models for the event go here. This will be used -# to check whether the input 'world' object or the model argument contains -# the models as required. -# Example: -# REQUIRED_MODELS <- c("MyBinaryModel", "MyRegressionModel") -REQUIRED_MODELS <- NULL - -# Main function ----------------------------------------------------------- -#' {{{event}}} -#' -#' Please see the module's README file for the details of this event function. -#' -#' @param world a [dymiumCore::World] object. -#' @param model a model object or a named list of model objects that are sip. -#' @param target a positive integers or a named list of positive integers. -#' @param time_steps a positive integer vector. -#' -#' @return x -run <- function(world, model = NULL, target = NULL, time_steps = NULL) { - - # early return if `time_steps` is not the current time - if (!dymiumCore::is_scheduled(time_steps)) { - return(invisible(world)) - } - - # logging to console - lg$info('Running {{{event}}}') - - # check the `model` argument - # Note: - # 1) if the `model` argument is given, meaning not `NULL` by default, the objects - # inside will be used first instead of the added model objects inside 'world'. - # However, if there are some required models that cannot be found in `model` - # it try to find them in `world`. If they are yet to be found then an error - # will be returned. - # 2) if the event is deterministic like 'ageing' or doesn't require models then - # you may remove the five lines below entirely and add a warning message to - # notify the user when the model argument is not NULL. - model <- pick_models(model, world, REQUIRED_MODELS) - - # uncomment the line belows if the event doesn't require `model` - # eg. If the event is deterministic like ageing. - # if (!is.null(model)) { - # lg$warn('`model` will not be used.') - # } - - # uncomment the line belows if the event doesn't require `target` - # eg. If the event is to be applied to all agents. - # if (!is.null(target)) { - # lg$warn('`target` will not be used.') - # } - - # (Recommended) - # create a reference to the entity and model objects for easy access for examples: - # To get entities.. - # Pop <- world$get("Population") - # Hh <- world$("Household") - # To get models.. - # MyModel <- world$get("MyModel") - # MyModel <- world$get_model("MyModel") - - # The beginning of the steps ----------------------- - - - - - # The end of the steps ----------------------- - - # always return the 'world' object invisibly. - invisible(world) -} - - -# Customised Transition classes ------------------------------------------- -# Note: If you need to add extra preprocessing steps to your Transition class -# you will need to extend TransitionClassification or TransitionRegression -# as necessary. -# Use the commented Transition codes below as a template for your own Transition class. -# TransitionDescription <- -# R6::R6Class( -# classname = "TransitionDescription", -# inherit = dymiumCore::TransitionClassification, -# public = list( -# mutate = function(.data) { -# .data %>% -# # create five years age group -# .[, age_group := cut(age, breaks = seq(0, 100, 5), include.lowest = TRUE, right = FALSE)] -# }, -# filter = function(.data) { -# .data %>% -# # only keep all agents with age less than 100 -# .[age < 100, ] -# } -# ) -# ) - - - -# Utility functions ------------------------------------------------------- diff --git a/inst/templates/helpers.R b/inst/templates/helpers.R deleted file mode 100644 index 8732e0ec..00000000 --- a/inst/templates/helpers.R +++ /dev/null @@ -1,14 +0,0 @@ -# The script is where helper functions of the module should reside. -# Sometimes you may have a function that are used across the module, in many events, -# this is the central place for you to store this type of function. Hence, in every -# event scrips that you create using 'dymiumCore::use_event' this script, helpers.R, -# will be imported. If not needed, you may remove the import line. -# -# To use these helper functions inside your event script I suggest you import the helper script -# as the following 'helpers <- modules::import('{{{module_path}}}/helpers.R')'. - -# If the package dymimCore is not needed you may remove the line below which imports it -modules::import('dymiumCore') - -# If you need your constants here uncomment the line below -# constants <- modules::use('{{{module_path}}}/constants.R') diff --git a/inst/templates/logger.R b/inst/templates/logger.R deleted file mode 100644 index 3fe8c585..00000000 --- a/inst/templates/logger.R +++ /dev/null @@ -1,30 +0,0 @@ -# This script creates a logger to be used across the module. -# To customise and learn more out the logger package used here please read the -# vignette of 'lgr' package (https://github.com/s-fleck/lgr). -# To use the logger inside your event script you may import the constants script -# as the following 'modules::expose('{{{module_path}}}/logger.R')' the logger -# A neat modification that I like to do is to colorize the -# name of my module's logger by changing '{.logger$name}' to '{crayon::blue(.logger$name)}' -# this will make your module's logger name more standout on your R console. To make -# the color modification you will need to have 'crayon' package installed. -# -# -# TL;DR - to use logger put this 'modules::expose('{{{module_path}}}/logger.R')' in your -# event script. Then use the following commands. -# -# > lg$info('I am the info-level logger') -# > lg$warn('I am the warn-level logger') -# > lg$error('I am the error-level logger') -# -# !! The codes below should work without any modifications, however if you are -# comfortable with how the 'lgr' and 'modules' packages work you may modify -# the codes below. -modules::import('lgr') -modules::export('lg') -lg <- lgr::get_logger_glue(name = '{{{module}}}') -lg$set_appenders(list(cons = lgr::AppenderConsole$new())) -lg$appenders$cons$set_layout(lgr::LayoutGlue$new( - fmt = '[{format(timestamp, \"%H:%M:%S\")}] \\ - {pad_right(colorize_levels(toupper(level_name)), 5)} \\ - {crayon::blue(.logger$name)} {caller}: {msg}')) -lg$set_propagate(FALSE) diff --git a/inst/templates/module-README.Rmd b/inst/templates/module-README.Rmd deleted file mode 100644 index 2063a488..00000000 --- a/inst/templates/module-README.Rmd +++ /dev/null @@ -1,130 +0,0 @@ ---- -output: - github_document: - toc: true - toc_depth: 2 ---- - -```{r setup, include=FALSE} -knitr::opts_chunk$set(echo = TRUE) -``` - -# {{{module}}} module documentation - -- Authors: Your name -- Email: your@email.com -- Current version: 0.1 - -This module provides the following functionalities... - -# Release notes - -## Version 0.1 - -This is the first version of this module. - -# Requirements - -This module requires the following packages ... and external dependecies such as ... - -# Events - -## Event name 1 - -### Description - -This event does... - -
- -Some technical details of the inner working, assumptions, and settings of the event function that shouldn't bother the user at their first glance. - -
- -### Usage - -```{r} -event_{{{module}}}_eventname1 <- modules::use(here::here("{{{module_path}}}/eventname.R")) -``` - -```{r, echo = FALSE} -event_{{{module}}}_eventname1 -``` - -### Params - -* world: a World object. -* model: a named list. - -```{r} -# For example -model <- list(x1 = list(yes = 0.5, no = 0.5), - x2 = data.table(sex = c("male", "female"), prob = c(0.2, 0.1))) -``` - -* target: a named list. -* time_steps: a numeric vector that indicates the time steps in the simulation clock -that this event should be run. - -### Example - -```{r, eval = FALSE} -event_{{{module}}}_eventname1 <- modules::use(here::here("{{{module_path}}}/eventname.R")) - -create_toy_world() - -world %>% - event_{{{module}}}_eventname1$run(world = ., model = model) -``` - -## Event name 2 - -### Description - -This event does... - -
- -Some technical details of the inner working, assumptions, and settings of the event function that shouldn't bother the user at their first glance. - -
- -### Usage - -```{r} -event_{{{module}}}_eventname2 <- modules::use(here::here("{{{module_path}}}/eventname.R")) -``` - -```{r, echo = FALSE} -event_{{{module}}}_eventname2 -``` - -### Params - -* world: a World object. -* model: a named list. - -```{r} -# For example -model <- list(x1 = list(yes = 0.5, no = 0.5), - x2 = data.table(sex = c("male", "female"), prob = c(0.2, 0.1))) -``` - -* target: a named list. -* time_steps: a numeric vector that indicates the time steps in the simulation clock -that this event should be run. - -### Example - -```{r, eval = FALSE} -event_{{{module}}}_eventname2 <- modules::use(here::here("{{{module_path}}}/eventname.R")) - -create_toy_world() - -world %>% - event_{{{module}}}_eventname2$run(world = ., model = model) -``` - -# Known issues - -Here are some known issues diff --git a/inst/templates/test.R b/inst/templates/test.R deleted file mode 100644 index d52007e7..00000000 --- a/inst/templates/test.R +++ /dev/null @@ -1,13 +0,0 @@ -# note: The 'Run tests' button in RStudio may not work (Please let me know if you can make it work!) -# to run this test use # test_file('{{{test_path}}}') -# import the module -library(dymiumCore) -# set logger's threshold to 'warn' to mute info level loggings -dymiumCore:::lg$set_threshold(level = 'warn') -{{{event_function_name}}} <- modules::use(here::here('{{{event_path}}}')) - -# write your on tests using testthat::test_that(...) -test_that('event works', { - # for example - expect_true(1 == 1) -}) diff --git a/man-roxygen/repo-arg.R b/man-roxygen/repo-arg.R deleted file mode 100644 index 462aef85..00000000 --- a/man-roxygen/repo-arg.R +++ /dev/null @@ -1 +0,0 @@ -#' @param repo A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'. diff --git a/man/check_module.Rd b/man/check_module.Rd deleted file mode 100644 index 57b9ce76..00000000 --- a/man/check_module.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{check_module} -\alias{check_module} -\title{Check if a module exists in a remote repository} -\usage{ -check_module(name, repo = dymiumModulesRepo) -} -\arguments{ -\item{name}{name of the module to check.} - -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} -} -\value{ -a logical value. -} -\description{ -Check if a module exists in a remote repository -} -\examples{ - -\dontrun{ - check_module('test') -} -} diff --git a/man/check_module_version.Rd b/man/check_module_version.Rd deleted file mode 100644 index e1507b09..00000000 --- a/man/check_module_version.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{check_module_version} -\alias{check_module_version} -\title{Check the existence of a module version.} -\usage{ -check_module_version(name, repo = dymiumModulesRepo, version) -} -\arguments{ -\item{name}{name of the module.} - -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} - -\item{version}{a character. For example, if you would like to check -for version 0.1.0 type it as a character '0.1.0'.} -} -\value{ -a logical value -} -\description{ -Check the existence of a module version. -} -\examples{ - -\dontrun{ - check_module_version('test', version = '0.0.1') -} -} diff --git a/man/download_module.Rd b/man/download_module.Rd deleted file mode 100644 index e735b9f1..00000000 --- a/man/download_module.Rd +++ /dev/null @@ -1,47 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{download_module} -\alias{download_module} -\title{Download a module from a repository.} -\usage{ -download_module( - name, - repo = dymiumModulesRepo, - version, - force = FALSE, - remove_download = FALSE, - .basedir = here::here() -) -} -\arguments{ -\item{name}{name of the module.} - -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} - -\item{version}{the version of the module to download. If not given, the latest version will -be downloaded.} - -\item{force}{A logical value. force download even though the module already exists locally.} - -\item{remove_download}{a logical value whether to delete the downloaded zip file or not.} - -\item{.basedir}{:: \code{character(1)}\cr -The base directory that the downloaded module will be saved at. \code{\link[here:here]{here::here()}} is -used to provide the default value which is is the root folder of the active RStudio project.} -} -\value{ -path to the module. -} -\description{ -Download and extract a module to the 'modules' folder in the active working directory. -If you are using an RStudio project then it will be saved in the 'modules' folder -of your project. If the 'modules' folder does not exist, it will be created. -} -\examples{ - -\dontrun{ - # download an test module. - download_modules('test', version = '0.0.1') -} - -} diff --git a/man/get_all_module_files.Rd b/man/get_all_module_files.Rd deleted file mode 100644 index 550ea87f..00000000 --- a/man/get_all_module_files.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{get_all_module_files} -\alias{get_all_module_files} -\title{Get all files from all modules in a repository.} -\usage{ -get_all_module_files(repo = dymiumModulesRepo) -} -\arguments{ -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} -} -\value{ -a character vector. -} -\description{ -Get all files from all modules in a repository. -} -\examples{ - -\dontrun{ - get_all_module_files("dymium-org/dymiumModules") -} - -} diff --git a/man/get_module_files.Rd b/man/get_module_files.Rd deleted file mode 100644 index 0a0aa6c0..00000000 --- a/man/get_module_files.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{get_module_files} -\alias{get_module_files} -\title{Get all files from a module} -\usage{ -get_module_files(name, repo = dymiumModulesRepo) -} -\arguments{ -\item{name}{name of the module.} - -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} -} -\value{ -a character vector. -} -\description{ -Get all files from a module -} -\examples{ - -\dontrun{ - get_module_files("demography") -} - -} diff --git a/man/get_module_versions.Rd b/man/get_module_versions.Rd deleted file mode 100644 index e2831a8d..00000000 --- a/man/get_module_versions.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{get_module_versions} -\alias{get_module_versions} -\title{Get all version numbers of a module} -\usage{ -get_module_versions(name, repo = dymiumModulesRepo) -} -\arguments{ -\item{name}{name of the module.} - -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} -} -\value{ -a character vector. -} -\description{ -Get all version numbers of a module -} -\examples{ - -\dontrun{ - get_module_versions("demography") -} -} diff --git a/man/get_modules.Rd b/man/get_modules.Rd deleted file mode 100644 index bd94cc91..00000000 --- a/man/get_modules.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/module.R -\name{get_modules} -\alias{get_modules} -\title{Get the names of available modules from a remote repository} -\usage{ -get_modules(repo = dymiumModulesRepo) -} -\arguments{ -\item{repo}{A GitHub repository to look for modules. By default, this uses 'dymium-org/dymiumModules'.} -} -\value{ -a character vector. -} -\description{ -Get the names of available modules from a remote repository -} -\examples{ - -\dontrun{ - get_modules() -} -} diff --git a/man/use_event.Rd b/man/use_event.Rd deleted file mode 100644 index 23b59b2d..00000000 --- a/man/use_event.Rd +++ /dev/null @@ -1,37 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/usethis.R -\name{use_event} -\alias{use_event} -\title{Create an event.} -\usage{ -use_event(name, module, with_comments) -} -\arguments{ -\item{name}{Name of the event.} - -\item{module}{Name of the module folder to add a event file to. The function -looks for a folder inside the \code{modules} folder at the root folder of the active -R project. If the module folder is not found or has not been created this will -return an error.} - -\item{with_comments}{a logical value. If \code{TRUE} the generated event script will contain -comments about what each component inside the script does and some recommendations -for the user to follow when authoring an event. For advance users, you may not need -this hence you may specify \code{FALSE}. If missing, it will be prompted in the console -for you to decide.} -} -\description{ -This function creates an event script from the provided event template inside -a module along with a testtthat test script. -} -\examples{ - -\dontrun{ - # Note: running this will create a folder called "modules" and a sub-folder - # to your working directory within the folder called "demography" - use_module(name = "demography") - - # create an event called 'birth' inside the 'demography' module. - use_event(name = "birth", module = 'demography') -} -} diff --git a/man/use_module.Rd b/man/use_module.Rd deleted file mode 100644 index 6e95ffc8..00000000 --- a/man/use_module.Rd +++ /dev/null @@ -1,36 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/usethis.R -\name{use_module} -\alias{use_module} -\title{Create and setup a module folder.} -\usage{ -use_module(name) -} -\arguments{ -\item{name}{Name of the module.} -} -\description{ -This function creates a new module inside the modules folder of an active r project. -If the 'modules' folder doesn't exist it will create it then adds a new folder -with the name as specified in the \code{name} argument inside the 'modules' folder. -R scripts to be used across the module will be added which contain the following: -\itemize{ -\item a lgr logger script, -\item a script that contains constant values, and -\item a script for storing helper functions. -} - -Since dymium modules use the 'modules' and 'checkmate' packages, if these -packages are not installed the function will ask whether you would like to -install them or not. - -Note that, to add event functions to a module see \link{use_event}. -} -\examples{ - -\dontrun{ - # Note: running this will create a folder called "modules" and a sub-folder - # to your working directory within the folder called "demography" - use_module(name = "demography") -} -} diff --git a/man/use_module_readme.Rd b/man/use_module_readme.Rd deleted file mode 100644 index f67a7f0a..00000000 --- a/man/use_module_readme.Rd +++ /dev/null @@ -1,21 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/usethis.R -\name{use_module_readme} -\alias{use_module_readme} -\title{Add a README rmarkdown file to an existing module} -\usage{ -use_module_readme(name) -} -\arguments{ -\item{name}{name of an existing module} -} -\description{ -Add a README rmarkdown file to an existing module -} -\examples{ - -\dontrun{ -# this assumes that you have a module named 'demography' -use_module_readme(name = "demography") -} -} diff --git a/tests/testthat/test-module.R b/tests/testthat/test-module.R deleted file mode 100644 index a7bfd047..00000000 --- a/tests/testthat/test-module.R +++ /dev/null @@ -1,31 +0,0 @@ -test_that("check_module", { - skip_on_ci() - skip_on_not_master() - expect_true(check_module("demography")) -}) - -test_that("get_modules", { - skip_on_ci() - skip_on_not_master() - checkmate::expect_names(get_modules(), must.include = c("demography", "matsim", "test")) -}) - -test_that(".filter_zip_versions", { - name <- "demography" - module_files <- c("modules/demography/readme.txt", - "modules/demography/event1.R", - "modules/demography/demography_1.0.0.zip", - "modules/demography/demography_1.2.0.zip", - "modules/demography/demography_dummy.zip", - "modules/demography/demography_dummy.1.2", - "modules/demography/demography_1.3.0/", - "modules/demography/demography_zip") - expect_length(.filter_zip_versions(x = module_files, name), n = 3) -}) - -test_that("get_module", { - skip_on_ci() - skip_on_not_master() - expect_error(download_module(name = "test", version = "10.0.0", force = T, remove_download = T), - regexp = "The requested version of test module doesn't exist.") -}) From b648fcecad6e93e59f20b0eb494c50cf0a682a85 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 16:48:19 +1100 Subject: [PATCH 17/38] removed all Building classes --- DESCRIPTION | 4 --- NAMESPACE | 4 --- R/Building.R | 53 ---------------------------------- R/BuildingCommercial.R | 42 --------------------------- R/BuildingIndustrial.R | 39 ------------------------- R/BuildingResidential.R | 45 ----------------------------- man/Building.Rd | 40 ------------------------- man/BuildingCommercial.Rd | 27 ----------------- man/BuildingIndustrial.Rd | 30 ------------------- man/BuildingResidential.Rd | 30 ------------------- tests/testthat/test-Building.R | 41 -------------------------- 11 files changed, 355 deletions(-) delete mode 100644 R/Building.R delete mode 100644 R/BuildingCommercial.R delete mode 100644 R/BuildingIndustrial.R delete mode 100644 R/BuildingResidential.R delete mode 100644 man/Building.Rd delete mode 100644 man/BuildingCommercial.Rd delete mode 100644 man/BuildingIndustrial.Rd delete mode 100644 man/BuildingResidential.Rd delete mode 100644 tests/testthat/test-Building.R diff --git a/DESCRIPTION b/DESCRIPTION index 3e675c74..62fd0981 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -62,10 +62,6 @@ Collate: 'Entity.R' 'Agent.R' 'Asset.R' - 'Building.R' - 'BuildingCommercial.R' - 'BuildingIndustrial.R' - 'BuildingResidential.R' 'ContainerGeneric.R' 'Container.R' 'DataBackend.R' diff --git a/NAMESPACE b/NAMESPACE index cfa8e7ef..7247a013 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -28,10 +28,6 @@ export("%>%") export(.get_sim_time) export(Agent) export(Asset) -export(Building) -export(BuildingCommercial) -export(BuildingIndustrial) -export(BuildingResidential) export(Container) export(ContainerGeneric) export(DataBackend) diff --git a/R/Building.R b/R/Building.R deleted file mode 100644 index 21897ca6..00000000 --- a/R/Building.R +++ /dev/null @@ -1,53 +0,0 @@ -#' @title Building class -#' @format [R6::R6Class] object inheriting from [Asset]<-[Entity]. -#' @include Asset.R -#' -#' @description -#' Create a building object. -#' -#' ``` -#' x <- Building$new(.data, id_col, owner) -#' ``` -#' -#' Stores `.data` as a DataBackend object inside the object's list of data (`private$.data`) -#' and registers the `id_col` (`private$.id_col`). -#' -#' * `.data` :: `data.frame`\cr -#' A object that inherits from `data.frame`. -#' -#' * `id_col` :: `character(1)`\cr -#' The id column of `.data`. -#' -#' * `owner` :: an [R6::R6Class] object that inherits [Agent].\cr -#' -#' @section Fields: -#' -#' `NULL`\cr -#' -#' @section Methods: -#' -#' * `is_vacant(ids)`\cr -#' (`integer()`) -> (`logical()`)\cr -#' Check if the assets in ids are vacant -#' -#' * `vacate(ids)`\cr -#' (`integer()`)\cr -#' This removes the owners of the assets in `ids`. -#' -#' @export -Building <- R6Class( - classname = "Building", - inherit = Asset, - public = list( - - is_vacant = function(ids) { - !super$is_owned(ids) - }, - - vacate = function(ids) { - super$remove_owner(ids) - } - ) -) - - diff --git a/R/BuildingCommercial.R b/R/BuildingCommercial.R deleted file mode 100644 index 4d68f5e5..00000000 --- a/R/BuildingCommercial.R +++ /dev/null @@ -1,42 +0,0 @@ -#' Commercial Building class -#' -#' @usage NULL -#' @format [R6::R6Class] object inheriting from [Building]<-[Asset]<-[Entity]. -#' -#' @description Create Commercial Building class, extended Agent class. -#' -#' @section Fields: -#' -#' * `NULL`\cr` -#' -#' @section Methods: -#' -#' * `is_occupied(ids)`\cr -#' (`integer()`) -> `logical()`\cr -#' Returns TRUE if dwelling in ids is occupied -#' -#' @export -BuildingCommercial <- R6Class( - classname = "BuildingCommercial", - inherit = Building, - public = list( - - ), - - active = list( - # minimum required data structure - data_template = function() { - return( - data.table( - # the first column should always be the unique id column of the class - did = integer(), # dwelling id - zid = integer(), # zone id - occupied_by = integer(), - price = double() # price of dwelling - ) - ) - } - ), - - private = list() -) diff --git a/R/BuildingIndustrial.R b/R/BuildingIndustrial.R deleted file mode 100644 index e41c494e..00000000 --- a/R/BuildingIndustrial.R +++ /dev/null @@ -1,39 +0,0 @@ -#' @title Industrial building class -#' -#' @usage NULL -#' @format [R6::R6Class] object inheriting from [Building]<-[Asset]<-[Entity]. -#' -#' @description Create dwelling class, extended Agent class. -#' -#' @section Fields: -#' -#' * `NULL`\cr` -#' -#' @section Methods: -#' -#' * `is_occupied(ids)`\cr -#' (`integer()`) -> `logical()`\cr -#' Returns TRUE if dwelling in ids is occupied -#' -#' * `is_vacant(ids)`\cr -#' (`integer()`) -> `logical()`\cr -#' Returns TRUE if dwelling in ids is vacant. -#' -#' @export -BuildingIndustrial <- R6Class( - classname = "BuildingIndustrial", - inherit = Building, - public = list(), - active = list( - data_template = function() { - data.table( - # the first column should always be the unique id column of the class - did = integer(), # dwelling id - zid = integer(), # zone id - occupied_by = integer(), - price = double() - ) - } - ), - private = list() -) diff --git a/R/BuildingResidential.R b/R/BuildingResidential.R deleted file mode 100644 index e0a8eb06..00000000 --- a/R/BuildingResidential.R +++ /dev/null @@ -1,45 +0,0 @@ -#' @title Building Residential class -#' -#' @usage NULL -#' @format [R6::R6Class] object inheriting from [Building]<-[Asset]<-[Entity]. -#' @include Asset.R -#' -#' @description -#' For storing methods and fields related to residential buildings. -#' -#' @section Fields: -#' -#' * `NULL`\cr` -#' -#' @section Methods: -#' -#' * `is_occupied(ids)`\cr -#' (`integer()`) -> `logical()`\cr -#' Returns TRUE if dwelling in ids is occupied -#' -#' * `is_vacant(ids)`\cr -#' (`integer()`) -> `logical()`\cr -#' Returns TRUE if dwelling in ids is vacant. -#' -#' @export -BuildingResidential <- R6Class( - classname = "BuildingResidential", - inherit = Building, - public = list(), - active = list( - data_template = function() { - data.table( - # the first column should always be the unique id column of the class - bid = integer(), # dwelling id - zid = integer(), # zone id - occupied_by = integer(), # household id, if is emptied then -1 - price = double(), # price of dwelling - bedroom = integer(), - bathroom = integer(), - parking = integer(), - type = character(), - ) - } - ), - private = list() -) diff --git a/man/Building.Rd b/man/Building.Rd deleted file mode 100644 index 352a2711..00000000 --- a/man/Building.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/Building.R -\name{Building} -\alias{Building} -\title{Building class} -\format{ -\link[R6:R6Class]{R6::R6Class} object inheriting from \link{Asset}<-\link{Entity}. -} -\description{ -Create a building object.\preformatted{x <- Building$new(.data, id_col, owner) -} - -Stores \code{.data} as a DataBackend object inside the object's list of data (\code{private$.data}) -and registers the \code{id_col} (\code{private$.id_col}). -\itemize{ -\item \code{.data} :: \code{data.frame}\cr -A object that inherits from \code{data.frame}. -\item \code{id_col} :: \code{character(1)}\cr -The id column of \code{.data}. -\item \code{owner} :: an \link[R6:R6Class]{R6::R6Class} object that inherits \link{Agent}.\cr -} -} -\section{Fields}{ - - -\code{NULL}\cr -} - -\section{Methods}{ - -\itemize{ -\item \code{is_vacant(ids)}\cr -(\code{integer()}) -> (\code{logical()})\cr -Check if the assets in ids are vacant -\item \code{vacate(ids)}\cr -(\code{integer()})\cr -This removes the owners of the assets in \code{ids}. -} -} - diff --git a/man/BuildingCommercial.Rd b/man/BuildingCommercial.Rd deleted file mode 100644 index d0d7e804..00000000 --- a/man/BuildingCommercial.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/BuildingCommercial.R -\name{BuildingCommercial} -\alias{BuildingCommercial} -\title{Commercial Building class} -\format{ -\link[R6:R6Class]{R6::R6Class} object inheriting from \link{Building}<-\link{Asset}<-\link{Entity}. -} -\description{ -Create Commercial Building class, extended Agent class. -} -\section{Fields}{ - -\itemize{ -\item \code{NULL}\cr` -} -} - -\section{Methods}{ - -\itemize{ -\item \code{is_occupied(ids)}\cr -(\code{integer()}) -> \code{logical()}\cr -Returns TRUE if dwelling in ids is occupied -} -} - diff --git a/man/BuildingIndustrial.Rd b/man/BuildingIndustrial.Rd deleted file mode 100644 index 9a118598..00000000 --- a/man/BuildingIndustrial.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/BuildingIndustrial.R -\name{BuildingIndustrial} -\alias{BuildingIndustrial} -\title{Industrial building class} -\format{ -\link[R6:R6Class]{R6::R6Class} object inheriting from \link{Building}<-\link{Asset}<-\link{Entity}. -} -\description{ -Create dwelling class, extended Agent class. -} -\section{Fields}{ - -\itemize{ -\item \code{NULL}\cr` -} -} - -\section{Methods}{ - -\itemize{ -\item \code{is_occupied(ids)}\cr -(\code{integer()}) -> \code{logical()}\cr -Returns TRUE if dwelling in ids is occupied -\item \code{is_vacant(ids)}\cr -(\code{integer()}) -> \code{logical()}\cr -Returns TRUE if dwelling in ids is vacant. -} -} - diff --git a/man/BuildingResidential.Rd b/man/BuildingResidential.Rd deleted file mode 100644 index 0eef22b9..00000000 --- a/man/BuildingResidential.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/BuildingResidential.R -\name{BuildingResidential} -\alias{BuildingResidential} -\title{Building Residential class} -\format{ -\link[R6:R6Class]{R6::R6Class} object inheriting from \link{Building}<-\link{Asset}<-\link{Entity}. -} -\description{ -For storing methods and fields related to residential buildings. -} -\section{Fields}{ - -\itemize{ -\item \code{NULL}\cr` -} -} - -\section{Methods}{ - -\itemize{ -\item \code{is_occupied(ids)}\cr -(\code{integer()}) -> \code{logical()}\cr -Returns TRUE if dwelling in ids is occupied -\item \code{is_vacant(ids)}\cr -(\code{integer()}) -> \code{logical()}\cr -Returns TRUE if dwelling in ids is vacant. -} -} - diff --git a/tests/testthat/test-Building.R b/tests/testthat/test-Building.R deleted file mode 100644 index acf70beb..00000000 --- a/tests/testthat/test-Building.R +++ /dev/null @@ -1,41 +0,0 @@ -.generate_building_data <- function(n_rows){ - data.table( - bid = 1:n_rows, - hid = sample(c(1:8, NA, NA), n_rows), - zid = 1L, - price = 1000 * runif(n_rows), - bedrooms = sample(1:4, n_rows, replace = TRUE) - ) -} - -test_that("initialising a building object", { - n_rows <- 10L - data <- .generate_building_data(n_rows) - id_col <- "bid" - Bld <- Building$new(data, id_col) - expect_true(Bld$n() == n_rows) - - Bld <- Building$new(data, id_col) - data <- .generate_building_data(n_rows = n_rows) - # alter data type to invoke error - data[, zid := as.character(zid)] - id_col = "hid" - expect_error(Bld$initialise_data(data, id_col)) -}) - -test_that("is_occupied and is_vacant", { - n_rows <- 10L - id_col = "bid" - - building_data <- .generate_building_data(n_rows) - owner_data <- building_data[!is.na(hid), .(hid, bid)] - - - Bld <- Building$new(building_data, id_col) - Hh <- Household$new(.data = owner_data, id_col = "hid") - - Bld$set_owner_object(x = Hh) - - vacant <- is.na(Bld$get_attr("hid")) - expect_equal(Bld$is_vacant(), vacant) -}) From 17286007fa29eb427ccc715696d19c86d8102e25 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 16:54:24 +1100 Subject: [PATCH 18/38] removed scenario-related files --- DESCRIPTION | 1 - NAMESPACE | 3 - R/scenario.R | 100 --------------------------------- man/create_scenario.Rd | 55 ------------------ tests/testthat/test-scenario.R | 6 -- 5 files changed, 165 deletions(-) delete mode 100644 R/scenario.R delete mode 100644 man/create_scenario.Rd delete mode 100644 tests/testthat/test-scenario.R diff --git a/DESCRIPTION b/DESCRIPTION index 62fd0981..f7782b91 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -101,7 +101,6 @@ Collate: 'makeModel.R' 'mutate-entity.R' 'population-register.R' - 'scenario.R' 'sim.R' 'simulate_choice.R' 'transition-fnc.R' diff --git a/NAMESPACE b/NAMESPACE index 7247a013..042d407b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -74,7 +74,6 @@ export(check_subset2) export(check_target) export(check_transition_supported_model) export(combine_histories) -export(create_scenario) export(create_toy_population) export(create_toy_world) export(dm_get_model) @@ -88,7 +87,6 @@ export(expect_subset2) export(expect_target) export(expect_transition_supported_model) export(extract_data) -export(get_active_scenario) export(get_history) export(get_log) export(get_models) @@ -111,7 +109,6 @@ export(pop_register) export(register) export(remove_entity) export(sample_choice) -export(set_active_scenario) export(sim) export(simulate_choice) export(test_entity) diff --git a/R/scenario.R b/R/scenario.R deleted file mode 100644 index 1c409110..00000000 --- a/R/scenario.R +++ /dev/null @@ -1,100 +0,0 @@ -#' Create, set, and get scenario. -#' -#' @description -#' -#' A scenario folder is where you organise and store the scripts, the data and -#' the models that associate with a microsimulation model implementation. This -#' is a recommended practice for dymium models. -#' -#' `create_scenario`: creates a scenario folder inside the `scenarios` folder, which -#' will be created if not already exists, at the root folder of your active RStudio -#' project. The standard structure of a scenario folder contains an 'inputs' folder, -#' an 'outputs' folder inside. However, if the scenario is already existed then it -#' this will set that scenario to `active` if `active` is `TRUE`. When you call a -#' dymium function such as `dm_save`, it will automatically save the data to the -#' `outputs` folder of the currently active scenario. -#' -#' `set_active_scenario`: is useful for event functions to access the current -#' active scenario directory. If the scenerio folder doesn't have 'inputs' and -#' 'ouputs' folders then they will be created. -#' -#' `get_active_scenario`: returns a list of 3 elements: 'scenario, 'inputs' and -#' 'outputs' directories. -#' -#' @param name :: `character(1)`\cr -#' Name of the scenario -#' @param .basedir :: `character(1)`\cr -#' The base directory that the downloaded module will be saved at. [here::here()] is -#' used to provide the default value which is is the root folder of the active RStudio project. -#' @param active :: `logical(1)\cr -#' Default as `TRUE`. Set the newly created scenario as active scenario. -#' @export -#' -#' @return `create_` and `set_` invisibly returns the scenario path and `get_` returns a named list. -#' -#' @examples -#' -#' \dontrun{ -#' create_scenario(name = "test", active = FALSE) -#' set_active_scenario(name = "test") -#' get_active_scenario() -#' } -create_scenario <- function(name, active = TRUE, .basedir = here::here()) { - .check_file_name(name) - path <- fs::path(.basedir, "scenarios", name) - fs::dir_create(path, recurse = TRUE) - message("Created: ", path) - fs::dir_create(fs::path(path, "inputs")) - message("Created: ", fs::path(path, "inputs")) - fs::dir_create(fs::path(path, "outputs")) - message("Created: ", fs::path(path, "outputs")) - if (active) { - set_active_scenario(name, .basedir = .basedir) - } - invisible(path) -} - -#' @rdname create_scenario -#' @export -set_active_scenario <- function(name, .basedir = here::here()) { - checkmate::assert_string(name, - pattern = "^[.]*[a-zA-Z]+[a-zA-Z0-9._.-]*$", - na.ok = FALSE, - null.ok = FALSE) - - scenario_path <- fs::path(.basedir, "scenarios", name) - input_path <- fs::path(scenario_path, "inputs") - output_path <- fs::path(scenario_path, "outputs") - - if (!checkmate::test_directory_exists(scenario_path, access = "rw")) { - stop(glue::glue( - "{scenario_path} doesn't exist. You can use `create_scenario()` to create \\ - a new scenario under your project directory or create it manually." - )) - } - - if (!checkmate::test_directory_exists(input_path, access = "rw")) { - fs::dir_create(input_path) - } - - if (!checkmate::test_directory_exists(output_path, access = "rw")) { - fs::dir_create(output_path) - } - - opts.dymium <- list( - dymium.scenario_dir = scenario_path, - dymium.input_dir = input_path, - dymium.output_dir = output_path - ) - options(opts.dymium) - - .dymium_options_msg() - - invisible(scenario_path) -} - -#' @rdname create_scenario -#' @export -get_active_scenario <- function() { - .dymium_options() -} diff --git a/man/create_scenario.Rd b/man/create_scenario.Rd deleted file mode 100644 index 34f13c7d..00000000 --- a/man/create_scenario.Rd +++ /dev/null @@ -1,55 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/scenario.R -\name{create_scenario} -\alias{create_scenario} -\alias{set_active_scenario} -\alias{get_active_scenario} -\title{Create, set, and get scenario.} -\usage{ -create_scenario(name, active = TRUE, .basedir = here::here()) - -set_active_scenario(name, .basedir = here::here()) - -get_active_scenario() -} -\arguments{ -\item{name}{:: \code{character(1)}\cr -Name of the scenario} - -\item{active}{:: \verb{logical(1)\\cr Default as }TRUE`. Set the newly created scenario as active scenario.} - -\item{.basedir}{:: \code{character(1)}\cr -The base directory that the downloaded module will be saved at. \code{\link[here:here]{here::here()}} is -used to provide the default value which is is the root folder of the active RStudio project.} -} -\value{ -\code{create_} and \code{set_} invisibly returns the scenario path and \code{get_} returns a named list. -} -\description{ -A scenario folder is where you organise and store the scripts, the data and -the models that associate with a microsimulation model implementation. This -is a recommended practice for dymium models. - -\code{create_scenario}: creates a scenario folder inside the \code{scenarios} folder, which -will be created if not already exists, at the root folder of your active RStudio -project. The standard structure of a scenario folder contains an 'inputs' folder, -an 'outputs' folder inside. However, if the scenario is already existed then it -this will set that scenario to \code{active} if \code{active} is \code{TRUE}. When you call a -dymium function such as \code{dm_save}, it will automatically save the data to the -\code{outputs} folder of the currently active scenario. - -\code{set_active_scenario}: is useful for event functions to access the current -active scenario directory. If the scenerio folder doesn't have 'inputs' and -'ouputs' folders then they will be created. - -\code{get_active_scenario}: returns a list of 3 elements: 'scenario, 'inputs' and -'outputs' directories. -} -\examples{ - -\dontrun{ - create_scenario(name = "test", active = FALSE) - set_active_scenario(name = "test") - get_active_scenario() -} -} diff --git a/tests/testthat/test-scenario.R b/tests/testthat/test-scenario.R deleted file mode 100644 index 16f9f667..00000000 --- a/tests/testthat/test-scenario.R +++ /dev/null @@ -1,6 +0,0 @@ -test_that("get_active_scenario", { - checkmate::expect_list(get_active_scenario(), types = "character", any.missing = FALSE) - checkmate::expect_access(get_active_scenario()[['scenario_dir']]) - checkmate::expect_access(get_active_scenario()[['output_dir']]) - checkmate::expect_access(get_active_scenario()[['input_dir']]) -}) From ef2e53bee1c2ddd0448466adad265339df317b4c Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 16:56:07 +1100 Subject: [PATCH 19/38] removed Building from create_toy_world --- R/create-world.R | 5 ----- 1 file changed, 5 deletions(-) diff --git a/R/create-world.R b/R/create-world.R index bbbdda5b..97464fa3 100644 --- a/R/create-world.R +++ b/R/create-world.R @@ -33,10 +33,5 @@ create_toy_world <- function(add_toy_zones = TRUE) { hid_col = c("hid") ) ) - world$add(BuildingResidential$new(toy_dwellings, "did")) - world$get(BuildingResidential)$set_owner_object(world$get(Household)) - if (add_toy_zones) { - world$add(Zone$new(toy_zones, "zid")) - } invisible(world) } From 787b3d4869b51baabb20254559484f8a4bb00e54 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 17:20:54 +1100 Subject: [PATCH 20/38] remove tests that required Building --- tests/testthat/test-Entity-functions.R | 4 +--- tests/testthat/test-create-world.R | 4 +--- 2 files changed, 2 insertions(+), 6 deletions(-) diff --git a/tests/testthat/test-Entity-functions.R b/tests/testthat/test-Entity-functions.R index 25b4e51a..a3cbbf93 100644 --- a/tests/testthat/test-Entity-functions.R +++ b/tests/testthat/test-Entity-functions.R @@ -59,13 +59,11 @@ test_that("combine_histories & plot_history", { create_toy_world() Ind <- world$get("Individual") Hh <- world$get("Household") - Bd <- world$get("BuildingResidential") - for (t in 1:10) { +ß for (t in 1:10) { for (e in 1:5) { n <- sample(1:20, 1) add_history(Ind, ids = sample(Ind$get_ids(), n), event = sample(paste0("event-ind-", 1:5), 1), time = t) add_history(Hh, ids = sample(Hh$get_ids(), n), event = sample(paste0("event-hh-", 1:5), 1), time = t) - add_history(Bd, ids = sample(Bd$get_ids(), n), event = sample(paste0("event-bd-", 1:5), 1), time = t) } } chist <- combine_histories(world) diff --git a/tests/testthat/test-create-world.R b/tests/testthat/test-create-world.R index 0cbcdc46..3a280bb7 100644 --- a/tests/testthat/test-create-world.R +++ b/tests/testthat/test-create-world.R @@ -1,7 +1,5 @@ test_that("create-world", { create_toy_world() - BldRes <- world$get("BuildingResidential") - expect_equal(length(world$entities), 4) + expect_equal(length(world$entities), 2) expect_true(validate_linkages(world)) - checkmate::expect_r6(BldRes$get_owner_object(), "Household") }) From 27dc33103b514bbc86b5b6d83739570b1010551a Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 17:22:40 +1100 Subject: [PATCH 21/38] removed event tests --- tests/testthat/test-usethis.R | 4 ---- 1 file changed, 4 deletions(-) delete mode 100644 tests/testthat/test-usethis.R diff --git a/tests/testthat/test-usethis.R b/tests/testthat/test-usethis.R deleted file mode 100644 index 495e5992..00000000 --- a/tests/testthat/test-usethis.R +++ /dev/null @@ -1,4 +0,0 @@ -test_that("event", { - expect_error(use_event("x"), "is missing, with no default") - expect_error(use_event("x", "y"), "A module called 'y' doesn't exist") -}) From 51a11ea7d492635ef2a0075cde020116de1f2bfc Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 17:22:59 +1100 Subject: [PATCH 22/38] fix typo in test --- tests/testthat/test-Entity-functions.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/testthat/test-Entity-functions.R b/tests/testthat/test-Entity-functions.R index a3cbbf93..8828451d 100644 --- a/tests/testthat/test-Entity-functions.R +++ b/tests/testthat/test-Entity-functions.R @@ -59,7 +59,7 @@ test_that("combine_histories & plot_history", { create_toy_world() Ind <- world$get("Individual") Hh <- world$get("Household") -ß for (t in 1:10) { + for (t in 1:10) { for (e in 1:5) { n <- sample(1:20, 1) add_history(Ind, ids = sample(Ind$get_ids(), n), event = sample(paste0("event-ind-", 1:5), 1), time = t) From 1241ac30a41e8aea062d53c20d03b3e350593cc6 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 22:07:30 +1100 Subject: [PATCH 23/38] removed sim() --- DESCRIPTION | 1 - NAMESPACE | 1 - R/sim.R | 108 -------------------------------------- man/sim.Rd | 96 --------------------------------- tests/testthat/test-sim.R | 67 ----------------------- 5 files changed, 273 deletions(-) delete mode 100644 R/sim.R delete mode 100644 man/sim.Rd delete mode 100644 tests/testthat/test-sim.R diff --git a/DESCRIPTION b/DESCRIPTION index f7782b91..17a62e73 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -101,7 +101,6 @@ Collate: 'makeModel.R' 'mutate-entity.R' 'population-register.R' - 'sim.R' 'simulate_choice.R' 'transition-fnc.R' 'utils-class.R' diff --git a/NAMESPACE b/NAMESPACE index 042d407b..6b536a36 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -109,7 +109,6 @@ export(pop_register) export(register) export(remove_entity) export(sample_choice) -export(sim) export(simulate_choice) export(test_entity) export(test_entity_ids) diff --git a/R/sim.R b/R/sim.R deleted file mode 100644 index 0cdc3b4d..00000000 --- a/R/sim.R +++ /dev/null @@ -1,108 +0,0 @@ -#' @title Compile and execute a microsimulation pipeline -#' -#' @description -#' This function compiles and executes a microsimulation pipeline. -#' -#' @param world (`World`)\cr -#' A [World] object. -#' @param pipeline (`function()`)\cr -#' A functional sequence (`fseq`) object. -#' @param n_iters a number of iterations. (`integer(1)`)\cr -#' Number of times the microsimulation pipeline should be repeated. -#' @param write.error.dump.folder (`character(1)`)\cr -#' path: Saves the dump of the workspace in a specific folder instead of the -#' working directory -#' @param write.error.dump.file (`logical(1)`)\cr -#' See [tryCatchLog::tryCatchLog]. -#' -#' -#' @return `NULL` -#' @export -#' -#' @examples -#' -#' library(data.table) -#' -#' # create simple models -#' birth_model <- list(yes = 0.1, no = 0.9) -#' death_model <- list(yes = 0.1, no = 0.9) -#' -#' # prepare population data -#' ind_data <- -#' data.table::copy(toy_individuals) %>% -#' .[, .give_birth := "no"] -#' -#' # create a World object, a container for all entities and models for simulation -#' world <- World$new() -#' world$add(x = Individual$new(.data = ind_data, id_col = "pid")) -#' -#' # create filters, this is a method for creating functions using `magrittr` and -#' # data.table's syntax -#' filter_eligible_females <- -#' . %>% -#' .[sex == "female" & age %between% c(18, 50)] -#' -#' filter_alive <- -#' . %>% -#' .[age != -1] -#' -#' microsimulation_pipeline <- -#' . %>% -#' # ageing -#' mutate_entity(entity = "Individual", -#' age := age + 1L, -#' subset = age != -1L) %>% -#' # simulate birth decision -#' transition(entity = "Individual", -#' model = birth_model, -#' attr = ".give_birth", -#' preprocessing_fn = . %>% filter_eligible_females %>% filter_alive) %>% -#' # add newborns -#' add_entity(entity = "Individual", -#' newdata = toy_individuals[age == 0, ], -#' target = .$entities$Individual$get_data()[.give_birth == "yes", .N]) %>% -#' # reset the birth decision variable -#' mutate_entity(entity = "Individual", -#' .give_birth := "no", -#' subset = age != -1L) %>% -#' # simulate deaths -#' transition(entity = "Individual", -#' model = death_model, -#' attr = "age", -#' values = c(yes = -1L), -#' preprocessing_fn = filter_alive) %>% -#' # log the total number of alive individuals at the end of the iteration -#' add_log(desc = "count:Individual", -#' value = .$entities$Individual$get_data()[age != -1L, .N]) -#' -#' # complie and execute a simulation pipeline -#' sim(world = world, pipeline = microsimulation_pipeline, n_iters = 10) -sim <- function(world, pipeline, n_iters, write.error.dump.file = FALSE, write.error.dump.folder) { - - checkmate::assert_r6(world, classes = "World") - checkmate::assert_function(pipeline, nargs = 1) - checkmate::assert_count(n_iters, positive = TRUE) - - if (write.error.dump.file) { - if (!missing(write.error.dump.folder)) { - checkmate::assert_directory_exists(write.error.dump.folder, access = "rwx") - } else { - write.error.dump.folder <- get_active_scenario()$output_dir - } - } - - tryCatchLog::tryCatchLog({ - for (i in 1:n_iters) { - world$start_iter(time_step = world$get_time() + 1L) %>% - pipeline(.) - }}, - write.error.dump.file = write.error.dump.file, - write.error.dump.folder = write.error.dump.folder - ) - - invisible() -} - - - - diff --git a/man/sim.Rd b/man/sim.Rd deleted file mode 100644 index aa1d5877..00000000 --- a/man/sim.Rd +++ /dev/null @@ -1,96 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/sim.R -\name{sim} -\alias{sim} -\title{Compile and execute a microsimulation pipeline} -\usage{ -sim( - world, - pipeline, - n_iters, - write.error.dump.file = FALSE, - write.error.dump.folder -) -} -\arguments{ -\item{world}{(\code{World})\cr -A \link{World} object.} - -\item{pipeline}{(\verb{function()})\cr -A functional sequence (\code{fseq}) object.} - -\item{n_iters}{a number of iterations. (\code{integer(1)})\cr -Number of times the microsimulation pipeline should be repeated.} - -\item{write.error.dump.file}{(\code{logical(1)})\cr -See \link[tryCatchLog:tryCatchLog]{tryCatchLog::tryCatchLog}.} - -\item{write.error.dump.folder}{(\code{character(1)})\cr -path: Saves the dump of the workspace in a specific folder instead of the -working directory} -} -\value{ -\code{NULL} -} -\description{ -This function compiles and executes a microsimulation pipeline. -} -\examples{ - -library(data.table) - -# create simple models -birth_model <- list(yes = 0.1, no = 0.9) -death_model <- list(yes = 0.1, no = 0.9) - -# prepare population data -ind_data <- - data.table::copy(toy_individuals) \%>\% - .[, .give_birth := "no"] - -# create a World object, a container for all entities and models for simulation -world <- World$new() -world$add(x = Individual$new(.data = ind_data, id_col = "pid")) - -# create filters, this is a method for creating functions using `magrittr` and -# data.table's syntax -filter_eligible_females <- - . \%>\% - .[sex == "female" & age \%between\% c(18, 50)] - -filter_alive <- - . \%>\% - .[age != -1] - -microsimulation_pipeline <- - . \%>\% - # ageing - mutate_entity(entity = "Individual", - age := age + 1L, - subset = age != -1L) \%>\% - # simulate birth decision - transition(entity = "Individual", - model = birth_model, - attr = ".give_birth", - preprocessing_fn = . \%>\% filter_eligible_females \%>\% filter_alive) \%>\% - # add newborns - add_entity(entity = "Individual", - newdata = toy_individuals[age == 0, ], - target = .$entities$Individual$get_data()[.give_birth == "yes", .N]) \%>\% - # reset the birth decision variable - mutate_entity(entity = "Individual", - .give_birth := "no", - subset = age != -1L) \%>\% - # simulate deaths - transition(entity = "Individual", - model = death_model, - attr = "age", - values = c(yes = -1L), - preprocessing_fn = filter_alive) \%>\% - # log the total number of alive individuals at the end of the iteration - add_log(desc = "count:Individual", - value = .$entities$Individual$get_data()[age != -1L, .N]) - -# complie and execute a simulation pipeline -sim(world = world, pipeline = microsimulation_pipeline, n_iters = 10) -} diff --git a/tests/testthat/test-sim.R b/tests/testthat/test-sim.R deleted file mode 100644 index 6f57aef7..00000000 --- a/tests/testthat/test-sim.R +++ /dev/null @@ -1,67 +0,0 @@ -test_that("sim works", { - # create simple models - birth_model <- list(yes = 0.1, no = 0.9) - death_model <- list(yes = 0.1, no = 0.9) - - # prepare population data - ind_data <- - data.table::copy(toy_individuals) %>% - .[, .give_birth := "no"] - - # create a World object, a container for all entities and models for simulation - world <- World$new() - world$add(x = Individual$new(.data = ind_data, id_col = "pid")) - - # create filters, this is a method for creating functions using `magrittr` and - # data.table's syntax - filter_eligible_females <- - . %>% - .[sex == "female" & age %between% c(18, 50)] - - filter_alive <- - . %>% - .[age != -1] - - microsimulation_pipeline <- - . %>% - # ageing - mutate_entity(entity = "Individual", - age := age + 1L, - subset = age != -1L) %>% - # simulate birth decision - transition(entity = "Individual", - model = birth_model, - attr = ".give_birth", - preprocessing_fn = . %>% filter_eligible_females %>% filter_alive) %>% - # add newborns - add_entity(entity = "Individual", - newdata = toy_individuals[age == 0, ], - target = .$entities$Individual$get_data()[.give_birth == "yes", .N]) %>% - # reset the birth decision variable - mutate_entity(entity = "Individual", - .give_birth := "no", - subset = age != -1L) %>% - # simulate deaths - transition(entity = "Individual", - model = death_model, - attr = "age", - values = c(yes = -1L), - preprocessing_fn = filter_alive) %>% - # log the total number of alive individuals at the end of the iteration - add_log(desc = "count:Individual", - value = .$entities$Individual$get_data()[age != -1L, .N]) - - n_iters = 10 - - sim(world = world, pipeline = microsimulation_pipeline, n_iters = n_iters, write.error.dump.folder = FALSE) - - expect_equal(world$get_time(), n_iters) - - expect_error(sim(world = 1, pipeline = microsimulation_pipeline, n_iters = 10), - "Assertion on 'world' failed: Must be an R6 class,") - expect_error(sim(world = world, pipeline = microsimulation_pipeline, n_iters = 0), - "Assertion on 'n_iters' failed: Must be >= 1.") - expect_error(sim(world = world, pipeline = 1, n_iters = 10), - "Assertion on 'pipeline' failed: Must be a function") - -}) From a99fd594cac85d0884bfd4651dacf5e16c6d3348 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 23 Nov 2020 22:51:34 +1100 Subject: [PATCH 24/38] renamed the pkg to dymium.core this will allow future dymium pkgs to have a consistent naming style --- DESCRIPTION | 2 +- dymiumCore.Rproj => dymium.core.Rproj | 0 2 files changed, 1 insertion(+), 1 deletion(-) rename dymiumCore.Rproj => dymium.core.Rproj (100%) diff --git a/DESCRIPTION b/DESCRIPTION index 17a62e73..10efb6ee 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,4 +1,4 @@ -Package: dymiumCore +Package: dymium.core Version: 0.1.9.9000 Title: A Toolkit for Building a Dynamic Microsimulation Model for Integrated Urban Modelling Description: A modular microsimulation modelling framework for integrated urban modelling. diff --git a/dymiumCore.Rproj b/dymium.core.Rproj similarity index 100% rename from dymiumCore.Rproj rename to dymium.core.Rproj From 3fd3d9ad8870c9a21c5d00b1275e98f54077b7be Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:16:48 +1100 Subject: [PATCH 25/38] fix(Network): raise an informative error when dodgr is missing. --- R/Network.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/R/Network.R b/R/Network.R index b4e47752..89dec95f 100644 --- a/R/Network.R +++ b/R/Network.R @@ -1,6 +1,5 @@ #' @title Network class #' @usage NULL -#' @format [R6::R6Class] object inheriting from [Environment]<-[Entity]. #' #' @description Network class. For creating a road network etc. #' @@ -53,6 +52,12 @@ Network <- R6::R6Class( inherit = Environment, public = list( initialize = function(.data, id_col, from_node, to_node, dist) { + + if (!requireNamespace("dodgr", quietly = TRUE)) { + stop("Package \"dodgr\" needed for this function to work. Please install it.", + call. = FALSE) + } + super$initialize(.data, id_col) self$add_data(.data = private$generate_dodgr_graph(from_node, to_node, dist), name = "dodgr_graph") From 4d4fb4f861939ca4d1b14e206a23525289a03a83 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:20:07 +1100 Subject: [PATCH 26/38] enabled R6 documentation style of roxygen2 --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 10efb6ee..af7a4ef6 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -53,7 +53,7 @@ Suggests: prettydoc, visNetwork (>= 2.0.0), dfidx -Roxygen: list(markdown = TRUE, r6 = FALSE) +Roxygen: list(markdown = TRUE, r6 = TRUE) RoxygenNote: 7.1.1 StagedInstall: no VignetteBuilder: knitr From 230e6bfd8ea7d135c3a8a7d8b19615400f55205e Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:21:33 +1100 Subject: [PATCH 27/38] removed the onLoad steps that create and show temp folders --- R/zzz.R | 57 --------------------------------------------------------- 1 file changed, 57 deletions(-) diff --git a/R/zzz.R b/R/zzz.R index f75c3d8b..bcd0c105 100644 --- a/R/zzz.R +++ b/R/zzz.R @@ -1,39 +1,5 @@ -.dymium_tempdir <- file.path(tempdir(), "scenario") - -.dymium_options <- function() { - return(list( - scenario_dir = getOption('dymium.scenario_dir'), - output_dir = getOption('dymium.output_dir'), - input_dir = getOption('dymium.input_dir') - )) -} - -.dymium_options_msg = function() { - opts <- grep("^dymium", names(options()), ignore.case = T, value = T) - optsval <- sapply(opts, function(x) {getOption(x)}) - cli::cli_text(cli::rule(left = " * dymium's options * ")) - cli::cli_li(items = paste(names(optsval), optsval, sep = ": ")) -} - .onLoad <- function(libname, pkgname) { - # create temp directory - fs::dir_create(.dymium_tempdir) - fs::dir_create(fs::path(.dymium_tempdir, "inputs")) - fs::dir_create(fs::path(.dymium_tempdir, "outputs")) - - # set global options - opts <- options() - opts.dymium <- list( - dymium.simulation_clock = 0L, - dymium.scenario_dir = file.path(.dymium_tempdir), - dymium.input_dir = file.path(.dymium_tempdir, "inputs"), - dymium.output_dir = file.path(.dymium_tempdir, "outputs"), - dymium.simulation_scale = 1 - ) - toset <- !(names(opts.dymium) %in% names(opts)) - if (any(toset)) options(opts.dymium[toset]) - # setup logger assign("lg", lgr::get_logger_glue(name = pkgname), envir = parent.env(environment())) @@ -49,32 +15,9 @@ {pad_right(colorize_levels(toupper(level_name)), 5)} \\ {crayon::yellow(.logger$name)} {caller}: {msg}")) - # config buffer appender - # !! Event with a custom field "value" and without a 'msg' field will be - # logged as a simulation output to json - sim_output_logfile <- paste0(opts.dymium$dymium.output_dir, "/sim_output.json") - fs::file_create(sim_output_logfile) - lg$appenders$buff$add_appender(lgr::AppenderJson$new(file = sim_output_logfile), name = "sim_output") - filter_sim_output <- function(event) { event$msg == "SIM_OUTPUT" } - lg$appenders$buff$appenders$sim_output$set_filters(list(filter_sim_output)) - - # print to console - .dymium_options_msg() - invisible() } .onUnload <- function(libpath) { - ## if temp session _dir is being used, ensure it gets reset each session - if (getOption("dymium.scenario_dir") == file.path(.dymium_tempdir)) { - options(dymium.scenario_dir = NULL) - } - - if (getOption("dymium.output_dir") == file.path(.dymium_tempdir, "outputs")) { - options(dymium.output_dir = NULL) - } - if (getOption("dymium.input_dir") == file.path(.dymium_tempdir, "inputs")) { - options(dymium.input_dir = NULL) - } } From c55ad057ac68a1a23c1670b454067344d7a1ea1a Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:25:41 +1100 Subject: [PATCH 28/38] fixed ModelMultinomialLogit - convert formula to Formula - compute_linear_combimation() now has two dispatch methods (formula for regression and binary logit, and the other for Formula which is for ModelMultinomialLogit) --- R/ModelCustom.R | 37 +++++++++++++++++++++++++++++++++---- R/ModelMultinomialLogit.R | 30 +++++++++++++----------------- 2 files changed, 46 insertions(+), 21 deletions(-) diff --git a/R/ModelCustom.R b/R/ModelCustom.R index db2ffa66..6fcfdc08 100644 --- a/R/ModelCustom.R +++ b/R/ModelCustom.R @@ -103,9 +103,38 @@ ModelCustom <- R6::R6Class( ) ) -compute_linear_combination <- function(params, formula, newdata) { +#' Compute linear combination +#' +#' @param formula (`formula(1)`|[Formula::Formula()])\cr +#' A formula which +#' @param params (named `numeric()`)\cr +#' Parameters of the explanatory variables specified in `formala`. +#' @param newdata (`data.frame()`)\cr +#' A dataset to be evaluated. +#' +#' @return (`data.frame()`). +#' @export +compute_linear_combination <- function(formula, ...) { + UseMethod("compute_linear_combination") +} + +#' @rdname compute_linear_combination +#' @export +compute_linear_combination.formula <- function(formula, params, newdata) { mm <- model.matrix(formula, newdata) - as.numeric(params %*% t(mm)) + return(as.numeric(params %*% t(mm))) +} + +#' @rdname compute_linear_combination +#' @export +compute_linear_combination.Formula <- function(formula, params, newdata) { + # Usually formula is the first argument of `model.frame` but mlogit has this + # weird order that newdata must be the first arg. + # see https://github.com/asiripanich/mlogit/blob/a111b401211b647cd458316dcbf5d6adab102935/R/mlogit.R#L346-L353 + mf <- model.frame(newdata, formula) + # see https://github.com/dymium-org/dymiumCore/issues/84 + mm <- mlogit:::model.matrix.dfidx_mlogit(mf) + return(as.numeric(params %*% t(mm))) } #' @param object a [ModelCustom] object @@ -117,7 +146,7 @@ compute_linear_combination <- function(params, formula, newdata) { #' @return prediction #' @export predict.ModelCustom <- function(object, newdata, ...) { - object$predict(newdata) + return(object$predict(newdata)) } #' @param object a [ModelCustom] object @@ -127,5 +156,5 @@ predict.ModelCustom <- function(object, newdata, ...) { #' @return summary #' @export summary.ModelCustom <- function(object, ...) { - object$summary() + return(object$summary()) } diff --git a/R/ModelMultinomialLogit.R b/R/ModelMultinomialLogit.R index 1f4dc861..bfd057ad 100644 --- a/R/ModelMultinomialLogit.R +++ b/R/ModelMultinomialLogit.R @@ -32,7 +32,7 @@ ModelMultinomialLogit <- R6::R6Class( #' @return NULL initialize = function(params, formula, preprocessing_fn = NULL) { - required_pkgs <- c("mlogit") + required_pkgs <- c("mlogit", "Formula") # required_versions <- c("1.1.0") for (i in seq_along(required_pkgs)) { @@ -42,7 +42,7 @@ ModelMultinomialLogit <- R6::R6Class( } super$initialize(params = params, - formula = formula, + formula = Formula::Formula(formula), type = "multinomial", preprocessing_fn = preprocessing_fn) @@ -65,27 +65,23 @@ 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) - 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)) %>% - .[, prob := exp(linear_comb)/sum(exp(linear_comb)), by = chooser_id] - } - ), + checkmate::assert_data_frame(newdata) + checkmate::assert_string(chooser_id_col) + checkmate::assert_string(choice_id_col) - 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 <- dfidx::dfidx(newdata, idx = c(chooser_id_col, choice_id_col)) } - mf <- model.frame(newdata, self$formula) - # see https://github.com/dymium-org/dymiumCore/issues/84 - mm <- mlogit:::model.matrix.dfidx_mlogit(mf) - return(as.numeric(self$params %*% t(mm))) + + data.table(chooser_id = newdata[[chooser_id_col]], + choice_id = newdata[[choice_id_col]], + linear_comb = compute_linear_combination(self$formula, self$params, newdata)) %>% + data.table::setkey(chooser_id) %>% + .[, prob := exp(linear_comb)/sum(exp(linear_comb)), by = chooser_id] } ) ) @@ -101,5 +97,5 @@ ModelMultinomialLogit <- R6::R6Class( #' @return a numeric vector #' @export predict.ModelMultinomialLogit = function(object, newdata, chooser_id_col, choice_id_col, ...) { - object$predict(newdata, chooser_id_col, choice_id_col) + return(object$predict(newdata, chooser_id_col, choice_id_col)) } From 4adcf6fbfcd7383edf68f836292a370c43ffe466 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:26:45 +1100 Subject: [PATCH 29/38] added man-roxygen scripts for various common params --- man-roxygen/param_data_name.R | 2 ++ man-roxygen/param_databackend.R | 2 ++ man-roxygen/param_dot_data.R | 2 ++ man-roxygen/param_id_col.R | 6 ++++++ man-roxygen/param_ids.R | 2 ++ man-roxygen/param_idx.R | 2 ++ 6 files changed, 16 insertions(+) create mode 100644 man-roxygen/param_data_name.R create mode 100644 man-roxygen/param_databackend.R create mode 100644 man-roxygen/param_dot_data.R create mode 100644 man-roxygen/param_id_col.R create mode 100644 man-roxygen/param_ids.R create mode 100644 man-roxygen/param_idx.R diff --git a/man-roxygen/param_data_name.R b/man-roxygen/param_data_name.R new file mode 100644 index 00000000..109f6b9d --- /dev/null +++ b/man-roxygen/param_data_name.R @@ -0,0 +1,2 @@ +#' @param name (`character(1)`)\cr +#' name of the data. diff --git a/man-roxygen/param_databackend.R b/man-roxygen/param_databackend.R new file mode 100644 index 00000000..e8d44d73 --- /dev/null +++ b/man-roxygen/param_databackend.R @@ -0,0 +1,2 @@ +#' @param databackend ([DataBackend])\cr +#' A DataBackend to be used for storing data. diff --git a/man-roxygen/param_dot_data.R b/man-roxygen/param_dot_data.R new file mode 100644 index 00000000..0c824fe7 --- /dev/null +++ b/man-roxygen/param_dot_data.R @@ -0,0 +1,2 @@ +#' @param .data (`data.frame()`)\cr +#' A object that inherits from `data.frame`. diff --git a/man-roxygen/param_id_col.R b/man-roxygen/param_id_col.R new file mode 100644 index 00000000..d6e4f55f --- /dev/null +++ b/man-roxygen/param_id_col.R @@ -0,0 +1,6 @@ +#' @param id_col (`character()`)\cr +#' ID fields in `.data`. The name of the id column of `.data` and all relation columns. +#' The first element will be checked as the main id column of the entity data, which +#' must be unique integers. The rest of the vector will be consider as relation +#' columns. For example, if `c("pid", "partner_id")` is given `pid` must contain +#' unique integers, while `partner_id` can be `NA` or non-unique integers. diff --git a/man-roxygen/param_ids.R b/man-roxygen/param_ids.R new file mode 100644 index 00000000..f7d25260 --- /dev/null +++ b/man-roxygen/param_ids.R @@ -0,0 +1,2 @@ +#' @param ids (`integer()`)\cr +#' IDs of the entities based on their primary ID field. diff --git a/man-roxygen/param_idx.R b/man-roxygen/param_idx.R new file mode 100644 index 00000000..2e8823b1 --- /dev/null +++ b/man-roxygen/param_idx.R @@ -0,0 +1,2 @@ +#' @param idx (`integer()`)\cr +#' Indexes of a data.table object to be queried. From 0657f264327270d5fbfb69d7843aae6a369c7433 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:27:04 +1100 Subject: [PATCH 30/38] added a simpler World class. --- R/World2.R | 103 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 103 insertions(+) create mode 100644 R/World2.R diff --git a/R/World2.R b/R/World2.R new file mode 100644 index 00000000..40184a6a --- /dev/null +++ b/R/World2.R @@ -0,0 +1,103 @@ +#' @title World Class +#' +#' @include Container.R +#' +#' @description +#' +#' The first step to creating a microsimulation model with `Dymium` is to define +#' what the "world" should look like. Your world can have multiple entities and +#' properties which define the rules and environment that govern those entities. +#' +#' @section S3 methods: +#' * `as.data.table(t)`\cr +#' [Task] -> [data.table::data.table()]\cr +#' Returns the complete data as [data.table::data.table()]. +#' +#' @export +#' @examples +#' world = World2$new() +World2 = + R6::R6Class( + classname = "World2", + public = list( + + #' @field entities (named `list()`)\cr + #' A named list that contains [Entities] instances. + entities = list(), + #' @field properties (named `list()`)\cr + #' A named list that contains [Targets], [Models], and other values to + #' be used in your simulation. + properties = list(), + + #' @description + #' Constructor method. + #' + #' @return a `World` instance. + initialize = function() { + self$add(0L, ".time") + self$add(1.0, ".scale") + self$add(0L, ".last_id") + invisible(self) + }, + + #' @description + #' + #' For adding [Entities] and properties (see the `properties` field) to [World]. + add = function(object, name) { + checkmate::assert( + checkmate::check_r6(object, classes = "Entity"), + checkmate::check_r6(object, classes = "Target"), + checkmate::check_r6(object, classes = "Model"), + checkmate::check_class(object, classes = "list"), + checkmate::check_class(object, classes = "numeric"), + checkmate::check_class(object, classes = "integer"), + combine = "or" + ) + checkmate::assert_string(name, null.ok = TRUE) + .field_name = ifelse(checkmate::test_r6(object, classes = "Entity"), + "entities", + "properties") + len = length(self[[.field_name]]) + self[[.field_name]][[len + 1L]] = object + names(self[[.field_name]])[[len + 1L]] = name + return(self) + }, + + print = function() { + message(sprintf("time = %s \nscale = %s", self$properties$.time, self$properties$.scale)) + } + + )) + + +#' @param value +#' +#' @rdname World2 +#' @export +set_time = function(world, value) { + checkmate::assert_class(world, "World") + checkmate::assert_integerish( + world$properties$.time, + lower = 0, + len = 1, + null.ok = FALSE + ) + world$properties$.time = value + return(world) +} + +#' @param value a value to be set. +#' +#' @rdname World2 +#' @export +set_scale = function(world, value) { + checkmate::assert_class(world, "World") + checkmate::assert_numeric( + world$properties$.scale, + len = 1, + finite = TRUE, + null.ok = FALSE + ) + world$properties$.scale = value + return(world) +} From 2216738afbc17e418dd2a28d223f0a19e78e07ae Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:27:20 +1100 Subject: [PATCH 31/38] added a new WIP Entity class. --- R/Entity2.R | 544 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 544 insertions(+) create mode 100644 R/Entity2.R diff --git a/R/Entity2.R b/R/Entity2.R new file mode 100644 index 00000000..df8406f3 --- /dev/null +++ b/R/Entity2.R @@ -0,0 +1,544 @@ +#' @title Entity class +#' +#' @description +#' +#' The base class (first building block) for creating new Entity classes. +#' +#' @template param_databackend +#' @template param_dot_data +#' @template param_id_col +#' @template param_data_name +#' @template param_ids +#' @template param_idx +#' +#' @family Entity +#' +#' @section Methods: +#' +#' * `get_removed_data(name)`\cr +#' (`character(1)`) -> [data.table::data.table()]\cr +#' Return removed agent data. If `name` is missing, the first data, which should +#' contains the main attributes of the agent object, will be returned. +#' +#' * `get_attr(x, ids)`\cr +#' (`character(1)`, `integer()`) -> `vector(type::col)`\cr +#' Extract the attribute from self$data as vector. If `ids` is given then only +#' the corresponding values to `ids` are returned, in the same order as the `ids`. +#' +#' * `has_attr(x)`\cr +#' (`character()`) -> `logical()`\cr +#' +#' +#' * `ids_exist(ids, include_removed_data = FALSE)`\cr +#' (`integer()`, `logical(1)`) -> `logical()`\cr +#' Check whether `ids` exist or not. And if `inclide_removed_data` is `TRUE` it +#' will also check the removed data. +#' +#' * `idx_exist(idx, by_element = FALSE)`\cr +#' (`integer()`) -> `logical()`\cr +#' Returns a logical vector of the same length as the argument `idx`. This function +#' checks whether the indexes in the argument `idx` exist or not. If `by_element` is +#' TRUE then it will return a logical vector with the same length as `ids` in +#' their respective order. +#' +#' * `print_data(n = 0)`\cr +#' (`logical(1)`) -> `self`\cr +#' Print to console the number of datasets and their dimensions. `n` is the number of rows +#' that will be output to console by `head()`, if 0 nothing will be printed. +#' +#' @aliases Entities +#' @export +Entity2 <- + R6::R6Class( + classname = "Entity2", + inherit = Generic, + public = list( + + #' @description + #' + #' Creates a new instance of this [R6][R6::R6Class] class. + #' + #' @return self + initialize = function(databackend, .data, id_col) { + checkmate::assert_character(id_col, null.ok = FALSE, min.len = 1, unique = T, any.missing = FALSE, names = "unnamed") + checkmate::assert_names(names(.data), must.include = id_col, type = 'strict') + checkmate::assert_integerish(.data[[id_col[1]]], unique = TRUE, any.missing = FALSE, null.ok = FALSE, min.len = 1) + private$.data[[1]] <- databackend$new(.data, key = id_col[1]) + checkmate::assert_r6(private$.data[[1]], classes = "DataBackend", .var.name = "databackend") + names(private$.data)[1] <- "attrs" + private$.last_id <- max(.data[[id_col[1]]]) + private$.id_col <- id_col + invisible() + }, + + #' @description + #' Append new data to the object's data list (`private$.data`). the new data + #' must be linkable with the attribute data of the object by the id_col. + add_data = function(databackend = DataBackendDataTable, .data, name) { + checkmate::assert_names(names(.data), must.include = private$.id_col[[1]], type = 'strict') + checkmate::assert_string(name, null.ok = FALSE, na.ok = FALSE) + checkmate::assert_names(name, type = "strict") + checkmate::assert_names(names(private$.data), disjunct.from = name) + private$.data[[length(private$.data) + 1L]] <- databackend$new(.data) + names(private$.data)[length(private$.data)] <- name + invisible() + }, + + #' @description + #' Returns a [DataBackend] with the name that matches `name`. + #' If `name` is not given, the function will try to return the [DataBackend] + #' with name `attrs`. If `attrs` is not present or no `DataBackEnd` objects + #' have been loaded it will return `NULL`. + #' @return ([DataBackend]|`NULL`)\cr + data = function(name) { + + if ((missing(name) & length(private$.data) == 0) | is.null(self$get_data_names())) { + lg$warn('{class(self)[[1]]} has no data.') + return(NULL) + } + + if (missing(name)) { + .data_pos <- 1 + } else { + .data_pos <- which(names(private$.data) == name) # return an integer or integer(0) if no match + } + + if (length(.data_pos) != 1) { + stop( + glue::glue( + "name='{name}' didn't match any data in private$.data [{.data_names}].", + .data_names = glue::glue_collapse(names(private$.data), ", ", last = " and ") + ) + ) + } + + lg$trace("returning {names(private$.data)[[.data_pos]]}") + return(private$.data[[.data_pos]]) + }, + + #' @description + #' Return agent data. When `ids` is specified, the data returned has the same + #' row order as the order of `ids`. If `copy` is TRUE then data.table's + #' reference semantics is returned. If `attrs` is not present or no `DataBackEnd` + #' objects have been loaded it will return `NULL`. + #' @param copy (`logical(1)`)\cr + #' When this is `FALSE`, it will return the reference to the request data. + #' Meaning that the data can be manipulated in place. + get_data = function(name, ids, copy = TRUE) { + + if (missing(name)) { + name <- "attrs" + } + + DataObj <- self$data(name) + + if (is.null(DataObj)) { + return(NULL) + } + + if (copy == FALSE) { + if (!missing(ids)) { + stop("It is not possible to return a reference semetic to the specific rows in `ids`.") + } + return(DataObj$get(copy = FALSE)) + } + + if (missing(ids)) { + return(DataObj$get()) + } else { + checkmate::check_integerish(x = ids, unique = TRUE, lower = 1, min.len = 1, null.ok = FALSE, any.missing = FALSE) + if (name == "attrs") { + return(DataObj$get(rows = self$get_idx(ids))) + } else { + lg$warn("The order of the returned data is not garantee to be the same \\ + with the input `ids`. Also not all ids are garantee to have \\ + valid records.") + return(DataObj$get()[get(self$get_id_col()) %in% ids,]) + } + + } + + }, + + #' @description + #' A different implementation of `self$get_data()`. + #' @return ([data.table::data.table()]|`data.frame()`) + get_data2 = function(name = "attrs", ids, copy = TRUE) { + + DataObj <- self$data(name) + + if (is.null(DataObj)) { + return(NULL) + } + + if (copy == FALSE) { + if (!missing(ids)) { + stop("It is not possible to return a reference semetic to the specific rows in `ids`.") + } + return(DataObj$get(copy = FALSE)) + } + + if (missing(ids)) { + return(DataObj$get()) + } else { + checkmate::check_integerish(x = ids, unique = TRUE, lower = 1, min.len = 1, null.ok = FALSE, any.missing = FALSE) + if (name == "attrs") { + if (is.null(DataObj$key)) { + DataObj$setkey(self$get_id_col()) + } + return( + data.table:::na.omit.data.table( + DataObj$get(copy = FALSE)[J(ids)], + cols = DataObj$colnames[2] + ) + ) + } else { + lg$warn("The order of the returned data is not garantee to be the same \\ + with the input `ids`. Also not all ids are garantee to have \\ + valid records.") + return(DataObj$get()[get(self$get_id_col()) %in% ids,]) + } + } + }, + + #' @description + #' Returns the names of all data objects (in `private$.data`) that belongs + #' to this object. + get_data_names = function() { + names(private$.data) + }, + + #' @description + #' Add attribute data of new entities. This makes sure none of the ids + #' of the new entities are the same as the existing entity records. However, other id columns, + #' relation columns can be exempted from the check by setting `check_existing` as `FALSE`. + #' Meaning, the other id columns can contain ids of the existing entities. + #' @param check_existing (`logical(1)`)\cr + #' Check the primary id of the new entities, in `.data`. + #' Whether to check that all ids in id cols exist in the existing entity ids. + #' If this function is to be called in a birth event, you probably want to + #' set this to `TRUE` since a newborn individual agent would have its mother id + #' of an existing individual agent. But if you are adding new individual agents + #' to the existing individual data then you wouldn't expect that there should + #' be existing ids + #' @note + #' The new data (`.data`) must comply with the existing data fields + #' of the existing entities' attribute data (`attrs`). + add = function(.data, check_existing = FALSE) { + + checkmate::assert_data_frame(.data) + checkmate::assert_flag(check_existing, na.ok = FALSE, null.ok = FALSE) + + # make sure the original copy of the data will not be mutated. + .data <- data.table::copy(.data) + + # check data structure ----------- + NewData <- DataBackendDataTable$new(.data, key = self$primary_id) + + res <- + all.equal(target = omit_derived_vars(self$database$attrs$data[0, ]), + current = omit_derived_vars(NewData$data[0, ]), + check.attributes = FALSE, + ignore.col.order = TRUE) + + if (!isTRUE(res)) { + cli::cli_alert_info("New data (.data)") + print(NewData$head()) + cli::cli_alert_info("Existing data") + print(self$database$attrs$head()) + stop(res) + } + + # check id columns ---------- + checkmate::assert_integerish( + .data[[self$primary_id]], + any.missing = FALSE, + null.ok = FALSE, + unique = T + ) + + if (any(.data[[self$primary_id]] %in% self$get_ids(include_removed = T))) { + lg$warn("entities in `.data` have the same ids as some of the existing \\ + entities. The duplicated ids will be replaced.") + data.table::set( + x = .data, + j = self$primary_id, + value = self$generate_new_ids(n = .data[, .N]) + ) + } + + # check relation columns + if (length(self$id_col) > 1) { + ids_in_relation_cols <- c() + relation_cols <- + self$id_col[!self$id_col %in% self$primary_id] + for (relation_col in relation_cols) { + ids_in_relation_cols <- + c(ids_in_relation_cols, na.omit(.data[[relation_col]])) + } + ids_in_relation_cols <- unique(ids_in_relation_cols) + if (check_existing) { + assert_subset2(ids_in_relation_cols, choices = c(self$get_ids(), .data[[self$primary_id]])) + } else { + assert_subset2(ids_in_relation_cols, choices = .data[[self$primary_id]]) + } + } + + self$database$attrs$add(.data = .data, fill = TRUE) + invisible() + }, + + #' @description + #' Check which of the attribute names given in `x` exist in the attribute data + #' of the object. + #' @param x (`character()`)\cr + #' Name of columns to check. + #' @return (`logical()`) + has_attr = function(x) { + x %in% self$database$attrs$colnames + }, + + get_attr = function(x, ids) { + checkmate::assert_string(x, na.ok = FALSE, null.ok = FALSE) + if (!missing(ids)) { + return(self$get_data(copy = FALSE)[self$get_idx(ids = ids)][[x]]) + } + self$data()$get(col = x)[[1]] + }, + + get_removed_data = function(name) { + DataObj <- self$data(name) + if (is.null(DataObj)) { + return(NULL) + } else { + DataObj$get_removed() + } + }, + + #' @description + #' + #' @param included_removed (`logical(1)`)\cr + #' If `TRUE`, ids of removed data will also be returned. + #' @return `(integer())` + get_ids = function(include_removed = FALSE) { + if (include_removed) { + return(c(self$get_attr(self$primary_id), + self$get_removed_data()[[self$primary_id]])) + } + self$get_attr(self$primary_id) + }, + + #' @description + #' Return the indexes of the ids in the argrument `ids`, respectively. + #' @param expect_na (`logical(1)`)\cr + #' If `FALSE`, `NA` will be returned where an `idx` that doesn't exist. + #' @return (`integer()`) + get_idx = function(ids, expect_na = FALSE) { + if (missing(ids)) { + return(seq_len(self$data()$nrow())) + } + all_ids <- self$get_ids() + if (expect_na == FALSE) { + assert_entity_ids(self, ids) + } + sorted_idx <- which(all_ids %in% ids) + sorted_ids <- all_ids[sorted_idx] + tab <- data.table(id = sorted_ids, idx = sorted_idx) + if (requireNamespace("fastmatch", quietly = TRUE)) { + return(tab[fastmatch::fmatch(ids, id)][["idx"]]) + } + tab[match(ids, id)][["idx"]] + }, + + #' @description + #' Returns the id column name. + #' @return (`character(1)`) + get_id_col = function(all = FALSE) { + if (all) { + return(private$.id_col) + } else { + return(private$.id_col[[1]]) + } + }, + + remove = function(ids) { + checkmate::assert_integerish(ids, any.missing = FALSE, unique = TRUE, lower = 1, min.len = 1) + if (length(private$.data) == 0) { + lg$warn("There is no data to be removed!") + return(invisible()) + } + for (DataObj in private$.data) { + idx <- which(DataObj$get(copy = FALSE)[[private$.id_col[[1]]]] %in% ids) + DataObj$remove(rows = idx) + } + invisible() + }, + + #' @description + #' Check if idx exist. + #' @param by_element (`logical(1)`)\cr + #' If TRUE, the check result will be return for each given index. + #' @return (`logical(1)`|`logical()`) + idx_exist = function(idx, by_element = FALSE) { + checkmate::assert_integerish(x = idx, lower = 0, any.missing = FALSE, null.ok = FALSE) + if (by_element) { + return(self$data()$nrow() >= idx) + } else { + return(self$data()$nrow() >= max(idx)) + } + }, + + #' @description + #' Check if ids exist. + #' @param include_removed_data (`logical(1)`)\cr + #' If TRUE, `ids` will also be checked if they have been used by any previous + #' records of this [Entity] which may have been removed. + #' @return (`logical(1)`) + ids_exist = function(ids, include_removed_data = FALSE) { + test_entity_ids(self, ids, include_removed_data = include_removed_data) + }, + + summary = function(verbose = TRUE) { + if (length(private$.data) == 0) { + summary_dt <- + data.table( + dataname = NA, + ncol = NA, + nrow = NA, + nrow_removed = NA, + size = NA + ) + } else { + summary_dt <- + purrr::map2( + .x = private$.data, + .y = names(private$.data), + .f = ~ { + data.table(dataname = .y, + ncol = .x$ncol(), + nrow = .x$nrow(), + nrow_removed = nrow(.x$get_removed()), + size = format(object.size(.x$get()), units = "Mb", standard = "SI")) + } + ) %>% + rbindlist() + } + + if (verbose) { + print(knitr::kable(summary_dt)) + } + + invisible(summary_dt) + }, + + print = function() { + .data_summary <- self$summary(verbose = FALSE) %>% + .[, description := glue::glue("{dataname}[{nrow}, {ncol}]", .envir = .)] + .class_inheritance <- glue::glue_collapse(class(self), sep = " <- ") + .data_names <- glue::glue_collapse(.data_summary[['description']], sep = ", ", last = ' and ') + .n_removed <- ifelse(is.null(self$get_removed_data()), 0, nrow(self$get_removed_data())) + # if (requireNamespace('pryr', quietly = TRUE)) { + # .memory <- paste0(format(pryr::object_size(self) / 10^6, digits = 3), " MB") + # } else { + # .memory <- "Not available, this requires the `pryr` package to be installed." + # } + + message( + glue::glue( + "Class: {class(self)[[1]]} + Inheritance: {.class_inheritance} + Number_of_entities: {self$n()} + Number_of_removed_entities: {.n_removed} + Data[rows, cols]: {.data_names} + " + ) + ) + }, + + print_data = function(n = 5) { + if (n > 0) { + print(purrr::map(private$.data, ~ .x$head(n))) + } + data_names = glue::glue_collapse(names(private$.data), ", ", last = " and ") + + lg$info( + glue::glue( + "{class(self)[[1]]} has {length(private$.data)} datasets{seperator} {.data_names}", + .data_names = ifelse(is.character(data_names), data_names, ""), + seperator = ifelse(is.character(data_names), "...", "") + ) + ) + invisible() + }, + + #' @description + #' Returns the number of entities represented by this object. + #' @return (`integer(1)`). + n = function() { + if (is.null(self$data())) { + return(0L) + } else { + self$data()$nrow() + } + }, + + get_last_id = function() { + private$.last_id + }, + + get_new_ids = function() { + private$.new_ids + }, + + generate_new_ids = function(n) { + checkmate::assert_integerish(n, lower = 1, len = 1, null.ok = FALSE, any.missing = FALSE) + # generate new ids + new_ids <- seq( + from = self$get_last_id() + 1L, + to = self$get_last_id() + n, + by = 1L + ) %>% + as.integer() + # update latest id + private$.last_id <- private$.last_id + n + # store the latest set of ids + private$.new_ids <- new_ids + # return the latest set of ids + invisible(new_ids) + }), + + active = list( + + #' @field database a list of [DataBackend] objects that this [Entity] possess. + database = function() { + get(".data", envir = private) + }, + + #' @field (`character()`)\cr + #' a character vector of all id columns with the first element being + #' the main id column and the other elements, if any, are relation columns. + id_col = function() { + get(".id_col", envir = private) + }, + + #' @field (`character(1)`)\cr + #' The ID column name. + primary_id = function() { + get(".id_col", envir = private)[[1]] + }, + + #' @param data_template ([data.table::data.table()])\cr + #' Contains the minimum data requirement apart from the `id_col`. + data_template = function() { + return(data.table()) + } + ), + + private = list( + .data = list(), + .id_col = NULL, + .history = NULL, + .last_id = NA_integer_, + .new_ids = NA_integer_ + ) + ) From 53f2921797066e09f3054fdf9bd6af3eeaebc3bc Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Sun, 29 Nov 2020 15:46:44 +1100 Subject: [PATCH 32/38] added ModelMultinomialLogit unit test --- tests/testthat/test-ModelMultinomialLogit.R | 47 +++++++++++++++++++-- 1 file changed, 44 insertions(+), 3 deletions(-) diff --git a/tests/testthat/test-ModelMultinomialLogit.R b/tests/testthat/test-ModelMultinomialLogit.R index 94313a67..1c42bd26 100644 --- a/tests/testthat/test-ModelMultinomialLogit.R +++ b/tests/testthat/test-ModelMultinomialLogit.R @@ -9,11 +9,52 @@ test_that("ModelMultinomialLogit", { # data for prediction .data <- dfidx::unfold_idx(.data_dfidx) + params = as.numeric(mod$coefficients) + names(params) = names(mod$coefficients) + Mod <- ModelMultinomialLogit$new(params = params, formula = mod$formula) + Mod_formula <- ModelMultinomialLogit$new(params = mod$coefficients, formula = mode ~ price + catch) + + # compare predictions + prediction_from_mlogit <- + predict(mod, .data_dfidx) %>% + as.data.table() + prediction_from_Mod <- + Mod$predict(.data, chooser_id_col = "id1", choice_id_col = "id2") %>% + data.table::dcast(chooser_id ~ choice_id, value.var = "prob") %>% + .[, -"chooser_id"] + prediction_from_Mod_formula <- Mod_formula$predict(.data, + chooser_id_col = "id1", + choice_id_col = "id2") %>% + data.table::dcast(chooser_id ~ choice_id, value.var = "prob") %>% + .[, -"chooser_id"] + prediction_from_Mod_using_dfidx <- + Mod$predict(.data_dfidx, chooser_id_col = "id1", choice_id_col = "id2") %>% + data.table::dcast(chooser_id ~ choice_id, value.var = "prob") %>% + .[, -"chooser_id"] - Mod <- ModelMultinomialLogit$new(params = mod$coefficients, formula = mod$formula) + expect_true(all.equal(prediction_from_mlogit, prediction_from_Mod)) + expect_true(all.equal(prediction_from_mlogit, prediction_from_Mod_formula)) + expect_true(all.equal(prediction_from_mlogit, prediction_from_Mod_using_dfidx)) - Mod_formula <- ModelMultinomialLogit$new(params = mod$coefficients, formula = mode ~ price + catch) + } +}) +test_that("ModelMultinomialLogit - Pure multinomial logit", { + if (requireNamespace('mlogit')) { + + data("Fishing", package = "mlogit") + + # fitting + form = mode ~ 0 | income + .data_dfidx <- dfidx::dfidx(Fishing, varying = 2:9, shape = "wide", choice = "mode") + mod <- mlogit::mlogit(form, data = .data_dfidx) + + # data for prediction + .data <- dfidx::unfold_idx(.data_dfidx) + params = as.numeric(mod$coefficients) + names(params) = names(mod$coefficients) + Mod <- ModelMultinomialLogit$new(params = params, formula = mod$formula) + Mod_formula <- ModelMultinomialLogit$new(params = mod$coefficients, formula = form) # compare predictions prediction_from_mlogit <- @@ -41,7 +82,7 @@ test_that("ModelMultinomialLogit", { }) test_that("ModelMultinomialLogit - different alternatives", { - num_rows <- 100 + num_rows <- 10000 num_choices = 30 my_formula <- chosen ~ x1 + x2 + I(x1^2) + x1:x2 + 0 From f9ccc287de969ee0f87b70575311dbc18a49351c Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 30 Nov 2020 13:30:47 +1100 Subject: [PATCH 33/38] fixes World2 R6 methods and S3 methods --- R/World2.R | 26 ++++++++++++++++---------- man-roxygen/param_world.R | 2 ++ 2 files changed, 18 insertions(+), 10 deletions(-) create mode 100644 man-roxygen/param_world.R diff --git a/R/World2.R b/R/World2.R index 40184a6a..483c0bd4 100644 --- a/R/World2.R +++ b/R/World2.R @@ -2,6 +2,8 @@ #' #' @include Container.R #' +#' @template param_world +#' #' @description #' #' The first step to creating a microsimulation model with `Dymium` is to define @@ -48,7 +50,8 @@ World2 = checkmate::check_r6(object, classes = "Entity"), checkmate::check_r6(object, classes = "Target"), checkmate::check_r6(object, classes = "Model"), - checkmate::check_class(object, classes = "list"), + checkmate::check_list(object, any.missing = FALSE, min.len = 1, names = "unique"), + # checkmate::check_class(object, classes = "list"), checkmate::check_class(object, classes = "numeric"), checkmate::check_class(object, classes = "integer"), combine = "or" @@ -75,14 +78,13 @@ World2 = #' @rdname World2 #' @export set_time = function(world, value) { - checkmate::assert_class(world, "World") - checkmate::assert_integerish( - world$properties$.time, + checkmate::assert_class(world, "World2") + world$properties$.time = checkmate::assert_integerish( + value, lower = 0, len = 1, null.ok = FALSE ) - world$properties$.time = value return(world) } @@ -91,13 +93,17 @@ set_time = function(world, value) { #' @rdname World2 #' @export set_scale = function(world, value) { - checkmate::assert_class(world, "World") - checkmate::assert_numeric( - world$properties$.scale, - len = 1, + checkmate::assert_class(world, "World2") + checkmate::assert_number( + value, finite = TRUE, - null.ok = FALSE + null.ok = FALSE, + lower = 0 ) + if (value == 0) { + stop("`value` (scale) cannot be set to 0. If you would like to set your Targets", + " to zero, please remove those Targets instead.") + } world$properties$.scale = value return(world) } diff --git a/man-roxygen/param_world.R b/man-roxygen/param_world.R new file mode 100644 index 00000000..09f85688 --- /dev/null +++ b/man-roxygen/param_world.R @@ -0,0 +1,2 @@ +#' @param world [World]\cr +#' A [World] object. From ca68cc5f210b5d03c4e1e3bdd608f8f158b37f4b Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 30 Nov 2020 13:30:58 +1100 Subject: [PATCH 34/38] add World2 unit tests --- tests/testthat/test-World2.R | 51 ++++++++++++++++++++++++++++++++++++ 1 file changed, 51 insertions(+) create mode 100644 tests/testthat/test-World2.R diff --git a/tests/testthat/test-World2.R b/tests/testthat/test-World2.R new file mode 100644 index 00000000..e4234893 --- /dev/null +++ b/tests/testthat/test-World2.R @@ -0,0 +1,51 @@ +test_that("World2 works", { + + +# constructor ------------------------------------------------------------- + + + world = World2$new() + checkmate::expect_r6(world, "World2") + +# add ------------------------------------------------------------------- + + # accepted objects + checkmate::expect_r6(world$add(1L, "an_integer"), "World2") + checkmate::expect_r6(world$add(1.0, "a_number"), "World2") + checkmate::expect_r6(world$add(list(x = 1), "a_named_list"), "World2") + checkmate::expect_r6(world$add(Entity$new(databackend = DataBackendDataTable, .data = toy_individuals, id_col = "pid"), name = "an_entity"), "World2") + checkmate::expect_r6(world$add(Target$new(list(x = 1)), name = "a_target"), "World2") + checkmate::expect_r6(world$add(Model$new(list(x = 1)), name = "a_model"), "World2") + + expect_length(world$entities, 1) + expect_length(world$properties, 5 + 3) # 5 added objects + 3 default fields (.time, .last_id, .scale) + + # not accepted objects + expect_error(world$add(list(1), "a_list")) + expect_error(world$add("x", "a_character")) + expect_error(world$add(list(), "an_emptied_list")) +}) + +test_that("World2's S3 methods", { + + world = World2$new() + + # accepted values + checkmate::expect_r6(set_time(world, value = 0), "World2") + checkmate::expect_r6(set_time(world, value = 10), "World2") + checkmate::expect_r6(set_time(world, value = 10.0), "World2") + checkmate::expect_r6(set_time(world, value = 10L), "World2") + checkmate::expect_r6(set_scale(world, value = 1), "World2") + checkmate::expect_r6(set_scale(world, value = 1.5), "World2") + checkmate::expect_r6(set_scale(world, value = 0.1), "World2") + + # not accepted values + expect_error(set_time(world, value = 1.5)) + expect_error(set_time(world, value = -1)) + expect_error(set_scale(world, value = 0)) + expect_error(set_scale(world, value = -1)) + expect_error(set_scale(world, value = Inf)) + expect_error(set_scale(world, value = -Inf)) + +}) + From a268479f9830c378cfb1bc5d778f844a4f9818af Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 30 Nov 2020 14:59:22 +1100 Subject: [PATCH 35/38] removed unnecessary double colons of self namespace --- R/Container.R | 10 +++++----- R/ContainerGeneric.R | 6 +++--- R/Entity.R | 2 +- R/Pipeline.R | 2 +- R/Target.R | 2 +- R/Transition.R | 2 +- R/World.R | 10 +++++----- R/simulate_choice.R | 2 +- R/transition-fnc.R | 2 +- tests/testthat/setup-models.R | 2 +- tests/testthat/test-Agent.R | 2 +- tests/testthat/test-Entity.R | 2 +- tests/testthat/test-Model.R | 2 +- tests/testthat/test-Population.R | 28 ++++++++++++++-------------- 14 files changed, 37 insertions(+), 37 deletions(-) diff --git a/R/Container.R b/R/Container.R index 3996acf0..7dbef82f 100644 --- a/R/Container.R +++ b/R/Container.R @@ -5,7 +5,7 @@ #' #' #' @usage NULL -#' @format [R6::R6Class] object inheriting from [dymiumCore::ContainerGeneric] +#' @format [R6::R6Class] object inheriting from [ContainerGeneric] #' @include ContainerGeneric.R #' #' @section Construction: @@ -25,8 +25,8 @@ #' #' * `add(x, name)`\cr #' ([R6::R6Class]|Supported Transition Models)\cr -#' Add an [R6::R6Class] object or a object of the classes in [dymiumCore::SupportedTransitionModels] to self$Cont. -#' Name must be given when `x` is an object of the classes in [dymiumCore::SupportedTransitionModels]. +#' Add an [R6::R6Class] object or a object of the classes in [SupportedTransitionModels] to self$Cont. +#' Name must be given when `x` is an object of the classes in [SupportedTransitionModels]. #' #' * `check_pos(x)`\cr #' (`integer(1)`) -> (`logical(1)`)\cr @@ -52,7 +52,7 @@ #' generator or string or integer. #' #' * `unpack(target)`\cr -#' ([dymiumCore::Container])\cr +#' ([Container])\cr #' Add all the references inside self$Cont to the `target` container. This is #' useful when you have containers within a container so that all references can #' be access via the top container. eg: A World container that contains a Population @@ -66,7 +66,7 @@ #' @export Container <- R6Class( classname = "Container", - inherit = dymiumCore::ContainerGeneric, + inherit = ContainerGeneric, public = list( add = function(x, name) { diff --git a/R/ContainerGeneric.R b/R/ContainerGeneric.R index bdfa70d5..0b7217b1 100644 --- a/R/ContainerGeneric.R +++ b/R/ContainerGeneric.R @@ -4,7 +4,7 @@ #' isn't supposed to be use directly. #' #' @usage NULL -#' @format [R6::R6Class] object inheriting from [dymiumCore::Generic] +#' @format [R6::R6Class] object inheriting from [Generic] #' @include ContainerGeneric.R #' #' @section Construction: @@ -45,7 +45,7 @@ #' Remove the object at the `x` element of `self$Cont`. #' #' * `unpack(target)`\cr -#' ([dymiumCore::Container])\cr +#' ([Container])\cr #' Add all the objects in `self$Cont` to another `target` Container. #' #' * `summary()`\cr @@ -54,7 +54,7 @@ #' @export ContainerGeneric <- R6Class( classname = "ContainerGeneric", - inherit = dymiumCore::Generic, + inherit = Generic, public = list( Cont = list(), diff --git a/R/Entity.R b/R/Entity.R index 7897c29f..8c0df8c4 100644 --- a/R/Entity.R +++ b/R/Entity.R @@ -48,7 +48,7 @@ #' must be linkable with the attribute data of the object by the id_col. #' #' * `data(name)`\cr -#' (`character(1)`) -> (`[dymiumCore::DataBackend]`|`NULL`)\cr +#' (`character(1)`) -> ([DataBackend]|`NULL`)\cr #' Returns a [DataBackend] with the name that matches `name`. #' If `name` is not given, the function will try to return the [DataBackend] with name `attrs`. #' If `attrs` is not present or no `DataBackEnd` objects have been loaded it will diff --git a/R/Pipeline.R b/R/Pipeline.R index b84d80db..f45c969a 100644 --- a/R/Pipeline.R +++ b/R/Pipeline.R @@ -23,7 +23,7 @@ #' ``` #' #' @usage NULL -#' @format [R6::R6Class] object inheriting from [dymiumCore::Generic]. +#' @format [R6::R6Class] object inheriting from [Generic]. #' @include Generic.R #' @include Population.R #' diff --git a/R/Target.R b/R/Target.R index af891846..e3d06e46 100644 --- a/R/Target.R +++ b/R/Target.R @@ -63,7 +63,7 @@ #' TrgtDynamic$get(10) Target <- R6::R6Class( classname = "Target", - inherit = dymiumCore::Generic, + inherit = Generic, public = list( initialize = function(x, name) { assert_target(x, null.ok = TRUE) diff --git a/R/Transition.R b/R/Transition.R index 3253e2f3..853744eb 100644 --- a/R/Transition.R +++ b/R/Transition.R @@ -106,7 +106,7 @@ Trans <- R6Class( } if (!is.null(target)) { - dymiumCore::assert_target(target) + assert_target(target) if (checkmate::test_r6(target, "Target")) { private$.target <- target$get() } else { diff --git a/R/World.R b/R/World.R index 3b5d158f..76ad43c8 100644 --- a/R/World.R +++ b/R/World.R @@ -46,8 +46,8 @@ #' @section Public Methods: #' #' * `add(x, name, replace = TRUE)`\cr -#' ([dymiumCore::Entity] and inheritances | [dymiumCore::Container] | an object of the classes in -#' [dymiumCore::SupportedTransitionModels], `character(1)`, `logical(1)`)\cr +#' ([Entity] and inheritances | [Container] | an object of the classes in +#' [SupportedTransitionModels], `character(1)`, `logical(1)`)\cr #' Add an object the allowed types to `self$Cont`, `self$entities`, `self$containers`, #' `self$models`. Only one instance of each class are allowed to be stored. #' The stored instances can be access via `self$` or `self$get(x)`. @@ -106,7 +106,7 @@ #' @export World <- R6::R6Class( classname = "World", - inherit = dymiumCore::Container, + inherit = Container, public = list( info = list( @@ -130,7 +130,7 @@ World <- R6::R6Class( checkmate::check_r6(x, classes = c("Container", "Generic"), null.ok = FALSE), checkmate::check_r6(x, classes = c("Model", "Generic"), null.ok = FALSE), checkmate::check_subset(class(x)[[1]], - choices = dymiumCore::SupportedTransitionModels(), + choices = SupportedTransitionModels(), empty.ok = FALSE), check_target(x, null.ok = FALSE), combine = "or" @@ -177,7 +177,7 @@ World <- R6::R6Class( .listname <- ".containers" } - if (class(x)[[1]] %in% dymiumCore::SupportedTransitionModels()) { + if (class(x)[[1]] %in% SupportedTransitionModels()) { lg$info("Adding a Model object '{name}' to the `models` field.") x <- Model$new(x, name = name) .listname <- ".models" diff --git a/R/simulate_choice.R b/R/simulate_choice.R index e1ad9be6..e6b6b7a2 100644 --- a/R/simulate_choice.R +++ b/R/simulate_choice.R @@ -36,7 +36,7 @@ simulate_choice.list <- function(model, newdata, target = NULL, ...) { any.missing = FALSE ) checkmate::assert_data_frame(newdata) - dymiumCore::sample_choice( + sample_choice( x = names(model), size = nrow(newdata), prob = model, diff --git a/R/transition-fnc.R b/R/transition-fnc.R index aa8929cf..f54e68b2 100644 --- a/R/transition-fnc.R +++ b/R/transition-fnc.R @@ -252,7 +252,7 @@ get_transition <- function(world, entity, model, target = NULL, targeted_ids = N e_data <- model$preprocessing_fn(e_data) } - e_data <- dymiumCore::normalise_derived_vars(e_data) + e_data <- normalise_derived_vars(e_data) # early return if no data if (nrow(e_data) == 0) { return(data.table(id = integer(), response = character())) diff --git a/tests/testthat/setup-models.R b/tests/testthat/setup-models.R index 9a62a3de..e0e9a36e 100644 --- a/tests/testthat/setup-models.R +++ b/tests/testthat/setup-models.R @@ -1,6 +1,6 @@ create_mlr_task <- function() { task_data <- - dymiumCore::toy_individuals[, sex := as.factor(sex)][, marital_status := as.factor(marital_status)] %>% + toy_individuals[, sex := as.factor(sex)][, marital_status := as.factor(marital_status)] %>% .[, .(age, sex, marital_status)] %>% as.data.frame() } diff --git a/tests/testthat/test-Agent.R b/tests/testthat/test-Agent.R index a8aa8807..28e60359 100644 --- a/tests/testthat/test-Agent.R +++ b/tests/testthat/test-Agent.R @@ -70,7 +70,7 @@ test_that("hatch and add", { new_agent_data <- register(MyAgent, toy_individuals) new_agent_data$toy_individuals MyAgent$add(.data = new_agent_data$toy_individuals, check_existing = FALSE) - expect_true(MyAgent$n() == nrow(dymiumCore::toy_individuals) * 2) + expect_true(MyAgent$n() == nrow(toy_individuals) * 2) pid_cols <- c('pid', 'partner_id', 'father_id', 'mother_id') unique_pid <- MyAgent$get_data()[, unlist(.SD), .SDcol = pid_cols] %>% unique() %>% na.omit() %>% length() diff --git a/tests/testthat/test-Entity.R b/tests/testthat/test-Entity.R index db539542..de096956 100644 --- a/tests/testthat/test-Entity.R +++ b/tests/testthat/test-Entity.R @@ -165,7 +165,7 @@ test_that("$subset_ids", { Ent <- Entity$new( databackend = DataBackendDataTable, - .data = dymiumCore::toy_individuals, + .data = toy_individuals, id_col = "pid" ) diff --git a/tests/testthat/test-Model.R b/tests/testthat/test-Model.R index 728966ca..741fbcac 100644 --- a/tests/testthat/test-Model.R +++ b/tests/testthat/test-Model.R @@ -48,7 +48,7 @@ test_that("Model - preprocess", { test_that("Model works with mlr model object", { if (requireNamespace("mlr") & requireNamespace("nnet")) { task_data <- - dymiumCore::toy_individuals[, sex := as.factor(sex)][, marital_status := as.factor(marital_status)] %>% + toy_individuals[, sex := as.factor(sex)][, marital_status := as.factor(marital_status)] %>% .[, .(age, sex, marital_status)] %>% as.data.frame() task <- mlr::makeClassifTask(id = "toy_multi_classes", data = task_data, target = "marital_status") diff --git a/tests/testthat/test-Population.R b/tests/testthat/test-Population.R index cdc0b388..56105e80 100644 --- a/tests/testthat/test-Population.R +++ b/tests/testthat/test-Population.R @@ -3,10 +3,10 @@ context("population class") test_that("initialize", { # missing household by removing create_toy_population() - toy_households2 <- copy(dymiumCore::toy_households)[-1,] + toy_households2 <- copy(toy_households)[-1,] expect_error( - pop$add_population(ind_data = dymiumCore::toy_individuals, + pop$add_population(ind_data = toy_individuals, hh_data = toy_households2), regexp = "Not all household ids exist in both `ind_data` and `hh_data`." ) @@ -14,20 +14,20 @@ test_that("initialize", { # missing household by altering ids create_toy_population() toy_households2 <- - copy(dymiumCore::toy_households)[1, hid := 99999] + copy(toy_households)[1, hid := 99999] expect_error( - pop$add_population(ind_data = dymiumCore::toy_individuals, + pop$add_population(ind_data = toy_individuals, hh_data = toy_households2), regexp = "Not all household ids exist in both `ind_data` and `hh_data`." ) # missing individual in ind_data by removing create_toy_population() - toy_individuals2 <- copy(dymiumCore::toy_individuals)[-1, ] + toy_individuals2 <- copy(toy_individuals)[-1, ] expect_error( pop$add_population(ind_data = toy_individuals2, - hh_data = dymiumCore::toy_households), + hh_data = toy_households), regexp = "Not all household ids exist in both `ind_data` and `hh_data`." ) @@ -125,30 +125,30 @@ test_that("check_unique_id_cols", { expect_error( pop$check_unique_id_cols( - ind_data = dymiumCore::toy_individuals, - hh_data = dymiumCore::toy_households + ind_data = toy_individuals, + hh_data = toy_households ) ) expect_true( pop$check_unique_id_cols( - ind_data = copy(dymiumCore::toy_individuals)[, `:=`(pid = 9999, hid = NA_integer_)] + ind_data = copy(toy_individuals)[, `:=`(pid = 9999, hid = NA_integer_)] ) ) - pop$check_unique_id_cols(ind_data = copy(dymiumCore::toy_individuals)[, `:=`(pid = 9999, hid = NA_integer_)]) + pop$check_unique_id_cols(ind_data = copy(toy_individuals)[, `:=`(pid = 9999, hid = NA_integer_)]) expect_error( pop$check_unique_id_cols( - ind_data = copy(dymiumCore::toy_individuals)[, `:=`(pid = 9999)], - hh_data = copy(dymiumCore::toy_households)[, hid := 9999] + ind_data = copy(toy_individuals)[, `:=`(pid = 9999)], + hh_data = copy(toy_households)[, hid := 9999] ) ) expect_true( pop$check_unique_id_cols( - ind_data = copy(dymiumCore::toy_individuals)[, `:=`(pid = 9999, hid = 9999)], - hh_data = copy(dymiumCore::toy_households)[, hid := 9999] + ind_data = copy(toy_individuals)[, `:=`(pid = 9999, hid = 9999)], + hh_data = copy(toy_households)[, hid := 9999] ) ) }) From 4571b9701eedc27f96daf1e801da922e49842fac Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Mon, 30 Nov 2020 15:02:31 +1100 Subject: [PATCH 36/38] fix(DataBackendDataTable): converts data.frame object to data.table instead of raising an error --- R/DataBackendDataTable.R | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/R/DataBackendDataTable.R b/R/DataBackendDataTable.R index 8b55cb3a..5247204c 100644 --- a/R/DataBackendDataTable.R +++ b/R/DataBackendDataTable.R @@ -79,8 +79,12 @@ DataBackendDataTable <- R6::R6Class( inherit = DataBackendDataFrame, public = list( initialize = function(.data, key = NULL) { - checkmate::assert_data_table(.data, min.rows = 1, null.ok = FALSE, col.names = "strict") - .data <- data.table::copy(.data) + checkmate::assert_data_frame(.data, min.rows = 1, null.ok = FALSE, col.names = "strict") + if (!data.table::is.data.table(.data)) { + .data = as.data.table(.data) + } else { + .data <- data.table::copy(.data) + } if (!is.null(key)) { if (!key %in% names(.data)) { stop(paste0("'", key, "' key column doesn't exist in `.data`.")) From 0964320a81cf2b218f5f4e514b63ad3e1f7fd607 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Tue, 1 Dec 2020 12:06:33 +1100 Subject: [PATCH 37/38] added drafts --- R/Entity2.R | 146 ++++++++--------------------- R/ModelBinaryChoice.R | 4 +- R/ModelCustom.R | 8 +- R/ModelWrapper.R | 27 ++++++ R/World2.R | 39 ++++++-- R/align_prediction.R | 4 + R/predict_transition.R | 30 ++++++ tests/testthat/test-Entity2.R | 16 ++++ tests/testthat/test-ModelWrapper.R | 77 +++++++++++++++ tests/testthat/test-World2.R | 2 - 10 files changed, 225 insertions(+), 128 deletions(-) create mode 100644 R/ModelWrapper.R create mode 100644 R/align_prediction.R create mode 100644 R/predict_transition.R create mode 100644 tests/testthat/test-Entity2.R create mode 100644 tests/testthat/test-ModelWrapper.R diff --git a/R/Entity2.R b/R/Entity2.R index df8406f3..e1a0a42e 100644 --- a/R/Entity2.R +++ b/R/Entity2.R @@ -20,15 +20,6 @@ #' Return removed agent data. If `name` is missing, the first data, which should #' contains the main attributes of the agent object, will be returned. #' -#' * `get_attr(x, ids)`\cr -#' (`character(1)`, `integer()`) -> `vector(type::col)`\cr -#' Extract the attribute from self$data as vector. If `ids` is given then only -#' the corresponding values to `ids` are returned, in the same order as the `ids`. -#' -#' * `has_attr(x)`\cr -#' (`character()`) -> `logical()`\cr -#' -#' #' * `ids_exist(ids, include_removed_data = FALSE)`\cr #' (`integer()`, `logical(1)`) -> `logical()`\cr #' Check whether `ids` exist or not. And if `inclide_removed_data` is `TRUE` it @@ -121,84 +112,55 @@ Entity2 <- #' row order as the order of `ids`. If `copy` is TRUE then data.table's #' reference semantics is returned. If `attrs` is not present or no `DataBackEnd` #' objects have been loaded it will return `NULL`. + #' @param name (`character(1)`)\cr + #' Default as 'attrs'. + #' @param ids (`integer()`)\cr + #' Subset the returned data by their unique ids. #' @param copy (`logical(1)`)\cr #' When this is `FALSE`, it will return the reference to the request data. #' Meaning that the data can be manipulated in place. - get_data = function(name, ids, copy = TRUE) { - - if (missing(name)) { - name <- "attrs" - } - - DataObj <- self$data(name) + #' @return ([data.table::data.table()]|`data.frame()`) + get_data = function(name = "attrs", ids, copy = TRUE) { - if (is.null(DataObj)) { - return(NULL) - } + checkmate::assert_string(name, na.ok = FALSE, null.ok = FALSE) - if (copy == FALSE) { - if (!missing(ids)) { - stop("It is not possible to return a reference semetic to the specific rows in `ids`.") - } - return(DataObj$get(copy = FALSE)) + if (!missing(ids)) { + checkmate::assert_integerish( + x = ids, + unique = TRUE, + lower = 1, + min.len = 1, + null.ok = FALSE, + any.missing = FALSE, + all.missing = FALSE + ) } - if (missing(ids)) { - return(DataObj$get()) - } else { - checkmate::check_integerish(x = ids, unique = TRUE, lower = 1, min.len = 1, null.ok = FALSE, any.missing = FALSE) - if (name == "attrs") { - return(DataObj$get(rows = self$get_idx(ids))) - } else { - lg$warn("The order of the returned data is not garantee to be the same \\ - with the input `ids`. Also not all ids are garantee to have \\ - valid records.") - return(DataObj$get()[get(self$get_id_col()) %in% ids,]) - } + checkmate::assert_flag(copy, na.ok = FALSE, null.ok = FALSE) + if (!missing(ids) && !isTRUE(copy)) { + stop("It is not possible to return the reference semantics of the rows in `ids`.") } - }, - - #' @description - #' A different implementation of `self$get_data()`. - #' @return ([data.table::data.table()]|`data.frame()`) - get_data2 = function(name = "attrs", ids, copy = TRUE) { - DataObj <- self$data(name) - if (is.null(DataObj)) { - return(NULL) - } - - if (copy == FALSE) { - if (!missing(ids)) { - stop("It is not possible to return a reference semetic to the specific rows in `ids`.") - } - return(DataObj$get(copy = FALSE)) + if (!inherits(DataObj, "DataBackendDataTable") & !isTRUE(copy)) { + stop("Cannot return the reference to the requested data, since it ", + "doesn't inherit from `DataBackendDataTable`.") } - if (missing(ids)) { - return(DataObj$get()) - } else { - checkmate::check_integerish(x = ids, unique = TRUE, lower = 1, min.len = 1, null.ok = FALSE, any.missing = FALSE) - if (name == "attrs") { - if (is.null(DataObj$key)) { - DataObj$setkey(self$get_id_col()) - } - return( - data.table:::na.omit.data.table( - DataObj$get(copy = FALSE)[J(ids)], - cols = DataObj$colnames[2] - ) + if (!missing(ids)) { + if (name != "attrs") { + warning( + "The order of the returned data is not garantee to be the same ", + "with the input `ids`. Also not all ids can be guaranteed to correspond ", + "to valid records." ) - } else { - lg$warn("The order of the returned data is not garantee to be the same \\ - with the input `ids`. Also not all ids are garantee to have \\ - valid records.") - return(DataObj$get()[get(self$get_id_col()) %in% ids,]) } + return(DataObj$get()[get(self$get_id_col()) %in% ids, ]) } + + DataObj$get(copy = copy) }, #' @description @@ -288,24 +250,6 @@ Entity2 <- invisible() }, - #' @description - #' Check which of the attribute names given in `x` exist in the attribute data - #' of the object. - #' @param x (`character()`)\cr - #' Name of columns to check. - #' @return (`logical()`) - has_attr = function(x) { - x %in% self$database$attrs$colnames - }, - - get_attr = function(x, ids) { - checkmate::assert_string(x, na.ok = FALSE, null.ok = FALSE) - if (!missing(ids)) { - return(self$get_data(copy = FALSE)[self$get_idx(ids = ids)][[x]]) - } - self$data()$get(col = x)[[1]] - }, - get_removed_data = function(name) { DataObj <- self$data(name) if (is.null(DataObj)) { @@ -455,31 +399,19 @@ Entity2 <- ) }, - print_data = function(n = 5) { - if (n > 0) { - print(purrr::map(private$.data, ~ .x$head(n))) - } - data_names = glue::glue_collapse(names(private$.data), ", ", last = " and ") - - lg$info( - glue::glue( - "{class(self)[[1]]} has {length(private$.data)} datasets{seperator} {.data_names}", - .data_names = ifelse(is.character(data_names), data_names, ""), - seperator = ifelse(is.character(data_names), "...", "") - ) - ) - invisible() - }, - #' @description #' Returns the number of entities represented by this object. + #' + #' @param included_removed (`logical(1)`)\cr + #' Should the number of removed entities be included. + #' #' @return (`integer(1)`). - n = function() { + n = function(included_removed = FALSE) { if (is.null(self$data())) { return(0L) - } else { - self$data()$nrow() } + + self$data()$nrow() }, get_last_id = function() { diff --git a/R/ModelBinaryChoice.R b/R/ModelBinaryChoice.R index ff315078..24941823 100644 --- a/R/ModelBinaryChoice.R +++ b/R/ModelBinaryChoice.R @@ -42,8 +42,8 @@ ModelBinaryChoice <- R6::R6Class( #' @export predict = function(newdata, link_function = c("logit")) { link_function <- match.arg(link_function) - linear_comb <- private$.compute_linear_combination(newdata) - 1 / (1 + exp(-linear_comb)) + linear_comb <- compute_linear_combination(self$formula, self$params, newdata) + return(1 / (1 + exp(-linear_comb))) } ) ) diff --git a/R/ModelCustom.R b/R/ModelCustom.R index 6fcfdc08..ad8d8f0c 100644 --- a/R/ModelCustom.R +++ b/R/ModelCustom.R @@ -93,13 +93,6 @@ ModelCustom <- R6::R6Class( summary = function() { self$print() } - ), - - private = list( - .compute_linear_combination = function(newdata) { - mm <- model.matrix(self$formula, newdata) - as.numeric(self$params %*% t(mm)) - } ) ) @@ -121,6 +114,7 @@ compute_linear_combination <- function(formula, ...) { #' @rdname compute_linear_combination #' @export compute_linear_combination.formula <- function(formula, params, newdata) { + browser() mm <- model.matrix(formula, newdata) return(as.numeric(params %*% t(mm))) } diff --git a/R/ModelWrapper.R b/R/ModelWrapper.R new file mode 100644 index 00000000..ccbad7ec --- /dev/null +++ b/R/ModelWrapper.R @@ -0,0 +1,27 @@ +ModelWrapper = + R6::R6Class( + classname = "ModelWrapper", + inherit = Model, + public = list(), + active = list() + ) + + + +get_prediction = function() {} + +# ModelTidymodel = +# R6::R6Class( +# classname = "ModelTidymodel", +# inherit = ModelWrapper, +# public = list( +# predict = function() { +# +# } +# )) +# +# ModelGlm = R6::R6Class(classname = "ModelGlm", inherit = ModelWrapper) +# ModelCaret = R6::R6Class(classname = "ModelCaret", inherit = ModelWrapper) +# ModelMlr = R6::R6Class(classname = "ModelMlr3", inherit = ModelWrapper) +# ModelMlr3 = R6::R6Class(classname = "ModelMlr3", inherit = ModelWrapper) +# ModelMlogit = R6::R6Class(classname = "ModelMlogit", inherit = ModelWrapper) diff --git a/R/World2.R b/R/World2.R index 483c0bd4..cd5896e8 100644 --- a/R/World2.R +++ b/R/World2.R @@ -43,27 +43,39 @@ World2 = }, #' @description - #' #' For adding [Entities] and properties (see the `properties` field) to [World]. + #' @param object ([Entity]|[Target]|[Model]|named `list()`|`numeric()`|`integer()`)\cr + #' A object to be added. `Entity` objects will be added to `self$entities`, whereas + #' other accepted objects will be added to `self$properties`. + #' @param name (`character(1)`)\cr + #' Name of the object that is being added. + #' + #' @return self. add = function(object, name) { checkmate::assert( - checkmate::check_r6(object, classes = "Entity"), + checkmate::check_r6(object, classes = "Entity2"), checkmate::check_r6(object, classes = "Target"), checkmate::check_r6(object, classes = "Model"), checkmate::check_list(object, any.missing = FALSE, min.len = 1, names = "unique"), - # checkmate::check_class(object, classes = "list"), - checkmate::check_class(object, classes = "numeric"), - checkmate::check_class(object, classes = "integer"), + checkmate::check_numeric(object), + checkmate::check_integerish(object), combine = "or" ) checkmate::assert_string(name, null.ok = TRUE) - .field_name = ifelse(checkmate::test_r6(object, classes = "Entity"), + .field_name = ifelse(checkmate::test_r6(object, classes = "Entity2"), "entities", "properties") - len = length(self[[.field_name]]) - self[[.field_name]][[len + 1L]] = object - names(self[[.field_name]])[[len + 1L]] = name - return(self) + len = length(self[[.field_name]]) + self[[.field_name]][[len + 1L]] = object + names(self[[.field_name]])[[len + 1L]] = name + return(self) + }, + + #' @description + #' + #' Remove the object. + remove = function(object) { + stop("To be implemented.") }, print = function() { @@ -107,3 +119,10 @@ set_scale = function(world, value) { world$properties$.scale = value return(world) } + +next_id = function(world) { + checkmate::assert_r6(world, "World2") + + last_id = world$entities$n() + return() +} diff --git a/R/align_prediction.R b/R/align_prediction.R new file mode 100644 index 00000000..57855c04 --- /dev/null +++ b/R/align_prediction.R @@ -0,0 +1,4 @@ +align_prediction = function(probs, target) { + checkmate::assert_data_frame(probs, col.names = "unique") + assert_target(target) +} diff --git a/R/predict_transition.R b/R/predict_transition.R new file mode 100644 index 00000000..9bab3552 --- /dev/null +++ b/R/predict_transition.R @@ -0,0 +1,30 @@ +#' Predict a transition +#' +#' +#' @template param_world +#' @template param_entity +#' @template param_model +#' @template param_target +#' @template param_ids +#' +#' @return [predict_transition] returns choices or results, whereas [predict_transition_prob] +#' returns choice probabilities. +#' @export +#' +#' @examples +#' +#' +predict_transition = function(entity, model, target, world, ids) { + predict_transition_prob(entity, model, world, ids) + if (!is.missing(target)) { + align_prediction + } +} + +predict_transition_prob = function(entity, model, world, ids) { + +} + +predict_transition_raw = function(entity, model, world, ids) { + +} diff --git a/tests/testthat/test-Entity2.R b/tests/testthat/test-Entity2.R new file mode 100644 index 00000000..b6687d9f --- /dev/null +++ b/tests/testthat/test-Entity2.R @@ -0,0 +1,16 @@ +test_that("Entity2 works", { + +# constructor ------------------------------------------------------------- + + en = Entity2$new(databackend = DataBackendDataTable, .data = toy_individuals, id_col = "pid") + + +# add --------------------------------------------------------------------- + + + +# get_data ---------------------------------------------------------------- + + checkmate::expect_data_table(en$get_data(), nrows = nrow(toy_individuals)) + +}) diff --git a/tests/testthat/test-ModelWrapper.R b/tests/testthat/test-ModelWrapper.R new file mode 100644 index 00000000..eafda6bd --- /dev/null +++ b/tests/testthat/test-ModelWrapper.R @@ -0,0 +1,77 @@ +test_that("ModelWrapper works", { + mod = ModelWrapper$new(list(x = 1), name = "ModelWrapper") + checkmate::expect_r6(mod, classes = "ModelWrapper") + +}) + + +test_that("ModelTidymodel works", { + + # tidymodel classification ---------------------------------------------------------- + logistic_reg = + parsnip::logistic_reg() %>% + parsnip::set_engine("glm") %>% + parsnip::fit(I(as.factor(sex)) ~ age + marital_status, data = toy_individuals) + + predict(logistic_reg, new_data = toy_individuals, type = "prob") + + random_forest_classif = + parsnip::rand_forest() %>% + parsnip::set_engine("ranger") %>% + parsnip::set_mode("classification") %>% + parsnip::fit(I(as.factor(sex)) ~ age + marital_status, data = toy_individuals) + + predict(random_forest_classif, new_data = toy_individuals, type = "prob") + + multinom_reg = + parsnip::multinom_reg() %>% + parsnip::set_engine("glmnet") %>% + parsnip::set_mode("classification") %>% + parsnip::fit(I(as.factor(marital_status)) ~ age + sex, data = toy_individuals) + + predict(multinom_reg, new_data = toy_individuals, type = "prob", penalty = 0) + + # tidymodel regression ---------------------------------------------------------- + linear_reg = + parsnip::linear_reg() %>% + parsnip::set_engine("lm") %>% + parsnip::fit(age ~ sex + marital_status, data = toy_individuals) + + predict(linear_reg, new_data = toy_individuals) + + random_forest_reg = + parsnip::rand_forest() %>% + parsnip::set_engine("ranger") %>% + parsnip::set_mode("regression") %>% + parsnip::fit(age ~ sex + marital_status, data = toy_individuals) + + predict(random_forest_reg, new_data = toy_individuals) + +}) + +test_that("ModelGlm works", { + + # glm classification ------------------------------------------------------ + logistic_reg = + glm(I(as.factor(sex)) ~ age + marital_status, data = toy_individuals, family = "binomial") + + # lm regression ------------------------------------------------------ + linear_reg = + glm(age ~ sex + marital_status, data = toy_individuals) +}) + +test_that("ModelCaret works", { + +}) + +test_that("ModelMlr3 works", { + +}) + +test_that("ModelMlr works", { + +}) + +test_that("ModelMlogit works", { + +}) diff --git a/tests/testthat/test-World2.R b/tests/testthat/test-World2.R index e4234893..10d8955d 100644 --- a/tests/testthat/test-World2.R +++ b/tests/testthat/test-World2.R @@ -2,8 +2,6 @@ test_that("World2 works", { # constructor ------------------------------------------------------------- - - world = World2$new() checkmate::expect_r6(world, "World2") From 1933bd7552361f3b991ef5de7c12840494c80bf3 Mon Sep 17 00:00:00 2001 From: amarin <17020181+asiripanich@users.noreply.github.com> Date: Tue, 1 Dec 2020 12:07:12 +1100 Subject: [PATCH 38/38] added some tidymodels pkgs to suggests --- DESCRIPTION | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index af7a4ef6..5d481664 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -52,7 +52,10 @@ Suggests: scales (>= 1.1.0), prettydoc, visNetwork (>= 2.0.0), - dfidx + dfidx, + parsnip, + ranger, + glmnet Roxygen: list(markdown = TRUE, r6 = TRUE) RoxygenNote: 7.1.1 StagedInstall: no