chore: synced file(s) with ssi-dk/diseasy

R/0_R6_utils.R

@@ -205,3 +205,59 @@ parse_diseasyconn <- function(conn, type = "source_conn") {
   # Catch all other cases
   stop(glue::glue("`{type}` could not be parsed!"))
 }
+
+
+#' Holistic hashing of an environment
+#' @description
+#'   Function that hashes the values of the environment,
+#'   handling special cases such as functions.
+#' @param environment (`environment` or `list`)\cr
+#'   The environment to hash.
+#' @return (`list`(`character`))\cr
+#'   A list of hashes for the environment.
+#' @examples
+#'   hash_environment(list(DiseasyActivity))
+#'   hash_environment(list(mtcars, iris))
+#' @export
+hash_environment <- function(environment) {
+
+  if (checkmate::test_environment(environment)) environment <- as.list(environment)
+
+  hash_list <- environment |>
+    purrr::map_if(checkmate::test_r6, ~ .$hash) |> # All modules call their hash routines
+    purrr::map_if(
+      checkmate::test_function, # For functions, we hash their attributes
+      ~ {
+        list(
+          "function_source" = rlang::fn_body(.) |>
+            deparse() |>
+            stringr::str_remove_all(r"{[\s\"]}") |>
+            paste(collapse = ""),
+          "function_attributes" = attributes(rlang::zap_srcref(.)) |>
+            purrr::discard_at("body") # Partialised functions have the source repeated as "body"
+        )
+      }
+    ) |>
+    purrr::map_if(
+      checkmate::test_list, # In some cases, we have lists of functions
+      ~ {
+        purrr::map_if(
+          .,
+          checkmate::test_function,
+          ~ {
+            list(
+              "function_source" = rlang::fn_body(.) |>
+                deparse() |>
+                stringr::str_remove_all(r"{[\s\"]}") |>
+                paste(collapse = ""),
+              "function_attributes" = attributes(rlang::zap_srcref(.)) |>
+                purrr::discard_at("body") # Partialised functions have the source repeated as "body"
+            )
+          }
+        )
+      }
+    ) |>
+    purrr::map_chr(rlang::hash)
+
+  return(hash_list)
+}

R/0_documentation.R

