-
Notifications
You must be signed in to change notification settings - Fork 1
/
render-hosp.R
121 lines (105 loc) · 4.42 KB
/
render-hosp.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
# renderer objects for hospitalization and ICU outcomes
#' @title Create list of renderer objects to track hospitalization and ICU incidence
#' @param parameters named list of model parameters
#' @return a named list of [individual::Render] objects
#' @importFrom individual Render
#' @export
create_hosp_renderers <- function(parameters) {
time_steps <- parameters$time_steps
stopifnot(!is.null(time_steps))
list(
"ICU_get_live" = Render$new(timesteps = time_steps),
"ICU_get_die" = Render$new(timesteps = time_steps),
"hosp_get_live" = Render$new(timesteps = time_steps),
"hosp_get_die" = Render$new(timesteps = time_steps),
"ICU_not_get_live" = Render$new(timesteps = time_steps),
"ICU_not_get_die" = Render$new(timesteps = time_steps),
"hosp_not_get_live" = Render$new(timesteps = time_steps),
"hosp_not_get_die" = Render$new(timesteps = time_steps)
)
}
#' @title Attach listeners to track hospitalization and ICU incidence
#' @param renderers a named list of [individual::Render] objects
#' @param events a named list of [individual::TargetedEvent] objects
#' @export
attach_hosp_listeners <- function(renderers, events) {
event_tags <- c("imv_get_live", "imv_get_die", "iox_get_live", "iox_get_die", "imv_not_get_live", "imv_not_get_die", "iox_not_get_live", "iox_not_get_die")
stopifnot(vapply(X = events[event_tags], FUN = function(x) {inherits(x, "TargetedEvent")}, FUN.VALUE = logical(1)))
stopifnot(vapply(X = renderers, FUN = function(x) {inherits(x, "Render")}, FUN.VALUE = logical(1)))
# need ICU, gets bed, lives
events$imv_get_live$add_listener(
function(timestep, target) {
renderers$ICU_get_live$render(name = "ICU_get_live", value = target$size(), timestep = timestep)
}
)
# need ICU, gets bed, dies
events$imv_get_die$add_listener(
function(timestep, target) {
renderers$ICU_get_die$render(name = "ICU_get_die", value = target$size(), timestep = timestep)
}
)
# need hosp, gets bed, lives
events$iox_get_live$add_listener(
function(timestep, target) {
renderers$hosp_get_live$render(name = "hosp_get_live", value = target$size(), timestep = timestep)
}
)
# need hosp, gets bed, dies
events$iox_get_die$add_listener(
function(timestep, target) {
renderers$hosp_get_die$render(name = "hosp_get_die", value = target$size(), timestep = timestep)
}
)
# need ICU, doesn't get bed, lives
events$imv_not_get_live$add_listener(
function(timestep, target) {
renderers$ICU_not_get_live$render(name = "ICU_not_get_live", value = target$size(), timestep = timestep)
}
)
# need ICU, doesn't get bed, dies
events$imv_not_get_die$add_listener(
function(timestep, target) {
renderers$ICU_not_get_die$render(name = "ICU_not_get_die", value = target$size(), timestep = timestep)
}
)
# need hosp, doesn't get bed, lives
events$iox_not_get_live$add_listener(
function(timestep, target) {
renderers$hosp_not_get_live$render(name = "hosp_not_get_live", value = target$size(), timestep = timestep)
}
)
# need hosp, doesn't get bed, dies
events$iox_not_get_die$add_listener(
function(timestep, target) {
renderers$hosp_not_get_die$render(name = "hosp_not_get_die", value = target$size(), timestep = timestep)
}
)
}
#' @title Process rendering output of hospitalization and ICU incidence
#' @description Process output from each rendering object and return a single
#' [data.table::data.table] object, where incidence has been aggregated by
#' day.
#' @param renderers a named list of [individual::Render] objects from [safir::create_hosp_renderers]
#' @param parameters a named list of model parameters
#' @importFrom data.table as.data.table .SD setnames
#' @export
process_hosp_renderers <- function(renderers, parameters) {
# process hospital renderers
out <- mapply(FUN = function(x, name) {
df <- x$to_dataframe()
if (ncol(df) == 1L) {
# attach zero col with right name
df[[name]] = rep(0, nrow(df))
}
df[which(is.na(df[, 2])), 2] <- 0
return(df)
}, x = renderers, name = names(renderers), SIMPLIFY = FALSE, USE.NAMES = FALSE)
out <- do.call(cbind, out)
out <- out[, -which(names(out) == "timestep")[-1]]
# go to days
out$timestep <- as.integer(floor(out$timestep * parameters$dt) + 1)
out <- as.data.table(out)
out <- out[, lapply(.SD, sum) , by = "timestep", .SDcols = !c("timestep")]
setnames(x = out, old = "timestep", new = "day")
return(out)
}