From 3a67bf15cb5cad8908b94b16686939013e473659 Mon Sep 17 00:00:00 2001 From: RasmusSkytte Date: Wed, 22 Jan 2025 08:32:13 +0000 Subject: [PATCH] chore: synced file(s) with ssi-dk/diseasy --- R/0_R6_utils.R | 56 ++++++++++++++++++++ R/0_documentation.R | 74 +++++++++++++++++++++++++-- inst/WORDLIST | 32 ++++++++++-- tests/testthat/test-0_documentation.R | 6 ++- 4 files changed, 158 insertions(+), 10 deletions(-) diff --git a/R/0_R6_utils.R b/R/0_R6_utils.R index d27ae653..09d89895 100644 --- a/R/0_R6_utils.R +++ b/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) +} diff --git a/R/0_documentation.R b/R/0_documentation.R index 701f59b5..b402264c 100644 --- a/R/0_documentation.R +++ b/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." + ) +} diff --git a/inst/WORDLIST b/inst/WORDLIST index 8809f858..493b6fbb 100644 --- a/inst/WORDLIST +++ b/inst/WORDLIST @@ -6,10 +6,16 @@ CCW backends bitemporal +bmatrix +cccc +ccccc +ccccccc +cccccccc catalog cetera cdot +cdots classname cloneable CMD @@ -22,12 +28,14 @@ COVID covid colname +dag db dbi DBIConnection DBIDriver dbplyr -dI +ddots +Diekmann diseasy diseasystore DiseasystoreBase @@ -35,6 +43,8 @@ DiseasystoreGoogleCovid diseasystores DiseasyActivity DiseasyBaseModule +DiseasyModelB +DiseasyModelG DiseasyObservables DiseasySeason DiseasyVariant @@ -42,16 +52,13 @@ 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 diff --git a/tests/testthat/test-0_documentation.R b/tests/testthat/test-0_documentation.R index 759aef2f..1ef4af33 100644 --- a/tests/testthat/test-0_documentation.R +++ b/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) }