@@ -77,9 +77,9 @@ rd_scale <- function(type = "param") {
 
 rd_conn <- function(type = "param") {
   checkmate::assert_choice(type, c("param", "field"))
-  paste("(`DBIConnection`)\\cr",
-        "A database connection.",
-        ifelse(type == "field", "Read only.", ""))
+  paste("(`DBIConnection` or `function`)\\cr",
+        "A database connection or function that opens a database connection",
+        ifelse(type == "field", " Read only.", ""))
 }
 
 
@@ -188,3 +188,71 @@ rd_activity_weights <- paste(
   "(`numeric(4)`)\\cr",
   "vector of weights for the four types of contacts. If `NULL`, no weighting is done."
 )
+
+## Templates for DiseasyModel ODE templates
+rd_diseasy_module <- paste(
+  "(`boolean` or `R6::R6Class instance`)\\cr",
+  "If a boolean is given, it dictates whether to load a new instance module of this class.\\cr",
+  "If an instance of the module is provided instead, a copy of this instance is added to the `DiseasyModel`",
+  "instance. This copy is a \"clone\" of the instance at the time it is added and any subsequent changes to the",
+  "instance will not reflect in the copy that is added to `DiseasyModel`."
+)
+
+rd_overall_infection_risk <- paste(
+  "(`numeric`)\\cr",
+  "The overall multiplier for the infection risk for the model."
+)
+
+rd_compartment_structure <- function(type = "param") {
+  checkmate::assert_choice(type, c("param", "field"))
+  paste(
+    "(`named integer()`)\\cr",
+    "The structure of the compartments in the model.",
+    "The names should be `E`, `I`, and `R` for the exposed, infectious, and recovered compartments, respectively.",
+    switch(type == "param", "The exposed compartments can optionally be omitted."),
+    switch(type == "field", "Read only.")
+  )
+}
+
+rd_disease_progression_rates <- function(type = "param") {
+  checkmate::assert_choice(type, c("param", "field"))
+  paste(
+    "(`named numeric()`)\\cr",
+    "The overall progression rates for the disease states.",
+    "The reciprocal of each rate is the average time spent in the all of the corresponding compartments.",
+    switch(type == "param", "The exposed compartments can optionally be omitted."),
+    switch(type == "field", "Read only.")
+  )
+}
+
+## Templates for DiseasyModel Regression templates
+rd_diseasymodel_glm_brm_description <- function(regression_class) {
+  glue::glue(
+    .sep = "\n",
+    "The `DiseasyModel{regression_class}` module implements common structure and functionality to",
+    "{regression_class} regression class of models beyond the model structure provided by `DiseasyModelRegression`.",
+    "",
+    "Most notably, the model module implements the `$fit_regression()` and `$get_prediction()` methods using",
+    "{regression_class}.",
+    "",
+    "`diseasy` includes two simple models that uses the `DiseasyModel{regression_class}` module:",
+    "`DiseasyModel{substr(regression_class, 1, 1)}0` and `DiseasyModel{substr(regression_class, 1, 1)}1`",
+    "These models implements a constant predictor and a exponential model based on the previous 7 and 21 days",
+    "of observations, respectively.",
+    "",
+    "When making a custom {regression_class} model, the subclass should implement the `$update_formula()` method.",
+    "The `$update_formula()` method should update the formula based on the stratifications.",
+    "If the model should flexibly adapt to different stratifications, this method should be implemented.",
+    "See `DiseasyModel{substr(regression_class, 1, 1)}0` and `DiseasyModel{substr(regression_class, 1, 1)}1` for",
+    "examples of how this can be done."
+  )
+}
+
+
+rd_diseasymodel_glm_brm_return <- function(regression_class) {
+  glue::glue(
+    .sep = "\n",
+    "A new instance of the `DiseasyModel{regression_class}`, `DiseasyModel{substr(regression_class, 1, 1)}0` or ",
+    "`DiseasyModel{substr(regression_class, 1, 1)}1` [R6][R6::R6Class] class."
+  )
+}

inst/WORDLIST

@@ -6,10 +6,16 @@ CCW
 
 backends
 bitemporal
+bmatrix
 
+cccc
+ccccc
+ccccccc
+cccccccc
 catalog
 cetera
 cdot
+cdots
 classname
 cloneable
 CMD
@@ -22,36 +28,37 @@ COVID
 covid
 colname
 
+dag
 db
 dbi
 DBIConnection
 DBIDriver
 dbplyr
-dI
+ddots
+Diekmann
 diseasy
 diseasystore
 DiseasystoreBase
 DiseasystoreGoogleCovid
 diseasystores
 DiseasyActivity
 DiseasyBaseModule
+DiseasyModelB
+DiseasyModelG
 DiseasyObservables
 DiseasySeason
 DiseasyVariant
 dk
 DMI
 doi
 dplyr
-dR
-ds
-dS
-dt
 dtplyr
 DuckDB
 
 ecdc
 ECDC
 Eggo
+EI
 endblock
 Engbo
 epiverse
@@ -67,6 +74,7 @@ github
 gov
 Gruson
 
+hline
 hypoexponential
 
 ij
@@ -82,22 +90,27 @@ Kirkeby
 kt
 
 Lasse
+leftarrow
 linelist
 linter
 linters
 lintr
 Lyngse
 
+malthusian
+mathcal
 md
 medrxiv
 Mielke
 moduleowner
 Myrup
 
+neq
 nolint
 normalise
 nrow
 
+odot
 OO
 ORCID
 org
@@ -120,14 +133,20 @@ R's
 Randl
 Rasmus
 regex
+rightarrow
+Rightarrow
 rlang
 rm
 RM
 Rmd
+RS
+rsif
 
 SCDB
 Schou
+seir
 SEIR
+sim
 simulist
 Skytte
 SSI
@@ -145,6 +164,9 @@ TODOs
 ts
 
 u
+underbrace
+
+vdots
 
 walkthrough
 www

tests/testthat/test-0_documentation.R

@@ -5,8 +5,10 @@ test_that("rd_templates works", {
 
   rd_functions <- rd_objects[purrr::map_lgl(rd_objects, ~ rlang::is_function(get(.)))]
 
-  for (type in c("field", "param")) {
-    for (rd_fun in rd_functions) {
+  for (rd_fun in rd_functions) {
+    if (!("type" %in% names(formals(rd_fun)))) next
+
+    for (type in c("field", "param")) {
       str <- expect_no_condition(do.call(rd_fun, args = list(type = type)))
       checkmate::expect_character(str)
     }