feat/refactor/fix(distributionregistry): big commit! (1) add JSON + dict, (2) remove validation (to be replaced) (3) remove old param classes (4) import parameters from JSON (5) add discrete and lognormal to DistributionRegistry (5) improve DistributionRegistry$get() error message (6) move transform_to_lnorm into DistributionRegistry and automatically apply as part of create() (7) remove redunant loop in create_batch()

Author: amyheather

NAMESPACE

@@ -2,30 +2,15 @@
 
 export(DistributionRegistry)
 export(add_patient_generator)
-export(check_all_param_names)
-export(check_all_positive)
 export(check_log_file_path)
-export(check_nonneg_integer)
-export(check_param_names)
-export(check_param_values)
-export(check_positive_integer)
-export(check_prob_vector)
 export(check_run_number)
-export(create_asu_arrivals)
-export(create_asu_los)
-export(create_asu_routing)
 export(create_asu_trajectory)
-export(create_parameters)
-export(create_rehab_arrivals)
-export(create_rehab_los)
-export(create_rehab_routing)
 export(create_rehab_trajectory)
 export(filter_warmup)
 export(get_occupancy_stats)
 export(model)
+export(parameters)
 export(runner)
-export(sample_routing)
-export(transform_to_lnorm)
 export(valid_inputs)
 importFrom(R6,R6Class)
 importFrom(dplyr,bind_rows)
@@ -38,6 +23,7 @@ importFrom(future,multisession)
 importFrom(future,plan)
 importFrom(future,sequential)
 importFrom(future.apply,future_lapply)
+importFrom(jsonlite,fromJSON)
 importFrom(rlang,.data)
 importFrom(simmer,add_generator)
 importFrom(simmer,add_resource)

R/distribution_registry.R

@@ -30,9 +30,28 @@ DistributionRegistry <- R6Class("DistributionRegistry", list( # nolint: object_n
     self$register("uniform", function(min, max) {
       function(size = 1L) runif(size, min = min, max = max)
     })
+    self$register("discrete", function(values, prob) {
+      values <- unlist(values)
+      prob <- unlist(prob)
+      # Validation (as not using a pre-made distribution function)
+      stopifnot(length(values) == length(prob))
+      stopifnot(all(prob >= 0))
+      if (round(abs(sum(prob) - 1), 2) > 0.01) {
+        stop(sprintf(
+          "'prob' must sum to 1 ± 0.01. Sum: %s", abs(sum(unlist(prob)))
+        ))
+      }
+      # Sampling function
+      function(size = 1L) sample(
+        values, size = size, replace = TRUE, prob = prob
+      )
+    })
     self$register("normal", function(mean, sd) {
       function(size = 1L) rnorm(size, mean = mean, sd = sd)
     })
+    self$register("lognormal", function(meanlog, sdlog) {
+      function(size = 1L) rlnorm(size, meanlog = meanlog, sdlog = sdlog)
+    })
     self$register("poisson", function(lambda) {
       function(size = 1L) rpois(size, lambda = lambda)
     })
@@ -76,22 +95,59 @@ DistributionRegistry <- R6Class("DistributionRegistry", list( # nolint: object_n
   #' @return Generator function for the distribution.
   get = function(name) {
     if (!(name %in% names(self$registry)))
-      stop(sprintf("Distribution '%s' not found", name), call. = FALSE)
+      stop(
+        sprintf(
+          c("Distribution '%s' not found.\nAvailable distributions:\n\t%s\n",
+            "Use register() to add new distributions."),
+          name, paste(names(self$registry), collapse = ",\n\t")
+        ),
+      call. = FALSE)
     self$registry[[name]]
   },
 
+  #' @description
+  #' Convert mean/sd to lognormal parameters, returning the corresponding
+  #' \code{meanlog} and \code{sdlog} parameters used by R's \code{rlnorm()}.
+  #'
+  #' @param params Named list with two elements: mean and sd.
+  #' @return A named list of the same structure, but with elements
+  #' \code{meanlog} and \code{sdlog} for each patient type.
+  transform_to_lnorm = function(params) {
+    variance <- params$sd^2L
+    sigma_sq <- log(variance / (params$mean^2L) + 1L)
+    sdlog <- sqrt(sigma_sq)
+    meanlog <- log(params$mean) - sigma_sq / 2L
+    list(meanlog = meanlog, sdlog = sdlog)
+  },
+
   #' @description
   #' Create a parameterised sampler for a distribution.
   #'
   #' The returned function draws random samples of a specified size from
   #' the given distribution with fixed parameters.
   #'
+  #' For "lognormal", if "meanlog" and "sdlog" are present in the parameters,
+  #' they will be used as-is. If not, but "mean" and "sd" are provided, these
+  #' will be transformed into "meanlog"/"sdlog" automatically.
+  #'
   #' @param name Distribution name
   #' @param ... Parameters for the generator
   #' @return A function that draws samples when called.
   create = function(name, ...) {
+    dots <- list(...)
+    if (name == "lognormal") {
+      if (!is.null(dots$meanlog) && !is.null(dots$sdlog)) {
+        dots <- dots
+      } else if (!is.null(dots$mean) && !is.null(dots$sd)) {
+        transformed <- self$transform_to_lnorm(dots)
+        dots <- c(transformed, dots[setdiff(names(dots), c("mean", "sd"))])
+      } else {
+        stop("Please supply either 'meanlog' and 'sdlog', or 'mean' and 'sd' ",
+             "for a lognormal distribution.")
+      }
+    }
     generator <- self$get(name)
-    generator(...)
+    do.call(generator, dots)
   },
 
   #' @description
@@ -105,11 +161,7 @@ DistributionRegistry <- R6Class("DistributionRegistry", list( # nolint: object_n
   #'   'class_name' and 'params'.
   #' @return List of parameterised samplers (named if config is named).
   create_batch = function(config) {
-    if (is.list(config) && is.null(names(config))) {
-      lapply(config, function(cfg) {
-        do.call(self$create, c(cfg$class_name, cfg$params))
-      })
-    } else if (is.list(config)) {
+    if (is.list(config)) {
       lapply(config, function(cfg) {
         do.call(self$create, c(cfg$class_name, cfg$params))
       })