custom models

DESCRIPTION

@@ -1,5 +1,5 @@
 Package: dymiumCore
-Version: 0.1.8.9000
+Version: 0.1.9
 Title: A Toolkit for Building a Dynamic Microsimulation Model for Integrated Urban Modelling
 Description: A modular microsimulation modelling framework for integrated urban modelling.
 Authors@R: c(
@@ -35,6 +35,7 @@ Suggests:
     furrr (>= 0.1.0),
     testthat (>= 2.1.0),
     fastmatch (>= 1.1.0),
+    mlogit (>= 1.1.0),
     caret (>= 6.0.0),
     mlr (>= 2.17.0),
     nnet (>= 7.3.0),
@@ -53,7 +54,8 @@ Suggests:
     scales (>= 1.1.0),
     prettydoc,
     ggthemes (>= 4.2.0),
-    visNetwork (>= 2.0.0)
+    visNetwork (>= 2.0.0),
+    dfidx
 Roxygen: list(markdown = TRUE, r6 = FALSE)
 RoxygenNote: 7.1.0
 StagedInstall: no
@@ -82,6 +84,10 @@ Collate:
     'MatchingMarketOptimal.R'
     'MatchingMarketStochastic.R'
     'Model.R'
+    'ModelBinaryChoice.R'
+    'ModelCustom.R'
+    'ModelLinear.R'
+    'ModelMultinomialLogit.R'
     'Network.R'
     'Population.R'
     'Pipeline.R'
@@ -99,6 +105,7 @@ Collate:
     'create-world.R'
     'data.R'
     'dymiumCore-package.R'
+    'makeModel.R'
     'module.R'
     'mutate-entity.R'
     'population-register.R'

NAMESPACE

@@ -11,6 +11,8 @@ S3method(get_history,Entity)
 S3method(get_log,Container)
 S3method(get_log,Generic)
 S3method(get_log,World)
+S3method(makeModel,mlogit)
+S3method(makeModel,train)
 S3method(simulate_choice,Model)
 S3method(simulate_choice,WrappedModel)
 S3method(simulate_choice,data.frame)
@@ -41,6 +43,10 @@ export(MatchingMarket)
 export(MatchingMarketOptimal)
 export(MatchingMarketStochastic)
 export(Model)
+export(ModelBinaryChoice)
+export(ModelCustom)
+export(ModelLinear)
+export(ModelMultinomialLogit)
 export(Network)
 export(Pipeline)
 export(Population)
@@ -101,6 +107,7 @@ export(is_dymium_class)
 export(is_scheduled)
 export(lookup_and_replace)
 export(lookup_and_replace2)
+export(makeModel)
 export(mutate_entity)
 export(normalise_derived_vars)
 export(omit_derived_varnames)
@@ -121,11 +128,13 @@ export(test_subset2)
 export(test_target)
 export(test_transition_supported_model)
 export(transition)
-export(unnest_datatable)
+export(unnest_dt)
 export(use_event)
 export(use_module)
 export(use_module_readme)
 export(validate_linkages)
+export(which_max_n)
+export(which_min_n)
 import(R6)
 import(data.table)
 importFrom(checkmate,makeExpectation)

NEWS.md

@@ -1,4 +1,9 @@
-# dymiumCore (development version)
+# dymiumCore 0.1.9
+
+- introduced `ModelCustom` a model class that let users specify its parameters and `predict` function. We also add `ModelMultinomialLogit`, `ModelBinaryChoice` and `ModelLinear` which are implementations of `ModelCustom`.
+- add `makeModel` to create a light weight Model object that can be used in the transition functions and classes. This basically creates an appropriate Model class from the given model object. 
+- add helper functions `which_min_n` and `which_max_n`.
+- renamed `unnest_datatable` to `unnest_dt` which can take names of the list columns as a character vector. 
 
 # dymiumCore 0.1.8
 

R/Generic.R

@@ -127,6 +127,14 @@ Generic <- R6Class(
   ),
 
   private = list(
+    .abstract = function(msg) {
+      # this is a method for abstract methods
+      if (!missing(msg))  {
+        lg$fatal(msg)
+      }
+      stop("This is an abstract method which is to be implemented.")
+    },
+
     abstract = function(msg) {
       # this is a method for abstract methods
       if (!missing(msg))  {

R/ModelBinaryChoice.R

@@ -0,0 +1,49 @@
+#' @title ModelBinaryChoice
+#'
+#' @usage NULL
+#' @format [R6::R6Class] object inheriting [ModelCustom].
+#'
+#' @export
+ModelBinaryChoice <- R6::R6Class(
+  classname = "ModelBinaryChoice",
+  inherit = ModelCustom,
+  public = list(
+
+
+    #' @description
+    #'
+    #' Initialisation function
+    #'
+    #' @param params a `data.frame` object.
+    #' @param formula a `formula` object.
+    #' @param preprocessing_fn a pre-processing function that gets applied to the
+    #'  data given to the `predict` method before making the prediction.
+    #'
+    #' @return NULL
+    initialize = function(params, formula, preprocessing_fn = NULL) {
+      super$initialize(params = params,
+                       formula = formula,
+                       type = "binary_choice",
+                       preprocessing_fn = preprocessing_fn)
+      invisible(NULL)
+    },
+
+    #' @description
+    #'
+    #' This predict method returns probabilities generated from the parameters
+    #' of this [Model] object.
+    #'
+    #' @param newdata a `data.frame` object.
+    #' @param link_function :: `character(1)`\cr
+    #'  default as 'logit' using `stats::binomial(link = "logit")`. Choice of
+    #'  'logit' and 'probit'. TODO: implement 'probit' option.
+    #'
+    #' @return
+    #' @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))
+    }
+  )
+)

R/ModelCustom.R

@@ -0,0 +1,99 @@
+#' ModelCustom
+#'
+#' @description
+#'
+#' A ModelCustom class.
+#'
+#' @export
+ModelCustom <- R6::R6Class(
+  classname = "ModelCustom",
+  inherit = Model,
+  public = list(
+
+    #' @field params named `numeric()`\cr
+    #'  a named numerical vector containing parameter values of the model object.
+    params = NULL,
+    #' @field type `character(1)`\cr
+    #'  type of the model.
+    type = NULL,
+    #' @field type `formula()`\cr
+    #'  model formula.
+    formula = NULL,
+    #' @field type `character(1)`\cr
+    #'  terms of the model. This gets generated using `stats::terms` on `formula`
+    #'  during initialisation.
+    terms = NULL,
+
+    #' @description
+    #'
+    #' Constructor function.
+    #'
+    #' @param params a named `numeric()`.
+    #' @param formula a model `formula()`.
+    #' @param type type of the model.
+    #' @param preprocessing_fn a pre-processing function that gets applied to the
+    #'  data given to the `predict` method before making the prediction.
+    #'
+    #' @return `NULL`
+    initialize = function(params, formula, type = "custom", preprocessing_fn) {
+
+      self$params = checkmate::assert_numeric(params,
+                                              finite = T,
+                                              any.missing = FALSE,
+                                              names = "unique")
+      self$formula = checkmate::assert_formula(formula, null.ok = FALSE)
+      self$type = checkmate::assert_string(type, na.ok = FALSE)
+      self$preprocessing_fn = checkmate::assert_function(preprocessing_fn,
+                                                         nargs = 1,
+                                                         null.ok = TRUE)
+      self$terms = terms(formula)
+      private$.model = self
+
+      invisible(NULL)
+    },
+
+    #' @description
+    #'
+    #' print method.
+    print = function() {
+      cat('Model type: ', self$type, "\n")
+      print(self$params)
+    },
+
+    #' @description
+    #'
+    #' an abstract method. Once implemented it should accept `newdata` as the first
+    #' argument and returns a `numeric()` vector or a `data.frame()` that contains
+    #' the predicted probabilities calculated using `self$params` and `newdata`.
+    predict = function() {
+      private$.abstract()
+    },
+
+    #' @description
+    #'
+    #' summary method.
+    summary = function() {
+      self$print()
+    }
+  ),
+
+  private = list(
+    .compute_linear_combination = function(newdata) {
+      mm <- model.matrix(self$formula, newdata)
+      as.numeric(self$params %*% t(mm))
+    }
+  )
+)
+
+compute_linear_combination <- function(params, formula, newdata) {
+  mm <- model.matrix(formula, newdata)
+  as.numeric(params %*% t(mm))
+}
+
+predict.ModelCustom <- function(object, newdata) {
+  object$predict(newdata)
+}
+
+summary.ModelCustom <- function(x) {
+  x$summary()
+}

R/ModelLinear.R

@@ -0,0 +1,31 @@
+#' @title ModelLinear
+#'
+#' @export
+ModelLinear <- R6::R6Class(
+  classname = "ModelLinear",
+  inherit = ModelCustom,
+  public = list(
+
+    #' @description
+    #'
+    #' Initialisation function
+    #'
+    #' @param params a `data.frame` object.
+    #' @param formula a `formula` object.
+    #' @param preprocessing_fn a pre-processing function that gets applied to the
+    #'  data given to the `predict` method before making the prediction.
+    #'
+    #' @return NULL
+    initialize = function(params, formula, preprocessing_fn = NULL) {
+      super$initialize(params = params,
+                       formula = formula,
+                       type = "linear",
+                       preprocessing_fn = preprocessing_fn)
+      invisible(NULL)
+    },
+
+    predict = function(newdata) {
+      private$.compute_linear_combination(newdata)
+    }
+  )
+)

R/ModelMultinomialLogit.R

@@ -0,0 +1,91 @@
+#' ModelMultinomialLogit
+#'
+#' @description
+#' A multinomial logit model
+#'
+#' @details
+#' This model object is use to create a multinomial model using already estimated
+#' parameters.
+#'
+#' @export
+#'
+#' @examples
+#'
+#' if (requireNamespace('mlogit')) {
+#'
+#'
+#' }
+ModelMultinomialLogit <- R6::R6Class(
+  classname = "ModelMultinomialLogit",
+  inherit = ModelCustom,
+  public = list(
+
+    #' @description
+    #'
+    #' Initialisation function
+    #'
+    #' @param params a named numeric vector.
+    #' @param formula a `formula` object of class [mlogit::mFormula], [Formula::Formula], or `formula`.
+    #' @param preprocessing_fn a pre-processing function that gets applied to the
+    #'  data given to the `predict` method before making the prediction.
+    #'
+    #' @return NULL
+    initialize = function(params, formula, preprocessing_fn = NULL) {
+
+      required_pkgs <- c("mlogit")
+      # required_versions <- c("1.1.0")
+
+      for (i in seq_along(required_pkgs)) {
+        if (!requireNamespace(required_pkgs[[i]])) {
+          stop("Required ", required_pkgs[[i]], " to be installed.")
+        }
+      }
+
+      super$initialize(params = params,
+                       formula = formula,
+                       type = "multinomial",
+                       preprocessing_fn = preprocessing_fn)
+
+      invisible(NULL)
+    },
+
+    #' @description
+    #'
+    #' This predict method returns probabilities generated from the parameters
+    #' of this [Model] object.
+    #'
+    #' @param newdata (`data.frame()`) \cr
+    #'  new data to generate probabilities conditioned on its explanatory variables.
+    #' @param chooser_id_col (`character(1)`)\cr
+    #'  column name of the chooser id
+    #' @param choice_id_col (`character(1)`)\cr
+    #'  column name of the choice id
+    #'
+    #' @return a `data.frame` object with three columns: chooser_id (`integer()`),
+    #'  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]
+    }
+  ),
+
+  private = list(
+    .compute_linear_combination = function(newdata, chooser_id_col, choice_id_col) {
+      if (inherits(newdata, "dfidx")) {
+        checkmate::expect_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)))
+    }
+  )
+)

R/Transition.R

@@ -403,7 +403,7 @@ SupportedTransitionModels <- function() {
 #' @rdname SupportedTransitionModels
 #' @export
 get_supported_models <- function() {
-  return(c("train", "list", "data.table", "numeric", "glm", "lm", "WrappedModel"))
+  return(c("train", "list", "data.table", "numeric", "glm", "lm", "WrappedModel", "mlogit"))
 }
 
 monte_carlo_sim <- function(prediction, target) {