-
Notifications
You must be signed in to change notification settings - Fork 14
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
competing_hazards.R: Giovanni designed two objects: CompetingOutcome …
…(containing an outcome following resolution and rates that that outcome occurs for each individual in the population) and CompetingHazard (contains all CompetingOutcomes and process function to resolve hazards). processes.R: create_biting_process now replaced with create_infection_rates_process and biting_process, that uses essentially the same functional pathway, but which stops when the rates of infection are generated, storing them in the infection_outcome object within human_infection.R Similarly, disease_progression_process(es) are replaced with new functions: create_recovery_rates_process and calculate_recovery_rates, that get the recovery rates for each individual based on disease state. We then add these processes to the process list, including the resolution function create_infection_recovery_hazard_process$resolve. This process (create_infection_recovery_hazard_process) contains infection_outcome and recovery_outcome. infection_outcome calls infection_process_resolved_hazard, which follows the rest of the infection pathway functions: assigning new infections to different human states. Note that this requires probability of infection which gets used in the incidence renderer function. recovery_outcome also updates human states and infectivities. I've adjusted some of the tests to reflect the changes in functions required to generate results. Removed white space deletions.
- Loading branch information
1 parent
a9b495c
commit 903547a
Showing
12 changed files
with
952 additions
and
387 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,78 @@ | ||
| ## Define classes to resolve competing hazards | ||
| CompetingOutcome <- R6::R6Class( | ||
| "CompetingOutcome", | ||
| private = list( | ||
| targeted_process = NULL | ||
| ), | ||
| public = list( | ||
| initialize = function(targeted_process, size){ | ||
| if (!is.function(targeted_process)){ | ||
| stop("targeted_process must be a function") | ||
| } | ||
| if (!is.numeric(size) || size <= 0){ | ||
| stop("size must be positive integer") | ||
| } | ||
| private$targeted_process <- targeted_process | ||
| self$rates <- rep(0, size) | ||
| }, | ||
| set_rates = function(rates){ | ||
| self$rates <- rates | ||
| }, | ||
| execute = function(t, target){ | ||
| private$targeted_process(t, target) | ||
| self$rates <- rep(0, length(self$rates)) | ||
| }, | ||
| rates = NULL | ||
| ) | ||
| ) | ||
|
|
||
| CompetingHazard <- R6::R6Class( | ||
| "CompetingHazard", | ||
| private = list( | ||
| outcomes = list(), | ||
| size = NULL, | ||
| # RNG is passed in because mockery is not able to stub runif | ||
| # TODO: change when fixed | ||
| rng = NULL | ||
| ), | ||
| public = list( | ||
| initialize = function(outcomes, rng = runif){ | ||
| if (length(outcomes) == 0){ | ||
| stop("At least one outcome must be provided") | ||
| } | ||
| if (!all(sapply(outcomes, function(x) inherits(x, "CompetingOutcome")))){ | ||
| stop("All outcomes must be of class CompetingOutcome") | ||
| } | ||
| private$outcomes <- outcomes | ||
| private$size <- length(outcomes[[1]]$rates) | ||
| private$rng <- rng | ||
| }, | ||
| resolve = function(t){ | ||
| event_probs <- do.call( | ||
| 'cbind', | ||
| lapply(private$outcomes, function(x) x$rates) | ||
| ) | ||
| occur_prob <- rowSums(event_probs) | ||
| occur_rng <- private$rng(private$size) | ||
| occurs <- occur_rng < occur_prob | ||
| norm_probs <- event_probs / occur_prob | ||
| norm_probs[is.na(norm_probs)] <- 0 | ||
| cum_probs <- apply(norm_probs, 1, cumsum) | ||
| event_rng <- private$rng(private$size) | ||
| for(o in seq_along(private$outcomes)){ | ||
| if (o == 1) { | ||
| selected <- (event_rng <= cum_probs[o,]) | ||
| } else { | ||
| selected <- (event_rng > cum_probs[o - 1,]) & | ||
| (event_rng <= cum_probs[o,]) | ||
| } | ||
| target <- individual::Bitset$new(private$size)$insert( | ||
| which(selected & occurs) | ||
| ) | ||
| if (target$size() > 0){ | ||
| private$outcomes[[o]]$execute(t, target) | ||
| } | ||
| } | ||
| } | ||
| ) | ||
| ) |
Oops, something went wrong.