Merge pull request #76 from mrc-ide/mrc-5799

Allow systems to have concept of default dt

R/compile.R

@@ -116,7 +116,7 @@ dust_generate <- function(config, filename, linking_to, cpp_std,
                           optimisation_level, compiler_options, mangle) {
   system <- read_lines(filename)
   data <- dust_template_data(config$name, config$class, config$time_type,
-                             linking_to, cpp_std,
+                             config$default_dt, linking_to, cpp_std,
                              optimisation_level, compiler_options, mangle)
   data$system_requirements <- data$cpp_std %||% "R (>= 4.0.0)"
 
@@ -171,6 +171,7 @@ dust_generate_cpp <- function(system, config, data) {
 dust_template_data <- function(name,
                                class,
                                time_type,
+                               default_dt,
                                linking_to = NULL,
                                cpp_std = NULL,
                                optimisation_level = NULL,
@@ -188,6 +189,7 @@ dust_template_data <- function(name,
   list(name = name,
        class = class,
        time_type = time_type,
+       default_dt = deparse1(default_dt),
        package = paste0(name, mangle %||% ""),
        linking_to = linking_to,
        cpp_std = cpp_std,

R/filter-support.R

@@ -10,16 +10,46 @@ check_generator_for_filter <- function(generator, what, call = NULL) {
 }
 
 
-check_dt <- function(dt, call = NULL) {
+check_system_dt <- function(dt, generator, name = "dt", call = NULL) {
+  is_discrete <- generator$properties$time_type == "discrete"
+  if (is_discrete) {
+    check_dt(dt %||% generator$default_dt, name, call = call)
+  } else {
+    if (!is.null(dt)) {
+      cli::cli_abort("Can't use '{name}' with continuous-time systems",
+                     call = call)
+    }
+  }
+}
+
+
+check_system_ode_control <- function(ode_control, generator,
+                                     name = "ode_control", call = NULL) {
+  is_discrete <- generator$properties$time_type == "discrete"
+  if (is_discrete) {
+    if (!is.null(ode_control)) {
+      cli::cli_abort("Can't use 'ode_control' with discrete-time systems")
+    }
+  } else {
+    if (is.null(ode_control)) {
+      ode_control <- dust_ode_control()
+    } else {
+      assert_is(ode_control, "dust_ode_control", call = environment())
+    }
+  }
+}
+
+
+check_dt <- function(dt, name = deparse(substitute(dt)), call = NULL) {
   assert_scalar_numeric(dt, call = call)
   if (dt <= 0) {
-    cli::cli_abort("Expected 'dt' to be greater than 0")
+    cli::cli_abort("Expected '{name}' to be greater than 0")
   }
   if (dt > 1) {
-    cli::cli_abort("Expected 'dt' to be at most 1")
+    cli::cli_abort("Expected '{name}' to be at most 1")
   }
   if (!rlang::is_integerish(1 / dt)) {
-    cli::cli_abort("Expected 'dt' to be the inverse of an integer",
+    cli::cli_abort("Expected '{name}' to be the inverse of an integer",
                    arg = "dt", call = call)
   }
   dt

R/interface-filter.R

@@ -32,7 +32,7 @@
 ##'
 ##' @export
 dust_filter_create <- function(generator, time_start, data,
-                               n_particles, n_groups = NULL, dt = 1,
+                               n_particles, n_groups = NULL, dt = NULL,
                                index_state = NULL, n_threads = 1,
                                preserve_group_dimension = FALSE,
                                seed = NULL) {
@@ -43,7 +43,7 @@ dust_filter_create <- function(generator, time_start, data,
 
   data <- prepare_data(data, n_groups, call = call)
   time_start <- check_time_start(time_start, data$time, call = call)
-  dt <- check_dt(dt, call = call)
+  dt <- check_system_dt(dt, generator, call = call)
 
   n_groups <- data$n_groups
   preserve_group_dimension <- preserve_group_dimension || n_groups > 1

R/interface-unfilter.R

@@ -19,7 +19,7 @@
 ##' @export
 dust_unfilter_create <- function(generator, time_start, data,
                                  n_particles = 1, n_groups = NULL,
-                                 dt = 1, n_threads = 1, index_state = NULL,
+                                 dt = NULL, n_threads = 1, index_state = NULL,
                                  preserve_particle_dimension = FALSE,
                                  preserve_group_dimension = FALSE) {
   call <- environment()
@@ -29,7 +29,7 @@ dust_unfilter_create <- function(generator, time_start, data,
 
   data <- prepare_data(data, n_groups, call = call)
   time_start <- check_time_start(time_start, data$time, call = call)
-  dt <- check_dt(dt, call = call)
+  dt <- check_system_dt(dt, generator, call = call)
 
   n_groups <- data$n_groups
   preserve_group_dimension <- preserve_group_dimension || n_groups > 1

R/interface.R

@@ -10,6 +10,8 @@
 ##'   the wrong time here will lead to crashes or failure to create
 ##'   the generator.
 ##'
+##' @param default_dt The default value for `dt` on initialisation
+##'
 ##' @param env The environment where the generator is defined.
 ##'
 ##' @return A `dust_system_generator` object
@@ -18,12 +20,12 @@
 ##' @keywords internal
 ##' @examples
 ##' # This creates the "sir" generator
-##' dust_system_generator("sir", "discrete", asNamespace("dust2"))
+##' dust_system_generator("sir", "discrete", 1, asNamespace("dust2"))
 ##'
 ##' # This is the same code as in "dust2:::sir", except there we find
 ##' # the correct environment automatically
 ##' dust2:::sir
-dust_system_generator <- function(name, time_type,
+dust_system_generator <- function(name, time_type, default_dt,
                                   env = parent.env(parent.frame())) {
   ## I don't love that this requires running through sprintf() each
   ## time we create a generator, but using a function for the generator (see
@@ -68,6 +70,7 @@ dust_system_generator <- function(name, time_type,
 
   ret <- list(name = name,
               methods = methods,
+              default_dt = default_dt,
               properties = properties)
 
   class(ret) <- "dust_system_generator"
@@ -147,22 +150,9 @@ dust_system_create <- function(generator, pars, n_particles, n_groups = 1,
   call <- environment()
   check_is_dust_system_generator(generator, substitute(generator))
 
-  is_discrete <- generator$properties$time_type == "discrete"
-  if (is_discrete) {
-    dt <- check_dt(dt %||% 1, call = call)
-    if (!is.null(ode_control)) {
-      cli::cli_abort("Can't use 'ode_control' with discrete-time systems")
-    }
-  } else {
-    if (!is.null(dt)) {
-      cli::cli_abort("Can't use 'dt' with continuous-time systems")
-    }
-    if (is.null(ode_control)) {
-      ode_control <- dust_ode_control()
-    } else {
-      assert_is(ode_control, "dust_ode_control", call = environment())
-    }
-  }
+  dt <- check_system_dt(dt, generator, call = call)
+  ode_control <- check_system_ode_control(ode_control, generator, call = call)
+
   check_time(time, dt, call = call)
 
   assert_scalar_size(n_particles, allow_zero = FALSE, call = call)
@@ -175,6 +165,7 @@ dust_system_create <- function(generator, pars, n_particles, n_groups = 1,
   preserve_group_dimension <- preserve_group_dimension || n_groups > 1
 
   pars <- check_pars(pars, n_groups, NULL, preserve_group_dimension)
+  is_discrete <- generator$properties$time_type == "discrete"
   if (is_discrete) {
     res <- generator$methods$alloc(pars, time, dt, n_particles,
                                    n_groups, seed, deterministic,
@@ -558,8 +549,13 @@ print.dust_system <- function(x, ...) {
     cli::cli_bullets(c(
       i = "This system has 'adjoint' support, and can compute gradients"))
   }
-  cli::cli_bullets(c(
-    i = "This system runs in {x$properties$time_type} time"))
+  if (x$properties$time_type == "discrete") {
+    cli::cli_bullets(c(
+      i = "This system runs in discrete time with dt = {x$dt}"))
+  } else {
+    cli::cli_bullets(c(
+      i = "This system runs in continuous time"))
+  }
   invisible(x)
 }
 
@@ -573,8 +569,14 @@ print.dust_system_generator <- function(x, ...) {
     cli::cli_bullets(c(
       i = "This system has 'compare_data' support"))
   }
-  cli::cli_bullets(c(
-    i = "This system runs in {x$properties$time_type} time"))
+  if (x$properties$time_type == "discrete") {
+    cli::cli_bullets(c(
+      i = paste("This system runs in discrete time",
+                "with a default dt of {x$default_dt}")))
+  } else {
+    cli::cli_bullets(c(
+      i = "This system runs in continuous time"))
+  }
   invisible(x)
 }
 

R/metadata.R

@@ -22,9 +22,11 @@ parse_metadata <- function(filename, call = NULL) {
   data <- decor::cpp_decorations(files = filename)
 
   class <- parse_metadata_class(data, call)
+  time_type <- parse_metadata_time_type(data, call)
   list(class = class,
        name = parse_metadata_name(data, call) %||% class,
-       time_type = parse_metadata_time_type(data, call),
+       time_type = time_type,
+       default_dt = parse_metadata_default_dt(data, time_type, call),
        has_compare = parse_metadata_has_compare(data, call),
        has_adjoint = parse_metadata_has_adjoint(data, call),
        parameters = parse_metadata_parameters(data, call))
@@ -95,6 +97,33 @@ parse_metadata_time_type <- function(data, call = NULL) {
 }
 
 
+parse_metadata_default_dt <- function(data, time_type, call = NULL) {
+  data <- find_attribute_value_single(data, "dust2::default_dt",
+                                      required = FALSE, call = call)
+  if (is.null(data)) {
+    return(if (time_type == "discrete") 1 else NULL)
+  }
+  if (time_type == "continuous") {
+    cli::cli_abort(
+      "Can't use '[[dust::default_dt()]]' with continuous-time systems",
+      call = call)
+  }
+  if (length(data) != 1 || nzchar(names(data))) {
+    cli::cli_abort(
+      "Expected a single unnamed argument to '[[dust2::default_dt()]]'",
+      call = call)
+  }
+  if (!is.numeric(data[[1]])) {
+    cli::cli_abort(
+      "Expected a numerical argument to '[[dust2::default_dt()]]'",
+      call = call)
+  }
+  value <- data[[1]]
+  check_dt(value, "[[dust2::default_dt()]]", call = call)
+  value
+}
+
+
 parse_metadata_has_compare <- function(data, call = NULL) {
   parse_metadata_has_feature("compare", data, call)
 }

R/package.R

@@ -218,7 +218,8 @@ package_validate_makevars_openmp <- function(text, call) {
 package_generate <- function(filename, call) {
   config <- parse_metadata(filename, call = call)
   system <- read_lines(filename)
-  data <- dust_template_data(config$name, config$class, config$time_type)
+  data <- dust_template_data(config$name, config$class, config$time_type,
+                             config$default_dt)
   list(r = substitute_dust_template(data, "dust.R"),
        cpp = dust_generate_cpp(system, config, data))
 }

inst/template/dust.R

@@ -1,3 +1,3 @@
 {{name}} <- function() {
-  dust2::dust_system_generator("{{name}}", "{{time_type}}")
+  dust2::dust_system_generator("{{name}}", "{{time_type}}", {{default_dt}})
 }