Skip to content

Commit

Permalink
Merge pull request #36 from ssi-dk/DiseasyModel
Browse files Browse the repository at this point in the history
DiseasyModel
  • Loading branch information
RasmusSkytte authored Jul 12, 2024
2 parents c734c15 + cff5a59 commit 9b5a270
Show file tree
Hide file tree
Showing 20 changed files with 1,072 additions and 159 deletions.
2 changes: 1 addition & 1 deletion DESCRIPTION
Original file line number Diff line number Diff line change
Expand Up @@ -15,7 +15,7 @@ Description: This package facilitates creation of an ensemble of models through
License: GPL-3
Encoding: UTF-8
Roxygen: list(markdown = TRUE)
RoxygenNote: 7.3.1
RoxygenNote: 7.3.2
Language: en-GB
LazyData: TRUE
Depends:
Expand Down
2 changes: 2 additions & 0 deletions NAMESPACE
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@

export(DiseasyActivity)
export(DiseasyBaseModule)
export(DiseasyModel)
export(DiseasyObservables)
export(DiseasySeason)
export(diseasyoption)
Expand All @@ -10,6 +11,7 @@ import(diseasystore)
import(lgr)
importFrom(Matrix,sparseMatrix)
importFrom(digest,digest)
importFrom(diseasystore,`%.%`)
importFrom(dplyr,as_label)
importFrom(lubridate,today)
importFrom(pracma,logseq)
Expand Down
14 changes: 13 additions & 1 deletion NEWS.md
Original file line number Diff line number Diff line change
@@ -1,3 +1,15 @@
# diseasy 0.0.0.9000

* Added a `NEWS.md` file to track changes to the package.
## Features:

* `DiseasyModel`: A base class for the model templates (#36).
* R6 class that defines the interface for the models and empower the flexible configuration of models from the
functional modules.

## Documentation:

* The functions are fully documented.

* Vignettes for the use of the package is included.
- `vignette("diseasy")`
- `vignette("creating-a-model")`
1 change: 1 addition & 0 deletions R/DiseasyActivity.R
Original file line number Diff line number Diff line change
Expand Up @@ -46,6 +46,7 @@
#' @return
#' A new instance of the `DiseasyActivity` [R6][R6::R6Class] class.
#' @importFrom Matrix sparseMatrix
#' @keywords functional-module
#' @export
DiseasyActivity <- R6::R6Class( # nolint: object_name_linter
classname = "DiseasyActivity",
Expand Down
66 changes: 32 additions & 34 deletions R/DiseasyBaseModule.R
Original file line number Diff line number Diff line change
@@ -1,4 +1,4 @@
#' @title Diseasy' basic module
#' @title Base module for diseasy
#'
#' @description
#' The `DiseasyBaseModule` module implements common functionality that all modules have available.
Expand Down Expand Up @@ -72,11 +72,29 @@ DiseasyBaseModule <- R6::R6Class(
#' @param clone (`boolean`)\cr
#' Toggle whether or not the module should be cloned when loading. Default TRUE.
#' @details
#' The methods allows the setting of the internal module instances after the `DiseasyBaseModule` instance is
#' created.
#' The methods allows the setting of the internal module instances after the instance is created.
#' @return `NULL`
load_module = function(module, clone = TRUE) {

# Within the `diseasy` framework, some modules includes instances of other modules.
# One such module instance that is used across modules is the `DiseasyObservables` since
# it is the main interface with data and many modules need data to run.

# Here, we check this module instance for any modules it contains. For each of these nested modules, we check
# if they require the module being loaded. If they do, we load the module into the nested instance as well.
# This happens via recursive calls to `$load_module()` on the nested instance with `clone = FALSE`, but only
# if the nested module does not already contain a loaded instance.

# This way, a copy (reference) of the module being loaded is propagated to the nested modules. Any changes to the
# parent module is then reflected in the nested instances.


# Check the instance has a slot for the module to be loaded
if (!paste0(".", class(module)[1]) %in% names(private)) {
stop(glue::glue("Module {class(module)[1]} not found in {class(self)[1]}"))
}

# Check if the module should be cloned (i.e. a new instance is created, or if the module is used by reference)
if (clone) {
# Create a clone of the module
module <- module$clone()
Expand All @@ -85,38 +103,18 @@ DiseasyBaseModule <- R6::R6Class(
module$set_moduleowner(class(self)[1])
}

# Within the `diseasy` framework, some modules includes instances of other modules.
# One such module instance that is used across modules is the `DiseasyObservables` since
# it is the main interface with data and many modules need data to run.
# Here, we check if this module instance has includes another instance of a module which uses
# the `DiseasyObservables`.
# If it does, we load recursively call `load_module` on the nested instance with clone = FALSE, but only
# if the nested module does not contain a loaded instance already.
# This way, this model instance has the `DiseasyObservables` instance loaded and any nested instances
# that needs the `DiseasyObservables` module uses the same as this (parent) instance.

# First we check if the given module is the `DiseasyObservables` module
# If it is, we load it into the nested instances
modules_with_observables <- "DiseasySeason"
if (class(module)[1] == "DiseasyObservables") {
modules_with_observables |>
purrr::map_chr(~ paste0(".", .)) |>
purrr::walk(~ {
if (!is.null(purrr::pluck(private, .)) && is.null(purrr::pluck(private, ., "observables"))) {
purrr::pluck(private, .)$load_module(module, clone = FALSE)
}
})
}

# Then we check the reverse case:
# That is, we check if the given module requires `DiseasyObservables` and
# then load the existing `DiseasyObservables` into the given module before storing it
if (class(module)[1] %in% modules_with_observables &&
is.null(purrr::pluck(module, "observables")) &&
!is.null(purrr::pluck(private, ".DiseasyObservables"))) {
# Determine all current diseasy modules loaded into the current instance
nested_diseasy_modules <- as.list(private, all.names = TRUE) |>
purrr::keep(~ inherits(., "DiseasyBaseModule"))

module$load_module(purrr::pluck(private, ".DiseasyObservables"), clone = FALSE)
}

# Use already loaded instances to populate the module being loaded
purrr::walk(nested_diseasy_modules, ~ try(module$load_module(., clone = FALSE), silent = TRUE))


# Load the module into currently nested modules
purrr::walk(nested_diseasy_modules, ~ try(.$load_module(module, clone = FALSE), silent = TRUE))


# Finally, store the module
Expand Down Expand Up @@ -306,7 +304,7 @@ DiseasyBaseModule <- R6::R6Class(
},

not_implemented_error = function(...) {
stop("Not implemented: ", glue::glue_collapse(...), call. = FALSE)
stop("Not implemented: ", glue::glue_collapse(c(...), sep = " "), call. = FALSE)
},

# Common logging
Expand Down
208 changes: 208 additions & 0 deletions R/DiseasyModel.R
Original file line number Diff line number Diff line change
@@ -0,0 +1,208 @@
#' @title Base module for diseasy model templates
#'
#' @description
#' The `DiseasyModel` module implements common functionality that all models have available beyond that provided by
#' `DiseasyBaseModule`.
#' Most notably, the model module facilitates:
#' * Module interfaces:
#' The module contains the functional modules via its active bindings:
#' * `$activity`: `DiseasyActivity`
#' * `$observables`: `DiseasyObservables`
#' * `$season`: `DiseasySeason`
#'
#' Configured instances of these modules can be provided during initialisation.
#' Alternatively, default instances of these modules can optionally be created.
#'
#' * Model interface:
#' The module defines the functions `$get_results()`, `$get_training_data()` and the `$parameters` binding.
#' These functions define the "API" of the models and ensure the models can take part in the ensemble.
#' @examples
#' # Normally, one would not want to create this module directly, but it is possible.
#' Model_module <- DiseasyModel$new()
#'
#' rm(Model_module)
#' @return
#' A new instance of the `DiseasyModel` [R6][R6::R6Class] class.
#' @export
#' @seealso [lgr][lgr::lgr]
DiseasyModel <- R6::R6Class( # nolint: object_name_linter
classname = "DiseasyModel",
inherit = DiseasyBaseModule,

public = list(

#' @description
#' Creates a new instance of the `DiseasyModel` [R6][R6::R6Class] class.
#' This module is typically not constructed directly but rather through `DiseasyModel*` classes.
#' @param activity,observables,season (`boolean` or `R6::R6Class instance`)\cr
#' If a boolean is given, it dictates whether to load a new instance module of this class.
#'
#' 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`.
#' @param label (`character`)\cr
#' A human readable label for the model instance.
#' @param ...
#' Parameters sent to `DiseasyBaseModule` [R6][R6::R6Class] constructor
#' @details
#' The `DiseasyModel` is the main template that the individual models should inherit from since this defines the
#' set of methods the later framework expects from each model. In addition, it provides the main interface with
#' the other modules of the framework.
#' @return
#' A new instance of the `DiseasyModel` [R6][R6::R6Class] class.
initialize = function(activity = FALSE,
observables = FALSE,
season = FALSE,
label = NULL,
...) {

coll <- checkmate::makeAssertCollection()
checkmate::assert(checkmate::check_logical(activity, null.ok = TRUE),
checkmate::check_class(activity, "DiseasyActivity", null.ok = TRUE),
add = coll)
checkmate::assert(checkmate::check_logical(observables, null.ok = TRUE),
checkmate::check_class(observables, "DiseasyObservables", null.ok = TRUE),
add = coll)
checkmate::assert(checkmate::check_logical(season, null.ok = TRUE),
checkmate::check_class(season, "DiseasySeason", null.ok = TRUE),
add = coll)
checkmate::assert_character(label, len = 1, any.missing = FALSE, null.ok = TRUE, add = coll)
checkmate::reportAssertions(coll)

# Pass further arguments to the DiseasyBaseModule initializer
super$initialize(...)

# Then try to set the modules
if (isTRUE(observables)) {
self$load_module(DiseasyObservables$new())
} else if (inherits(observables, "DiseasyObservables")) {
self$load_module(observables)
}

if (isTRUE(activity)) {
self$load_module(DiseasyActivity$new())
} else if (inherits(activity, "DiseasyActivity")) {
self$load_module(activity)
}

if (isTRUE(season)) {
self$load_module(DiseasySeason$new())
} else if (inherits(season, "DiseasySeason")) {
self$load_module(season)
}

# Set the label for the model
private$label <- label
},


# Roxygen has only limited support for R6 docs currently, so we need to do some tricks for the documentation
# of get_results
#' @description `r rd_get_results_description`
#' @param observable `r rd_observable()`
#' @param prediction_length `r rd_prediction_length()`
#' @param quantiles `r rd_quantiles()`
#' @param stratification `r rd_stratification()`
#' @return `r rd_get_results_return`
#' @seealso `r rd_get_results_seealso`
get_results = function(observable, prediction_length, quantiles = NULL, stratification = NULL) {
private$not_implemented_error(
"`DiseasyModel` should not be used directly. Did you do so by mistake?",
"Instead, use a model that inherits`DiseasyModel` as it should implement the `$get_results()` method."
)
},


#' @description
#' A method that returns training data for the models based on the model value of `training_length` and
#' the `last_queryable_date` of the `DiseasyObservables` module.
#' @param observable `r rd_observable()`
#' @param stratification `r rd_stratification()`
#' @return The output of `DiseasyObservables$get_observation` constrained to the training period.
get_training_data = function(observable, stratification = NULL) {

# Input validation
coll <- checkmate::makeAssertCollection()
checkmate::assert_character(observable, add = coll)
checkmate::assert_number(self %.% parameters %.% training_length, add = coll)
checkmate::assert_date(self %.% observables %.% last_queryable_date, add = coll)
checkmate::reportAssertions(coll)

# Get the observable at the stratification level
start_date <- self %.% observables %.% last_queryable_date -
lubridate::days(self %.% parameters %.% training_length)
end_date <- self %.% observables %.% last_queryable_date # Only within the training period

data <- self %.% observables %.% get_observation(observable, stratification, start_date, end_date) |>
dplyr::mutate(t = lubridate::interval(max(zoo::as.Date(date)), zoo::as.Date(date)) / lubridate::days(1))

return(data)
}
),

# Make active bindings to the private variables
active = list(

#' @field activity (`diseasy::activity`)\cr
#' The local copy of an activity module. Read-only.
#' @seealso [diseasy::DiseasyActivity]
#' @importFrom diseasystore `%.%`
activity = purrr::partial(
.f = active_binding, # nolint: indentation_linter
name = "activity",
expr = return(private %.% .DiseasyActivity)),


#' @field observables (`diseasy::DiseasyObservables`)\cr
#' The local copy of an DiseasyObservables module. Read-only.
#' @seealso [diseasy::DiseasyObservables]
#' @importFrom diseasystore `%.%`
observables = purrr::partial(
.f = active_binding, # nolint: indentation_linter
name = "observables",
expr = return(private %.% .DiseasyObservables)),


#' @field season (`diseasy::season`)\cr
#' The local copy of an season module. Read-only.
#' @seealso [diseasy::DiseasySeason]
#' @importFrom diseasystore `%.%`
season = purrr::partial(
.f = active_binding, # nolint: indentation_linter
name = "season",
expr = return(private %.% .DiseasySeason)),


#' @field parameters (`list()`)\cr
#' The parameters used in the model. Read-only.
#' @importFrom diseasystore `%.%`
parameters = purrr::partial(
.f = active_binding, # nolint: indentation_linter
name = "parameters",
expr = return(private %.% .parameters))
),

private = list(

.DiseasyActivity = NULL,
.DiseasyObservables = NULL,
.DiseasySeason = NULL,
.parameters = NULL,

# @param label (`character`)\cr
# A human readable label for the model instance.
label = NULL,

model_cannot_predict = function(observable = NULL, stratification = NULL) {
coll <- checkmate::makeAssertCollection()
if (!is.null(observable)) {
coll$push(glue::glue("Model not configured to predict for observable: {observable}"))
}
if (!is.null(stratification)) {
coll$push(glue::glue("Model not configured to predict at stratification: ",
"{private$stratification_to_string(stratification)}"))
}
checkmate::reportAssertions(coll)
}
)
)
14 changes: 10 additions & 4 deletions R/DiseasyObservables.R
Original file line number Diff line number Diff line change
Expand Up @@ -25,6 +25,7 @@
#' rm(obs)
#' @return
#' A new instance of the `DiseasyBaseModule` [R6][R6::R6Class] class.
#' @keywords functional-module
#' @export
DiseasyObservables <- R6::R6Class( # nolint: object_name_linter
classname = "DiseasyObservables",
Expand Down Expand Up @@ -148,7 +149,12 @@ DiseasyObservables <- R6::R6Class(
#' Date to slice the database on
#' @seealso [SCDB::get_table]
set_slice_ts = function(slice_ts) {
checkmate::assert_character(slice_ts, pattern = r"{\d{4}-\d{2}-\d{2}(<? \d{2}:\d{2}:\d{2})}", any.missing = FALSE)
checkmate::assert(
checkmate::check_character(
slice_ts, pattern = r"{\d{4}-\d{2}-\d{2}(<? \d{2}:\d{2}:\d{2})}", any.missing = FALSE
),
checkmate::check_date(slice_ts, any.missing = FALSE)
)
private$.slice_ts <- slice_ts
private$lg$info("slice_ts set to {self$slice_ts}")
},
Expand Down Expand Up @@ -331,8 +337,8 @@ DiseasyObservables <- R6::R6Class(
),


#' @field slice_ts (`Date`)\cr
#' The timestamp to slice database on. Read-only.
#' @field slice_ts (`Date` or `character`)\cr
#' Date to slice the database on. See [SCDB::get_table()]. Read-only.
slice_ts = purrr::partial(
.f = active_binding,
name = "slice_ts",
Expand All @@ -350,7 +356,7 @@ DiseasyObservables <- R6::R6Class(
),

private = list(
.diseasystore = NULL,
.diseasystore = NULL,
.start_date = NULL,
.end_date = NULL,
.last_queryable_date = NULL,
Expand Down
Loading

0 comments on commit 9b5a270

Please sign in to comment.