1 |
#' Row Numbers of Data with Missing Variables |
|
2 |
#' |
|
3 |
#' @param df (`data.frame`)\cr input data. |
|
4 |
#' @param formula (`formula` or `NULL`)\cr which variables to inspect for missingness, if `NULL` |
|
5 |
#' all variables are considered. |
|
6 |
#' |
|
7 |
#' @returns Numeric vector specifying which rows contain at least 1 missing observation |
|
8 |
#' in any of the inspected variables. |
|
9 |
#' |
|
10 |
#' @keywords internal |
|
11 |
get_missing_rownumbers <- function(df, formula = NULL) { |
|
12 | 440x |
if (is.null(formula)) { |
13 | ! |
formula <- ~ . |
14 |
} |
|
15 | 440x |
mdf <- stats::model.frame(formula, data = df, na.action = stats::na.pass) |
16 | 440x |
which(!stats::complete.cases(mdf)) |
17 |
} |
|
18 | ||
19 |
#' Remove Rows with Missing Variables |
|
20 |
#' |
|
21 |
#' Removes any rows from a data set that contain missing values in the inspected |
|
22 |
#' variables. Allows users to specify which variables to inspect for missing values |
|
23 |
#' based on either a formula or a character vector of variable names. |
|
24 |
#' |
|
25 |
#' @param data (`data.frame`)\cr input data. |
|
26 |
#' @param formula (`formula` or `NULL`)\cr which variables to inspect for missingness. |
|
27 |
#' @param extra_vars (`character`)\cr additional variables to inspect for missingness. |
|
28 |
#' |
|
29 |
#' @returns The `data` after removing observations that contain missing values in the required variables. |
|
30 |
#' Note that additional variables not listed in `formula` or `extra_vars` are not dropped and may |
|
31 |
#' still contain missing values. |
|
32 |
#' |
|
33 |
#' @keywords internal |
|
34 |
remove_missing_rows <- function(data, formula, extra_vars = NULL) { |
|
35 | 439x |
if (!is.null(extra_vars)) { |
36 | 1x |
extra_vars <- paste(extra_vars, collapse = " + ") |
37 | 1x |
formula_update_string <- paste0(". ~ . + ", extra_vars) |
38 | 1x |
formula <- stats::update(formula, formula_update_string) |
39 |
} |
|
40 | ||
41 | 439x |
missing_rows <- get_missing_rownumbers(data, formula) |
42 | ||
43 | 439x |
if (length(missing_rows) == 0) { |
44 | 437x |
return(data) |
45 |
} |
|
46 | 2x |
message(sprintf( |
47 | 2x |
"Note that %d observations were removed as one of more required variables contained missing values", |
48 | 2x |
length(missing_rows) |
49 |
)) |
|
50 | 2x |
data_reduced <- data[-missing_rows, ] |
51 | 2x |
rownames(data_reduced) <- NULL |
52 | 2x |
data_reduced |
53 |
} |
|
54 | ||
55 |
#' Replicate Single Values in a List |
|
56 |
#' |
|
57 |
#' @param initial_values (`list`)\cr initial values with names. |
|
58 |
#' @param sizes (`list`)\cr each size corresponds to an element in `initial_values`, |
|
59 |
#' matched by the names. An attribute `array` must be attached to each element, |
|
60 |
#' see [replace_with_lookup()]. |
|
61 |
#' |
|
62 |
#' @returns A named list of values, with any single values in the `initial_values` list |
|
63 |
#' replicated according to the corresponding values in the `sizes` list. |
|
64 |
#' Even when the size is 1, the value is passed as an `array` if the corresponding |
|
65 |
#' attribute is `TRUE` in `sizes`. |
|
66 |
#' |
|
67 |
#' @note The resulting list has the same names as the original lists. |
|
68 |
#' |
|
69 |
#' @keywords internal |
|
70 |
expand_initial_values <- function(initial_values, sizes) { |
|
71 | 25x |
assert_that( |
72 | 25x |
is.list(initial_values), |
73 | 25x |
msg = "`initial_values` must be a list" |
74 |
) |
|
75 | 25x |
assert_that( |
76 | 25x |
is.list(sizes), |
77 | 25x |
msg = "`sizes` must be a list" |
78 |
) |
|
79 | 25x |
assert_that( |
80 | 25x |
all(names(sizes) %in% names(initial_values)), |
81 | 25x |
all(names(initial_values) %in% names(sizes)), |
82 | 25x |
msg = "`initial_values` and `sizes` must have identical names" |
83 |
) |
|
84 | ||
85 | 25x |
for (name in names(initial_values)) { |
86 |
# Check for single values and replicate them according to sizes. |
|
87 | 173x |
if (length(initial_values[[name]]) == 1) { |
88 | 170x |
initial_values[[name]] <- rep(initial_values[[name]], sizes[[name]]) |
89 |
} |
|
90 |
# Check for array handling. |
|
91 | 173x |
needs_array <- attr(sizes[[name]], "array") |
92 | 173x |
assert_that( |
93 | 173x |
is.flag(needs_array), |
94 | 173x |
msg = "each sizes element must have array flag attribute" |
95 |
) |
|
96 | 173x |
if (needs_array) { |
97 | 106x |
initial_values[[name]] <- as.array(initial_values[[name]]) |
98 |
} |
|
99 |
} |
|
100 | ||
101 |
# Check that each element of initial_values has the same length as specified in sizes. |
|
102 | 25x |
for (name in names(initial_values)) { |
103 | 173x |
assert_that( |
104 | 173x |
length(initial_values[[name]]) == sizes[[name]], |
105 | 173x |
msg = "length of element in `initial_values` does not match specified size" |
106 |
) |
|
107 |
} |
|
108 | ||
109 | 25x |
initial_values |
110 |
} |
|
111 | ||
112 |
#' Replace Character Size by Looked Up Numbers |
|
113 |
#' |
|
114 |
#' @param sizes (`list`)\cr may include character elements that correspond to |
|
115 |
#' names in the data list. |
|
116 |
#' @param data (`list`)\cr data containing numeric values. |
|
117 |
#' |
|
118 |
#' @returns A list of sizes with character elements in `sizes` |
|
119 |
#' replaced by their corresponding numeric values in `data`. |
|
120 |
#' |
|
121 |
#' @details An attribute `array` for each returned list element indicates |
|
122 |
#' whether the parameter needs to be handled |
|
123 |
#' as an array. This is the case when the size is larger than 1, or when |
|
124 |
#' the size was looked up in the `data`, because in that case it is flexible |
|
125 |
#' and hence is handled as an array in the Stan code. |
|
126 |
#' |
|
127 |
#' @note Each element in the final list of sizes must be a single number. |
|
128 |
#' |
|
129 |
#' @keywords internal |
|
130 |
replace_with_lookup <- function(sizes, data) { |
|
131 | ||
132 | 18x |
assert_that(is.list(sizes), msg = "`sizes` must be a list") |
133 | 18x |
assert_that(is.list(data), msg = "`data` must be a list") |
134 | ||
135 | 18x |
for (idx in seq_along(sizes)) { |
136 | 122x |
val <- sizes[[idx]] |
137 | 122x |
if (is.character(val)) { |
138 | 75x |
assert_that( |
139 | 75x |
length(val) == 1, |
140 | 75x |
msg = "character elements of `sizes` must be strings" |
141 |
) |
|
142 | 75x |
assert_that( |
143 | 75x |
val %in% names(data), |
144 | 75x |
msg = sprintf("`%s` is not available in `data`", val) |
145 |
) |
|
146 | 75x |
new_val <- data[[val]] |
147 | 75x |
assert_that( |
148 | 75x |
is.number(new_val), |
149 | 75x |
msg = "Selected values from data must be single numbers" |
150 |
) |
|
151 | 74x |
sizes[[idx]] <- structure(new_val, array = TRUE) |
152 |
} else { |
|
153 | 47x |
assert_that( |
154 | 47x |
is.number(val), |
155 | 47x |
msg = "Existing values in sizes must be single numbers" |
156 |
) |
|
157 | 46x |
sizes[[idx]] <- structure(val, array = val > 1) |
158 |
} |
|
159 |
} |
|
160 | 16x |
sizes |
161 |
} |
|
162 | ||
163 |
#' Obtain Median and Credible Intervals from MCMC samples |
|
164 |
#' |
|
165 |
#' @param samples (`matrix`)\cr with samples in rows and parameters in columns. |
|
166 |
#' @param level (`number`)\cr credibility level to use for the credible intervals. |
|
167 |
#' |
|
168 |
#' @returns A `data.frame` with columns `median`, `lower` and `upper`. |
|
169 |
#' @keywords internal |
|
170 |
#' samples_median_ci(samples) |
|
171 |
samples_median_ci <- function(samples, level = 0.95) { |
|
172 | 38x |
assert_that(is.matrix(samples)) |
173 | 38x |
assert_that(is.number(level), level < 1, level > 0) |
174 | ||
175 | 38x |
samples_median <- apply(samples, MARGIN = 2L, FUN = stats::median) |
176 | 38x |
probs <- c((1 - level) / 2, (1 + level) / 2) |
177 | 38x |
samples_ci <- t(apply(samples, MARGIN = 2L, FUN = stats::quantile, probs = probs)) |
178 | 38x |
colnames(samples_ci) <- c("lower", "upper") |
179 | 38x |
as.data.frame(cbind( |
180 | 38x |
median = samples_median, |
181 | 38x |
samples_ci |
182 |
)) |
|
183 |
} |
|
184 | ||
185 | ||
186 | ||
187 |
#' `decorated_render` |
|
188 |
#' |
|
189 |
#' Simple wrapper around [jinjar::render()] that provides some additional default |
|
190 |
#' variables about the system (avoids each call to jinjar having to specify them) |
|
191 |
#' @param ... Arguments passed onto [jinjar::render()] |
|
192 |
#' @returns See [jinjar::render()] |
|
193 |
#' @keywords internal |
|
194 |
decorated_render <- function(...) { |
|
195 | 423x |
jinjar::render( |
196 |
..., |
|
197 | 423x |
machine_double_eps = 0, |
198 | 423x |
machine_double_neg_eps = 0 |
199 |
) |
|
200 |
} |
|
201 | ||
202 | ||
203 |
is_windows <- function() { |
|
204 | 49x |
sysname <- Sys.info()["sysname"] |
205 | 49x |
return(sysname == "Windows") |
206 |
} |
|
207 | ||
208 |
#' `validate_time_grid` |
|
209 |
#' |
|
210 |
#' Validate that the provided time grid is: |
|
211 |
#' - finite |
|
212 |
#' - numeric |
|
213 |
#' - non-missing |
|
214 |
#' - sorted |
|
215 |
#' - unique |
|
216 |
#' |
|
217 |
#' @param time_grid (`numeric`)\cr A vector of times which quantities will be |
|
218 |
#' evaluated at. |
|
219 |
#' |
|
220 |
#' @keywords internal |
|
221 |
validate_time_grid <- function(time_grid) { |
|
222 | 80x |
assert_that( |
223 | 80x |
!any(is.na(time_grid)), |
224 | 80x |
is.numeric(time_grid), |
225 | 80x |
!is.null(time_grid), |
226 | 80x |
!is.unsorted(time_grid), |
227 | 80x |
!any(duplicated(time_grid)), |
228 | 80x |
all(is.finite(time_grid)), |
229 | 80x |
msg = "`time_grid` needs to be finite, sorted, unique valued numeric vector" |
230 |
) |
|
231 | 76x |
invisible(time_grid) |
232 |
} |
|
233 | ||
234 | ||
235 | ||
236 |
#' `expand_subjects` |
|
237 |
#' |
|
238 |
#' This function checks and expands a given subjects vector. |
|
239 |
#' The input vector must be unique and contain only values |
|
240 |
#' as specified by `all_subjects` |
|
241 |
#' |
|
242 |
#' @param subjects (`character` or `NULL`)\cr Character vector representing the subjects. |
|
243 |
#' If NULL, it will be set to the value of `all_subjects`. |
|
244 |
#' @param all_subjects (`character`)\cr Character vector representing all possible subjects. |
|
245 |
#' @return Returns the expanded `subjects` vector. |
|
246 |
#' @keywords internal |
|
247 |
expand_subjects <- function(subjects, all_subjects) { |
|
248 | 38x |
assert_that( |
249 | 38x |
is.character(all_subjects), |
250 | 38x |
msg = "`all_subjects` must be a character vector" |
251 |
) |
|
252 | 38x |
if (is.null(subjects)) { |
253 | 3x |
subjects <- unique(all_subjects) |
254 |
} |
|
255 | 38x |
assert_that( |
256 | 38x |
is.character(subjects), |
257 | 38x |
all(subjects %in% all_subjects), |
258 | 38x |
!any(duplicated(subjects)), |
259 | 38x |
msg = "`subjects` should be a unique character vector containing only values from the original df" |
260 |
) |
|
261 | 30x |
return(subjects) |
262 |
} |
|
263 | ||
264 | ||
265 | ||
266 |
#' Decompose subjects into Relevant Components |
|
267 |
#' |
|
268 |
#' This function takes in a character vector or list of subjects and decomposes it into a |
|
269 |
#' structured format. |
|
270 |
#' |
|
271 |
#' The primary use of this function is to correctly setup indexing variables for |
|
272 |
#' predicting survival quantities (see [SurvivalQuantities()]) |
|
273 |
#' |
|
274 |
#' @param subjects (`character` or `list`)\cr subject identifiers. If `NULL` will be set to `all_subjects`. |
|
275 |
#' |
|
276 |
#' @param all_subjects (`character`)\cr the set of allowable subject identifiers. |
|
277 |
#' Will cause an error if any value of `subjects` is not in this vector. |
|
278 |
#' |
|
279 |
#' @return A list containing three components: |
|
280 |
#' - `groups`: (`list`)\cr each element of the list is a character vector |
|
281 |
#' specifying which subjects belong to a given "group" where the "group" is the element name |
|
282 |
#' - `unique_values`: (`character`)\cr vector of the unique subjects within `subjects` |
|
283 |
#' - `indexes`: (`list`)\cr each element is a named and is a numeric index vector |
|
284 |
#' that maps the values of `grouped` to `unique_values` |
|
285 |
#' @examples |
|
286 |
#' \dontrun{ |
|
287 |
#' result <- decompose_subjects(c("A", "B"), c("A", "B", "C", "D")) |
|
288 |
#' result <- decompose_subjects( |
|
289 |
#' list("g1" = c("A", "B"), "g2" = c("B", "C")), |
|
290 |
#' c("A", "B", "C", "D") |
|
291 |
#' ) |
|
292 |
#' } |
|
293 |
#' @seealso [expand_subjects()], [SurvivalQuantities()] |
|
294 |
#' @keywords internal |
|
295 |
decompose_subjects <- function(subjects, all_subjects) { |
|
296 | 13x |
if (is.character(subjects) || is.null(subjects)) { |
297 | 7x |
subjects <- expand_subjects(subjects, all_subjects) |
298 | 4x |
names(subjects) <- subjects |
299 | 4x |
subjects <- as.list(subjects) |
300 |
} |
|
301 | 10x |
subjects <- lapply( |
302 | 10x |
subjects, |
303 | 10x |
expand_subjects, |
304 | 10x |
all_subjects = all_subjects |
305 |
) |
|
306 | 8x |
assert_that( |
307 | 8x |
is.list(subjects), |
308 | 8x |
length(unique(names(subjects))) == length(subjects), |
309 | 8x |
all(vapply(subjects, is.character, logical(1))) |
310 |
) |
|
311 | 8x |
subjects_vec_unordered <- unique(unlist(subjects)) |
312 | 8x |
subjects_vec <- subjects_vec_unordered[order(subjects_vec_unordered)] |
313 | 8x |
subjects_lookup <- stats::setNames(seq_along(subjects_vec), subjects_vec) |
314 | 8x |
subjects_index <- lapply( |
315 | 8x |
subjects, |
316 | 8x |
\(x) { |
317 | 22x |
z <- subjects_lookup[x] |
318 | 22x |
names(z) <- NULL |
319 | 22x |
z |
320 |
} |
|
321 |
) |
|
322 | 8x |
list( |
323 | 8x |
groups = subjects, |
324 | 8x |
unique_values = subjects_vec, |
325 | 8x |
indexes = subjects_index |
326 |
) |
|
327 |
} |
|
328 | ||
329 |
is_cmdstanr_available <- function() { |
|
330 | 4x |
requireNamespace("cmdstanr", quietly = TRUE) |
331 |
} |
|
332 | ||
333 | ||
334 |
is_connection <- function(obj) { |
|
335 | ! |
inherits(obj, "connection") |
336 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include Grid.R |
|
3 |
NULL |
|
4 | ||
5 | ||
6 |
#' @rdname Quant-Dev |
|
7 |
.QuantityGeneratorSubject <- setClass( |
|
8 |
"QuantityGeneratorSubject", |
|
9 |
contains = "QuantityGenerator", |
|
10 |
slots = c( |
|
11 |
"times" = "numeric", |
|
12 |
"subjects" = "character_or_NULL" |
|
13 |
) |
|
14 |
) |
|
15 | ||
16 | ||
17 |
#' @rdname Quant-Dev |
|
18 |
QuantityGeneratorSubject <- function(times, subjects = NULL) { |
|
19 | 78x |
.QuantityGeneratorSubject( |
20 | 78x |
times = times, |
21 | 78x |
subjects = subjects |
22 |
) |
|
23 |
} |
|
24 | ||
25 | ||
26 |
setValidity( |
|
27 |
"QuantityGeneratorSubject", |
|
28 |
function(object) { |
|
29 |
if (length(object@times) != length(object@subjects)) { |
|
30 |
return("Length of `times` and `subjects` must be equal") |
|
31 |
} |
|
32 |
return(TRUE) |
|
33 |
} |
|
34 |
) |
|
35 | ||
36 | ||
37 |
#' @rdname as_stan_list.QuantityGenerator |
|
38 |
#' @export |
|
39 |
as_stan_list.QuantityGeneratorSubject <- function(object, data, ...) { |
|
40 | 26x |
assert_that( |
41 | 26x |
is(data, "DataJoint") |
42 |
) |
|
43 | 26x |
ret <- list() |
44 | 26x |
data_list <- as.list(data) |
45 | 26x |
ret[["gq_subject_index"]] <- data_list$subject_to_index[as.character(object@subjects)] |
46 | 26x |
ret[["gq_n_quant"]] <- length(object@subjects) |
47 | 26x |
ret[["gq_times"]] <- object@times |
48 | ||
49 |
# dummy pop indexes in order for stan code to actualy compile. In this setting |
|
50 |
# this matrix isn't actually used so doesn't matter what these values are |
|
51 |
# but don't want to have to burden individual longitudinal models with the |
|
52 |
# conditional logic to check if they are generating population quantities or not |
|
53 | 26x |
ret[["gq_long_pop_arm_index"]] <- rep(1, ret[["gq_n_quant"]]) |
54 | 26x |
ret[["gq_long_pop_study_index"]] <- rep(1, ret[["gq_n_quant"]]) |
55 | ||
56 |
# Sanity checks |
|
57 | 26x |
assert_that( |
58 | 26x |
length(ret[["gq_times"]]) == ret[["gq_n_quant"]], |
59 | 26x |
all(object@subjects %in% names(data_list$subject_to_index)) |
60 |
) |
|
61 | 26x |
return(ret) |
62 |
} |
1 |
#' @include Grid.R |
|
2 |
#' @include generics.R |
|
3 |
NULL |
|
4 | ||
5 |
#' @rdname Grid-Dev |
|
6 |
.GridEvent <- setClass( |
|
7 |
"GridEvent", |
|
8 |
contains = "Grid", |
|
9 |
slots = c( |
|
10 |
"subjects" = "character_or_NULL" |
|
11 |
) |
|
12 |
) |
|
13 | ||
14 | ||
15 |
#' @rdname Grid-Functions |
|
16 |
#' @export |
|
17 |
GridEvent <- function(subjects = NULL) { |
|
18 | 1x |
.GridEvent( |
19 | 1x |
subjects = subjects |
20 |
) |
|
21 |
} |
|
22 | ||
23 |
#' @rdname Quant-Dev |
|
24 |
#' @export |
|
25 |
as.QuantityGenerator.GridEvent <- function(object, data, ...) { |
|
26 | 3x |
assert_class(data, "DataJoint") |
27 | 3x |
assert_that( |
28 | 3x |
!is.null(data@survival), |
29 | 3x |
msg = "Survival data must have been provided to `DataJoint()` in order to use `GridEvent()`" |
30 |
) |
|
31 | 2x |
data_list <- as.list(data) |
32 | 2x |
subjects <- unlist(as.list(object, data = data), use.names = FALSE) |
33 | 2x |
event_times <- data_list$event_times[data_list$subject_to_index[subjects]] |
34 | 2x |
QuantityGeneratorSubject( |
35 | 2x |
times = event_times, |
36 | 2x |
subjects = subjects |
37 |
) |
|
38 |
} |
|
39 | ||
40 |
#' @rdname Quant-Dev |
|
41 |
#' @export |
|
42 |
as.QuantityCollapser.GridEvent <- function(object, data, ...) { |
|
43 | 1x |
generator <- as.QuantityGenerator(object, data) |
44 | 1x |
QuantityCollapser( |
45 | 1x |
times = generator@times, |
46 | 1x |
groups = generator@subjects, |
47 | 1x |
indexes = as.list(seq_along(generator@times)) |
48 |
) |
|
49 |
} |
|
50 | ||
51 |
#' @export |
|
52 |
as.list.GridEvent <- function(x, data, ...) { |
|
53 | 2x |
subjects_to_list(x@subjects, data) |
54 |
} |
1 |
#' @include generics.R |
|
2 |
NULL |
|
3 | ||
4 |
# STAN_BLOCKS ---- |
|
5 | ||
6 |
#' List of Stan Blocks |
|
7 |
#' |
|
8 |
#' @description |
|
9 |
#' A list with 1 element per standard Stan program blocks. |
|
10 |
#' This object is mostly used internally as a reference for |
|
11 |
#' what blocks are expected to exist within a given Stan program. |
|
12 |
#' |
|
13 |
#' @export |
|
14 |
STAN_BLOCKS <- list( |
|
15 |
functions = "functions", |
|
16 |
data = "data", |
|
17 |
transformed_data = "transformed data", |
|
18 |
parameters = "parameters", |
|
19 |
transformed_parameters = "transformed parameters", |
|
20 |
model = "model", |
|
21 |
generated_quantities = "generated quantities" |
|
22 |
) |
|
23 | ||
24 |
# add_missing_stan_blocks ---- |
|
25 | ||
26 |
#' Add Missing Stan Blocks |
|
27 |
#' |
|
28 |
#' @param x (`list`)\cr list of Stan code blocks |
|
29 |
#' @param stan_blocks (`list`)\cr reference list of stan blocks. |
|
30 |
#' |
|
31 |
#' @return Amended list `x` such that all blocks in the global variable |
|
32 |
#' `STAN_BLOCKS` are contained. |
|
33 |
#' |
|
34 |
#' @keywords internal |
|
35 |
add_missing_stan_blocks <- function(x, stan_blocks = STAN_BLOCKS) { |
|
36 | 476x |
for (block in names(stan_blocks)) { |
37 | 3327x |
if (is.null(x[[block]])) { |
38 | 167x |
x[[block]] <- "" |
39 |
} |
|
40 |
} |
|
41 | 476x |
return(x) |
42 |
} |
|
43 | ||
44 |
# StanModule-class ---- |
|
45 | ||
46 |
#' `StanModule` Object and Constructor Function |
|
47 |
#' |
|
48 |
#' @param x (`string`)\cr file path to a Stan program or a character vector |
|
49 |
#' of Stan code to be parsed. |
|
50 |
#' @param ... additional arguments passed to the constructor. |
|
51 |
#' |
|
52 |
#' @slot functions (`character`)\cr the `functions` block. |
|
53 |
#' @slot data (`character`)\cr the `data` block. |
|
54 |
#' @slot transformed_data (`character`)\cr the `transformed_data` block. |
|
55 |
#' @slot parameters (`character`)\cr the `parameters` block. |
|
56 |
#' @slot transformed_parameters (`character`)\cr the `transformed_parameters` block. |
|
57 |
#' @slot model (`character`)\cr the `model` block. |
|
58 |
#' @slot generated_quantities (`character`)\cr the `generated_quantities` block. |
|
59 |
#' |
|
60 |
#' @exportClass StanModule |
|
61 |
#' @export StanModule |
|
62 |
#' @family StanModule |
|
63 |
.StanModule <- setClass( |
|
64 |
Class = "StanModule", |
|
65 |
slots = list( |
|
66 |
functions = "character", |
|
67 |
data = "character", |
|
68 |
transformed_data = "character", |
|
69 |
parameters = "character", |
|
70 |
transformed_parameters = "character", |
|
71 |
model = "character", |
|
72 |
generated_quantities = "character" |
|
73 |
) |
|
74 |
) |
|
75 | ||
76 |
# StanModule-constructors ---- |
|
77 | ||
78 |
#' @rdname StanModule-class |
|
79 |
StanModule <- function( |
|
80 |
x = "", |
|
81 |
... |
|
82 |
) { |
|
83 | 2885x |
assert_that( |
84 | 2885x |
is.character(x), |
85 | 2885x |
length(x) == 1, |
86 | 2885x |
msg = "`x` must be a length 1 character vector" |
87 |
) |
|
88 | 2885x |
code <- read_stan(x) |
89 | 2885x |
code_fragments <- as_stan_fragments(code) |
90 | ||
91 | 2882x |
if (paste0(unlist(code_fragments), collapse = "") == "" && paste0(x, collaspe = "") != "") { |
92 | 1x |
warning("Non-empty input resulted in an empty StanModule object. Is the input correct?") |
93 |
} |
|
94 | ||
95 | 2882x |
.StanModule( |
96 | 2882x |
functions = code_fragments$functions, |
97 | 2882x |
data = code_fragments$data, |
98 | 2882x |
transformed_data = code_fragments$transformed_data, |
99 | 2882x |
parameters = code_fragments$parameters, |
100 | 2882x |
transformed_parameters = code_fragments$transformed_parameters, |
101 | 2882x |
model = code_fragments$model, |
102 | 2882x |
generated_quantities = code_fragments$generated_quantities, |
103 |
... |
|
104 |
) |
|
105 |
} |
|
106 | ||
107 |
# as.character-StanModule ---- |
|
108 | ||
109 |
#' `StanModule` -> `character` |
|
110 |
#' @param x ([`StanModule`])\cr A stan program |
|
111 |
#' @param ... Not Used. |
|
112 |
#' @description |
|
113 |
#' Converts a [`StanModule`] object into a valid Stan program file where each |
|
114 |
#' line of the returned `character` vector represents a line of the program |
|
115 |
#' @family StanModule |
|
116 |
#' @export |
|
117 |
as.character.StanModule <- function(x, ...) { |
|
118 | 549x |
as_stan_file( |
119 | 549x |
functions = x@functions, |
120 | 549x |
data = x@data, |
121 | 549x |
transformed_data = x@transformed_data, |
122 | 549x |
parameters = x@parameters, |
123 | 549x |
transformed_parameters = x@transformed_parameters, |
124 | 549x |
model = x@model, |
125 | 549x |
generated_quantities = x@generated_quantities |
126 |
) |
|
127 |
} |
|
128 | ||
129 | ||
130 | ||
131 |
# merge-StanModule,StanModule ---- |
|
132 | ||
133 |
#' @param stan_blocks (`list`)\cr reference list of stan blocks. |
|
134 |
#' @rdname merge |
|
135 |
setMethod( |
|
136 |
f = "merge", |
|
137 |
signature = c("StanModule", "StanModule"), |
|
138 |
definition = function(x, y, stan_blocks = STAN_BLOCKS, ...) { |
|
139 | 1145x |
stan_fragments <- lapply( |
140 | 1145x |
names(stan_blocks), |
141 | 1145x |
\(par) { |
142 | 8015x |
if (all(slot(y, par) == "")) { |
143 | 5514x |
return(slot(x, par)) |
144 |
} |
|
145 | 2501x |
if (all(slot(x, par) == "")) { |
146 | 623x |
return(slot(y, par)) |
147 |
} |
|
148 | 1878x |
return(c(slot(x, par), slot(y, par))) |
149 |
} |
|
150 |
) |
|
151 | 1145x |
names(stan_fragments) <- names(stan_blocks) |
152 | 1145x |
stan_code <- do.call(as_stan_file, stan_fragments) |
153 | 1145x |
StanModule( |
154 | 1145x |
x = stan_code |
155 |
) |
|
156 |
} |
|
157 |
) |
|
158 | ||
159 |
# compileStanModel-StanModule,character ---- |
|
160 | ||
161 |
#' @rdname compileStanModel |
|
162 |
compileStanModel.StanModule <- function(object) { |
|
163 | 45x |
exe_dir <- getOption("jmpost.cache_dir") |
164 | 45x |
if (!dir.exists(exe_dir)) { |
165 | 3x |
dir.create(exe_dir, recursive = TRUE) |
166 |
} |
|
167 | 45x |
stan_code <- as.character(object) |
168 | 45x |
hash_name <- digest::digest(stan_code, "md5") |
169 | 45x |
exe_name <- paste0( |
170 | 45x |
"model_", |
171 | 45x |
hash_name, |
172 | 45x |
if (is_windows()) ".exe" else "" |
173 |
) |
|
174 | 45x |
exe_file <- file.path(exe_dir, exe_name) |
175 | 45x |
source_file <- cmdstanr::write_stan_file( |
176 | 45x |
code = stan_code, |
177 | 45x |
dir = exe_dir, |
178 | 45x |
basename = sprintf("model_%s.stan", hash_name) |
179 |
) |
|
180 | ||
181 |
# Suppress "model executable is up to date" message as |
|
182 |
# users are not in control of the cache so this message is meaningless |
|
183 | 45x |
withCallingHandlers( |
184 |
{ |
|
185 | 45x |
x <- cmdstanr::cmdstan_model( |
186 | 45x |
stan_file = source_file, |
187 | 45x |
exe_file = exe_file, |
188 | 45x |
quiet = TRUE |
189 |
) |
|
190 |
}, |
|
191 | 45x |
message = function(m) { |
192 | ! |
if (m$message == "Model executable is up to date!\n") { |
193 | ! |
invokeRestart("muffleMessage") |
194 |
} |
|
195 |
} |
|
196 |
) |
|
197 | 45x |
invisible(x) |
198 |
} |
|
199 | ||
200 | ||
201 | ||
202 |
# as.list-StanModule ---- |
|
203 | ||
204 |
#' `StanModule` -> `list` |
|
205 |
#' @description |
|
206 |
#' Returns a named list where each element of the list corresponds |
|
207 |
#' to a Stan modelling block e.g. `data`, `model`, etc. |
|
208 |
#' @param x ([`StanModule`])\cr A Stan Module |
|
209 |
#' @param stan_blocks (`list`)\cr reference list of stan blocks. |
|
210 |
#' @param ... Not Used. |
|
211 |
#' @family StanModule |
|
212 |
#' @export |
|
213 |
as.list.StanModule <- function(x, stan_blocks = STAN_BLOCKS, ...) { |
|
214 | 451x |
string <- as.character(x) |
215 | 451x |
li <- as_stan_fragments(string) |
216 | 451x |
for (block in names(stan_blocks)) { |
217 | 3157x |
li[[block]] <- paste(li[[block]], collapse = "\n") |
218 |
} |
|
219 | 451x |
return(li) |
220 |
} |
|
221 | ||
222 |
# is_file ---- |
|
223 | ||
224 |
#' Is String a Valid File? |
|
225 |
#' |
|
226 |
#' A utility function to check if a string is a valid file or not. |
|
227 |
#' Used to help address short comings of [file.exists()] that will return `TRUE` |
|
228 |
#' for a directory as well as a file. |
|
229 |
#' |
|
230 |
#' @param filename (`string`)\cr file name. |
|
231 |
#' |
|
232 |
#' @keywords internal |
|
233 |
is_file <- function(filename = NULL) { |
|
234 | 9630x |
if (is.null(filename)) { |
235 | ! |
return(FALSE) |
236 |
} |
|
237 | 9630x |
assert_that( |
238 | 9630x |
is.character(filename), |
239 | 9630x |
length(filename) == 1, |
240 | 9630x |
msg = "`filename` must be a length 1 character" |
241 |
) |
|
242 | 9630x |
if (nchar(filename) > 1000) { |
243 | 1954x |
return(FALSE) |
244 |
} |
|
245 | 7676x |
if (is.na(filename)) { |
246 | ! |
return(FALSE) |
247 |
} |
|
248 | 7676x |
return(file.exists(filename) & !dir.exists(filename)) |
249 |
} |
|
250 | ||
251 |
# read_stan ---- |
|
252 | ||
253 |
#' Stan Code as Character |
|
254 |
#' |
|
255 |
#' @param string Character, either the absolute path of a stan file, or the name of the stan |
|
256 |
#' file in the package directory or the stan code as a string. |
|
257 |
read_stan <- function(string) { |
|
258 | 3218x |
local_inst_file <- file.path("inst", "stan", string) |
259 | 3218x |
system_file <- system.file(file.path("stan", string), package = "jmpost") |
260 | 3218x |
local_file <- string |
261 | 3218x |
files <- c(local_file, local_inst_file, system_file) |
262 | 3218x |
for (fi in files) { |
263 | 9630x |
if (is_file(fi)) { |
264 | 752x |
string <- readLines(fi) |
265 | 752x |
break |
266 |
} |
|
267 |
} |
|
268 | 3218x |
string <- paste0(string, collapse = "\n") |
269 | 3218x |
return(string) |
270 |
} |
|
271 | ||
272 |
# as_stan_file ---- |
|
273 | ||
274 |
#' Merging Code Blocks into Stan Code Character Vector |
|
275 |
#' |
|
276 |
#' @param functions (`character`)\cr code block. |
|
277 |
#' @param data (`character`)\cr code block. |
|
278 |
#' @param transformed_data (`character`)\cr code block. |
|
279 |
#' @param parameters (`character`)\cr code block. |
|
280 |
#' @param transformed_parameters (`character`)\cr code block. |
|
281 |
#' @param model (`character`)\cr code block. |
|
282 |
#' @param generated_quantities (`character`)\cr code block. |
|
283 |
#' @param stan_blocks (`list`)\cr reference list of stan blocks. |
|
284 |
#' |
|
285 |
#' @return Character vector of the complete Stan code. |
|
286 |
#' |
|
287 |
#' @keywords internal |
|
288 |
as_stan_file <- function( |
|
289 |
functions = "", |
|
290 |
data = "", |
|
291 |
transformed_data = "", |
|
292 |
parameters = "", |
|
293 |
transformed_parameters = "", |
|
294 |
model = "", |
|
295 |
generated_quantities = "", |
|
296 |
stan_blocks = STAN_BLOCKS |
|
297 |
) { |
|
298 | 1694x |
block_strings <- lapply( |
299 | 1694x |
names(stan_blocks), |
300 | 1694x |
function(id) { |
301 | 11858x |
char <- get(id) |
302 | 11858x |
if (any(nchar(char) >= 1)) { |
303 | 5420x |
return(sprintf("%s {\n%s\n}\n\n", stan_blocks[[id]], paste(char, collapse = "\n"))) |
304 |
} else { |
|
305 | 6438x |
return("") |
306 |
} |
|
307 |
} |
|
308 |
) |
|
309 | 1694x |
return(paste0(block_strings, collapse = "")) |
310 |
} |
|
311 | ||
312 |
# as_stan_fragments ---- |
|
313 | ||
314 |
#' Conversion of Character Vector into Stan Code Block List |
|
315 |
#' |
|
316 |
#' @param x (`character`)\cr the single Stan code vector. |
|
317 |
#' @param stan_blocks (`list`)\cr reference list of stan blocks. |
|
318 |
#' |
|
319 |
#' @return A list with the Stan code blocks. |
|
320 |
#' |
|
321 |
#' @details |
|
322 |
#' Function only works if code is in format |
|
323 |
#' ``` |
|
324 |
#' data { |
|
325 |
#' <code> |
|
326 |
#' } |
|
327 |
#' model { |
|
328 |
#' <code> |
|
329 |
#' } |
|
330 |
#' ``` |
|
331 |
#' That is to say we do not support code in inline format i.e. |
|
332 |
#' ``` |
|
333 |
#' data { <code> } |
|
334 |
#' model { <code> } |
|
335 |
#' ``` |
|
336 |
#' |
|
337 |
#' @keywords internal |
|
338 |
as_stan_fragments <- function(x, stan_blocks = STAN_BLOCKS) { |
|
339 | 3336x |
code <- unlist(stringr::str_split(x, "\n")) |
340 | ||
341 | 3336x |
errmsg <- paste( |
342 | 3336x |
"There were problems parsing the `%s` block.", |
343 | 3336x |
"Please consult the `Formatting Stan Files` section of the", |
344 | 3336x |
"`Extending jmpost` vignette" |
345 |
) |
|
346 | ||
347 |
# Check to see if any block openings exist that have code on the same line |
|
348 |
# e.g. `data { int i;}`. This is unsupported so we throw an error |
|
349 | 3336x |
for (block in stan_blocks) { |
350 | 23347x |
regex <- sprintf("^\\s*%s\\s*\\{\\s*[^\\s-]+", block) |
351 | 23347x |
if (any(grepl(regex, code, perl = TRUE))) { |
352 | 2x |
stop(sprintf(errmsg, block)) |
353 |
} |
|
354 |
} |
|
355 | ||
356 |
# We first look to identify the opening of a block e.g. `data {` |
|
357 |
# We then regard all lines that follow as belonging to that block |
|
358 |
# until we see another block being opened e.g. `model{` |
|
359 | 3334x |
results <- list() |
360 | 3334x |
target <- NULL |
361 | 3334x |
for (line in code) { |
362 | 241467x |
for (block in names(stan_blocks)) { |
363 | 1661228x |
regex <- sprintf("^\\s*%s\\s*\\{\\s*$", stan_blocks[[block]]) |
364 | 1661228x |
if (stringr::str_detect(line, regex)) { |
365 | 9118x |
target <- block |
366 | 9118x |
line <- NULL |
367 | 9118x |
break |
368 |
} |
|
369 |
} |
|
370 | 241467x |
if (!is.null(target)) { |
371 |
# This is memory inefficient but given the relatively small size of |
|
372 |
# stan files its regarded as a acceptable simplification to ease the |
|
373 |
# code burden |
|
374 | 240301x |
results[[target]] <- c(results[[target]], line) |
375 |
} |
|
376 |
} |
|
377 | ||
378 |
# Loop over each block to remove trailing "}". |
|
379 | 3334x |
for (block in names(results)) { |
380 | 9117x |
block_length <- length(results[[block]]) |
381 |
# The following processing is only required if the block actually has content |
|
382 | 9117x |
if (block_length == 1 && results[[block]] == "") { |
383 | ! |
next |
384 |
} |
|
385 | 9117x |
has_removed_char <- FALSE |
386 |
# Walk backwards to find the closing `}` that corresponds to the `<block> {` |
|
387 | 9117x |
for (index in rev(seq_len(block_length))) { |
388 | 19701x |
line <- results[[block]][[index]] |
389 |
# This code will exit the for loop as soon as it hits the closing `}` |
|
390 |
# thus if we ever see a line that ends in text/numbers it means |
|
391 |
# somethings gone wrong |
|
392 | 19701x |
if (stringr::str_detect(line, "[\\w\\d]+\\s*$")) { |
393 | 1x |
stop(sprintf(errmsg, block)) |
394 |
} |
|
395 | 19700x |
if (stringr::str_detect(line, "\\}\\s*$")) { |
396 | 9116x |
new_line <- stringr::str_replace(line, "\\s*\\}\\s*$", "") |
397 |
# If the line is now blank after removing the closing `}` then drop the line |
|
398 | 9116x |
keep_offset <- if (nchar(new_line) == 0) -1 else 0 |
399 |
# Only keep lines from the start of the block to the closing `}` |
|
400 |
# this is to ensure we drop blank lines that were between the end |
|
401 |
# of the block and the start of the next |
|
402 | 9116x |
keep_range <- seq_len(index + keep_offset) |
403 | 9116x |
results[[block]][[index]] <- new_line |
404 | 9116x |
results[[block]] <- results[[block]][keep_range] |
405 | 9116x |
has_removed_char <- TRUE |
406 | 9116x |
break |
407 |
} |
|
408 |
} |
|
409 |
# If we haven't actually removed a closing `}` then something has gone wrong... |
|
410 | 9116x |
if (!has_removed_char) { |
411 | ! |
stop(sprintf(errmsg, block)) |
412 |
} |
|
413 |
} |
|
414 | ||
415 |
# Add any missing blocks back in |
|
416 | 3333x |
for (block in names(stan_blocks)) { |
417 | 23331x |
if (is.null(results[[block]])) { |
418 | 14215x |
results[[block]] <- "" |
419 |
} |
|
420 |
} |
|
421 | 3333x |
results |
422 |
} |
|
423 | ||
424 |
#' `StanModule` -> Printable `Character` |
|
425 |
#' |
|
426 |
#' Converts [`StanModule`] object into a printable string. |
|
427 |
#' @param object ([`StanModule`])\cr A stan program |
|
428 |
#' @family StanModule |
|
429 |
#' @param indent (`numeric`)\cr how much white space to prefix the print string with. |
|
430 |
#' @keywords internal |
|
431 |
#' @export |
|
432 |
as_print_string.StanModule <- function(object, indent = 1, ...) { |
|
433 | 1x |
slots <- names(getSlots("StanModule")) |
434 | 1x |
components <- Filter(\(block) paste(slot(object, block), collapse = "") != "", slots) |
435 | 1x |
template <- c( |
436 | 1x |
"StanModule Object with components:", |
437 | 1x |
paste(" ", components) |
438 |
) |
|
439 | 1x |
pad <- rep(" ", indent) |> paste(collapse = "") |
440 | 1x |
template_padded <- paste(pad, template) |
441 | 1x |
sprintf( |
442 | 1x |
paste(template_padded, collapse = "\n") |
443 |
) |
|
444 |
} |
|
445 | ||
446 |
#' @rdname show-object |
|
447 |
#' @export |
|
448 |
setMethod( |
|
449 |
f = "show", |
|
450 |
signature = "StanModule", |
|
451 |
definition = function(object) { |
|
452 | 1x |
string <- as_print_string(object) |
453 | 1x |
cat("\n", string, "\n\n") |
454 |
} |
|
455 |
) |
1 |
#' @include JointModel.R |
|
2 |
#' @include SurvivalQuantities.R |
|
3 |
NULL |
|
4 | ||
5 |
setOldClass("CmdStanMCMC") |
|
6 | ||
7 |
# JointModelSamples-class ---- |
|
8 | ||
9 |
#' `JointModelSamples` |
|
10 |
#' |
|
11 |
#' Contains samples from a [`JointModel`]. |
|
12 |
#' |
|
13 |
#' @slot model ([`JointModel`])\cr the model that the samples were drawn from. |
|
14 |
#' @slot data ([`DataJoint`])\cr the data that the model was fitted on. |
|
15 |
#' @slot results ([`cmdstanr::CmdStanMCMC`])\cr the STAN samples. |
|
16 |
#' |
|
17 |
#' @aliases JointModelSamples |
|
18 |
#' @export |
|
19 |
.JointModelSamples <- setClass( |
|
20 |
"JointModelSamples", |
|
21 |
slots = c( |
|
22 |
model = "JointModel", |
|
23 |
data = "DataJoint", |
|
24 |
results = "CmdStanMCMC" |
|
25 |
) |
|
26 |
) |
|
27 | ||
28 | ||
29 |
#' @rdname generateQuantities |
|
30 |
#' @param generator (`QuantityGenerator`)\cr object that specifies which subjects and time points |
|
31 |
#' to calculate the quantities at |
|
32 |
#' @param type (`character`)\cr type of quantities to be generated, must be either "survival" or |
|
33 |
#' "longitudinal". |
|
34 |
#' @export |
|
35 |
generateQuantities.JointModelSamples <- function(object, generator, type, ...) { |
|
36 | ||
37 | 31x |
data <- as_stan_list(object@data) |> |
38 | 31x |
append(as_stan_list(object@model@parameters)) |> |
39 | 31x |
append(as_stan_list(generator, data = object@data, model = object@model)) |
40 | ||
41 | 30x |
stanobj <- as.StanModule(object, generator = generator, type = type) |
42 | 30x |
model <- compileStanModel(stanobj) |
43 | ||
44 | 30x |
devnull <- utils::capture.output( |
45 | 30x |
results <- model$generate_quantities( |
46 | 30x |
data = data, |
47 | 30x |
fitted_params = object@results |
48 |
) |
|
49 |
) |
|
50 | 30x |
return(results) |
51 |
} |
|
52 | ||
53 | ||
54 |
#' `JointModelSamples` -> `StanModule` |
|
55 |
#' |
|
56 |
#' Converts a `JointModelSamples` object into a `StanModule` object ensuring |
|
57 |
#' that the resulting `StanModule` object is able to generate post sampling |
|
58 |
#' quantities. |
|
59 |
#' |
|
60 |
#' @inheritParams generateQuantities |
|
61 |
#' @export |
|
62 |
as.StanModule.JointModelSamples <- function(object, generator, type, ...) { |
|
63 | 38x |
assert_that( |
64 | 38x |
is(generator, "QuantityGenerator"), |
65 | 38x |
length(type) == 1, |
66 | 38x |
type %in% c("survival", "longitudinal") |
67 |
) |
|
68 | ||
69 | 38x |
quant_stanobj <- read_stan("base/quantities.stan") |> |
70 | 38x |
decorated_render( |
71 | 38x |
include_gq_longitudinal_idv = (type == "longitudinal") & is(generator, "QuantityGeneratorSubject"), |
72 | 38x |
include_gq_longitudinal_pop = (type == "longitudinal") & is(generator, "QuantityGeneratorPopulation"), |
73 | 38x |
include_gq_survival_idv = (type == "survival") & is(generator, "QuantityGeneratorSubject"), |
74 | 38x |
include_gq_survival_pred = (type == "survival") & is(generator, "QuantityGeneratorPrediction") |
75 |
) |> |
|
76 | 38x |
StanModule() |
77 | ||
78 | 38x |
stanobj <- Reduce( |
79 | 38x |
merge, |
80 | 38x |
list( |
81 | 38x |
as.StanModule(object@model), |
82 | 38x |
enableGQ(object@model), |
83 | 38x |
quant_stanobj |
84 |
) |
|
85 |
) |
|
86 | 38x |
stanobj |
87 |
} |
|
88 | ||
89 | ||
90 | ||
91 |
#' `JointModelSamples` -> Printable `Character` |
|
92 |
#' |
|
93 |
#' Converts [`JointModelSamples`] object into a printable string. |
|
94 |
#' @param object ([`JointModelSamples`])\cr samples as drawn from a [`JointModel`]. |
|
95 |
#' @family JointModelSamples |
|
96 |
#' @param indent (`numeric`)\cr how much white space to prefix the print string with. |
|
97 |
#' @keywords internal |
|
98 |
#' @export |
|
99 |
as_print_string.JointModelSamples <- function(object, indent = 1, ...) { |
|
100 | 14x |
sizes <- vapply( |
101 | 14x |
cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variable_sizes"]], |
102 | 14x |
\(x) { |
103 | 74x |
if (length(x) == 1 && x == 1) return("") |
104 | 149x |
paste0("[", paste(x, collapse = ", "), "]") |
105 |
}, |
|
106 | 14x |
character(1) |
107 |
) |
|
108 | 14x |
variable_string <- paste0( |
109 |
" ", |
|
110 | 14x |
cmdstanr::as.CmdStanMCMC(object)$metadata()[["stan_variables"]], |
111 | 14x |
sizes |
112 |
) |
|
113 | 14x |
template <- c( |
114 | 14x |
"JointModelSamples Object with:", |
115 |
"", |
|
116 | 14x |
" # of samples per chain = %d", |
117 | 14x |
" # of chains = %d", |
118 |
"", |
|
119 | 14x |
" Variables:", |
120 | 14x |
variable_string[order(variable_string)] |
121 |
) |
|
122 | 14x |
pad <- rep(" ", indent) |> paste(collapse = "") |
123 | 14x |
template_padded <- paste(pad, template) |
124 | 14x |
sprintf( |
125 | 14x |
paste(template_padded, collapse = "\n"), |
126 | 14x |
cmdstanr::as.CmdStanMCMC(object)$metadata()$iter_sampling, |
127 | 14x |
cmdstanr::as.CmdStanMCMC(object)$num_chains() |
128 |
) |
|
129 |
} |
|
130 | ||
131 |
#' @rdname show-object |
|
132 |
#' @export |
|
133 |
setMethod( |
|
134 |
f = "show", |
|
135 |
signature = "JointModelSamples", |
|
136 |
definition = function(object) { |
|
137 | 14x |
string <- as_print_string(object) |
138 | 14x |
cat("\n", string, "\n\n") |
139 |
} |
|
140 |
) |
|
141 | ||
142 | ||
143 |
#' @rdname as.CmdStanMCMC |
|
144 |
as.CmdStanMCMC.JointModelSamples <- function(object, ...) { |
|
145 | 66x |
return(object@results) |
146 |
} |
1 | ||
2 | ||
3 |
#' Re-used documentation for Brier Score components |
|
4 |
#' |
|
5 |
#' @param t (`numeric`)\cr timepoints to calculate the desired quantity at. |
|
6 |
#' @param times (`numeric`)\cr observed times. |
|
7 |
#' @param events (`numeric`)\cr event indicator for `times`. Either 1 for an event or 0 for censor. |
|
8 |
#' @param event_offset (`logical`)\cr If `TRUE` then \eqn{G(T_i)} is evaluated at \eqn{G(T_i-)}. |
|
9 |
#' Setting this as `TRUE` mirrors the implementation of the `{pec}` package. |
|
10 |
#' @param maintain_cen_order (`logical`)\cr If `TRUE` then, in the case of ties, |
|
11 |
#' censor times are always considered |
|
12 |
#' to have occurred after the event times when calculating the "reverse Kaplan-Meier" for the |
|
13 |
#' IPCW estimates. Setting this to `TRUE` mirrors the implementation of the `{prodlim}` |
|
14 |
#' package. |
|
15 |
#' @param ... not used. |
|
16 |
#' |
|
17 |
#' @name Brier-Score-Shared |
|
18 |
#' @keywords internal |
|
19 |
NULL |
|
20 | ||
21 | ||
22 | ||
23 | ||
24 |
#' Reverse Kaplan-Meier |
|
25 |
#' |
|
26 |
#' @inheritParams Brier-Score-Shared |
|
27 |
#' @description |
|
28 |
#' Calculates the survival estimates of the censoring distribution |
|
29 |
#' using the Kaplan-Meier estimate. |
|
30 |
#' This is primarily used in the calculation of the IPCW estimates. |
|
31 |
#' |
|
32 |
#' @details |
|
33 |
#' With regards to ties between censor and event times; the standard |
|
34 |
#' approach is to regard events as occurring before censors. However, |
|
35 |
#' when modelling the censoring distribution we are regarding the |
|
36 |
#' censors as "events" so which should come first in the case of ties? |
|
37 |
#' |
|
38 |
#' The `reverse_km_event_first()` function maintains the rule |
|
39 |
#' that events always come first even if we are regarding the censors |
|
40 |
#' as "events". This matches the implementation of |
|
41 |
#' `prodlim::prodlim(..., reverse = TRUE)`. |
|
42 |
#' |
|
43 |
#' The `reverse_km_cen_first()` function provides the alternative |
|
44 |
#' implementation assuming that in the case of ties the censor "events" |
|
45 |
#' come before the event "censors". This is essentially a thin wrapper |
|
46 |
#' around `survival::survfit(Surv(time, 1 - event), ...)` |
|
47 |
#' |
|
48 |
#' @name reverse_km |
|
49 |
#' @keywords internal |
|
50 |
reverse_km_event_first <- function(t, times, events) { |
|
51 | 5x |
assert_numeric(t, any.missing = FALSE, finite = TRUE) |
52 | 5x |
assert_numeric(times, any.missing = FALSE, finite = TRUE) |
53 | 5x |
assert_numeric(events, any.missing = FALSE, finite = TRUE) |
54 | 5x |
assert_that( |
55 | 5x |
length(times) == length(events), |
56 | 5x |
all(events == 1 | events == 0) |
57 |
) |
|
58 | 5x |
events_cen <- 1 - events |
59 | 5x |
ord <- order(times, events_cen) |
60 | 5x |
times <- times[ord] |
61 | 5x |
events <- events[ord] |
62 | 5x |
events_cen <- events_cen[ord] |
63 | 5x |
cs_events <- cumsum(events) |
64 | 5x |
cs_censor <- cumsum(events_cen) |
65 | ||
66 | 5x |
g_times <- unique(times) |
67 | 5x |
g_n_events_cen <- tapply(events_cen, times, sum) |
68 | 5x |
g_cs_events_cen <- tapply(cs_censor, times, max) |
69 | 5x |
g_cs_events <- tapply(cs_events, times, max) |
70 | 5x |
g_is_cen <- tapply(events_cen, times, max) |
71 | ||
72 | 5x |
nrisk <- length(times) - g_cs_events - g_cs_events_cen + g_n_events_cen |
73 | 5x |
surv_interval <- 1 - g_n_events_cen / nrisk |
74 | 5x |
surv_interval <- ifelse(nrisk == 0, 1, surv_interval) |
75 | 5x |
surv <- cumprod(surv_interval) |
76 | ||
77 | 5x |
ct <- g_times[which(g_is_cen == 1)] |
78 | 5x |
sv <- surv[which(g_is_cen == 1)] |
79 | ||
80 | 5x |
names(surv) <- NULL |
81 | 5x |
names(ct) <- NULL |
82 | 5x |
names(sv) <- NULL |
83 | 5x |
list( |
84 | 5x |
t = t, |
85 | 5x |
surv = c(1, sv)[findInterval(t, ct) + 1] |
86 |
) |
|
87 |
} |
|
88 | ||
89 | ||
90 |
#' @rdname reverse_km |
|
91 |
reverse_km_cen_first <- function(t, times, events) { |
|
92 | 1x |
assert_numeric(t, any.missing = FALSE, finite = TRUE) |
93 | 1x |
assert_numeric(times, any.missing = FALSE, finite = TRUE) |
94 | 1x |
assert_numeric(events, any.missing = FALSE, finite = TRUE) |
95 | 1x |
assert_that( |
96 | 1x |
length(times) == length(events), |
97 | 1x |
all(events == 1 | events == 0) |
98 |
) |
|
99 | 1x |
dat <- data.frame( |
100 | 1x |
times = times, |
101 | 1x |
events = events, |
102 | 1x |
cen_events = 1 - events |
103 |
) |
|
104 | 1x |
mod <- survival::survfit( |
105 | 1x |
survival::Surv(times, cen_events) ~ 1, |
106 | 1x |
data = dat |
107 |
) |
|
108 | 1x |
preds <- summary(mod, times = t[order(t)], extend = TRUE)$surv |
109 | ||
110 | 1x |
assert_that( |
111 | 1x |
length(preds) == length(t) |
112 |
) |
|
113 | 1x |
list( |
114 | 1x |
t = t, |
115 | 1x |
surv = preds[match_order(t)] |
116 |
) |
|
117 |
} |
|
118 | ||
119 |
#' Match Order |
|
120 |
#' |
|
121 |
#' @param x (`numeric`)\cr a vector for which we want to generate an index so other |
|
122 |
#' vectors can be put into the same sort order |
|
123 |
#' |
|
124 |
#' Assuming we have a vector that is sorted then this function |
|
125 |
#' will return the index vector to convert that sorted vector |
|
126 |
#' into the same sort order as the input vector `x`. |
|
127 |
#' For example let `x = 8, 7, 9 , 7`. If sorted we would get |
|
128 |
#' `x_sort = 7, 7, 8, 9`. So in order to convert `x_sort` |
|
129 |
#' back into `x` we'd need an index vector of `3, 1, 4, 2`. |
|
130 |
#' This function is used to determine that corresponding |
|
131 |
#' index vector for an arbitrarily sorted vector `x`. |
|
132 |
#' |
|
133 |
#' There is no specific handling of ties. It is assuming that in the case |
|
134 |
#' of ties for `x` that the vector you are re-indexing also has tied values |
|
135 |
#' thus the specific tied element selection does not matter. |
|
136 |
#' @keywords internal |
|
137 |
match_order <- function(x) { |
|
138 | 2x |
order(order(x)) |
139 |
} |
|
140 | ||
141 | ||
142 |
#' Brier Score |
|
143 |
#' |
|
144 |
#' @inheritParams Brier-Score-Shared |
|
145 |
#' |
|
146 |
#' @description |
|
147 |
#' Implements the Brier Score as detailed in \insertCite{blanche2015}{jmpost} |
|
148 |
#' |
|
149 |
#' @details |
|
150 |
#' - `bs_get_squared_dist()` - implements the squared distance part |
|
151 |
#' of the formula. |
|
152 |
#' - `bs_get_weights()` - implements the IPCW weighting |
|
153 |
#' |
|
154 |
#' @references |
|
155 |
#' \insertAllCited{} |
|
156 |
#' |
|
157 |
#' @keywords internal |
|
158 |
brier_score <- function( |
|
159 |
t, |
|
160 |
times, |
|
161 |
events, |
|
162 |
pred_mat, |
|
163 |
maintain_cen_order = TRUE, |
|
164 |
event_offset = TRUE |
|
165 |
) { |
|
166 | ||
167 | 2x |
square_diff_mat <- bs_get_squared_dist( |
168 | 2x |
t = t, |
169 | 2x |
times = times, |
170 | 2x |
events = events, |
171 | 2x |
pred_mat = pred_mat |
172 |
) |
|
173 | ||
174 | 2x |
weight_mat <- bs_get_weights( |
175 | 2x |
t = t, |
176 | 2x |
times = times, |
177 | 2x |
events = events, |
178 | 2x |
event_offset = event_offset, |
179 | 2x |
maintain_cen_order = maintain_cen_order |
180 |
) |
|
181 | ||
182 |
# the following is a computational shortcut for diag(A %*% B) |
|
183 |
# as we don't want to compute the off-diagonal entries of the |
|
184 |
# matrix multiplication |
|
185 | 2x |
x <- colSums(weight_mat * square_diff_mat) |
186 | 2x |
names(x) <- t |
187 | 2x |
x / length(times) |
188 |
} |
|
189 | ||
190 | ||
191 |
#' @rdname brier_score |
|
192 |
bs_get_squared_dist <- function(t, times, events, pred_mat) { |
|
193 | ||
194 | 3x |
assert_numeric( |
195 | 3x |
times, |
196 | 3x |
finite = TRUE, |
197 | 3x |
any.missing = FALSE |
198 |
) |
|
199 | 3x |
assert_numeric( |
200 | 3x |
t, |
201 | 3x |
finite = TRUE, |
202 | 3x |
any.missing = FALSE |
203 |
) |
|
204 | 3x |
assert_numeric( |
205 | 3x |
events, |
206 | 3x |
finite = TRUE, |
207 | 3x |
any.missing = FALSE, |
208 | 3x |
lower = 0, |
209 | 3x |
upper = 1 |
210 |
) |
|
211 | 3x |
assert_matrix( |
212 | 3x |
pred_mat, |
213 | 3x |
any.missing = FALSE, |
214 | 3x |
nrows = length(times), |
215 | 3x |
ncols = length(t) |
216 |
) |
|
217 | 3x |
assert_that( |
218 | 3x |
length(events) == length(times) |
219 |
) |
|
220 | ||
221 | ||
222 | 3x |
expected_mat <- mapply( |
223 | 3x |
\(ti, event) (ti <= t) * event * 1, |
224 | 3x |
ti = times, |
225 | 3x |
event = events, |
226 | 3x |
SIMPLIFY = FALSE |
227 |
) |> |
|
228 | 3x |
unlist() |> |
229 | 3x |
matrix(ncol = length(t), byrow = TRUE) |
230 | ||
231 | 3x |
assert_that( |
232 | 3x |
nrow(pred_mat) == nrow(expected_mat), |
233 | 3x |
ncol(pred_mat) == ncol(expected_mat) |
234 |
) |
|
235 | ||
236 | 3x |
(expected_mat - pred_mat)^2 |
237 |
} |
|
238 | ||
239 | ||
240 |
#' @rdname brier_score |
|
241 |
bs_get_weights <- function( |
|
242 |
t, |
|
243 |
times, |
|
244 |
events, |
|
245 |
event_offset = TRUE, |
|
246 |
maintain_cen_order = TRUE |
|
247 |
) { |
|
248 | 3x |
assert_numeric( |
249 | 3x |
times, |
250 | 3x |
finite = TRUE, |
251 | 3x |
any.missing = FALSE |
252 |
) |
|
253 | 3x |
assert_numeric( |
254 | 3x |
t, |
255 | 3x |
finite = TRUE, |
256 | 3x |
any.missing = FALSE |
257 |
) |
|
258 | 3x |
assert_numeric( |
259 | 3x |
events, |
260 | 3x |
finite = TRUE, |
261 | 3x |
any.missing = FALSE, |
262 | 3x |
lower = 0, |
263 | 3x |
upper = 1 |
264 |
) |
|
265 | 3x |
assert_flag(event_offset, na.ok = FALSE, null.ok = FALSE) |
266 | 3x |
assert_flag(maintain_cen_order, na.ok = FALSE, null.ok = FALSE) |
267 | 3x |
n_col <- length(t) |
268 | 3x |
n_row <- length(times) |
269 | ||
270 | 3x |
reverse_km <- if (maintain_cen_order) reverse_km_event_first else reverse_km_cen_first |
271 | 3x |
offset <- if (event_offset) -.Machine$double.eps^(1 / 2) else 0 |
272 | ||
273 | 3x |
censor_dist_t <- reverse_km(t, times, events) |
274 | 3x |
weight_mat_t <- 1 / matrix( |
275 | 3x |
rep(censor_dist_t$surv, n_row), |
276 | 3x |
nrow = n_row, |
277 | 3x |
byrow = TRUE |
278 |
) |
|
279 | ||
280 | 3x |
censor_dist_ti <- reverse_km(times + offset, times, events) |
281 | 3x |
weight_mat_ti <- 1 / matrix( |
282 | 3x |
rep(censor_dist_ti$surv, n_col), |
283 | 3x |
nrow = n_row |
284 |
) |
|
285 | ||
286 | 3x |
indicator_mat_t <- mapply( |
287 | 3x |
\(ti) (ti > t) * 1, |
288 | 3x |
ti = times, |
289 | 3x |
SIMPLIFY = FALSE |
290 |
) |> |
|
291 | 3x |
unlist() |> |
292 | 3x |
matrix(ncol = n_col, byrow = TRUE) |
293 | ||
294 | 3x |
indicator_mat_ti <- mapply( |
295 | 3x |
\(ti, event) (ti <= t) * event * 1, |
296 | 3x |
ti = times, |
297 | 3x |
event = events, |
298 | 3x |
SIMPLIFY = FALSE |
299 |
) |> |
|
300 | 3x |
unlist() |> |
301 | 3x |
matrix(ncol = n_col, byrow = TRUE) |
302 | ||
303 | 3x |
assert_that( |
304 | 3x |
all(indicator_mat_t + indicator_mat_ti <= 1) |
305 |
) |
|
306 | ||
307 | 3x |
weight_mat_t[indicator_mat_t == 0] <- 0 |
308 | 3x |
weight_mat_ti[indicator_mat_ti == 0] <- 0 |
309 | ||
310 | 3x |
(weight_mat_t + weight_mat_ti) |
311 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include StanModule.R |
|
3 |
NULL |
|
4 | ||
5 |
#' `Prior` Function Arguments |
|
6 |
#' |
|
7 |
#' The documentation lists all the conventional arguments for [`Prior`] |
|
8 |
#' constructors. |
|
9 |
#' |
|
10 |
#' @param centre (`number`)\cr the central point of distribution to shrink sampled values towards |
|
11 |
#' (for most distributions this is the mean or median if the mean is undefined) |
|
12 |
#' @param x ([`Prior`])\cr a prior Distribution |
|
13 |
#' @param object ([`Prior`])\cr a prior Distribution |
|
14 |
#' @param name (`character`)\cr the name of the parameter the prior distribution is for |
|
15 |
#' @param ... Not Used. |
|
16 |
#' |
|
17 |
#' @name Prior-Shared |
|
18 |
#' @keywords internal |
|
19 |
NULL |
|
20 | ||
21 |
# Prior-class ---- |
|
22 | ||
23 |
#' Prior Object and Constructor Function |
|
24 |
#' |
|
25 |
#' Specifies the prior distribution in a Stan Model |
|
26 |
#' |
|
27 |
#' @slot parameters (`list`)\cr See arguments. |
|
28 |
#' @slot repr_model (`string`)\cr See arguments. |
|
29 |
#' @slot repr_data (`string`)\cr See arguments. |
|
30 |
#' @slot centre (`numeric`)\cr See arguments. |
|
31 |
#' @slot validation (`list`)\cr See arguments. |
|
32 |
#' @slot display (`string`)\cr See arguments. |
|
33 |
#' @slot sample (`function`)\cr See arguments. |
|
34 |
#' @slot limits (`numeric`)\cr See arguments. |
|
35 |
#' |
|
36 |
#' @family Prior-internal |
|
37 |
#' @export Prior |
|
38 |
#' @exportClass Prior |
|
39 |
.Prior <- setClass( |
|
40 |
Class = "Prior", |
|
41 |
slots = c( |
|
42 |
"parameters" = "list", |
|
43 |
"display" = "character", |
|
44 |
"repr_model" = "character", |
|
45 |
"repr_data" = "character", |
|
46 |
"centre" = "numeric", |
|
47 |
"validation" = "list", |
|
48 |
"sample" = "function", |
|
49 |
"limits" = "numeric" |
|
50 |
) |
|
51 |
) |
|
52 | ||
53 | ||
54 |
#' @param parameters (`list`)\cr the prior distribution parameters. |
|
55 |
#' @param repr_model (`string`)\cr the Stan code representation for the model block. |
|
56 |
#' @param repr_data (`string`)\cr the Stan code representation for the data block. |
|
57 |
#' @param display (`string`)\cr the string to display when object is printed. |
|
58 |
#' @param centre (`numeric`)\cr the central point of distribution to shrink sampled values towards |
|
59 |
#' @param validation (`list`)\cr the prior distribution parameter validation functions. Must have |
|
60 |
#' the same names as the `paramaters` slot. |
|
61 |
#' @param sample (`function`)\cr a function to sample from the prior distribution. |
|
62 |
#' @param limits (`numeric`)\cr the lower and upper limits for a truncated distribution |
|
63 |
#' @rdname Prior-class |
|
64 |
Prior <- function( |
|
65 |
parameters, |
|
66 |
display, |
|
67 |
repr_model, |
|
68 |
repr_data, |
|
69 |
centre, |
|
70 |
validation, |
|
71 |
sample, |
|
72 |
limits = c(-Inf, Inf) |
|
73 |
) { |
|
74 | 1108x |
.Prior( |
75 | 1108x |
parameters = parameters, |
76 | 1108x |
repr_model = repr_model, |
77 | 1108x |
repr_data = repr_data, |
78 | 1108x |
centre = centre, |
79 | 1108x |
display = display, |
80 | 1108x |
validation = validation, |
81 | 1108x |
sample = sample, |
82 | 1108x |
limits = limits |
83 |
) |
|
84 |
} |
|
85 | ||
86 | ||
87 |
setValidity( |
|
88 |
Class = "Prior", |
|
89 |
method = function(object) { |
|
90 |
for (param in names(object@parameters)) { |
|
91 |
if (!param %in% names(object@validation)) { |
|
92 |
return(sprintf("Parameter `%s` does not have a validation method", param)) |
|
93 |
} |
|
94 |
if (!object@validation[[param]](object@parameters[[param]])) { |
|
95 |
return_message <- sprintf( |
|
96 |
"Invalid value of `%d` for parameter `%s`", |
|
97 |
object@parameters[[param]], |
|
98 |
param |
|
99 |
) |
|
100 |
return(return_message) |
|
101 |
} |
|
102 |
} |
|
103 |
return(TRUE) |
|
104 |
} |
|
105 |
) |
|
106 | ||
107 | ||
108 | ||
109 |
#' @rdname set_limits |
|
110 |
#' @export |
|
111 |
set_limits.Prior <- function(object, lower = -Inf, upper = Inf) { |
|
112 | 370x |
object@limits <- c(lower, upper) |
113 | 370x |
return(object) |
114 |
} |
|
115 | ||
116 | ||
117 |
#' `Prior` -> `Character` |
|
118 |
#' |
|
119 |
#' Converts a [`Prior`] object to a character vector |
|
120 |
#' @inheritParams Prior-Shared |
|
121 |
#' @family Prior-internal |
|
122 |
#' @export |
|
123 |
as.character.Prior <- function(x, ...) { |
|
124 | ||
125 | 70x |
parameters_rounded <- lapply(x@parameters, round, 5) |
126 | ||
127 | 70x |
do.call( |
128 | 70x |
glue::glue, |
129 | 70x |
append(x@display, parameters_rounded) |
130 |
) |
|
131 |
} |
|
132 | ||
133 | ||
134 |
#' @rdname show-object |
|
135 |
#' @export |
|
136 |
setMethod( |
|
137 |
f = "show", |
|
138 |
signature = "Prior", |
|
139 |
definition = function(object) { |
|
140 | 1x |
x <- sprintf("\nPrior Object:\n %s\n\n", as.character(object)) |
141 | 1x |
cat(x) |
142 | 1x |
return(object) |
143 |
} |
|
144 |
) |
|
145 | ||
146 | ||
147 |
#' `Prior` -> `StanModule` |
|
148 |
#' |
|
149 |
#' Converts a [`Prior`] object to a [`StanModule`] object |
|
150 |
#' |
|
151 |
#' @inheritParams Prior-Shared |
|
152 |
#' |
|
153 |
#' @family Prior-internal |
|
154 |
#' @family as.StanModule |
|
155 |
#' @export |
|
156 |
as.StanModule.Prior <- function(object, name, ...) { |
|
157 | 889x |
string <- paste( |
158 | 889x |
"data {{", |
159 | 889x |
paste0(" ", object@repr_data, collapse = "\n"), |
160 |
"}}", |
|
161 | 889x |
"model {{", |
162 | 889x |
paste0(" ", object@repr_model, collapse = "\n"), |
163 |
"}}", |
|
164 | 889x |
sep = "\n" |
165 |
) |
|
166 | 889x |
StanModule(glue::glue(string, name = name)) |
167 |
} |
|
168 | ||
169 | ||
170 |
#' `Prior` -> `list` |
|
171 |
#' |
|
172 |
#' Converts a Prior object to a list of parameter data values |
|
173 |
#' for a Stan model. |
|
174 |
#' |
|
175 |
#' @inheritParams Prior-Shared |
|
176 |
#' |
|
177 |
#' @family as_stan_list |
|
178 |
#' @family Prior-internal |
|
179 |
#' @export |
|
180 |
as_stan_list.Prior <- function(object, name, ...) { |
|
181 | 376x |
vals <- object@parameters |
182 | 376x |
vals_names <- names(vals) |
183 | 376x |
if (length(vals_names) >= 1) { |
184 | 309x |
names(vals) <- paste0("prior_", vals_names, "_", name) |
185 |
} |
|
186 | 376x |
return(vals) |
187 |
} |
|
188 | ||
189 | ||
190 | ||
191 |
#' Prior Getter Functions |
|
192 |
#' @description |
|
193 |
#' Getter functions for the slots of a [`Prior`] object |
|
194 |
#' @inheritParams Prior-Shared |
|
195 |
#' @family Prior-internal |
|
196 |
#' @name Prior-Getter-Methods |
|
197 |
NULL |
|
198 | ||
199 | ||
200 | ||
201 |
# initialValues-Prior ---- |
|
202 | ||
203 |
#' @describeIn Prior-Getter-Methods The prior's initial value |
|
204 |
#' @export |
|
205 |
initialValues.Prior <- function(object, ...) { |
|
206 | 70552x |
samples <- getOption("jmpost.prior_shrinkage") * object@centre + |
207 | 70552x |
(1 - getOption("jmpost.prior_shrinkage")) * object@sample(100) |
208 | ||
209 | 70552x |
valid_samples <- samples[samples >= min(object@limits) & samples <= max(object@limits)] |
210 | 70552x |
assert_that( |
211 | 70552x |
length(valid_samples) >= 1, |
212 | 70552x |
msg = "Unable to generate an initial value that meets the required constraints" |
213 |
) |
|
214 | 70535x |
if (length(valid_samples) == 1) { |
215 | 26x |
return(valid_samples) |
216 |
} |
|
217 | 70509x |
return(sample(valid_samples, 1)) |
218 |
} |
|
219 | ||
220 | ||
221 |
# Prior-constructors ---- |
|
222 | ||
223 |
#' Normal Prior Distribution |
|
224 |
#' |
|
225 |
#' @param mu (`number`)\cr mean. |
|
226 |
#' @param sigma (`number`)\cr standard deviation. |
|
227 |
#' @family Prior |
|
228 |
#' @export |
|
229 |
prior_normal <- function(mu, sigma) { |
|
230 | 427x |
Prior( |
231 | 427x |
parameters = list(mu = mu, sigma = sigma), |
232 | 427x |
display = "normal(mu = {mu}, sigma = {sigma})", |
233 | 427x |
repr_model = "{name} ~ normal(prior_mu_{name}, prior_sigma_{name});", |
234 | 427x |
repr_data = c( |
235 | 427x |
"real prior_mu_{name};", |
236 | 427x |
"real<lower=0> prior_sigma_{name};" |
237 |
), |
|
238 | 427x |
centre = mu, |
239 | 427x |
sample = \(n) local_rnorm(n, mu, sigma), |
240 | 427x |
validation = list( |
241 | 427x |
mu = is.numeric, |
242 | 427x |
sigma = \(x) x > 0 |
243 |
) |
|
244 |
) |
|
245 |
} |
|
246 | ||
247 | ||
248 |
#' Standard Normal Prior Distribution |
|
249 |
#' |
|
250 |
#' |
|
251 |
#' @family Prior |
|
252 |
#' @export |
|
253 |
prior_std_normal <- function() { |
|
254 | 185x |
Prior( |
255 | 185x |
parameters = list(), |
256 | 185x |
display = "std_normal()", |
257 | 185x |
repr_model = "{name} ~ std_normal();", |
258 | 185x |
repr_data = "", |
259 | 185x |
centre = 0, |
260 | 185x |
sample = \(n) local_rnorm(n), |
261 | 185x |
validation = list() |
262 |
) |
|
263 |
} |
|
264 | ||
265 |
#' Cauchy Prior Distribution |
|
266 |
#' |
|
267 |
#' @param mu (`number`)\cr mean. |
|
268 |
#' @param sigma (`number`)\cr scale. |
|
269 |
#' @family Prior |
|
270 |
#' |
|
271 |
#' @export |
|
272 |
prior_cauchy <- function(mu, sigma) { |
|
273 | 5x |
Prior( |
274 | 5x |
parameters = list(mu = mu, sigma = sigma), |
275 | 5x |
display = "cauchy(mu = {mu}, sigma = {sigma})", |
276 | 5x |
repr_model = "{name} ~ cauchy(prior_mu_{name}, prior_sigma_{name});", |
277 | 5x |
repr_data = c( |
278 | 5x |
"real prior_mu_{name};", |
279 | 5x |
"real<lower=0> prior_sigma_{name};" |
280 |
), |
|
281 | 5x |
centre = mu, |
282 | 5x |
sample = \(n) local_rcauchy(n, mu, sigma), |
283 | 5x |
validation = list( |
284 | 5x |
mu = is.numeric, |
285 | 5x |
sigma = \(x) x > 0 |
286 |
) |
|
287 |
) |
|
288 |
} |
|
289 | ||
290 | ||
291 |
#' Gamma Prior Distribution |
|
292 |
#' |
|
293 |
#' @param alpha (`number`)\cr shape. |
|
294 |
#' @param beta (`number`)\cr inverse scale. |
|
295 |
#' @family Prior |
|
296 |
#' |
|
297 |
#' @export |
|
298 |
prior_gamma <- function(alpha, beta) { |
|
299 | 57x |
Prior( |
300 | 57x |
parameters = list(alpha = alpha, beta = beta), |
301 | 57x |
repr_model = "{name} ~ gamma(prior_alpha_{name}, prior_beta_{name});", |
302 | 57x |
display = "gamma(alpha = {alpha}, beta = {beta})", |
303 | 57x |
repr_data = c( |
304 | 57x |
"real<lower=0> prior_alpha_{name};", |
305 | 57x |
"real<lower=0> prior_beta_{name};" |
306 |
), |
|
307 | 57x |
centre = alpha / beta, |
308 | 57x |
sample = \(n) local_rgamma(n, shape = alpha, rate = beta), |
309 | 57x |
validation = list( |
310 | 57x |
alpha = \(x) x > 0, |
311 | 57x |
beta = \(x) x > 0 |
312 |
) |
|
313 |
) |
|
314 |
} |
|
315 | ||
316 |
#' Log-Normal Prior Distribution |
|
317 |
#' |
|
318 |
#' @param mu (`number`)\cr mean of the logarithm. |
|
319 |
#' @param sigma (`number`)\cr standard deviation of the logarithm. |
|
320 |
#' @family Prior |
|
321 |
#' |
|
322 |
#' @export |
|
323 |
prior_lognormal <- function(mu, sigma) { |
|
324 | 351x |
Prior( |
325 | 351x |
parameters = list(mu = mu, sigma = sigma), |
326 | 351x |
display = "lognormal(mu = {mu}, sigma = {sigma})", |
327 | 351x |
repr_model = "{name} ~ lognormal(prior_mu_{name}, prior_sigma_{name});", |
328 | 351x |
repr_data = c( |
329 | 351x |
"real prior_mu_{name};", |
330 | 351x |
"real<lower=0> prior_sigma_{name};" |
331 |
), |
|
332 | 351x |
centre = exp(mu + (sigma^2) / 2), |
333 | 351x |
sample = \(n) local_rlnorm(n, mu, sigma), |
334 | 351x |
validation = list( |
335 | 351x |
mu = is.numeric, |
336 | 351x |
sigma = \(x) x > 0 |
337 |
) |
|
338 |
) |
|
339 |
} |
|
340 | ||
341 |
#' Beta Prior Distribution |
|
342 |
#' |
|
343 |
#' @param a (`number`)\cr first parameter. |
|
344 |
#' @param b (`number`)\cr second parameter |
|
345 |
#' @family Prior |
|
346 |
#' |
|
347 |
#' @export |
|
348 |
prior_beta <- function(a, b) { |
|
349 | 5x |
Prior( |
350 | 5x |
parameters = list(a = a, b = b), |
351 | 5x |
display = "beta(a = {a}, b = {b})", |
352 | 5x |
repr_model = "{name} ~ beta(prior_a_{name}, prior_b_{name});", |
353 | 5x |
repr_data = c( |
354 | 5x |
"real<lower=0> prior_a_{name};", |
355 | 5x |
"real<lower=0> prior_b_{name};" |
356 |
), |
|
357 | 5x |
centre = a / (a + b), |
358 | 5x |
sample = \(n) local_rbeta(n, a, b), |
359 | 5x |
validation = list( |
360 | 5x |
a = \(x) x > 0, |
361 | 5x |
b = \(x) x > 0 |
362 |
) |
|
363 |
) |
|
364 |
} |
|
365 | ||
366 |
#' Initial Values Specification |
|
367 |
#' |
|
368 |
#' @param dist (`Prior`)\cr a prior Distribution |
|
369 |
#' @family Prior |
|
370 |
#' @description |
|
371 |
#' This function is used to specify only the initial values for a parameter. |
|
372 |
#' This is primarily used for hierarchical parameters whose distributions |
|
373 |
#' are fixed within the model and cannot be altered by the user. |
|
374 |
#' |
|
375 |
#' @export |
|
376 |
prior_init_only <- function(dist) { |
|
377 | 63x |
Prior( |
378 | 63x |
parameters = list(), |
379 | 63x |
display = "<None>", |
380 | 63x |
repr_model = "", |
381 | 63x |
repr_data = "", |
382 | 63x |
sample = \(n) { |
383 | 632x |
dist@sample(n) |
384 |
}, |
|
385 | 63x |
centre = dist@centre, |
386 | 63x |
validation = list() |
387 |
) |
|
388 |
} |
|
389 | ||
390 | ||
391 | ||
392 | ||
393 |
#' Uniform Prior Distribution |
|
394 |
#' |
|
395 |
#' @param alpha (`number`)\cr minimum value parameter. |
|
396 |
#' @param beta (`number`)\cr maximum value parameter. |
|
397 |
#' @family Prior |
|
398 |
#' |
|
399 |
#' @export |
|
400 |
prior_uniform <- function(alpha, beta) { |
|
401 | 5x |
assert_that( |
402 | 5x |
alpha < beta, |
403 | 5x |
msg = "`alpha`` must be less than `beta`" |
404 |
) |
|
405 | 4x |
Prior( |
406 | 4x |
parameters = list(alpha = alpha, beta = beta), |
407 | 4x |
display = "uniform(alpha = {alpha}, beta = {beta})", |
408 | 4x |
repr_model = "{name} ~ uniform(prior_alpha_{name}, prior_beta_{name});", |
409 | 4x |
repr_data = c( |
410 | 4x |
"real prior_alpha_{name};", |
411 | 4x |
"real prior_beta_{name};" |
412 |
), |
|
413 | 4x |
centre = 0.5 * (alpha + beta), |
414 | 4x |
sample = \(n) local_runif(n, alpha, beta), |
415 | 4x |
validation = list( |
416 | 4x |
alpha = is.numeric, |
417 | 4x |
beta = is.numeric |
418 |
) |
|
419 |
) |
|
420 |
} |
|
421 | ||
422 | ||
423 |
#' Student-t Prior Distribution |
|
424 |
#' |
|
425 |
#' @param nu (`number`)\cr Degrees of freedom parameter. |
|
426 |
#' @param mu (`number`)\cr Location parameter. |
|
427 |
#' @param sigma (`number`)\cr Scale parameter. |
|
428 |
#' @family Prior |
|
429 |
#' |
|
430 |
#' @export |
|
431 |
prior_student_t <- function(nu, mu, sigma) { |
|
432 | 3x |
Prior( |
433 | 3x |
parameters = list( |
434 | 3x |
nu = nu, |
435 | 3x |
mu = mu, |
436 | 3x |
sigma = sigma |
437 |
), |
|
438 | 3x |
display = "student_t(nu = {nu}, mu = {mu}, sigma = {sigma})", |
439 | 3x |
repr_model = "{name} ~ student_t(prior_nu_{name}, prior_mu_{name}, prior_sigma_{name});", |
440 | 3x |
repr_data = c( |
441 | 3x |
"real<lower=0> prior_nu_{name};", |
442 | 3x |
"real prior_mu_{name};", |
443 | 3x |
"real<lower=0> prior_sigma_{name};" |
444 |
), |
|
445 | 3x |
centre = mu, |
446 | 3x |
sample = \(n) local_rt(n, nu, mu, sigma), |
447 | 3x |
validation = list( |
448 | 3x |
nu = \(x) x > 0, |
449 | 3x |
mu = is.numeric, |
450 | 3x |
sigma = \(x) x > 0 |
451 |
) |
|
452 |
) |
|
453 |
} |
|
454 | ||
455 | ||
456 | ||
457 |
#' Logistic Prior Distribution |
|
458 |
#' |
|
459 |
#' @param mu (`number`)\cr Location parameter. |
|
460 |
#' @param sigma (`number`)\cr Scale parameter. |
|
461 |
#' @family Prior |
|
462 |
#' |
|
463 |
#' @export |
|
464 |
prior_logistic <- function(mu, sigma) { |
|
465 | 2x |
Prior( |
466 | 2x |
parameters = list( |
467 | 2x |
mu = mu, |
468 | 2x |
sigma = sigma |
469 |
), |
|
470 | 2x |
display = "logistic(mu = {mu}, sigma = {sigma})", |
471 | 2x |
repr_model = "{name} ~ logistic(prior_mu_{name}, prior_sigma_{name});", |
472 | 2x |
repr_data = c( |
473 | 2x |
"real prior_mu_{name};", |
474 | 2x |
"real<lower=0> prior_sigma_{name};" |
475 |
), |
|
476 | 2x |
centre = mu, |
477 | 2x |
sample = \(n) local_rlogis(n, mu, sigma), |
478 | 2x |
validation = list( |
479 | 2x |
mu = is.numeric, |
480 | 2x |
sigma = \(x) x > 0 |
481 |
) |
|
482 |
) |
|
483 |
} |
|
484 | ||
485 | ||
486 |
#' Log-Logistic Prior Distribution |
|
487 |
#' |
|
488 |
#' @param alpha (`number`)\cr Scale parameter. |
|
489 |
#' @param beta (`number`)\cr Shape parameter. |
|
490 |
#' @family Prior |
|
491 |
#' |
|
492 |
#' @export |
|
493 |
prior_loglogistic <- function(alpha, beta) { |
|
494 | 3x |
Prior( |
495 | 3x |
parameters = list( |
496 | 3x |
alpha = alpha, |
497 | 3x |
beta = beta |
498 |
), |
|
499 | 3x |
display = "loglogistic(alpha = {alpha}, beta = {beta})", |
500 | 3x |
repr_model = "{name} ~ loglogistic(prior_alpha_{name}, prior_beta_{name});", |
501 | 3x |
repr_data = c( |
502 | 3x |
"real<lower=0> prior_alpha_{name};", |
503 | 3x |
"real<lower=0> prior_beta_{name};" |
504 |
), |
|
505 | 3x |
centre = alpha * pi / (beta * sin(pi / beta)), |
506 | 3x |
sample = \(n) { |
507 | ! |
local_rloglogis(n, alpha, beta) |
508 |
}, |
|
509 | 3x |
validation = list( |
510 | 3x |
alpha = \(x) x > 0, |
511 | 3x |
beta = \(x) x > 0 |
512 |
) |
|
513 |
) |
|
514 |
} |
|
515 | ||
516 | ||
517 |
#' Inverse-Gamma Prior Distribution |
|
518 |
#' |
|
519 |
#' @param alpha (`number`)\cr Shape parameter. |
|
520 |
#' @param beta (`number`)\cr Scale parameter. |
|
521 |
#' @family Prior |
|
522 |
#' |
|
523 |
#' @export |
|
524 |
prior_invgamma <- function(alpha, beta) { |
|
525 | 3x |
Prior( |
526 | 3x |
parameters = list( |
527 | 3x |
alpha = alpha, |
528 | 3x |
beta = beta |
529 |
), |
|
530 | 3x |
display = "inv_gamma(alpha = {alpha}, beta = {beta})", |
531 | 3x |
repr_model = "{name} ~ inv_gamma(prior_alpha_{name}, prior_beta_{name});", |
532 | 3x |
repr_data = c( |
533 | 3x |
"real<lower=0> prior_alpha_{name};", |
534 | 3x |
"real<lower=0> prior_beta_{name};" |
535 |
), |
|
536 | 3x |
centre = beta / (alpha - 1), |
537 | 3x |
sample = \(n) local_rinvgamma(n, alpha, beta), |
538 | 3x |
validation = list( |
539 | 3x |
alpha = \(x) x > 0, |
540 | 3x |
beta = \(x) x > 0 |
541 |
) |
|
542 |
) |
|
543 |
} |
|
544 | ||
545 | ||
546 |
# nolint start |
|
547 |
# |
|
548 |
# Developer Notes |
|
549 |
# |
|
550 |
# The `median.Prior` function is a rough workaround to help generate initial values for |
|
551 |
# hierarchical distributions. The original implementation involved sampling initial values |
|
552 |
# for the random effects using the medians of the parent distribution e.g. |
|
553 |
# ``` |
|
554 |
# random_effect ~ beta(a_prior@centre, b_prior@centre) |
|
555 |
# ``` |
|
556 |
# A problem came up though when we implemented support for constrained distributions |
|
557 |
# as there was no longer any guarantee that the median/centre of the distribution is |
|
558 |
# a valid value e.g. `a_prior ~ prior_normal(-200, 400)`. |
|
559 |
# |
|
560 |
# To resolve this issue the `median.Prior` method was created which simply samples |
|
561 |
# multiple observations from the constrained distribution and then takes the median |
|
562 |
# of those constrained observations; this then ensures that the value being used |
|
563 |
# for the parameters is a valid value |
|
564 |
# |
|
565 |
# nolint end |
|
566 |
#' @importFrom stats median |
|
567 |
#' @export |
|
568 |
median.Prior <- function(x, na.rm, ...) { |
|
569 | 122x |
vals <- replicate( |
570 | 122x |
n = 500, |
571 | 122x |
initialValues(x), |
572 | 122x |
simplify = FALSE |
573 |
) |> |
|
574 | 122x |
unlist() |
575 | 121x |
median(vals) |
576 |
} |
|
577 | ||
578 | ||
579 | ||
580 | ||
581 |
#' Stub functions for sampling from distributions |
|
582 |
#' |
|
583 |
#' @description |
|
584 |
#' These functions only exist so that they can be mocked during unit |
|
585 |
#' tests in order to provide deterministic values. In most cases |
|
586 |
#' these are just straight forward pass throughs for the underlying |
|
587 |
#' distributions. |
|
588 |
#' |
|
589 |
#' @param alpha (`number`)\cr Parameter for underlying distribution. |
|
590 |
#' @param beta (`number`)\cr Parameter for underlying distribution. |
|
591 |
#' @param mu (`number`)\cr Parameter for underlying distribution. |
|
592 |
#' @param sigma (`number`)\cr Parameter for underlying distribution. |
|
593 |
#' @param nu (`number`)\cr Parameter for underlying distribution. |
|
594 |
#' @param ... Pass any additional arguments to the underlying distribution. |
|
595 |
#' |
|
596 |
#' @importFrom stats rbeta rcauchy rgamma rlnorm rlogis rnorm rt runif |
|
597 |
#' |
|
598 |
#' @details |
|
599 |
#' |
|
600 |
#' ## Log-Logistic |
|
601 |
#' |
|
602 |
#' There is no log-logistic sampling function within base R so it was implemented |
|
603 |
#' in terms of sampling from the CDF distribution. Using the Stan parameterisation |
|
604 |
#' the CDF is defined as: |
|
605 |
#' \deqn{ |
|
606 |
#' u = F(x) = \frac{1}{1 + (x/ \alpha)^{-\beta}} |
|
607 |
#' } |
|
608 |
#' The inverse of this function is: |
|
609 |
#' \deqn{ |
|
610 |
#' x = ((u / (1 - u))^(1 / beta)) * alpha |
|
611 |
#' } |
|
612 |
#' |
|
613 |
#' Thus we can sample u from a \eqn{Uni(0, 1)} distribution and then derive x from this. |
|
614 |
#' |
|
615 |
#' ## Inverse-Gamma |
|
616 |
#' |
|
617 |
#' The inverse Gamma distribution is defined as 1/Gamma thus we calculate this simply |
|
618 |
#' by sampling sampling from the Gamma distribution and then taking the reciprocal. |
|
619 |
#' |
|
620 |
#' ## Student-t |
|
621 |
#' |
|
622 |
#' R's sampling functions only produce the standard Student-t distribution so in order |
|
623 |
#' to match Stan's implementation we multiply by the scale parameter and add the location |
|
624 |
#' parameter. See this \href{https://stats.stackexchange.com/a/623611}{Stack Overflow} post |
|
625 |
#' for details |
|
626 |
#' |
|
627 |
#' @name Local_Sample |
|
628 |
#' @keywords internal |
|
629 |
NULL |
|
630 | ||
631 |
#' @rdname Local_Sample |
|
632 | 38297x |
local_rnorm <- \(...) rnorm(...) |
633 | ||
634 |
#' @rdname Local_Sample |
|
635 | 700x |
local_rcauchy <- \(...) rcauchy(...) |
636 | ||
637 |
#' @rdname Local_Sample |
|
638 | 604x |
local_rgamma <- \(...) rgamma(...) |
639 | ||
640 |
#' @rdname Local_Sample |
|
641 | 30323x |
local_rlnorm <- \(...) rlnorm(...) |
642 | ||
643 |
#' @rdname Local_Sample |
|
644 | 2x |
local_rbeta <- \(...) rbeta(...) |
645 | ||
646 |
#' @rdname Local_Sample |
|
647 | 600x |
local_runif <- \(...) runif(...) |
648 | ||
649 |
#' @rdname Local_Sample |
|
650 |
local_rt <- \(n, nu, mu, sigma) { |
|
651 | ! |
rt(n, nu) * sigma + mu |
652 |
} |
|
653 | ||
654 |
#' @rdname Local_Sample |
|
655 | ! |
local_rlogis <- \(...) rlogis(...) |
656 | ||
657 |
#' @rdname Local_Sample |
|
658 |
local_rloglogis <- \(n, alpha, beta) { |
|
659 | ! |
r <- runif(n) |
660 | ! |
((r / (1 - r))^(1 / beta)) * alpha |
661 |
} |
|
662 | ||
663 |
#' @rdname Local_Sample |
|
664 |
local_rinvgamma <- \(n, alpha, beta) { |
|
665 | ! |
1 / rgamma(n, alpha, rate = beta) |
666 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include Grid.R |
|
3 |
NULL |
|
4 | ||
5 |
#' @rdname Quant-Dev |
|
6 |
.QuantityGeneratorPopulation <- setClass( |
|
7 |
"QuantityGeneratorPopulation", |
|
8 |
contains = "QuantityGenerator", |
|
9 |
slots = c( |
|
10 |
"times" = "numeric", |
|
11 |
"studies" = "character_or_NULL", |
|
12 |
"arms" = "character_or_NULL" |
|
13 |
) |
|
14 |
) |
|
15 | ||
16 | ||
17 |
#' @rdname Quant-Dev |
|
18 |
QuantityGeneratorPopulation <- function(times, studies = NULL, arms = NULL) { |
|
19 | 8x |
.QuantityGeneratorPopulation( |
20 | 8x |
times = times, |
21 | 8x |
studies = studies, |
22 | 8x |
arms = arms |
23 |
) |
|
24 |
} |
|
25 | ||
26 | ||
27 |
setValidity( |
|
28 |
"QuantityGeneratorPopulation", |
|
29 |
function(object) { |
|
30 |
if (length(object@times) != length(object@arms)) { |
|
31 |
return("Length of `times` and `arms` must be equal") |
|
32 |
} |
|
33 |
if (length(object@times) != length(object@studies)) { |
|
34 |
return("Length of `times` and `studies` must be equal") |
|
35 |
} |
|
36 |
return(TRUE) |
|
37 |
} |
|
38 |
) |
|
39 | ||
40 | ||
41 |
#' @rdname as_stan_list.QuantityGenerator |
|
42 |
#' @export |
|
43 |
as_stan_list.QuantityGeneratorPopulation <- function(object, data, ...) { |
|
44 | 2x |
assert_that( |
45 | 2x |
is(data, "DataJoint") |
46 |
) |
|
47 | 2x |
ret <- list() |
48 | 2x |
data_list <- as.list(data) |
49 | 2x |
ret[["gq_times"]] <- object@times |
50 | 2x |
ret[["gq_n_quant"]] <- length(object@arms) |
51 | 2x |
ret[["gq_long_pop_arm_index"]] <- data_list$arm_to_index[object@arms] |
52 | 2x |
ret[["gq_long_pop_study_index"]] <- data_list$study_to_index[object@studies] |
53 | ||
54 |
# Sanity checks |
|
55 | 2x |
assert_that( |
56 | 2x |
length(ret[["gq_long_pop_arm_index"]]) == length(ret[["gq_long_pop_study_index"]]), |
57 | 2x |
length(ret[["gq_long_pop_study_index"]]) == length(ret[["gq_times"]]), |
58 | 2x |
length(ret[["gq_long_pop_study_index"]]) == ret[["gq_n_quant"]], |
59 | 2x |
all(!is.na(ret[["gq_long_pop_arm_index"]])), |
60 | 2x |
all(!is.na(ret[["gq_long_pop_study_index"]])) |
61 |
) |
|
62 | 2x |
return(ret) |
63 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include Link.R |
|
3 |
#' @include LongitudinalModel.R |
|
4 |
#' @include SurvivalModel.R |
|
5 |
#' @include StanModule.R |
|
6 |
#' @include StanModel.R |
|
7 |
#' @include Parameter.R |
|
8 |
NULL |
|
9 | ||
10 | ||
11 | ||
12 |
#' @rdname getParameters |
|
13 |
#' @export |
|
14 |
getParameters.default <- function(object, ...) { |
|
15 | 18x |
if (missing(object) || is.null(object)) { |
16 | 18x |
return(NULL) |
17 |
} |
|
18 | ! |
stop(sprintf("No default method implemented for getParameters(<%s>)", typeof(object))) |
19 |
} |
|
20 | ||
21 | ||
22 |
# merge ---- |
|
23 | ||
24 |
## merge-StanModel,NULL ---- |
|
25 | ||
26 |
#' @rdname merge |
|
27 |
setMethod( |
|
28 |
"merge", |
|
29 |
signature = c("StanModel", "NULL"), |
|
30 | ! |
definition = function(x, y, ...) x@stan |
31 |
) |
|
32 | ||
33 |
## merge-NULL,StanModel ---- |
|
34 | ||
35 |
#' @rdname merge |
|
36 |
setMethod( |
|
37 |
"merge", |
|
38 |
signature = c("NULL", "StanModel"), |
|
39 | ! |
definition = function(x, y, ...) y@stan |
40 |
) |
|
41 | ||
42 |
## merge-StanModule,NULL ---- |
|
43 | ||
44 |
#' @rdname merge |
|
45 |
setMethod( |
|
46 |
"merge", |
|
47 |
signature = c("StanModule", "NULL"), |
|
48 | ! |
definition = function(x, y, ...) x |
49 |
) |
|
50 | ||
51 |
## merge-NULL,StanModule ---- |
|
52 | ||
53 |
#' @rdname merge |
|
54 |
setMethod( |
|
55 |
"merge", |
|
56 |
signature = c("NULL", "StanModule"), |
|
57 | ! |
definition = function(x, y, ...) y |
58 |
) |
|
59 | ||
60 |
## merge-ParameterList,NULL ---- |
|
61 | ||
62 |
#' @rdname merge |
|
63 |
setMethod( |
|
64 |
"merge", |
|
65 |
signature = c("ParameterList", "NULL"), |
|
66 | 41x |
definition = function(x, y, ...) x |
67 |
) |
|
68 | ||
69 |
## merge-NULL,ParameterList ---- |
|
70 | ||
71 |
#' @rdname merge |
|
72 |
setMethod( |
|
73 |
"merge", |
|
74 |
signature = c("NULL", "ParameterList"), |
|
75 | 6x |
definition = function(x, y, ...) y |
76 |
) |
|
77 | ||
78 |
## merge-NULL,NULL ---- |
|
79 | ||
80 |
#' @rdname merge |
|
81 |
setMethod( |
|
82 |
"merge", |
|
83 |
signature = c("NULL", "NULL"), |
|
84 | ! |
definition = function(x, y, ...) NULL |
85 |
) |
1 |
#' Simulating Joint Longitudinal and Time-to-Event Data |
|
2 |
#' |
|
3 |
#' @param design (`list`)\cr a list of [`SimGroup`] objects. See details. |
|
4 |
#' @param longitudinal ([`SimLongitudinal`])\cr object specifying how to simulate the longitudinal data |
|
5 |
#' @param survival ([`SimSurvival`])\cr object specifying how to simulate the survival data |
|
6 |
#' @param .silent (`flag`)\cr whether to suppress info messages |
|
7 |
#' |
|
8 |
#' @slot longitudinal (`data.frame`)\cr the simulated longitudinal data. |
|
9 |
#' @slot survival (`data.frame`)\cr the simulated survival data. |
|
10 |
#' |
|
11 |
#' @details |
|
12 |
#' |
|
13 |
#' The `design` argument is used to specify how many distinct groups should be simulated |
|
14 |
#' including key information such as the number of subjects within the group as well as |
|
15 |
#' which treatment arm and study the group belongs to. The `design` argument should be a |
|
16 |
#' list of [`SimGroup`] objects e.g. |
|
17 |
#' ``` |
|
18 |
#' design = list( |
|
19 |
#' SimGroup(n = 50, study = "Study-1", arm = "Arm-A"), |
|
20 |
#' SimGroup(n = 50, study = "Study-1", arm = "Arm-B") |
|
21 |
#' ) |
|
22 |
#' ``` |
|
23 |
#' |
|
24 |
#' @name SimJointData-class |
|
25 |
#' @exportClass SimJointData |
|
26 |
.SimJointData <- setClass( |
|
27 |
"SimJointData", |
|
28 |
slots = list( |
|
29 |
longitudinal = "data.frame", |
|
30 |
survival = "data.frame" |
|
31 |
) |
|
32 |
) |
|
33 | ||
34 | ||
35 | ||
36 |
#' @rdname SimJointData-class |
|
37 |
#' @export |
|
38 |
SimJointData <- function( |
|
39 |
design = list( |
|
40 |
SimGroup(n = 50, study = "Study-1", arm = "Arm-A"), |
|
41 |
SimGroup(n = 50, study = "Study-1", arm = "Arm-B") |
|
42 |
), |
|
43 |
longitudinal, |
|
44 |
survival, |
|
45 |
.silent = FALSE |
|
46 |
) { |
|
47 | ||
48 | 19x |
assert( |
49 | 19x |
all(vapply(design, \(x) is(x, "SimGroup"), logical(1))), |
50 | 19x |
msg = "All elements of `design` must be of class `SimGroup`" |
51 |
) |
|
52 | ||
53 | 19x |
hazard_evaluation_info <- hazardWindows(survival) |
54 | ||
55 | 19x |
n_group <- vapply(design, function(x) x@n, numeric(1)) |
56 | 19x |
arms <- vapply(design, function(x) x@arm, character(1)) |
57 | 19x |
studies <- vapply(design, function(x) x@study, character(1)) |
58 | 19x |
n_subjects <- sum(n_group) |
59 | 19x |
n_times <- length(hazard_evaluation_info$midpoint) |
60 | ||
61 | 19x |
sprintf_string <- paste0("subject_%0", ceiling(log(n_subjects, 10)) + 1, "i") |
62 | ||
63 | 19x |
baseline <- dplyr::tibble(subject = sprintf(sprintf_string, seq_len(n_subjects))) |> |
64 | 19x |
dplyr::mutate(arm = factor(rep(arms, times = n_group), levels = unique(arms))) |> |
65 | 19x |
dplyr::mutate(study = factor(rep(studies, times = n_group), levels = unique(studies))) |
66 | ||
67 | 19x |
os_baseline <- sampleSubjects(survival, subjects_df = baseline) |
68 | 19x |
lm_baseline <- sampleSubjects(longitudinal, subjects_df = baseline) |
69 | ||
70 | 19x |
lm_dat_no_obvs <- lapply( |
71 | 19x |
longitudinal@times, |
72 | 19x |
\(time) { |
73 | 4514x |
baseline[["time"]] <- time |
74 | 4514x |
baseline |
75 |
} |
|
76 |
) |> |
|
77 | 19x |
dplyr::bind_rows() |> |
78 | 19x |
dplyr::left_join(lm_baseline, by = c("subject", "study", "arm")) |
79 | ||
80 | 19x |
lm_dat <- sampleObservations(longitudinal, lm_dat_no_obvs) |
81 | ||
82 | ||
83 | 19x |
hazard_eval_df <- dplyr::tibble( |
84 | 19x |
subject = rep(lm_baseline$subject, each = n_times), |
85 | 19x |
arm = rep(lm_baseline$arm, each = n_times), |
86 | 19x |
study = rep(lm_baseline$study, each = n_times), |
87 | 19x |
midpoint = rep(as.double(hazard_evaluation_info$midpoint), times = n_subjects), |
88 | 19x |
time = rep(as.double(hazard_evaluation_info$upper), times = n_subjects), |
89 | 19x |
width = rep(as.double(hazard_evaluation_info$width), times = n_subjects) |
90 |
) |
|
91 | ||
92 | 19x |
lm_link_dat <- sampleObservations( |
93 | 19x |
longitudinal, |
94 | 19x |
dplyr::left_join(hazard_eval_df, lm_baseline, by = c("subject", "study", "arm")) |
95 | 19x |
)[, c("subject", "study", "arm", "log_haz_link", "time", "width", "midpoint")] |
96 | ||
97 | 19x |
os_eval_df <- lm_link_dat |> |
98 | 19x |
dplyr::left_join(os_baseline, by = c("subject", "study", "arm")) |
99 | ||
100 | 19x |
withCallingHandlers( |
101 | 19x |
os_dat <- sampleObservations(survival, os_eval_df), |
102 | 19x |
message = function(e) { |
103 | ! |
if (!.silent) message(e) |
104 | 8x |
invokeRestart("muffleMessage") |
105 |
} |
|
106 |
) |
|
107 | ||
108 | 19x |
lm_dat2 <- lm_dat |> |
109 | 19x |
dplyr::left_join(dplyr::select(os_dat, "subject", os_time = "time"), by = "subject") |> |
110 | 19x |
dplyr::mutate(observed = (.data$time <= .data$os_time)) |> |
111 | 19x |
dplyr::arrange(dplyr::pick(c("subject", "time"))) |
112 | ||
113 | 19x |
assert_that( |
114 | 19x |
length(unique(os_dat$subject)) == length(os_dat$subject), |
115 | 19x |
length(os_dat$subject) == n_subjects, |
116 | 19x |
all(os_dat$time >= 0), |
117 | 19x |
all(os_dat$event %in% c(0, 1)), |
118 | 19x |
msg = "Assumptions for the Survival data are not met (please report this issue)" |
119 |
) |
|
120 | ||
121 | 19x |
assert_that( |
122 | 19x |
nrow(lm_dat2) == n_subjects * length(longitudinal@times), |
123 | 19x |
length(unique(lm_dat2$subject)) == n_subjects, |
124 | 19x |
msg = "Assumptions for the Longitudinal data are not met (please report this issue)" |
125 |
) |
|
126 | ||
127 | 19x |
return( |
128 | 19x |
.SimJointData( |
129 | 19x |
survival = os_dat, |
130 | 19x |
longitudinal = lm_dat2[, c("subject", "arm", "study", "time", "sld", "observed")] |
131 |
) |
|
132 |
) |
|
133 |
} |
|
134 | ||
135 |
#' @rdname show-object |
|
136 |
#' @export |
|
137 |
setMethod( |
|
138 |
f = "show", |
|
139 |
signature = "SimJointData", |
|
140 |
definition = function(object) { |
|
141 | 1x |
x <- sprintf("\nA SimJointData Object\n\n") |
142 | 1x |
cat(x) |
143 | 1x |
return(object) |
144 |
} |
|
145 |
) |
1 | ||
2 |
#' Quantity Grid Specification |
|
3 |
#' |
|
4 |
#' @param subjects (`character` or `NULL`)\cr vector of subjects to extract quantities for. |
|
5 |
#' If `NULL` will default to all subjects within the dataset. |
|
6 |
#' |
|
7 |
#' @param times (`numeric` or `NULL`)\cr vector of time points to extract quantities at. |
|
8 |
#' If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max |
|
9 |
#' observation time (for [`LongitudinalQuantities`]) or max event time (for [`SurvivalQuantities`]). |
|
10 |
#' |
|
11 |
#' @param groups (`list`)\cr named list of subjects to extract quantities for. See Group Specification. |
|
12 |
#' |
|
13 |
#' @param spec (`list`)\cr named list of subjects to extract quantities for. The names of each |
|
14 |
#' element should be the required subjects with the element itself being a numeric vector of timepoints |
|
15 |
#' to generate the quantity at. |
|
16 |
#' |
|
17 |
#' @param length.out (`numeric`)\cr number of evenly spaced timepoints to generate quantities at. |
|
18 |
#' |
|
19 |
#' @param newdata (`data.frame`) \cr new data to generate quantities for. Must contain the same columns |
|
20 |
#' and factor levels of the original data used in the [`DataSurvival`] object. |
|
21 |
#' |
|
22 |
#' @param params (`list`)\cr named list of parameters to fix the longitudinal model parameters at when |
|
23 |
#' predicting survival quantities. See [`getPredictionNames()`] for the required parameters. |
|
24 |
#' |
|
25 |
#' @description |
|
26 |
#' These functions are used to specify which subjects and timepoints should be generated |
|
27 |
#' when calculating quantities via [`SurvivalQuantities`] and [`LongitudinalQuantities`]. |
|
28 |
#' |
|
29 |
#' @details |
|
30 |
#' |
|
31 |
#' - `GridFixed()` is used to specify a fixed set of timepoints to generate quantities at for |
|
32 |
#' all the specified subjects. |
|
33 |
#' |
|
34 |
#' - `GridGrouped()` is similar to `GridFixed()` but allows for groupwise averaging |
|
35 |
#' (see Group Specification). |
|
36 |
#' |
|
37 |
#' - `GridObserved()` generates quantities at the observed longitudinal timepoints for each |
|
38 |
#' subject. |
|
39 |
#' |
|
40 |
#' - `GridManual()` allows for individual timepoint specification for each subject. |
|
41 |
#' |
|
42 |
#' - `GridEven()` generates quantities for each subject at N evenly spaced timepoints |
|
43 |
#' between each subjects first and last longitudinal observations. |
|
44 |
#' |
|
45 |
#' - `GridEvent()` generates one quantity for each subject at their event/censor time |
|
46 |
#' as indicated by the `time` variable in the survival dataset. |
|
47 |
#' |
|
48 |
#' - `GridPopulation()` generates longitudinal model quantities based on the population parameters at the |
|
49 |
#' specified time points. Generates 1 set of quantities for each distinct combination of `arm` |
|
50 |
#' and `study` within the [`DataSubject`] object provided to the [`JointModel`]. |
|
51 |
#' |
|
52 |
#' - `GridPrediction()` generates survival quantities based on any user-defined values at the |
|
53 |
#' specified time points. This is useful for generating quantities for a new dataset |
|
54 |
#' on specific longitudinal model parameters. See [`getPredictionNames()`] to determine which |
|
55 |
#' longitudinal model parameters need to be defined for a given longitudinal model. |
|
56 |
#' |
|
57 |
#' @section Group Specification: |
|
58 |
#' For `GridGrouped()`, `groups` must be a named list of character vectors. Each element of the list |
|
59 |
#' must be a character vector of the subjects that will form the group where the element name |
|
60 |
#' is the corresponding name of the group. For example if the goal was to create two groups |
|
61 |
#' named `Group-1` and `Group-2` which are composed of the subjects `sub-1`, `sub-2` and |
|
62 |
#' `sub-3`, `sub-4` respectively then this would be specified as: |
|
63 |
#' ``` |
|
64 |
#' GridGrouped( |
|
65 |
#' groups = list( |
|
66 |
#' "Group-1" = c("sub-1", "sub-2"), |
|
67 |
#' "Group-2" = c("sub-3", "sub-4") |
|
68 |
#' ) |
|
69 |
#' ) |
|
70 |
#' ``` |
|
71 |
#' @seealso [`SurvivalQuantities`], [`LongitudinalQuantities`] |
|
72 |
#' @name Grid-Functions |
|
73 |
NULL |
|
74 | ||
75 | ||
76 | ||
77 | ||
78 | ||
79 | ||
80 |
#' Grid Developer Notes |
|
81 |
#' |
|
82 |
#' @description |
|
83 |
#' Developer details for implementing / extending `Grid` objects for defining |
|
84 |
#' generated quantities for [`SurvivalQuantities`] and [`LongitudinalQuantities`]. |
|
85 |
#' |
|
86 |
#' @slot subjects (`character` or `NULL`)\cr vector of subjects to extract quantities for. |
|
87 |
#' If `NULL` will default to all subjects within the dataset. |
|
88 |
#' @slot times (`numeric` or `NULL`)\cr vector of time points to extract quantities at. |
|
89 |
#' If `NULL` will default to 201 evenly spaced timepoints between 0 and either the max |
|
90 |
#' @slot groups (`list`)\cr named list of subjects to extract quantities for. See details. |
|
91 |
#' |
|
92 |
#' @details |
|
93 |
#' All grid classes must inherit from the abstract `Grid` class. |
|
94 |
#' All grid classes must provide `as.QuantityGenerator(object, data)` and |
|
95 |
#' `as.QuantityCollapser(object, data)` methods where `data` is a [`DataJoint`] object. |
|
96 |
#' These methods must return a `QuantityGenerator` and `QuantityCollapser` object respectively. |
|
97 |
#' The `QuantityGenerator` object specifies unique subject/timepoint combinations that samples |
|
98 |
#' should be generated at. |
|
99 |
#' The `QuantityCollapser` object specifies how to combine these generated samples |
|
100 |
#' to form the desired quantities. |
|
101 |
#' As an example say we want to generate grouped samples for the groups `Group-1` and `Group-2` |
|
102 |
#' which consist of the subjects `sub-1`, `sub-2` and `sub-3`, `sub-4` respectively at two time points |
|
103 |
#' `10` and `20`. We can achieve this as follows: |
|
104 |
#' ``` |
|
105 |
#' QuantityGenerator( |
|
106 |
#' times = c(10, 10, 10, 10, 20, 20, 20, 20), |
|
107 |
#' subjects = c("sub-1" "sub-2", "sub-3", "sub-4", "sub-1" "sub-2", "sub-3", "sub-4") |
|
108 |
#' ) |
|
109 |
#' QuantityCollapser( |
|
110 |
#' times = c(10, 20, 10 , 20), |
|
111 |
#' groups = c("Group-1", "Group-1", "Group-2", "Group-2"), |
|
112 |
#' indexes = list(c(1, 2), c(5, 6), c(3, 4), c(7, 8)) |
|
113 |
#' ) |
|
114 |
#' ``` |
|
115 |
#' For population based quantities use the `arms` and `studies` arguments of `QuantityGenerator` |
|
116 |
#' instead of `subjects`. |
|
117 |
#' |
|
118 |
#' @inheritSection Grid-Functions Group Specification |
|
119 |
#' |
|
120 |
#' @keywords internal |
|
121 |
#' @seealso `Quant-Dev` |
|
122 |
#' @name Grid-Dev |
|
123 |
NULL |
|
124 | ||
125 | ||
126 | ||
127 |
#' Quantity Developer Notes |
|
128 |
#' |
|
129 |
#' @description |
|
130 |
#' Developer details for `QuantityX` objects/methods. This page just outlines the arguments |
|
131 |
#' and slots of these objects/methods. For the full implementation details please see [Grid-Dev] |
|
132 |
#' |
|
133 |
#' @slot times (`numeric`)\cr See Arguments for details. |
|
134 |
#' @slot subjects (`character`)\cr See Arguments for details. |
|
135 |
#' @slot groups (`character`)\cr See Arguments for details. |
|
136 |
#' @slot indexes (`list`)\cr See Arguments for details. |
|
137 |
#' |
|
138 |
#' @param times (`numeric`)\cr vector of time points to extract quantities at. |
|
139 |
#' @param subjects (`character`)\cr vector of subjects to extract quantities for. |
|
140 |
#' @param groups (`character`)\cr vector of labels to apply to the generated quantities. |
|
141 |
#' @param indexes (`list`)\cr list of indexes that specify which observations from a |
|
142 |
#' `QuantityGenerator` should be combined to form the desired quantities. |
|
143 |
#' |
|
144 |
#' @param object (`Grid`)\cr object to convert to a `QuantityGenerator` or `QuantityCollapser`. |
|
145 |
#' @param data (`DataJoint`)\cr Survival and Longitudinal Data. |
|
146 |
#' @param ... Not currently used. |
|
147 |
#' |
|
148 |
#' @details |
|
149 |
#' The `as.QuantityGenerator` must return a `QuantityGenerator` object. |
|
150 |
#' The `as.QuantityCollapser` must return a `QuantityCollapser` object. |
|
151 |
#' @keywords internal |
|
152 |
#' @name Quant-Dev |
|
153 |
NULL |
|
154 | ||
155 | ||
156 |
#' @rdname Grid-Dev |
|
157 |
.Grid <- setClass("Grid") |
|
158 | ||
159 | ||
160 |
#' @rdname Quant-Dev |
|
161 |
.QuantityGenerator <- setClass( |
|
162 |
"QuantityGenerator" |
|
163 |
) |
|
164 |
#' `QuantityGenerator` -> `list` |
|
165 |
#' @description |
|
166 |
#' Converts a `QuantityGenerator` object to a list containing the required input data for a stan |
|
167 |
#' model. |
|
168 |
#' @param object (`QuantityGenerator`)\cr object to convert to a list. |
|
169 |
#' @param data (`DataJoint`)\cr Survival and Longitudinal Data. |
|
170 |
#' @param ... Not currently used. |
|
171 |
#' @keywords internal |
|
172 |
as_stan_list.QuantityGenerator <- function(object, data, ...) { |
|
173 | ! |
stop("as_stan_list.QuantityGenerator not implemented") |
174 |
} |
|
175 | ||
176 | ||
177 | ||
178 |
#' @rdname Quant-Dev |
|
179 |
.QuantityCollapser <- setClass( |
|
180 |
"QuantityCollapser", |
|
181 |
slots = c( |
|
182 |
"times" = "numeric", |
|
183 |
"groups" = "character", |
|
184 |
"indexes" = "list" |
|
185 |
) |
|
186 |
) |
|
187 |
#' @rdname Quant-Dev |
|
188 |
QuantityCollapser <- function(times, groups, indexes) { |
|
189 | 47x |
.QuantityCollapser( |
190 | 47x |
times = times, |
191 | 47x |
groups = groups, |
192 | 47x |
indexes = indexes |
193 |
) |
|
194 |
} |
|
195 | ||
196 |
setValidity( |
|
197 |
"QuantityCollapser", |
|
198 |
function(object) { |
|
199 |
if ( |
|
200 |
length(object@times) != length(object@groups) || |
|
201 |
length(object@times) != length(object@indexes) |
|
202 |
) { |
|
203 |
return("Length of `times`, `groups`, and `indexes` must be equal") |
|
204 |
} |
|
205 |
} |
|
206 |
) |
|
207 | ||
208 |
#' @export |
|
209 |
length.QuantityCollapser <- function(x) { |
|
210 | 68x |
length(x@indexes) |
211 |
} |
|
212 | ||
213 | ||
214 |
#' Expand and Validate Subjects |
|
215 |
#' |
|
216 |
#' @param subjects (`character`)\cr vector of subjects that should exist in `data` |
|
217 |
#' @param data (`DataJoint`)\cr Survival and Longitudinal Data. |
|
218 |
#' |
|
219 |
#' @description |
|
220 |
#' If `subjects` is `NULL` this will return a named list of all subjects in `data`. |
|
221 |
#' Else it will return `subjects` as a named list ensuring that all subjects exist in `data`. |
|
222 |
#' |
|
223 |
#' @keywords internal |
|
224 |
subjects_to_list <- function(subjects = NULL, data) { |
|
225 | 66x |
data_list <- as.list(data) |
226 | 66x |
subjects_exp <- if (is.null(subjects)) { |
227 | 10x |
subs <- as.list(names(data_list$subject_to_index)) |
228 | 10x |
names(subs) <- names(data_list$subject_to_index) |
229 | 10x |
subs |
230 |
} else { |
|
231 | 56x |
subs <- as.list(subjects) |
232 | 56x |
names(subs) <- subjects |
233 | 56x |
subs |
234 |
} |
|
235 | 66x |
subjects_exp_vec <- unlist(subjects_exp, use.names = FALSE) |
236 | 66x |
assert_that( |
237 | 66x |
identical(subjects_exp_vec, unique(subjects_exp_vec)), |
238 | 66x |
msg = "All subject names must be unique" |
239 |
) |
|
240 | 66x |
assert_that( |
241 | 66x |
all(subjects_exp_vec %in% names(data_list$subject_to_index)), |
242 | 66x |
msg = "Not all subjects exist within the data object" |
243 |
) |
|
244 | 65x |
subjects_exp |
245 |
} |
1 |
#' @include Grid.R |
|
2 |
#' @include generics.R |
|
3 |
NULL |
|
4 | ||
5 | ||
6 |
#' @rdname Grid-Dev |
|
7 |
.GridPrediction <- setClass( |
|
8 |
"GridPrediction", |
|
9 |
contains = "Grid", |
|
10 |
slots = c( |
|
11 |
"times" = "numeric_or_NULL", |
|
12 |
"newdata" = "data.frame", |
|
13 |
"params" = "list" |
|
14 |
) |
|
15 |
) |
|
16 |
#' @rdname Grid-Functions |
|
17 |
#' @export |
|
18 |
GridPrediction <- function(times = NULL, newdata, params = list()) { |
|
19 | 7x |
.GridPrediction( |
20 | 7x |
times = times, |
21 | 7x |
params = params, |
22 | 7x |
newdata = newdata |
23 |
) |
|
24 |
} |
|
25 |
setValidity( |
|
26 |
"GridPrediction", |
|
27 |
function(object) { |
|
28 |
for (param in names(object@params)) { |
|
29 |
if (length(object@params[[param]]) != 1) { |
|
30 |
return(sprintf("Parameter '%s' must be length 1", param)) |
|
31 |
} |
|
32 |
} |
|
33 |
if (length(object@params) != length(names(object@params))) { |
|
34 |
return("All elements of `params` must be named") |
|
35 |
} |
|
36 |
if (!is.null(object@newdata[["..new_subject.."]])) { |
|
37 |
return("`newdata` must not contain a column named '..new_subject..'") |
|
38 |
} |
|
39 |
return(TRUE) |
|
40 |
} |
|
41 |
) |
|
42 | ||
43 | ||
44 |
#' @rdname Quant-Dev |
|
45 |
#' @export |
|
46 |
as.QuantityGenerator.GridPrediction <- function(object, data, ...) { |
|
47 | ||
48 | 6x |
assert_class(data, "DataJoint") |
49 | 6x |
data_list <- as.list(data) |
50 | 6x |
validate_time_grid(object@times) |
51 | ||
52 | 6x |
n_times <- length(object@times) |
53 | 6x |
n_obs <- nrow(object@newdata) |
54 | 6x |
newdata <- object@newdata |
55 | 6x |
newdata[["..new_subject.."]] <- sprintf( |
56 | 6x |
"new_subject_%i", |
57 | 6x |
seq_len(nrow(newdata)) |
58 |
) |
|
59 | ||
60 | 6x |
QuantityGeneratorPrediction( |
61 | 6x |
times = rep(object@times, each = n_obs), |
62 | 6x |
newdata = replicate(newdata, n = n_times, simplify = FALSE) |> dplyr::bind_rows(), |
63 | 6x |
params = object@params |
64 |
) |
|
65 |
} |
|
66 | ||
67 |
#' @rdname Quant-Dev |
|
68 |
#' @export |
|
69 |
as.QuantityCollapser.GridPrediction <- function(object, data, ...) { |
|
70 | 2x |
assert_class(data, "DataJoint") |
71 | 2x |
data_list <- as.list(data) |
72 | 2x |
generator <- as.QuantityGenerator(object, data) |
73 | 2x |
QuantityCollapser( |
74 | 2x |
times = generator@times, |
75 | 2x |
groups = generator@newdata[["..new_subject.."]], |
76 | 2x |
indexes = as.list(seq_along(generator@times)) |
77 |
) |
|
78 |
} |
|
79 | ||
80 | ||
81 |
#' @export |
|
82 |
as.list.GridPrediction <- function(x, data, ...) { |
|
83 | ! |
stop("`as.list()` is not implemented for `GridPrediction` objects") |
84 |
} |
|
85 | ||
86 | ||
87 |
#' @rdname coalesceGridTime |
|
88 |
#' @export |
|
89 |
coalesceGridTime.GridPrediction <- function(object, times, ...) { |
|
90 | 4x |
if (is.null(object@times)) { |
91 | ! |
object <- GridPrediction( |
92 | ! |
times = times, |
93 | ! |
newdata = object@newdata, |
94 | ! |
params = object@params |
95 |
) |
|
96 |
} |
|
97 | 4x |
object |
98 |
} |
1 | ||
2 |
#' @include DataJoint.R |
|
3 |
#' @include Quantities.R |
|
4 |
NULL |
|
5 | ||
6 | ||
7 | ||
8 |
#' Re-used documentation for `SurvivalQuantities` |
|
9 |
#' |
|
10 |
#' @param object ([`SurvivalQuantities`]) \cr survival quantities. |
|
11 |
#' @param x ([`SurvivalQuantities`]) \cr survival quantities. |
|
12 |
#' @param ... not used. |
|
13 |
#' |
|
14 |
#' @keywords internal |
|
15 |
#' @name SurvivalQuantities-Shared |
|
16 |
NULL |
|
17 | ||
18 | ||
19 | ||
20 |
#' `SurvivalQuantities` Object & Constructor Function |
|
21 |
#' |
|
22 |
#' Constructor function to generate a `SurvivalQuantities` object. |
|
23 |
#' |
|
24 |
#' @slot quantities (`Quantities`)\cr The sampled quantities. Should contain 1 element per |
|
25 |
#' element of `group` |
|
26 |
#' @slot groups (`list`)\cr See argument section for details |
|
27 |
#' @slot type (`character`)\cr See See argument section for details |
|
28 |
#' @slot time_grid (`numeric`)\cr See argument section for details |
|
29 |
#' @slot data ([`DataJoint`])\cr The data that the Joint Model was fitted to to produce |
|
30 |
#' the samples/quantities |
|
31 |
#' |
|
32 |
#' @section Group Specification: |
|
33 |
#' If `groups` is a character vector of subject IDs then the survival quantities will |
|
34 |
#' only be calculated for those specific subjects. |
|
35 |
#' |
|
36 |
#' If `groups` is a list then any elements with more than 1 subject ID will be grouped together |
|
37 |
#' and their quantities will be calculated by taking a point-wise average. |
|
38 |
#' For example: `groups = list("g1" = c("sub1", "sub2"), "g2" = c("sub3", "sub4"))` would result |
|
39 |
#' in 2 groups being created whose values are the pointwise average |
|
40 |
#' of `c("sub1", "sub2")` and `c("sub3", "sub4")` respectively. |
|
41 |
#' |
|
42 |
#' If `groups=NULL` then all subjects from original dataset will be selected |
|
43 |
#' |
|
44 |
#' @family SurvivalQuantities |
|
45 |
#' @name SurvivalQuantities-class |
|
46 |
#' @export SurvivalQuantities |
|
47 |
.SurvivalQuantities <- setClass( |
|
48 |
Class = "SurvivalQuantities", |
|
49 |
slots = c( |
|
50 |
"quantities" = "Quantities", |
|
51 |
"grid" = "Grid", |
|
52 |
"type" = "character", |
|
53 |
"data" = "DataJoint" |
|
54 |
) |
|
55 |
) |
|
56 | ||
57 |
#' @param object ([`JointModelSamples`]) \cr samples as drawn from a Joint Model. |
|
58 |
#' |
|
59 |
#' @param grid (`Grid`) \cr object that specifies which subjects and time points to calculate the |
|
60 |
#' quantities for. See [Grid-Functions]. |
|
61 |
#' |
|
62 |
#' @param type (`character`)\cr quantity to be generated. |
|
63 |
#' Must be one of `surv`, `haz`, `loghaz`, `cumhaz`. |
|
64 |
#' |
|
65 |
#' @rdname SurvivalQuantities-class |
|
66 |
SurvivalQuantities <- function( |
|
67 |
object, |
|
68 |
grid, |
|
69 |
type = c("surv", "haz", "loghaz", "cumhaz") |
|
70 |
) { |
|
71 | 23x |
type <- match.arg(type) |
72 | 23x |
assert_class(object, "JointModelSamples") |
73 | 23x |
assert_class(grid, "Grid") |
74 | 21x |
assert_that( |
75 | 21x |
!is(grid, "GridPopulation"), |
76 | 21x |
msg = "GridPopulation objects are not supported for `SurvivalQuantities`" |
77 |
) |
|
78 | ||
79 | 20x |
time_grid <- seq( |
80 | 20x |
from = 0, |
81 | 20x |
to = max(as.list(object@data)[["event_times"]]), |
82 | 20x |
length = 201 |
83 |
) |
|
84 | ||
85 | 20x |
grid <- coalesceGridTime(grid, time_grid) |
86 | ||
87 | 20x |
generator <- as.QuantityGenerator(grid, data = object@data) |
88 | ||
89 | 20x |
assert_that( |
90 | 20x |
all(generator@times >= 0), |
91 | 20x |
msg = "Time points must be greater than or equal to 0" |
92 |
) |
|
93 | ||
94 | 18x |
gq <- generateQuantities( |
95 | 18x |
object, |
96 | 18x |
generator = generator, |
97 | 18x |
type = "survival" |
98 |
) |
|
99 | ||
100 | 17x |
quantities_raw <- extract_quantities(gq, type) |
101 | 17x |
collapser <- as.QuantityCollapser(grid, object@data) |
102 | 17x |
quantities <- collapse_quantities(quantities_raw, collapser) |
103 | ||
104 | 17x |
.SurvivalQuantities( |
105 | 17x |
quantities = Quantities( |
106 | 17x |
quantities, |
107 | 17x |
groups = collapser@groups, |
108 | 17x |
times = collapser@times |
109 |
), |
|
110 | 17x |
grid = grid, |
111 | 17x |
data = object@data, |
112 | 17x |
type = type |
113 |
) |
|
114 |
} |
|
115 | ||
116 | ||
117 | ||
118 |
#' `as.data.frame` |
|
119 |
#' |
|
120 |
#' @param x ([`SurvivalQuantities`]) \cr longitudinal quantities. |
|
121 |
#' @param ... not used. |
|
122 |
#' @family SurvivalQuantities |
|
123 |
#' @export |
|
124 |
as.data.frame.SurvivalQuantities <- function(x, ...) { |
|
125 | ! |
as.data.frame(x@quantities) |
126 |
} |
|
127 | ||
128 | ||
129 | ||
130 |
#' summary |
|
131 |
#' |
|
132 |
#' @description |
|
133 |
#' This method returns a `data.frame` of the longitudinal quantities. |
|
134 |
#' |
|
135 |
#' @param conf.level (`numeric`) \cr confidence level of the interval. |
|
136 |
#' @inheritParams SurvivalQuantities-Shared |
|
137 |
#' |
|
138 |
#' @family SurvivalQuantities |
|
139 |
#' @family summary |
|
140 |
#' @export |
|
141 |
summary.SurvivalQuantities <- function( |
|
142 |
object, |
|
143 |
conf.level = 0.95, |
|
144 |
... |
|
145 |
) { |
|
146 | 19x |
summary(object@quantities, conf.level = conf.level) |
147 |
} |
|
148 | ||
149 | ||
150 |
#' Automatic Plotting for `SurvivalQuantities`` |
|
151 |
#' |
|
152 |
#' @inheritParams SurvivalQuantities-Shared |
|
153 |
#' @param add_km (`logical`) \cr if `TRUE` Kaplan-Meier curves will be added to the plot for |
|
154 |
#' each group/subject. |
|
155 |
#' @param add_wrap (`logical`) \cr if `TRUE` will apply a [ggplot2::facet_wrap()] to the plot |
|
156 |
#' by each group/subject. |
|
157 |
#' @param conf.level (`numeric`) \cr confidence level of the interval. If values of `FALSE`, |
|
158 |
#' `NULL` or `0` are provided then confidence regions will not be added to the plot |
|
159 |
#' @param ... not used. |
|
160 |
#' |
|
161 |
#' @family SurvivalQuantities |
|
162 |
#' @family autoplot |
|
163 |
#' @export |
|
164 |
autoplot.SurvivalQuantities <- function( |
|
165 |
object, |
|
166 |
conf.level = 0.95, |
|
167 |
add_km = FALSE, |
|
168 |
add_wrap = TRUE, |
|
169 |
... |
|
170 |
) { |
|
171 | 3x |
include_ci <- !is.null(conf.level) && is.numeric(conf.level) && conf.level > 0 |
172 |
# If CI aren't needed supply a default 0.95 to summary function as it needs |
|
173 |
# a value to be specified to work |
|
174 | 3x |
conf.level <- if (include_ci) conf.level else 0.95 |
175 | 3x |
assert_that( |
176 | 3x |
is.flag(add_km), |
177 | 3x |
length(conf.level) == 1, |
178 | 3x |
conf.level < 1, |
179 | 3x |
is.flag(add_wrap) |
180 |
) |
|
181 | 3x |
kmdf <- if (add_km) { |
182 | 1x |
subset( |
183 | 1x |
object@data, |
184 | 1x |
as.list(object@grid, data = object@data) |
185 |
) |
|
186 |
} else { |
|
187 | 2x |
NULL |
188 |
} |
|
189 | 3x |
all_fit_df <- summary(object, conf.level = conf.level) |
190 | 3x |
label <- switch( |
191 | 3x |
object@type, |
192 | 3x |
"surv" = expression(S(t)), |
193 | 3x |
"cumhaz" = expression(H(t)), |
194 | 3x |
"haz" = expression(h(t)), |
195 | 3x |
"loghaz" = expression(log(h(t))) |
196 |
) |
|
197 | 3x |
survival_plot( |
198 | 3x |
data = all_fit_df, |
199 | 3x |
add_ci = include_ci, |
200 | 3x |
add_wrap = add_wrap, |
201 | 3x |
kmdf = kmdf, |
202 | 3x |
y_label = label |
203 |
) |
|
204 |
} |
|
205 | ||
206 | ||
207 | ||
208 | ||
209 |
#' Survival Plot |
|
210 |
#' |
|
211 |
#' Internal plotting function to create survival plots with KM curve overlays |
|
212 |
#' This function predominately exists to extract core logic into its own function |
|
213 |
#' to enable easier unit testing. |
|
214 |
#' |
|
215 |
#' @param data (`data.frame`)\cr summary statistics for a survival |
|
216 |
#' curve to be plotted. See details. |
|
217 |
#' @param add_ci (`logical`)\cr should confidence intervals be added? Default = `TRUE`. |
|
218 |
#' @param add_wrap (`logical`)\cr should the plots be wrapped by `data$group`? Default = `TRUE`. |
|
219 |
#' @param kmdf (`data.frame` or `NULL`)\cr event times and status used to plot |
|
220 |
#' overlaying KM curves. If `NULL` no KM curve will be plotted. See details. |
|
221 |
#' @param y_label (`character` or `expression`) \cr label to display on the y-axis. |
|
222 |
#' Default = `expression(S(t))`. |
|
223 |
#' @param x_label (`character` or `expression`) \cr label to display on the x-axis. |
|
224 |
#' |
|
225 |
#' @details |
|
226 |
#' |
|
227 |
#' ## `data` |
|
228 |
#' Should contain the following columns: |
|
229 |
#' - `time` (`numeric`) \cr time point for the summary statistic. |
|
230 |
#' - `group` (`character`) \cr the group in which the observation belongs to. |
|
231 |
#' - `median` (`numeric`) \cr the median value for the summary statistic. |
|
232 |
#' - `upper` (`numeric`) \cr the upper 95% CI for the summary statistic. |
|
233 |
#' - `lower` (`numeric`) \cr the lower 95% CI for the summary statistic. |
|
234 |
#' |
|
235 |
#' ## `kmdf` |
|
236 |
#' Should contain the following columns: |
|
237 |
#' - `time` (`numeric`) \cr the time at which an event occurred. |
|
238 |
#' - `event` (`numeric`) \cr 1/0 status indicator for the event. |
|
239 |
#' - `group` (`character`) \cr which group the event belongs to, should correspond to values in `data$group`. |
|
240 |
#' @keywords internal |
|
241 |
survival_plot <- function( |
|
242 |
data, |
|
243 |
add_ci = TRUE, |
|
244 |
add_wrap = TRUE, |
|
245 |
kmdf = NULL, |
|
246 |
y_label = expression(S(t)), |
|
247 |
x_label = expression(t) |
|
248 |
) { |
|
249 | 6x |
assert_that( |
250 | 6x |
is.flag(add_ci), |
251 | 6x |
is.flag(add_wrap), |
252 | 6x |
is.expression(y_label) || is.character(y_label), |
253 | 6x |
is.expression(x_label) || is.character(x_label), |
254 | 6x |
is.null(kmdf) | is.data.frame(kmdf) |
255 |
) |
|
256 | ||
257 | 6x |
p <- ggplot() + |
258 | 6x |
xlab(x_label) + |
259 | 6x |
ylab(y_label) + |
260 | 6x |
theme_bw() |
261 | ||
262 | 6x |
if (add_wrap) { |
263 | 2x |
p <- p + facet_wrap(~group) |
264 | 2x |
aes_ci <- aes(x = .data$time, ymin = .data$lower, ymax = .data$upper) |
265 | 2x |
aes_line <- aes(x = .data$time, y = .data$median) |
266 | 2x |
aes_km <- aes(time = .data$time, status = .data$event) |
267 |
} else { |
|
268 | 4x |
aes_ci <- aes( |
269 | 4x |
x = .data$time, |
270 | 4x |
ymin = .data$lower, |
271 | 4x |
ymax = .data$upper, |
272 | 4x |
fill = .data$group, |
273 | 4x |
group = .data$group |
274 |
) |
|
275 | 4x |
aes_line <- aes( |
276 | 4x |
x = .data$time, |
277 | 4x |
y = .data$median, |
278 | 4x |
colour = .data$group, |
279 | 4x |
group = .data$group |
280 |
) |
|
281 | 4x |
aes_km <- aes( |
282 | 4x |
time = .data$time, |
283 | 4x |
status = .data$event, |
284 | 4x |
group = .data$group, |
285 | 4x |
colour = .data$group |
286 |
) |
|
287 |
} |
|
288 | 6x |
p <- p + geom_line(aes_line, data = data) |
289 | 6x |
if (add_ci) { |
290 | 2x |
p <- p + geom_ribbon(aes_ci, data = data, alpha = 0.3) |
291 |
} |
|
292 | 6x |
if (!is.null(kmdf)) { |
293 | 2x |
p <- p + |
294 | 2x |
ggplot2.utils::geom_km(aes_km, data = kmdf) + |
295 | 2x |
ggplot2.utils::geom_km_ticks(aes_km, data = kmdf) |
296 |
} |
|
297 | 6x |
p |
298 |
} |
|
299 | ||
300 | ||
301 |
#' @rdname show-object |
|
302 |
#' @export |
|
303 |
setMethod( |
|
304 |
f = "show", |
|
305 |
signature = "SurvivalQuantities", |
|
306 |
definition = function(object) { |
|
307 | 1x |
template <- c( |
308 | 1x |
"SurvivalQuantities Object:", |
309 | 1x |
" # of samples = %d", |
310 | 1x |
" # of quantities = %d", |
311 | 1x |
" Type = %s" |
312 |
) |
|
313 | 1x |
string <- sprintf( |
314 | 1x |
paste(template, collapse = "\n"), |
315 | 1x |
nrow(object@quantities), |
316 | 1x |
ncol(object@quantities), |
317 | 1x |
object@type |
318 |
) |
|
319 | 1x |
cat("\n", string, "\n\n") |
320 |
} |
|
321 |
) |
|
322 | ||
323 | ||
324 | ||
325 |
#' `brierScore` |
|
326 |
#' |
|
327 |
#' @description |
|
328 |
#' Derives the Brier Scores (using Inverse Probability of Censoring Weighting) |
|
329 |
#' for the Survival estimates as detailed in \insertCite{blanche2015}{jmpost}. |
|
330 |
#' |
|
331 |
#' @inheritParams SurvivalQuantities-Shared |
|
332 |
#' @inheritParams Brier-Score-Shared |
|
333 |
#' |
|
334 |
#' @family brierScore |
|
335 |
#' @family SurvivalQuantities |
|
336 |
#' @references |
|
337 |
#' \insertAllCited{} |
|
338 |
#' @export |
|
339 |
brierScore.SurvivalQuantities <- function( |
|
340 |
object, |
|
341 |
maintain_cen_order = TRUE, |
|
342 |
event_offset = TRUE, |
|
343 |
... |
|
344 |
) { |
|
345 | 1x |
assert_that( |
346 | 1x |
object@type == "surv", |
347 | 1x |
msg = paste( |
348 | 1x |
"Brier Score can only be calculated when the survival quantities were", |
349 | 1x |
"generated with `type = 'surv'`", |
350 | 1x |
collapse = " " |
351 |
) |
|
352 |
) |
|
353 | 1x |
assert_that( |
354 | 1x |
is(object@grid, "GridFixed"), |
355 | 1x |
msg = paste( |
356 | 1x |
"Brier Score can only be calculated when the survival quantities were", |
357 | 1x |
"generated with `grid = GridFixed()`", |
358 | 1x |
collapse = " " |
359 |
) |
|
360 |
) |
|
361 | ||
362 | 1x |
sdat <- summary(object) |
363 | 1x |
times <- unique(as.QuantityGenerator(object@grid, object@data)@times) |
364 | 1x |
times <- times[order(times)] |
365 | 1x |
assert_that( |
366 | 1x |
nrow(sdat) == length(times) * length(unique(sdat$group)) |
367 |
) |
|
368 | ||
369 | 1x |
subject_col <- extractVariableNames(object@data@subject)$subject |
370 | 1x |
time_col <- extractVariableNames(object@data@survival)$time |
371 | 1x |
event_col <- extractVariableNames(object@data@survival)$event |
372 | 1x |
groups <- as.character(object@data@survival@data[[subject_col]]) |
373 | 1x |
orig_times <- object@data@survival@data[[time_col]] |
374 | 1x |
events <- object@data@survival@data[[event_col]] |
375 | ||
376 | 1x |
pred_mat <- matrix( |
377 | 1x |
ncol = length(times), |
378 | 1x |
nrow = length(unique(sdat$group)) |
379 |
) |
|
380 | 1x |
for (i in seq_along(times)) { |
381 | 6x |
pred_mat[, i] <- sdat[sdat["time"] == times[i], "median"] |
382 | 6x |
assert_that( |
383 | 6x |
all(groups == sdat[sdat["time"] == times[i], "group"]) |
384 |
) |
|
385 |
} |
|
386 | 1x |
brier_score( |
387 | 1x |
t = times, |
388 | 1x |
times = orig_times, |
389 | 1x |
events = events, |
390 | 1x |
pred_mat = 1 - pred_mat, |
391 | 1x |
maintain_cen_order = maintain_cen_order, |
392 | 1x |
event_offset = event_offset |
393 |
) |
|
394 |
} |
1 | ||
2 | ||
3 |
#' @include SimLongitudinal.R |
|
4 |
#' @include generics.R |
|
5 |
NULL |
|
6 | ||
7 |
#' Simulate Longitudinal Data from a GSF Model |
|
8 |
#' |
|
9 |
#' @param times (`numeric`)\cr the times to generate observations at. |
|
10 |
#' @param sigma (`number`)\cr the variance of the longitudinal values. |
|
11 |
#' @param mu_s (`numeric`)\cr the mean shrinkage rates. |
|
12 |
#' @param mu_g (`numeric`)\cr the mean growth rates. |
|
13 |
#' @param mu_b (`numeric`)\cr the mean baseline values. |
|
14 |
#' @param mu_phi (`numeric`)\cr the mean proportion of cells affected by the treatment |
|
15 |
#' @param omega_b (`number`)\cr the baseline value standard deviation. |
|
16 |
#' @param omega_s (`number`)\cr the shrinkage rate standard deviation. |
|
17 |
#' @param omega_g (`number`)\cr the growth rate standard deviation. |
|
18 |
#' @param omega_phi (`number`)\cr for the standard deviation of the proportion of cells |
|
19 |
#' affected by the treatment `omega_phi`. |
|
20 |
#' @param link_dsld (`number`)\cr the link coefficient for the derivative contribution. |
|
21 |
#' @param link_ttg (`number`)\cr the link coefficient for the time-to-growth contribution. |
|
22 |
#' @param link_identity (`number`)\cr the link coefficient for the SLD Identity contribution. |
|
23 |
#' @param link_growth (`number`)\cr the link coefficient for the log-growth parameter contribution. |
|
24 |
#' @param link_shrinkage (`number`)\cr the link coefficient for the log-shrinkage parameter contribution. |
|
25 |
#' @param scaled_variance (`logical`)\cr whether the variance should be scaled by the expected value |
|
26 |
#' (see the "Statistical Specifications" vignette for more details) |
|
27 |
#' |
|
28 |
#' @slot sigma (`numeric`)\cr See arguments. |
|
29 |
#' @slot mu_s (`numeric`)\cr See arguments. |
|
30 |
#' @slot mu_g (`numeric`)\cr See arguments. |
|
31 |
#' @slot mu_b (`numeric`)\cr See arguments. |
|
32 |
#' @slot mu_phi (`numeric`)\cr See arguments. |
|
33 |
#' @slot omega_b (`numeric`)\cr See arguments. |
|
34 |
#' @slot omega_s (`numeric`)\cr See arguments. |
|
35 |
#' @slot omega_g (`numeric`)\cr See arguments. |
|
36 |
#' @slot omega_phi (`numeric`)\cr See arguments. |
|
37 |
#' @slot link_dsld (`numeric`)\cr See arguments. |
|
38 |
#' @slot link_ttg (`numeric`)\cr See arguments. |
|
39 |
#' @slot link_identity (`numeric`)\cr See arguments. |
|
40 |
#' @slot link_growth (`numeric`)\cr See arguments. |
|
41 |
#' @slot link_shrinkage (`numeric`)\cr See arguments. |
|
42 |
#' @slot scaled_variance (`numeric`)\cr See arguments. |
|
43 |
#' @family SimLongitudinal |
|
44 |
#' @name SimLongitudinalGSF-class |
|
45 |
#' @exportClass SimLongitudinalGSF |
|
46 |
.SimLongitudinalGSF <- setClass( |
|
47 |
"SimLongitudinalGSF", |
|
48 |
contains = "SimLongitudinal", |
|
49 |
slots = c( |
|
50 |
sigma = "numeric", |
|
51 |
mu_s = "numeric", |
|
52 |
mu_g = "numeric", |
|
53 |
mu_b = "numeric", |
|
54 |
mu_phi = "numeric", |
|
55 |
omega_b = "numeric", |
|
56 |
omega_s = "numeric", |
|
57 |
omega_g = "numeric", |
|
58 |
omega_phi = "numeric", |
|
59 |
link_dsld = "numeric", |
|
60 |
link_ttg = "numeric", |
|
61 |
link_identity = "numeric", |
|
62 |
link_growth = "numeric", |
|
63 |
link_shrinkage = "numeric", |
|
64 |
scaled_variance = "logical" |
|
65 |
) |
|
66 |
) |
|
67 | ||
68 |
#' @rdname SimLongitudinalGSF-class |
|
69 |
#' @export |
|
70 |
SimLongitudinalGSF <- function( |
|
71 |
times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365, |
|
72 |
sigma = 0.01, |
|
73 |
mu_s = log(c(0.6, 0.4)), |
|
74 |
mu_g = log(c(0.25, 0.35)), |
|
75 |
mu_b = log(60), |
|
76 |
mu_phi = qlogis(c(0.4, 0.6)), |
|
77 |
omega_b = 0.2, |
|
78 |
omega_s = 0.2, |
|
79 |
omega_g = 0.2, |
|
80 |
omega_phi = 0.2, |
|
81 |
link_dsld = 0, |
|
82 |
link_ttg = 0, |
|
83 |
link_identity = 0, |
|
84 |
link_growth = 0, |
|
85 |
link_shrinkage = 0, |
|
86 |
scaled_variance = TRUE |
|
87 |
) { |
|
88 | ||
89 | 8x |
if (length(omega_b) == 1) omega_b <- rep(omega_b, length(mu_b)) |
90 | 8x |
if (length(omega_s) == 1) omega_s <- rep(omega_s, length(mu_s)) |
91 | 8x |
if (length(omega_g) == 1) omega_g <- rep(omega_g, length(mu_g)) |
92 | 8x |
if (length(omega_phi) == 1) omega_phi <- rep(omega_phi, length(mu_phi)) |
93 | ||
94 | 8x |
.SimLongitudinalGSF( |
95 | 8x |
times = times, |
96 | 8x |
sigma = sigma, |
97 | 8x |
mu_s = mu_s, |
98 | 8x |
mu_g = mu_g, |
99 | 8x |
mu_b = mu_b, |
100 | 8x |
mu_phi = mu_phi, |
101 | 8x |
omega_b = omega_b, |
102 | 8x |
omega_s = omega_s, |
103 | 8x |
omega_g = omega_g, |
104 | 8x |
omega_phi = omega_phi, |
105 | 8x |
link_dsld = link_dsld, |
106 | 8x |
link_ttg = link_ttg, |
107 | 8x |
link_identity = link_identity, |
108 | 8x |
link_growth = link_growth, |
109 | 8x |
link_shrinkage = link_shrinkage, |
110 | 8x |
scaled_variance = scaled_variance |
111 |
) |
|
112 |
} |
|
113 | ||
114 | ||
115 |
setValidity( |
|
116 |
"SimLongitudinalGSF", |
|
117 |
function(object) { |
|
118 |
par_lengths <- c( |
|
119 |
length(object@mu_s), |
|
120 |
length(object@mu_g), |
|
121 |
length(object@mu_phi) |
|
122 |
) |
|
123 |
if (length(unique(par_lengths)) != 1) { |
|
124 |
return("The parameters `mu_s`, `mu_g` and `mu_phi` must have the same length.") |
|
125 |
} |
|
126 | ||
127 |
pairs <- list( |
|
128 |
"omega_b" = "mu_b", |
|
129 |
"omega_s" = "mu_s", |
|
130 |
"omega_g" = "mu_g", |
|
131 |
"omega_phi" = "mu_phi" |
|
132 |
) |
|
133 |
for (i in seq_along(pairs)) { |
|
134 |
omega <- slot(object, names(pairs)[[i]]) |
|
135 |
mu <- slot(object, pairs[[i]]) |
|
136 |
if (!(length(omega) == length(mu))) { |
|
137 |
return( |
|
138 |
sprintf("`%s` must be length 1 or the same length as `%s`", omega, mu) |
|
139 |
) |
|
140 |
} |
|
141 |
} |
|
142 | ||
143 |
len_1_pars <- c( |
|
144 |
"sigma", |
|
145 |
"link_dsld", "link_ttg", "link_identity", "link_growth", |
|
146 |
"link_shrinkage" |
|
147 |
) |
|
148 |
for (par in len_1_pars) { |
|
149 |
if (length(slot(object, par)) != 1) { |
|
150 |
return(sprintf("The `%s` parameter must be a length 1 numeric.", par)) |
|
151 |
} |
|
152 |
} |
|
153 | ||
154 |
return(TRUE) |
|
155 |
} |
|
156 |
) |
|
157 | ||
158 |
#' @rdname as_print_string |
|
159 |
as_print_string.SimLongitudinalGSF <- function(object) { |
|
160 | 1x |
return("SimLongitudinalGSF") |
161 |
} |
|
162 | ||
163 |
#' @rdname sampleObservations |
|
164 |
#' @export |
|
165 |
sampleObservations.SimLongitudinalGSF <- function(object, times_df) { |
|
166 | 13x |
times_df |> |
167 | 13x |
dplyr::mutate(mu_sld = gsf_sld(.data$time, .data$psi_b, .data$psi_s, .data$psi_g, .data$psi_phi)) |> |
168 | 13x |
dplyr::mutate(dsld = gsf_dsld(.data$time, .data$psi_b, .data$psi_s, .data$psi_g, .data$psi_phi)) |> |
169 | 13x |
dplyr::mutate(ttg = gsf_ttg(.data$time, .data$psi_b, .data$psi_s, .data$psi_g, .data$psi_phi)) |> |
170 | 13x |
dplyr::mutate(sld_sd = ifelse(object@scaled_variance, .data$mu_sld * object@sigma, object@sigma)) |> |
171 | 13x |
dplyr::mutate(sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd)) |> |
172 | 13x |
dplyr::mutate( |
173 | 13x |
log_haz_link = |
174 | 13x |
(object@link_dsld * .data$dsld) + |
175 | 13x |
(object@link_ttg * .data$ttg) + |
176 | 13x |
(object@link_identity * .data$mu_sld) + |
177 | 13x |
(object@link_growth * log(.data$psi_g)) + |
178 | 13x |
(object@link_shrinkage * log(.data$psi_s)) |
179 |
) |
|
180 |
} |
|
181 | ||
182 | ||
183 |
#' @rdname sampleSubjects |
|
184 |
#' @export |
|
185 |
sampleSubjects.SimLongitudinalGSF <- function(object, subjects_df) { |
|
186 | 7x |
assert_that( |
187 | 7x |
is.factor(subjects_df$study), |
188 | 7x |
is.factor(subjects_df$arm), |
189 | 7x |
length(levels(subjects_df$study)) == length(object@mu_b), |
190 | 7x |
length(levels(subjects_df$arm)) == length(object@mu_s), |
191 | 7x |
length(levels(subjects_df$arm)) == length(object@mu_g), |
192 | 7x |
length(levels(subjects_df$arm)) == length(object@mu_phi) |
193 |
) |
|
194 | ||
195 | 7x |
res <- subjects_df |> |
196 | 7x |
dplyr::distinct(.data$subject, .data$arm, .data$study) |> |
197 | 7x |
dplyr::mutate(study_idx = as.numeric(.data$study)) |> |
198 | 7x |
dplyr::mutate(arm_idx = as.numeric(.data$arm)) |> |
199 | 7x |
dplyr::mutate(psi_b = stats::rlnorm( |
200 | 7x |
dplyr::n(), |
201 | 7x |
object@mu_b[.data$study_idx], |
202 | 7x |
object@omega_b[.data$study_idx] |
203 |
)) |> |
|
204 | 7x |
dplyr::mutate(psi_s = stats::rlnorm( |
205 | 7x |
dplyr::n(), |
206 | 7x |
object@mu_s[.data$arm_idx], |
207 | 7x |
object@omega_s[.data$arm_idx] |
208 |
)) |> |
|
209 | 7x |
dplyr::mutate(psi_g = stats::rlnorm( |
210 | 7x |
dplyr::n(), |
211 | 7x |
object@mu_g[.data$arm_idx], |
212 | 7x |
object@omega_g[.data$arm_idx] |
213 |
)) |> |
|
214 | 7x |
dplyr::mutate(psi_phi_logit = stats::rnorm( |
215 | 7x |
dplyr::n(), |
216 | 7x |
object@mu_phi[.data$arm_idx], |
217 | 7x |
object@omega_phi[.data$arm_idx] |
218 |
)) |> |
|
219 | 7x |
dplyr::mutate(psi_phi = stats::plogis(.data$psi_phi_logit)) |
220 | ||
221 | 7x |
res[, c("subject", "arm", "study", "psi_b", "psi_s", "psi_g", "psi_phi")] |
222 |
} |
|
223 | ||
224 | ||
225 | ||
226 | ||
227 |
## sim_lm_gsf ---- |
|
228 | ||
229 |
#' Generalized Stein-Fojo Functionals |
|
230 |
#' |
|
231 |
#' @param time (`numeric`)\cr time grid. |
|
232 |
#' @param b (`number`)\cr baseline. |
|
233 |
#' @param s (`number`)\cr shrinkage. |
|
234 |
#' @param g (`number`)\cr growth. |
|
235 |
#' @param phi (`number`)\cr shrinkage proportion. |
|
236 |
#' |
|
237 |
#' @returns The function results. |
|
238 |
#' |
|
239 |
#' @keywords internal |
|
240 |
gsf_sld <- function(time, b, s, g, phi) { |
|
241 | 18x |
phi <- dplyr::if_else(time >= 0, phi, 0) |
242 | 18x |
b * (phi * exp(-s * time) + (1 - phi) * exp(g * time)) |
243 |
} |
|
244 | ||
245 | ||
246 |
#' @rdname gsf_sld |
|
247 |
gsf_ttg <- function(time, b, s, g, phi) { |
|
248 | 16x |
t1 <- (log(s * phi / (g * (1 - phi))) / (g + s)) |
249 | 16x |
t1[t1 <= 0] <- 0 |
250 | 16x |
return(t1) |
251 |
} |
|
252 | ||
253 | ||
254 |
#' @rdname gsf_sld |
|
255 |
gsf_dsld <- function(time, b, s, g, phi) { |
|
256 | 16x |
phi <- dplyr::if_else(time >= 0, phi, 0) |
257 | 16x |
t1 <- (1 - phi) * g * exp(g * time) |
258 | 16x |
t2 <- phi * s * exp(-s * time) |
259 | 16x |
return(b * (t1 - t2)) |
260 |
} |
1 | ||
2 |
#' @include SimLongitudinal.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 |
#' Simulate Longitudinal Data from a Stein-Fojo Model |
|
7 |
#' |
|
8 |
#' @param times (`numeric`)\cr the times to generate observations at. |
|
9 |
#' @param sigma (`number`)\cr the variance of the longitudinal values. |
|
10 |
#' @param mu_s (`numeric`)\cr the mean shrinkage rates for the two treatment arms. |
|
11 |
#' @param mu_g (`numeric`)\cr the mean growth rates for the two treatment arms. |
|
12 |
#' @param mu_b (`numeric`)\cr the mean baseline values for the two treatment arms. |
|
13 |
#' @param omega_b (`number`)\cr the baseline value standard deviation. |
|
14 |
#' @param omega_s (`number`)\cr the shrinkage rate standard deviation. |
|
15 |
#' @param omega_g (`number`)\cr the growth rate standard deviation. |
|
16 |
#' @param link_dsld (`number`)\cr the link coefficient for the derivative contribution. |
|
17 |
#' @param link_ttg (`number`)\cr the link coefficient for the time-to-growth contribution. |
|
18 |
#' @param link_identity (`number`)\cr the link coefficient for the SLD Identity contribution. |
|
19 |
#' @param link_growth (`number`)\cr the link coefficient for the log-growth parameter contribution. |
|
20 |
#' @param link_shrinkage (`number`)\cr the link coefficient for the log-shrinkage parameter contribution. |
|
21 |
#' @param scaled_variance (`logical`)\cr whether the variance should be scaled by the expected value |
|
22 |
#' (see the "Statistical Specifications" vignette for more details) |
|
23 |
#' |
|
24 |
#' @slot sigma (`numeric`)\cr See arguments. |
|
25 |
#' @slot mu_s (`numeric`)\cr See arguments. |
|
26 |
#' @slot mu_g (`numeric`)\cr See arguments. |
|
27 |
#' @slot mu_b (`numeric`)\cr See arguments. |
|
28 |
#' @slot omega_b (`numeric`)\cr See arguments. |
|
29 |
#' @slot omega_s (`numeric`)\cr See arguments. |
|
30 |
#' @slot omega_g (`numeric`)\cr See arguments. |
|
31 |
#' @slot link_dsld (`numeric`)\cr See arguments. |
|
32 |
#' @slot link_ttg (`numeric`)\cr See arguments. |
|
33 |
#' @slot link_identity (`numeric`)\cr See arguments. |
|
34 |
#' @slot link_growth (`numeric`)\cr See arguments. |
|
35 |
#' @slot link_shrinkage (`numeric`)\cr See arguments. |
|
36 |
#' @slot scaled_variance (`logical`)\cr See arguments. |
|
37 |
#' |
|
38 |
#' @family SimLongitudinal |
|
39 |
#' @name SimLongitudinalSteinFojo-class |
|
40 |
#' @exportClass SimLongitudinalSteinFojo |
|
41 |
.SimLongitudinalSteinFojo <- setClass( |
|
42 |
"SimLongitudinalSteinFojo", |
|
43 |
contains = "SimLongitudinal", |
|
44 |
slots = c( |
|
45 |
sigma = "numeric", |
|
46 |
mu_s = "numeric", |
|
47 |
mu_g = "numeric", |
|
48 |
mu_b = "numeric", |
|
49 |
omega_b = "numeric", |
|
50 |
omega_s = "numeric", |
|
51 |
omega_g = "numeric", |
|
52 |
link_dsld = "numeric", |
|
53 |
link_ttg = "numeric", |
|
54 |
link_identity = "numeric", |
|
55 |
link_growth = "numeric", |
|
56 |
link_shrinkage = "numeric", |
|
57 |
scaled_variance = "logical" |
|
58 |
) |
|
59 |
) |
|
60 | ||
61 |
#' @rdname SimLongitudinalSteinFojo-class |
|
62 |
#' @export |
|
63 |
SimLongitudinalSteinFojo <- function( |
|
64 |
times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365, |
|
65 |
sigma = 0.01, |
|
66 |
mu_s = log(c(0.6, 0.4)), |
|
67 |
mu_g = log(c(0.25, 0.35)), |
|
68 |
mu_b = log(60), |
|
69 |
omega_b = 0.2, |
|
70 |
omega_s = 0.2, |
|
71 |
omega_g = 0.2, |
|
72 |
link_dsld = 0, |
|
73 |
link_ttg = 0, |
|
74 |
link_identity = 0, |
|
75 |
link_growth = 0, |
|
76 |
link_shrinkage = 0, |
|
77 |
scaled_variance = TRUE |
|
78 |
) { |
|
79 | ||
80 | 2x |
if (length(omega_b) == 1) omega_b <- rep(omega_b, length(mu_b)) |
81 | 2x |
if (length(omega_s) == 1) omega_s <- rep(omega_s, length(mu_s)) |
82 | 2x |
if (length(omega_g) == 1) omega_g <- rep(omega_g, length(mu_g)) |
83 | ||
84 | 2x |
.SimLongitudinalSteinFojo( |
85 | 2x |
times = times, |
86 | 2x |
sigma = sigma, |
87 | 2x |
mu_s = mu_s, |
88 | 2x |
mu_g = mu_g, |
89 | 2x |
mu_b = mu_b, |
90 | 2x |
omega_b = omega_b, |
91 | 2x |
omega_s = omega_s, |
92 | 2x |
omega_g = omega_g, |
93 | 2x |
link_dsld = link_dsld, |
94 | 2x |
link_ttg = link_ttg, |
95 | 2x |
link_identity = link_identity, |
96 | 2x |
link_growth = link_growth, |
97 | 2x |
link_shrinkage = link_shrinkage, |
98 | 2x |
scaled_variance = scaled_variance |
99 |
) |
|
100 |
} |
|
101 | ||
102 | ||
103 |
setValidity( |
|
104 |
"SimLongitudinalSteinFojo", |
|
105 |
function(object) { |
|
106 |
par_lengths <- c( |
|
107 |
length(object@mu_s), |
|
108 |
length(object@mu_g) |
|
109 |
) |
|
110 |
if (length(unique(par_lengths)) != 1) { |
|
111 |
return("The parameters `mu_s` and `mu_g` must have the same length.") |
|
112 |
} |
|
113 |
pairs <- list( |
|
114 |
"omega_b" = "mu_b", |
|
115 |
"omega_s" = "mu_s", |
|
116 |
"omega_g" = "mu_g" |
|
117 |
) |
|
118 |
for (i in seq_along(pairs)) { |
|
119 |
omega <- slot(object, names(pairs)[[i]]) |
|
120 |
mu <- slot(object, pairs[[i]]) |
|
121 |
if (!(length(omega) == length(mu))) { |
|
122 |
return( |
|
123 |
sprintf("`%s` must be length 1 or the same length as `%s`", omega, mu) |
|
124 |
) |
|
125 |
} |
|
126 |
} |
|
127 |
len_1_pars <- c( |
|
128 |
"sigma", |
|
129 |
"link_dsld", "link_ttg", "link_identity", |
|
130 |
"link_growth", "link_shrinkage" |
|
131 |
) |
|
132 |
for (par in len_1_pars) { |
|
133 |
if (length(slot(object, par)) != 1) { |
|
134 |
return(sprintf("The `%s` parameter must be a length 1 numeric.", par)) |
|
135 |
} |
|
136 |
} |
|
137 |
return(TRUE) |
|
138 |
} |
|
139 |
) |
|
140 | ||
141 |
#' @rdname as_print_string |
|
142 |
as_print_string.SimLongitudinalSteinFojo <- function(object) { |
|
143 | 1x |
return("SimLongitudinalSteinFojo") |
144 |
} |
|
145 | ||
146 |
#' @rdname sampleObservations |
|
147 |
#' @export |
|
148 |
sampleObservations.SimLongitudinalSteinFojo <- function(object, times_df) { |
|
149 | 1x |
times_df |> |
150 | 1x |
dplyr::mutate(mu_sld = sf_sld(.data$time, .data$psi_b, .data$psi_s, .data$psi_g)) |> |
151 | 1x |
dplyr::mutate(dsld = sf_dsld(.data$time, .data$psi_b, .data$psi_s, .data$psi_g)) |> |
152 | 1x |
dplyr::mutate(ttg = sf_ttg(.data$time, .data$psi_b, .data$psi_s, .data$psi_g)) |> |
153 | 1x |
dplyr::mutate(sld_sd = ifelse(object@scaled_variance, .data$mu_sld * object@sigma, object@sigma)) |> |
154 | 1x |
dplyr::mutate(sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd)) |> |
155 | 1x |
dplyr::mutate( |
156 | 1x |
log_haz_link = |
157 | 1x |
(object@link_dsld * .data$dsld) + |
158 | 1x |
(object@link_ttg * .data$ttg) + |
159 | 1x |
(object@link_identity * .data$mu_sld) + |
160 | 1x |
(object@link_growth * log(.data$psi_g)) + |
161 | 1x |
(object@link_shrinkage * log(.data$psi_s)) |
162 |
) |
|
163 |
} |
|
164 | ||
165 | ||
166 |
#' @rdname sampleSubjects |
|
167 |
#' @export |
|
168 |
sampleSubjects.SimLongitudinalSteinFojo <- function(object, subjects_df) { |
|
169 | 1x |
assert_that( |
170 | 1x |
is.factor(subjects_df$study), |
171 | 1x |
is.factor(subjects_df$arm), |
172 | 1x |
length(levels(subjects_df$study)) == length(object@mu_b), |
173 | 1x |
length(levels(subjects_df$arm)) == length(object@mu_s) |
174 |
) |
|
175 | ||
176 | 1x |
res <- subjects_df |> |
177 | 1x |
dplyr::distinct(.data$subject, .data$arm, .data$study) |> |
178 | 1x |
dplyr::mutate(study_idx = as.numeric(.data$study)) |> |
179 | 1x |
dplyr::mutate(arm_idx = as.numeric(.data$arm)) |> |
180 | 1x |
dplyr::mutate(psi_b = stats::rlnorm( |
181 | 1x |
dplyr::n(), |
182 | 1x |
object@mu_b[.data$study_idx], |
183 | 1x |
object@omega_b[.data$study_idx] |
184 |
)) |> |
|
185 | 1x |
dplyr::mutate(psi_s = stats::rlnorm( |
186 | 1x |
dplyr::n(), |
187 | 1x |
object@mu_s[.data$arm_idx], |
188 | 1x |
object@omega_s[.data$arm_idx] |
189 |
)) |> |
|
190 | 1x |
dplyr::mutate(psi_g = stats::rlnorm( |
191 | 1x |
dplyr::n(), |
192 | 1x |
object@mu_g[.data$arm_idx], |
193 | 1x |
object@omega_g[.data$arm_idx] |
194 |
)) |
|
195 | ||
196 | 1x |
res[, c("subject", "arm", "study", "psi_b", "psi_s", "psi_g")] |
197 |
} |
|
198 | ||
199 | ||
200 |
#' Stein-Fojo Functionals |
|
201 |
#' |
|
202 |
#' @param time (`numeric`)\cr time grid. |
|
203 |
#' @param b (`number`)\cr baseline. |
|
204 |
#' @param s (`number`)\cr shrinkage. |
|
205 |
#' @param g (`number`)\cr growth. |
|
206 |
#' |
|
207 |
#' @returns The function results. |
|
208 |
#' @keywords internal |
|
209 |
sf_sld <- function(time, b, s, g) { |
|
210 | 1x |
s <- dplyr::if_else(time >= 0, s, 0) |
211 | 1x |
b * (exp(-s * time) + exp(g * time) - 1) |
212 |
} |
|
213 | ||
214 | ||
215 |
#' @rdname sf_sld |
|
216 |
sf_ttg <- function(time, b, s, g) { |
|
217 | 1x |
t1 <- (log(s) - log(g)) / (g + s) |
218 | 1x |
t1[t1 <= 0] <- 0 |
219 | 1x |
return(t1) |
220 |
} |
|
221 | ||
222 | ||
223 |
#' @rdname sf_sld |
|
224 |
sf_dsld <- function(time, b, s, g) { |
|
225 | 1x |
s <- dplyr::if_else(time >= 0, s, 0) |
226 | 1x |
t1 <- g * exp(g * time) |
227 | 1x |
t2 <- s * exp(-s * time) |
228 | 1x |
return(b * (t1 - t2)) |
229 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include Parameter.R |
|
3 |
#' @include Prior.R |
|
4 |
NULL |
|
5 | ||
6 | ||
7 |
#' ParameterList-Shared |
|
8 |
#' @param object (`ParameterList`) \cr A List of [`Parameter`] Objects. |
|
9 |
#' @param x (`ParameterList`) \cr A List of [`Parameter`] Objects. |
|
10 |
#' @param ... Not Used. |
|
11 |
#' @keywords internal |
|
12 |
#' @name ParameterList-Shared |
|
13 |
NULL |
|
14 | ||
15 | ||
16 |
# ParameterList-class ---- |
|
17 | ||
18 |
#' `ParameterList` |
|
19 |
#' |
|
20 |
#' This class extends the general [`list`] type for containing [`Parameter`] |
|
21 |
#' specifications. |
|
22 |
#' |
|
23 |
#' |
|
24 | ||
25 |
#' @slot parameters (`list`) \cr a list of [`Parameter`] objects |
|
26 |
#' @family ParameterList |
|
27 |
#' @export ParameterList |
|
28 |
#' @exportClass ParameterList |
|
29 |
.ParameterList <- setClass( |
|
30 |
Class = "ParameterList", |
|
31 |
slots = c( |
|
32 |
parameters = "list" |
|
33 |
) |
|
34 |
) |
|
35 |
#' @param ... (`Parameter`)\cr which parameter specifications to include. |
|
36 |
#' @rdname ParameterList-class |
|
37 |
ParameterList <- function(...) { |
|
38 | 290x |
.ParameterList(parameters = list(...)) |
39 |
} |
|
40 | ||
41 |
# ParameterList-validity ---- |
|
42 | ||
43 |
setValidity( |
|
44 |
Class = "ParameterList", |
|
45 |
method = function(object) { |
|
46 |
is_parameters <- vapply(object@parameters, function(x) is(x, "Parameter"), logical(1)) |
|
47 |
if (!all(is_parameters)) { |
|
48 |
return("all elements must be of class 'Parameter'") |
|
49 |
} |
|
50 |
return(TRUE) |
|
51 |
} |
|
52 |
) |
|
53 | ||
54 | ||
55 | ||
56 |
# as.StanModule-ParameterList ---- |
|
57 | ||
58 |
#' `ParameterList` -> `StanModule` |
|
59 |
#' |
|
60 |
#' Converts a [`ParameterList`] object to a [`StanModule`] object |
|
61 |
#' |
|
62 |
#' @inheritParams ParameterList-Shared |
|
63 |
#' |
|
64 |
#' @family ParameterList |
|
65 |
#' @family as.StanModule |
|
66 |
#' @export |
|
67 |
as.StanModule.ParameterList <- function(object, ...) { |
|
68 | 88x |
stan_modules <- lapply( |
69 | 88x |
object@parameters, |
70 | 88x |
as.StanModule |
71 |
) |
|
72 | 88x |
assert_that( |
73 | 88x |
all(vapply(stan_modules, inherits, logical(1), "StanModule")) |
74 |
) |
|
75 | 88x |
Reduce(merge, stan_modules) |
76 |
} |
|
77 | ||
78 | ||
79 | ||
80 |
#' `ParameterList` -> `list` |
|
81 |
#' |
|
82 |
#' Converts a ParameterList object to a list of parameter data values |
|
83 |
#' for a Stan model. |
|
84 |
#' |
|
85 |
#' @inheritParams ParameterList-Shared |
|
86 |
#' |
|
87 |
#' @family as_stan_list |
|
88 |
#' @family ParameterList |
|
89 |
#' @export |
|
90 |
as_stan_list.ParameterList <- function(object, ...) { |
|
91 | 46x |
stan_lists <- lapply( |
92 | 46x |
object@parameters, |
93 | 46x |
as_stan_list |
94 |
) |
|
95 | 46x |
assert_that( |
96 | 46x |
all(vapply(stan_lists, is.list, logical(1))) |
97 |
) |
|
98 | 46x |
Reduce(append, stan_lists) |
99 |
} |
|
100 | ||
101 | ||
102 |
# merge-ParameterList,ParameterList ---- |
|
103 | ||
104 |
#' @rdname merge |
|
105 |
setMethod( |
|
106 |
f = "merge", |
|
107 |
signature = c(x = "ParameterList", y = "ParameterList"), |
|
108 |
definition = function(x, y) { |
|
109 | 68x |
parameters <- append(x@parameters, y@parameters) |
110 | 68x |
do.call(ParameterList, parameters) |
111 |
} |
|
112 |
) |
|
113 | ||
114 |
# as.list-ParameterList ---- |
|
115 | ||
116 |
#' `ParameterList` -> `list` |
|
117 |
#' @description |
|
118 |
#' Returns a named list where each element of the list corresponds |
|
119 |
#' to a Stan modelling block e.g. `data`, `model`, etc. |
|
120 |
#' @inheritParams ParameterList-Shared |
|
121 |
#' @family ParameterList |
|
122 |
#' @export |
|
123 |
as.list.ParameterList <- function(x, ...) { |
|
124 | 87x |
as.list(as.StanModule(x)) |
125 |
} |
|
126 | ||
127 | ||
128 | ||
129 | ||
130 |
#' Parameter-List Getter Functions |
|
131 |
#' @description |
|
132 |
#' Getter functions for the slots of a [`ParameterList`] object |
|
133 |
#' @inheritParams ParameterList-Shared |
|
134 |
#' @family ParameterList |
|
135 |
#' @param n_chains (`integer`) \cr the number of chains. |
|
136 |
#' @name ParameterList-Getter-Methods |
|
137 |
NULL |
|
138 | ||
139 | ||
140 |
#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter names |
|
141 |
#' @export |
|
142 |
names.ParameterList <- function(x) { |
|
143 | 118x |
vapply(x@parameters, names, character(1)) |
144 |
} |
|
145 | ||
146 | ||
147 |
#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter initial values |
|
148 |
#' @export |
|
149 |
initialValues.ParameterList <- function(object, n_chains, ...) { |
|
150 |
# Generate initial values as a list of lists. This is to ensure it is in the required |
|
151 |
# format as specified by cmdstanr see the `init` argument of |
|
152 |
# `help("model-method-sample", "cmdstanr")` for more details |
|
153 | 42x |
lapply( |
154 | 42x |
seq_len(n_chains), |
155 | 42x |
\(i) { |
156 | 948x |
vals <- lapply(object@parameters, initialValues) |
157 | 933x |
name <- vapply(object@parameters, names, character(1)) |
158 | 933x |
names(vals) <- name |
159 | 933x |
vals |
160 |
} |
|
161 |
) |
|
162 |
} |
|
163 | ||
164 | ||
165 |
#' @describeIn ParameterList-Getter-Methods The parameter-list's parameter dimensionality |
|
166 |
#' @export |
|
167 |
size.ParameterList <- function(object) { |
|
168 | 15x |
x <- lapply(object@parameters, size) |
169 | 15x |
names(x) <- names(object) |
170 | 15x |
return(x) |
171 |
} |
|
172 | ||
173 | ||
174 |
#' `ParameterList` -> Printable `Character` |
|
175 |
#' |
|
176 |
#' Converts [`ParameterList`] object into a printable string. |
|
177 |
#' @inheritParams ParameterList-Shared |
|
178 |
#' @family ParameterList |
|
179 |
#' @keywords internal |
|
180 |
#' @export |
|
181 |
as_print_string.ParameterList <- function(object, ...) { |
|
182 | 14x |
x <- vapply(object@parameters, as.character, character(1)) |
183 | 14x |
if (length(x) == 0) { |
184 | ! |
x <- "<No Parameters>" |
185 |
} |
|
186 | 14x |
return(x) |
187 |
} |
|
188 | ||
189 | ||
190 | ||
191 |
#' @rdname show-object |
|
192 |
#' @export |
|
193 |
setMethod( |
|
194 |
f = "show", |
|
195 |
signature = "ParameterList", |
|
196 |
definition = function(object) { |
|
197 | 1x |
chrs <- as_print_string(object) |
198 | 1x |
string <- paste(" ", chrs) |> paste(collapse = "\n") |
199 | 1x |
x <- sprintf("\nParameterList Object:\n%s\n\n", string) |
200 | 1x |
cat(x) |
201 | 1x |
return(object) |
202 |
} |
|
203 |
) |
1 |
#' @include StanModule.R |
|
2 |
#' @include LongitudinalModel.R |
|
3 |
#' @include ParameterList.R |
|
4 |
#' @include LinkComponent.R |
|
5 |
#' @include Prior.R |
|
6 |
NULL |
|
7 | ||
8 | ||
9 |
#' `Link` Function Arguments |
|
10 |
#' |
|
11 |
#' This exists just to contain all the common arguments for [`Link`] methods. |
|
12 |
#' |
|
13 |
#' @param x ([`Link`])\cr a link object. |
|
14 |
#' @param object ([`Link`])\cr a link object. |
|
15 |
#' @param ... Not Used. |
|
16 |
#' |
|
17 |
#' @name Link-Shared |
|
18 |
#' @keywords internal |
|
19 |
NULL |
|
20 | ||
21 | ||
22 | ||
23 |
#' `Link` |
|
24 |
#' |
|
25 |
#' @slot components (`list`)\cr a list of [`LinkComponent`] or [`PromiseLinkComponent`] objects. |
|
26 |
#' @slot resolved (`logical`)\cr indicates if all the `components` have been resolved. |
|
27 |
#' |
|
28 |
#' @param ... ([`LinkComponent`] or [`PromiseLinkComponent`])\cr |
|
29 |
#' an arbitrary number of link components. |
|
30 |
#' |
|
31 |
#' @description |
|
32 |
#' Simple container class to enable the use of multiple link components in a joint model. |
|
33 |
#' Note that the constructor of this object is idempotent e.g. `Link(Link(x)) == Link(x)` |
|
34 |
#' |
|
35 |
#' @examples |
|
36 |
#' Link( |
|
37 |
#' linkDSLD(), |
|
38 |
#' linkTTG() |
|
39 |
#' ) |
|
40 |
#' |
|
41 |
#' @family Link |
|
42 |
#' @name Link-class |
|
43 |
#' @exportClass Link |
|
44 |
.Link <- setClass( |
|
45 |
Class = "Link", |
|
46 |
slots = list( |
|
47 |
components = "list", |
|
48 |
resolved = "logical" |
|
49 |
) |
|
50 |
) |
|
51 | ||
52 |
#' @rdname Link-class |
|
53 |
#' @export |
|
54 |
Link <- function(...) { |
|
55 | 119x |
components <- list(...) |
56 | ||
57 |
# If the input is already a Link object, return it (e.g. implement |
|
58 |
# a constructor that is idempotent) |
|
59 | 119x |
if (length(components) == 1 && is(components[[1]], "Link")) { |
60 | 42x |
return(components[[1]]) |
61 |
} |
|
62 | ||
63 | 77x |
.Link( |
64 | 77x |
components = components, |
65 | 77x |
resolved = !any(vapply(components, \(x) is(x, "PromiseLinkComponent"), logical(1))) |
66 |
) |
|
67 |
} |
|
68 | ||
69 | ||
70 |
#' Resolve any promises |
|
71 |
#' |
|
72 |
#' Loops over all components and ensures that any [`PromiseLinkComponent`] objects |
|
73 |
#' are resolved to [`LinkComponent`] objects. |
|
74 |
#' |
|
75 |
#' @param object ([`Link`])\cr a link object. |
|
76 |
#' @param model ([`LongitudinalModel`])\cr the model object. |
|
77 |
#' @param ... Not Used. |
|
78 |
#' |
|
79 |
#' @export |
|
80 |
resolvePromise.Link <- function(object, model, ...) { |
|
81 | 50x |
if (length(object) == 0) { |
82 | 29x |
return(object) |
83 |
} |
|
84 | 21x |
assert_that( |
85 | 21x |
is(model, "LongitudinalModel"), |
86 | 21x |
msg = "model must be of class `LongitudinalModel`" |
87 |
) |
|
88 | 21x |
do.call(Link, lapply(object@components, resolvePromise, model = model)) |
89 |
} |
|
90 | ||
91 | ||
92 |
setValidity( |
|
93 |
Class = "Link", |
|
94 |
method = function(object) { |
|
95 | ||
96 |
for (i in object@components) { |
|
97 |
if (!(is(i, "LinkComponent") || is(i, "PromiseLinkComponent"))) { |
|
98 |
return("All components must be of class `LinkComponent` or `PromiseLinkComponent`") |
|
99 |
} |
|
100 |
} |
|
101 | ||
102 |
contains_promise <- any( |
|
103 |
vapply( |
|
104 |
object@components, |
|
105 |
\(x) is(x, "PromiseLinkComponent"), |
|
106 |
logical(1) |
|
107 |
) |
|
108 |
) |
|
109 |
if (contains_promise & object@resolved) { |
|
110 |
return("Object cannot be resolved if it contains promises") |
|
111 |
} |
|
112 | ||
113 |
if (length(object@resolved) > 1) { |
|
114 |
return("The `resolved` slot must be a logical scalar") |
|
115 |
} |
|
116 |
return(TRUE) |
|
117 |
} |
|
118 |
) |
|
119 | ||
120 | ||
121 | ||
122 | ||
123 |
#' `Link` -> `StanModule` |
|
124 |
#' |
|
125 |
#' Converts a [`Link`] object to a [`StanModule`] object |
|
126 |
#' |
|
127 |
#' @inheritParams Link-Shared |
|
128 |
#' |
|
129 |
#' @family Link |
|
130 |
#' @family as.StanModule |
|
131 |
#' @export |
|
132 |
as.StanModule.Link <- function(object, ...) { |
|
133 | ||
134 | 88x |
if (length(object@components) == 0) { |
135 | 64x |
return(StanModule("base/link_none.stan")) |
136 |
} |
|
137 | ||
138 | 24x |
keys <- vapply( |
139 | 24x |
object@components, |
140 | 24x |
function(x) x@key, |
141 | 24x |
character(1) |
142 |
) |
|
143 | ||
144 | 24x |
base_stan <- StanModule( |
145 | 24x |
decorated_render( |
146 | 24x |
.x = read_stan("base/link.stan"), |
147 | 24x |
items = as.list(keys) |
148 |
) |
|
149 |
) |
|
150 | ||
151 | 24x |
stan_list <- lapply( |
152 | 24x |
object@components, |
153 | 24x |
as.StanModule |
154 |
) |
|
155 | ||
156 | 24x |
stan <- Reduce( |
157 | 24x |
merge, |
158 | 24x |
append(base_stan, stan_list) |
159 |
) |
|
160 | 24x |
return(stan) |
161 |
} |
|
162 | ||
163 | ||
164 | ||
165 | ||
166 |
#' `Link` -> `list` |
|
167 |
#' |
|
168 |
#' @inheritParams Link-Shared |
|
169 |
#' |
|
170 |
#' @description |
|
171 |
#' Returns a named list where each element of the list corresponds |
|
172 |
#' to a Stan modelling block e.g. `data`, `model`, etc. |
|
173 |
#' |
|
174 |
#' @family Link |
|
175 |
#' @export |
|
176 |
as.list.Link <- function(x, ...) { |
|
177 | 87x |
as.list(as.StanModule(x, ...)) |
178 |
} |
|
179 | ||
180 | ||
181 | ||
182 |
#' @export |
|
183 |
#' @rdname getParameters |
|
184 |
getParameters.Link <- function(object, ...) { |
|
185 | 50x |
parameters_list <- lapply( |
186 | 50x |
object@components, |
187 | 50x |
getParameters, |
188 |
... |
|
189 |
) |
|
190 | 50x |
Reduce( |
191 | 50x |
merge, |
192 | 50x |
parameters_list |
193 |
) |
|
194 |
} |
|
195 | ||
196 | ||
197 |
#' @rdname initialValues |
|
198 |
#' @export |
|
199 |
initialValues.Link <- function(object, ...) { |
|
200 | ! |
unlist( |
201 | ! |
lapply(object@components, initialValues), |
202 | ! |
recursive = FALSE |
203 |
) |
|
204 |
} |
|
205 | ||
206 | ||
207 |
#' `Link` -> `list` |
|
208 |
#' |
|
209 |
#' @inheritParams Link-Shared |
|
210 |
#' |
|
211 |
#' @description |
|
212 |
#' Returns the number of link components within the [`Link`] object |
|
213 |
#' |
|
214 |
#' @family Link |
|
215 |
#' @export |
|
216 |
length.Link <- function(x) { |
|
217 | 103x |
length(x@components) |
218 |
} |
|
219 | ||
220 | ||
221 |
#' @export |
|
222 |
as_print_string.Link <- function(object, ...) { |
|
223 | 2x |
if (length(object) == 0) { |
224 | 1x |
return("\nNo Link") |
225 |
} |
|
226 | ||
227 | 1x |
strings <- vapply(object@components, as_print_string, character(1)) |
228 | ||
229 | 1x |
paste( |
230 | 1x |
c( |
231 | 1x |
"\nLink with the following components/parameters:", |
232 | 1x |
paste0(" ", strings) |
233 |
), |
|
234 | 1x |
collapse = "\n" |
235 |
) |
|
236 |
} |
|
237 | ||
238 | ||
239 |
#' @rdname show-object |
|
240 |
#' @export |
|
241 |
setMethod( |
|
242 |
f = "show", |
|
243 |
signature = "Link", |
|
244 |
definition = function(object) { |
|
245 | 1x |
cat(paste0(as_print_string(object), "\n")) |
246 |
} |
|
247 |
) |
1 | ||
2 | ||
3 |
#' Re-used documentation for `DataSubject` |
|
4 |
#' |
|
5 |
#' @param object ([`DataSubject`]) \cr subject-level data. |
|
6 |
#' @param x ([`DataSubject`]) \cr subject-level data. |
|
7 |
#' @param ... Not Used. |
|
8 |
#' |
|
9 |
#' @name DataSubject-Shared |
|
10 |
#' @keywords internal |
|
11 |
NULL |
|
12 | ||
13 | ||
14 | ||
15 |
#' Subject Data Object and Constructor Function |
|
16 |
#' |
|
17 |
#' The [`DataSubject`] class handles the processing of the subject data for |
|
18 |
#' fitting a [`JointModel`]. |
|
19 |
#' |
|
20 |
#' @slot data (`data.frame`)\cr the subject-level data. |
|
21 |
#' @slot subject (`character`)\cr the name of the variable containing the subject identifier. |
|
22 |
#' @slot arm (`character`)\cr the name of the variable containing the arm identifier. |
|
23 |
#' @slot study (`character`)\cr the name of the variable containing the study identifier. |
|
24 |
#' |
|
25 |
#' @family DataObjects |
|
26 |
#' @family DataSubject |
|
27 |
#' @exportClass DataSubject |
|
28 |
#' @export DataSubject |
|
29 |
.DataSubject <- setClass( |
|
30 |
Class = "DataSubject", |
|
31 |
representation = list( |
|
32 |
data = "data.frame", |
|
33 |
subject = "character", |
|
34 |
arm = "character", |
|
35 |
study = "character" |
|
36 |
) |
|
37 |
) |
|
38 | ||
39 | ||
40 |
#' @param data (`data.frame`)\cr the subject-level data. |
|
41 |
#' @param subject (`character`)\cr the name of the variable containing the subject identifier. |
|
42 |
#' @param arm (`character`)\cr the name of the variable containing the arm identifier. |
|
43 |
#' @param study (`character`)\cr the name of the variable containing the study identifier. |
|
44 |
#' @rdname DataSubject-class |
|
45 |
#' @export |
|
46 |
DataSubject <- function(data, subject, arm, study) { |
|
47 | 349x |
vars <- c(subject, arm, study) |
48 | 349x |
vars_frm_chr <- paste0("~ ", paste(vars, collapse = " + ")) |
49 | 349x |
.DataSubject( |
50 | 349x |
data = remove_missing_rows(data, stats::as.formula(vars_frm_chr)), |
51 | 349x |
subject = subject, |
52 | 349x |
arm = arm, |
53 | 349x |
study = study |
54 |
) |
|
55 |
} |
|
56 | ||
57 |
setValidity( |
|
58 |
"DataSubject", |
|
59 |
method = function(object) { |
|
60 |
if (length(object@subject) != 1) { |
|
61 |
return("`subject` must be a length 1 character") |
|
62 |
} |
|
63 |
if (length(object@arm) != 1) { |
|
64 |
return("`arm` must be a length 1 character") |
|
65 |
} |
|
66 |
if (length(object@study) != 1) { |
|
67 |
return("`study` must be a length 1 character") |
|
68 |
} |
|
69 |
if (nrow(object@data) == 0) { |
|
70 |
return("`data` should not have 0 rows") |
|
71 |
} |
|
72 |
sbj <- object@data[[object@subject]] |
|
73 |
if (!(is(sbj, "character") | is(sbj, "factor"))) { |
|
74 |
return("`data[[subject]]` should be of type character or factor") |
|
75 |
} |
|
76 |
} |
|
77 |
) |
|
78 | ||
79 | ||
80 | ||
81 |
#' @inheritParams DataSubject-Shared |
|
82 |
#' @inherit extractVariableNames description title |
|
83 |
#' |
|
84 |
#' @returns |
|
85 |
#' A list with the following named elements: |
|
86 |
#' - `subject` (`character`)\cr the name of the variable containing the subject identifier. |
|
87 |
#' - `arm` (`character`)\cr the name of the variable containing the arm identifier. |
|
88 |
#' - `study` (`character`) \cr the name of the variable containing the study identifier. |
|
89 |
#' @family DataSubject |
|
90 |
#' @family extractVariableNames |
|
91 |
#' @export |
|
92 |
#' @keywords internal |
|
93 |
extractVariableNames.DataSubject <- function(object) { |
|
94 | 952x |
list( |
95 | 952x |
subject = object@subject, |
96 | 952x |
arm = object@arm, |
97 | 952x |
study = object@study |
98 |
) |
|
99 |
} |
|
100 | ||
101 | ||
102 |
#' @rdname as_stan_list.DataObject |
|
103 |
#' @family DataSubject |
|
104 |
#' @export |
|
105 |
as_stan_list.DataSubject <- function(object, ...) { |
|
106 | 290x |
df <- as.data.frame(harmonise(object)) |
107 | 290x |
vars <- extractVariableNames(object) |
108 | ||
109 | 290x |
unique_arm_study_combos <- unique( |
110 | 290x |
data.frame( |
111 | 290x |
arm = as.numeric(df[[vars$arm]]), |
112 | 290x |
study = as.numeric(df[[vars$study]]) |
113 |
) |
|
114 |
) |
|
115 | ||
116 | 290x |
list( |
117 | 290x |
n_subjects = nrow(df), |
118 | 290x |
n_studies = length(unique(df[[vars$study]])), |
119 | 290x |
n_arms = length(unique(df[[vars$arm]])), |
120 | 290x |
subject_study_index = as.numeric(df[[vars$study]]), |
121 | 290x |
subject_arm_index = as.numeric(df[[vars$arm]]), |
122 | 290x |
subject_to_index = stats::setNames( |
123 | 290x |
seq_len(nlevels(df[[vars$subject]])), |
124 | 290x |
levels(df[[vars$subject]]) |
125 |
), |
|
126 | 290x |
arm_to_index = stats::setNames( |
127 | 290x |
seq_len(nlevels(df[[vars$arm]])), |
128 | 290x |
levels(df[[vars$arm]]) |
129 |
), |
|
130 | 290x |
study_to_index = stats::setNames( |
131 | 290x |
seq_len(nlevels(df[[vars$study]])), |
132 | 290x |
levels(df[[vars$study]]) |
133 |
), |
|
134 | 290x |
pop_arm_index = unique_arm_study_combos$arm, |
135 | 290x |
pop_study_index = unique_arm_study_combos$study |
136 |
) |
|
137 |
} |
|
138 | ||
139 |
#' @rdname as_stan_list.DataObject |
|
140 |
#' @export |
|
141 |
as.list.DataSubject <- function(x, ...) { |
|
142 | ! |
as_stan_list(x, ...) |
143 |
} |
|
144 | ||
145 | ||
146 |
#' `DataSubject` -> `data.frame` |
|
147 |
#' |
|
148 |
#' @inheritParams DataSubject-Shared |
|
149 |
#' |
|
150 |
#' @description |
|
151 |
#' Converts a [`DataSubject`] object into a `data.frame`. |
|
152 |
#' The subject variable is cast to factor. |
|
153 |
#' @family DataSubject |
|
154 |
#' @export |
|
155 |
as.data.frame.DataSubject <- function(x, ...) { |
|
156 | 685x |
x <- x@data |
157 | 685x |
rownames(x) <- NULL |
158 | 685x |
x |
159 |
} |
|
160 | ||
161 | ||
162 | ||
163 |
#' @rdname harmonise |
|
164 |
harmonise.DataSubject <- function(object, ...) { |
|
165 | 319x |
data <- as.data.frame(object) |
166 | 319x |
vars <- extractVariableNames(object) |
167 | 319x |
assert_that( |
168 | 319x |
vars$subject %in% names(data), |
169 | 319x |
vars$arm %in% names(data), |
170 | 319x |
vars$study %in% names(data) |
171 |
) |
|
172 | 319x |
assert_character( |
173 | 319x |
as.character(data[[vars$subject]]), |
174 | 319x |
any.missing = FALSE, |
175 | 319x |
unique = TRUE |
176 |
) |
|
177 | 318x |
data[[vars$subject]] <- factor(data[[vars$subject]]) |
178 | 318x |
data[[vars$arm]] <- factor(data[[vars$arm]]) |
179 | 318x |
data[[vars$study]] <- factor(data[[vars$study]]) |
180 | 318x |
data <- data[order(data[[vars$subject]]), ] |
181 | 318x |
DataSubject( |
182 | 318x |
data = data, |
183 | 318x |
subject = object@subject, |
184 | 318x |
arm = object@arm, |
185 | 318x |
study = object@study |
186 |
) |
|
187 |
} |
|
188 | ||
189 |
#' `DataSubject` -> Printable `Character` |
|
190 |
#' |
|
191 |
#' Converts [`DataSubject`] object into a printable string. |
|
192 |
#' @inheritParams DataSubject-Shared |
|
193 |
#' @family DataSubject |
|
194 |
#' @keywords internal |
|
195 |
#' @param indent (`numeric`)\cr how much white space to prefix the print string with. |
|
196 |
#' @export |
|
197 |
as_print_string.DataSubject <- function(object, indent = 1, ...) { |
|
198 | 2x |
template <- c( |
199 | 2x |
"Subject-Data Object:", |
200 | 2x |
" # of Subjects = %d", |
201 | 2x |
" # of Studies = %d", |
202 | 2x |
" # of Arms = %d" |
203 |
) |
|
204 | 2x |
pad <- rep(" ", indent) |> paste(collapse = "") |
205 | 2x |
template_padded <- paste(pad, template) |
206 | 2x |
vars <- extractVariableNames(object) |
207 | 2x |
sprintf( |
208 | 2x |
paste(template_padded, collapse = "\n"), |
209 | 2x |
nrow(object@data), |
210 | 2x |
length(unique(object@data[[vars$study]])), |
211 | 2x |
length(unique(object@data[[vars$arm]])) |
212 |
) |
|
213 |
} |
|
214 | ||
215 |
#' @rdname show-object |
|
216 |
#' @export |
|
217 |
setMethod( |
|
218 |
f = "show", |
|
219 |
signature = "DataSubject", |
|
220 |
definition = function(object) { |
|
221 | 1x |
string <- as_print_string(object) |
222 | 1x |
cat("\n", string, "\n\n") |
223 |
} |
|
224 |
) |
1 | ||
2 |
#' @include DataJoint.R |
|
3 |
#' @include Quantities.R |
|
4 |
NULL |
|
5 | ||
6 | ||
7 |
#' Re-used documentation for `LongitudinalQuantities` |
|
8 |
#' |
|
9 |
#' @param x ([`LongitudinalQuantities`]) \cr longitudinal quantities. |
|
10 |
#' @param object ([`LongitudinalQuantities`]) \cr longitudinal quantities. |
|
11 |
#' @param ... not used. |
|
12 |
#' |
|
13 |
#' @keywords internal |
|
14 |
#' @name LongitudinalQuantities-Shared |
|
15 |
NULL |
|
16 | ||
17 | ||
18 |
#' `LongitudinalQuantities` Object & Constructor Function |
|
19 |
#' |
|
20 |
#' Constructor function to generate a `LongitudinalQuantities` object. |
|
21 |
#' |
|
22 |
#' @details |
|
23 |
#' Note that unlike [`SurvivalQuantities`], [`LongitudinalQuantities`] does not support |
|
24 |
#' group aggregation. |
|
25 |
#' |
|
26 |
#' @slot quantities (`Quantities`)\cr The sampled quantities. Should contain 1 element per |
|
27 |
#' element of `group` |
|
28 |
#' |
|
29 |
#' @slot data (`DataJoint`)\cr Survival and Longitudinal Data. |
|
30 |
#' |
|
31 |
#' @family LongitudinalQuantities |
|
32 |
#' @name LongitudinalQuantities-class |
|
33 |
#' @export LongitudinalQuantities |
|
34 |
.LongitudinalQuantities <- setClass( |
|
35 |
"LongitudinalQuantities", |
|
36 |
slots = c( |
|
37 |
"quantities" = "Quantities", |
|
38 |
"data" = "DataJoint" |
|
39 |
) |
|
40 |
) |
|
41 | ||
42 |
#' @param object ([`JointModelSamples`]) \cr samples as drawn from a Joint Model. |
|
43 |
#' |
|
44 |
#' @param grid (`Grid`) \cr object that specifies which subjects and time points to calculate the |
|
45 |
#' quantities for. See [Grid-Functions]. |
|
46 |
#' @rdname LongitudinalQuantities-class |
|
47 |
LongitudinalQuantities <- function( |
|
48 |
object, |
|
49 |
grid |
|
50 |
) { |
|
51 | 13x |
assert_class(object, "JointModelSamples") |
52 | 13x |
assert_class(grid, "Grid") |
53 | 13x |
assert_that( |
54 | 13x |
!is(grid, "GridPrediction"), |
55 | 13x |
msg = "`GridPrediction` objects are not supported for `LongitudinalQuantities`" |
56 |
) |
|
57 | ||
58 | 13x |
time_grid <- seq( |
59 | 13x |
from = 0, |
60 | 13x |
to = max(as.list(object@data)[["tumour_time"]]), |
61 | 13x |
length = 201 |
62 |
) |
|
63 | ||
64 | 13x |
grid <- coalesceGridTime(grid, time_grid) |
65 | ||
66 | 13x |
gq <- generateQuantities( |
67 | 13x |
object, |
68 | 13x |
generator = as.QuantityGenerator(grid, object@data), |
69 | 13x |
type = "longitudinal" |
70 |
) |
|
71 | ||
72 | 13x |
quantities_raw <- extract_quantities(gq, type = "lm_identity") |
73 | ||
74 | 13x |
collapser <- as.QuantityCollapser(grid, object@data) |
75 | 13x |
quantities <- collapse_quantities(quantities_raw, collapser) |
76 | ||
77 | 13x |
.LongitudinalQuantities( |
78 | 13x |
quantities = Quantities( |
79 | 13x |
quantities, |
80 | 13x |
groups = collapser@groups, |
81 | 13x |
times = collapser@times |
82 |
), |
|
83 | 13x |
data = object@data |
84 |
) |
|
85 |
} |
|
86 | ||
87 | ||
88 | ||
89 |
#' `as.data.frame` |
|
90 |
#' |
|
91 |
#' @param x ([`LongitudinalQuantities`]) \cr longitudinal quantities. |
|
92 |
#' @param ... not used. |
|
93 |
#' @family LongitudinalQuantities |
|
94 |
#' @export |
|
95 |
as.data.frame.LongitudinalQuantities <- function(x, ...) { |
|
96 | 1x |
as.data.frame(x@quantities) |
97 |
} |
|
98 | ||
99 | ||
100 | ||
101 |
#' summary |
|
102 |
#' |
|
103 |
#' @description |
|
104 |
#' This method returns a `data.frame` of the longitudinal quantities. |
|
105 |
#' |
|
106 |
#' @param conf.level (`numeric`) \cr confidence level of the interval. |
|
107 |
#' @inheritParams LongitudinalQuantities-Shared |
|
108 |
#' |
|
109 |
#' @family LongitudinalQuantities |
|
110 |
#' @family summary |
|
111 |
#' @export |
|
112 |
summary.LongitudinalQuantities <- function( |
|
113 |
object, |
|
114 |
conf.level = 0.95, |
|
115 |
... |
|
116 |
) { |
|
117 | 12x |
summary(object@quantities, conf.level = conf.level) |
118 |
} |
|
119 | ||
120 | ||
121 |
#' Longitudinal Plot |
|
122 |
#' |
|
123 |
#' Internal plotting function to create longitudinal plots |
|
124 |
#' This function predominately exists to extract core logic into its own function |
|
125 |
#' to enable easier unit testing. |
|
126 |
#' |
|
127 |
#' @param data (`data.frame`)\cr summary statistics for longitudinal |
|
128 |
#' value estimates. See details. |
|
129 |
#' @param data_obs (`data.frame`)\cr real observed values to be |
|
130 |
#' overlaid for reference. See details. |
|
131 |
#' @param add_ci (`logical`)\cr Should confidence intervals be added? Default = `TRUE`. |
|
132 |
#' @details |
|
133 |
#' |
|
134 |
#' ## `data` |
|
135 |
#' Should contain the following columns: |
|
136 |
#' - `time` (`numeric`) \cr time point for the summary statistic. |
|
137 |
#' - `group` (`character`) \cr the group in which the observation belongs to. |
|
138 |
#' - `median` (`numeric`) \cr the median value for the summary statistic. |
|
139 |
#' - `upper` (`numeric`) \cr the upper 95% CI for the summary statistic. |
|
140 |
#' - `lower` (`numeric`) \cr the lower 95% CI for the summary statistic. |
|
141 |
#' |
|
142 |
#' ## `data_obs` |
|
143 |
#' Should contain the following columns: |
|
144 |
#' - `time` (`numeric`) \cr the time at which the observed value occurred. |
|
145 |
#' - `Yob` (`numeric`) \cr the real observed value. |
|
146 |
#' - `group` (`character`) \cr which group the event belongs to, should correspond to |
|
147 |
#' values in `data$group`. |
|
148 |
#' @keywords internal |
|
149 |
longitudinal_plot <- function( |
|
150 |
data, |
|
151 |
data_obs = NULL, |
|
152 |
add_ci = FALSE |
|
153 |
) { |
|
154 | 3x |
p <- ggplot() + |
155 | 3x |
geom_line(aes(x = .data$time, y = .data$median), data = data) + |
156 | 3x |
xlab(expression(t)) + |
157 | 3x |
ylab(expression(y)) + |
158 | 3x |
facet_wrap(~group) + |
159 | 3x |
theme_bw() |
160 | ||
161 | 3x |
if (add_ci) { |
162 | 2x |
p <- p + geom_ribbon( |
163 | 2x |
aes(x = .data$time, ymin = .data$lower, ymax = .data$upper), |
164 | 2x |
data = data, |
165 | 2x |
alpha = 0.3 |
166 |
) |
|
167 |
} |
|
168 | ||
169 | 3x |
if (!is.null(data_obs)) { |
170 | 3x |
p <- p + geom_point(aes(x = .data$time, y = .data$Yob), data = data_obs) |
171 |
} |
|
172 | 3x |
return(p) |
173 |
} |
|
174 | ||
175 | ||
176 |
#' Automatic Plotting for `LongitudinalQuantities` |
|
177 |
#' |
|
178 |
#' @param conf.level (`numeric`) \cr confidence level of the interval. If values of `FALSE`, |
|
179 |
#' `NULL` or `0` are provided then confidence regions will not be added to the plot. |
|
180 |
#' @inheritParams LongitudinalQuantities-Shared |
|
181 |
#' |
|
182 |
#' @family LongitudinalQuantities |
|
183 |
#' @family autoplot |
|
184 |
#' @export |
|
185 |
autoplot.LongitudinalQuantities <- function(object, conf.level = 0.95, ...) { |
|
186 | 2x |
include_ci <- !is.null(conf.level) && is.numeric(conf.level) && conf.level > 0 |
187 |
# If CI aren't needed supply a default 0.95 to summary function as it needs |
|
188 |
# a value to be specified to work. |
|
189 | 2x |
conf.level <- if (include_ci) conf.level else 0.95 |
190 | 2x |
data_sum <- summary(object, conf.level = conf.level) |
191 | 2x |
data_obs <- extract_observed_values(object@data) |
192 | 2x |
assert_that( |
193 | 2x |
"group" %in% names(data_sum), |
194 | 2x |
"subject" %in% names(data_obs) |
195 |
) |
|
196 | 2x |
data_obs$group <- data_obs$subject |
197 | 2x |
data_obs <- data_obs[data_obs$group %in% data_sum$group, ] |
198 | 2x |
longitudinal_plot( |
199 | 2x |
data = data_sum, |
200 | 2x |
data_obs = data_obs, |
201 | 2x |
add_ci = include_ci |
202 |
) |
|
203 |
} |
|
204 | ||
205 | ||
206 | ||
207 |
#' @rdname show-object |
|
208 |
#' @export |
|
209 |
setMethod( |
|
210 |
f = "show", |
|
211 |
signature = "LongitudinalQuantities", |
|
212 |
definition = function(object) { |
|
213 | 1x |
template <- c( |
214 | 1x |
"LongitudinalQuantities Object:", |
215 | 1x |
" # of samples = %d", |
216 | 1x |
" # of quantities = %d" |
217 |
) |
|
218 | 1x |
string <- sprintf( |
219 | 1x |
paste(template, collapse = "\n"), |
220 | 1x |
nrow(object@quantities), |
221 | 1x |
ncol(object@quantities) |
222 |
) |
|
223 | 1x |
cat("\n", string, "\n\n") |
224 |
} |
|
225 |
) |
1 |
#' @include LongitudinalModel.R |
|
2 |
#' @include StanModule.R |
|
3 |
#' @include generics.R |
|
4 |
#' @include ParameterList.R |
|
5 |
#' @include Parameter.R |
|
6 |
#' @include Link.R |
|
7 |
NULL |
|
8 | ||
9 | ||
10 |
#' `LongitudinalSteinFojo` |
|
11 |
#' |
|
12 |
#' This class extends the general [`LongitudinalModel`] class for using the |
|
13 |
#' Stein-Fojo model for the longitudinal outcome. |
|
14 |
#' |
|
15 |
#' @section Available Links: |
|
16 |
#' - [`linkDSLD()`] |
|
17 |
#' - [`linkTTG()`] |
|
18 |
#' - [`linkIdentity()`] |
|
19 |
#' - [`linkGrowth()`] |
|
20 |
#' @exportClass LongitudinalSteinFojo |
|
21 |
.LongitudinalSteinFojo <- setClass( |
|
22 |
Class = "LongitudinalSteinFojo", |
|
23 |
contains = "LongitudinalModel" |
|
24 |
) |
|
25 | ||
26 | ||
27 |
#' @rdname LongitudinalSteinFojo-class |
|
28 |
#' |
|
29 |
#' @param mu_bsld (`Prior`)\cr for the mean baseline value `mu_bsld`. |
|
30 |
#' @param mu_ks (`Prior`)\cr for the mean shrinkage rate `mu_ks`. |
|
31 |
#' @param mu_kg (`Prior`)\cr for the mean growth rate `mu_kg`. |
|
32 |
#' |
|
33 |
#' @param omega_bsld (`Prior`)\cr for the baseline value standard deviation `omega_bsld`. |
|
34 |
#' @param omega_ks (`Prior`)\cr for the shrinkage rate standard deviation `omega_ks`. |
|
35 |
#' @param omega_kg (`Prior`)\cr for the growth rate standard deviation `omega_kg`. |
|
36 |
#' |
|
37 |
#' @param sigma (`Prior`)\cr for the variance of the longitudinal values `sigma`. |
|
38 |
#' |
|
39 |
#' @param scaled_variance (`logical`)\cr whether the variance should be scaled by the expected value |
|
40 |
#' (see the "Statistical Specifications" vignette for more details) |
|
41 |
#' @param centred (`logical`)\cr whether to use the centred parameterization. |
|
42 |
#' |
|
43 |
#' @export |
|
44 |
LongitudinalSteinFojo <- function( |
|
45 | ||
46 |
mu_bsld = prior_normal(log(60), 1), |
|
47 |
mu_ks = prior_normal(log(0.5), 1), |
|
48 |
mu_kg = prior_normal(log(0.3), 1), |
|
49 | ||
50 |
omega_bsld = prior_lognormal(log(0.2), 1), |
|
51 |
omega_ks = prior_lognormal(log(0.2), 1), |
|
52 |
omega_kg = prior_lognormal(log(0.2), 1), |
|
53 | ||
54 |
sigma = prior_lognormal(log(0.1), 1), |
|
55 | ||
56 |
scaled_variance = TRUE, |
|
57 |
centred = FALSE |
|
58 |
) { |
|
59 | ||
60 | 16x |
sf_model <- StanModule(decorated_render( |
61 | 16x |
.x = read_stan("lm-stein-fojo/model.stan"), |
62 | 16x |
centred = centred, |
63 | 16x |
scaled_variance = scaled_variance |
64 |
)) |
|
65 | ||
66 |
# Apply constriants |
|
67 | 16x |
omega_bsld <- set_limits(omega_bsld, lower = 0) |
68 | 16x |
omega_ks <- set_limits(omega_ks, lower = 0) |
69 | 16x |
omega_kg <- set_limits(omega_kg, lower = 0) |
70 | 16x |
sigma <- set_limits(sigma, lower = 0) |
71 | ||
72 | 16x |
parameters <- list( |
73 | 16x |
Parameter(name = "lm_sf_mu_bsld", prior = mu_bsld, size = "n_studies"), |
74 | 16x |
Parameter(name = "lm_sf_mu_ks", prior = mu_ks, size = "n_arms"), |
75 | 16x |
Parameter(name = "lm_sf_mu_kg", prior = mu_kg, size = "n_arms"), |
76 | ||
77 | 16x |
Parameter(name = "lm_sf_omega_bsld", prior = omega_bsld, size = "n_studies"), |
78 | 16x |
Parameter(name = "lm_sf_omega_ks", prior = omega_ks, size = "n_arms"), |
79 | 16x |
Parameter(name = "lm_sf_omega_kg", prior = omega_kg, size = "n_arms"), |
80 | ||
81 | 16x |
Parameter(name = "lm_sf_sigma", prior = sigma, size = 1) |
82 |
) |
|
83 | ||
84 | 16x |
assert_flag(centred) |
85 | 16x |
parameters_extra <- if (centred) { |
86 | 3x |
list( |
87 | 3x |
Parameter( |
88 | 3x |
name = "lm_sf_psi_bsld", |
89 | 3x |
prior = prior_init_only(prior_lognormal(median(mu_bsld), median(omega_bsld))), |
90 | 3x |
size = "n_subjects" |
91 |
), |
|
92 | 3x |
Parameter( |
93 | 3x |
name = "lm_sf_psi_ks", |
94 | 3x |
prior = prior_init_only(prior_lognormal(median(mu_ks), median(omega_ks))), |
95 | 3x |
size = "n_subjects" |
96 |
), |
|
97 | 3x |
Parameter( |
98 | 3x |
name = "lm_sf_psi_kg", |
99 | 3x |
prior = prior_init_only(prior_lognormal(median(mu_kg), median(omega_kg))), |
100 | 3x |
size = "n_subjects" |
101 |
) |
|
102 |
) |
|
103 |
} else { |
|
104 | 13x |
list( |
105 | 13x |
Parameter(name = "lm_sf_eta_tilde_bsld", prior = prior_std_normal(), size = "n_subjects"), |
106 | 13x |
Parameter(name = "lm_sf_eta_tilde_ks", prior = prior_std_normal(), size = "n_subjects"), |
107 | 13x |
Parameter(name = "lm_sf_eta_tilde_kg", prior = prior_std_normal(), size = "n_subjects") |
108 |
) |
|
109 |
} |
|
110 | 16x |
parameters <- append(parameters, parameters_extra) |
111 | ||
112 | 16x |
x <- LongitudinalModel( |
113 | 16x |
name = "Stein-Fojo", |
114 | 16x |
stan = merge( |
115 | 16x |
sf_model, |
116 | 16x |
StanModule("lm-stein-fojo/functions.stan") |
117 |
), |
|
118 | 16x |
parameters = do.call(ParameterList, parameters) |
119 |
) |
|
120 | 16x |
.LongitudinalSteinFojo(x) |
121 |
} |
|
122 | ||
123 | ||
124 | ||
125 |
#' @export |
|
126 |
enableGQ.LongitudinalSteinFojo <- function(object, ...) { |
|
127 | 2x |
StanModule("lm-stein-fojo/quantities.stan") |
128 |
} |
|
129 | ||
130 |
#' @export |
|
131 |
enableLink.LongitudinalSteinFojo <- function(object, ...) { |
|
132 | 3x |
object@stan <- merge( |
133 | 3x |
object@stan, |
134 | 3x |
StanModule("lm-stein-fojo/link.stan") |
135 |
) |
|
136 | 3x |
object |
137 |
} |
|
138 | ||
139 |
#' @export |
|
140 |
linkDSLD.LongitudinalSteinFojo <- function(prior = prior_normal(0, 2), model, ...) { |
|
141 | 2x |
LinkComponent( |
142 | 2x |
key = "link_dsld", |
143 | 2x |
stan = StanModule("lm-stein-fojo/link_dsld.stan"), |
144 | 2x |
prior = prior |
145 |
) |
|
146 |
} |
|
147 | ||
148 |
#' @export |
|
149 |
linkTTG.LongitudinalSteinFojo <- function(prior = prior_normal(0, 2), model, ...) { |
|
150 | 1x |
LinkComponent( |
151 | 1x |
key = "link_ttg", |
152 | 1x |
stan = StanModule("lm-stein-fojo/link_ttg.stan"), |
153 | 1x |
prior = prior |
154 |
) |
|
155 |
} |
|
156 | ||
157 |
#' @export |
|
158 |
linkIdentity.LongitudinalSteinFojo <- function(prior = prior_normal(0, 2), model, ...) { |
|
159 | ! |
LinkComponent( |
160 | ! |
key = "link_identity", |
161 | ! |
stan = StanModule("lm-stein-fojo/link_identity.stan"), |
162 | ! |
prior = prior |
163 |
) |
|
164 |
} |
|
165 | ||
166 |
#' @export |
|
167 |
linkGrowth.LongitudinalSteinFojo <- function(prior = prior_normal(0, 2), model, ...) { |
|
168 | 2x |
LinkComponent( |
169 | 2x |
key = "link_growth", |
170 | 2x |
stan = StanModule("lm-stein-fojo/link_growth.stan"), |
171 | 2x |
prior = prior |
172 |
) |
|
173 |
} |
|
174 | ||
175 |
#' @export |
|
176 |
linkShrinkage.LongitudinalSteinFojo <- function(prior = prior_normal(0, 2), model, ...) { |
|
177 | 1x |
LinkComponent( |
178 | 1x |
key = "link_shrinkage", |
179 | 1x |
stan = StanModule("lm-stein-fojo/link_shrinkage.stan"), |
180 | 1x |
prior = prior |
181 |
) |
|
182 |
} |
|
183 | ||
184 |
#' @rdname getPredictionNames |
|
185 |
#' @export |
|
186 |
getPredictionNames.LongitudinalSteinFojo <- function(object, ...) { |
|
187 | 1x |
c("b", "s", "g") |
188 |
} |
1 |
#' @include LongitudinalModel.R |
|
2 |
#' @include StanModule.R |
|
3 |
#' @include generics.R |
|
4 |
#' @include ParameterList.R |
|
5 |
#' @include Parameter.R |
|
6 |
#' @include Link.R |
|
7 |
NULL |
|
8 | ||
9 | ||
10 |
#' `LongitudinalClaretBruno` |
|
11 |
#' |
|
12 |
#' This class extends the general [`LongitudinalModel`] class for using the |
|
13 |
#' Claret-Bruno model for the longitudinal outcome. |
|
14 |
#' |
|
15 |
#' @section Available Links: |
|
16 |
#' - [`linkDSLD()`] |
|
17 |
#' - [`linkTTG()`] |
|
18 |
#' - [`linkIdentity()`] |
|
19 |
#' - [`linkGrowth()`] |
|
20 |
#' @exportClass LongitudinalClaretBruno |
|
21 |
.LongitudinalClaretBruno <- setClass( |
|
22 |
Class = "LongitudinalClaretBruno", |
|
23 |
contains = "LongitudinalModel" |
|
24 |
) |
|
25 | ||
26 | ||
27 |
#' @rdname LongitudinalClaretBruno-class |
|
28 |
#' |
|
29 |
#' @param mu_b (`Prior`)\cr for the mean population baseline sld value. |
|
30 |
#' @param mu_g (`Prior`)\cr for the mean population growth rate. |
|
31 |
#' @param mu_c (`Prior`)\cr for the mean population resistance rate. |
|
32 |
#' @param mu_p (`Prior`)\cr for the mean population growth inhibition |
|
33 |
#' |
|
34 |
#' @param omega_b (`Prior`)\cr for the population standard deviation for the baseline sld value. |
|
35 |
#' @param omega_g (`Prior`)\cr for the population standard deviation for the growth rate. |
|
36 |
#' @param omega_c (`Prior`)\cr for the population standard deviation for the resistance rate. |
|
37 |
#' @param omega_p (`Prior`)\cr for the population standard deviation for the growth inhibition. |
|
38 |
#' |
|
39 |
#' @param sigma (`Prior`)\cr for the variance of the longitudinal values. |
|
40 |
#' |
|
41 |
#' @param centred (`logical`)\cr whether to use the centred parameterization. |
|
42 |
#' @param scaled_variance (`logical`)\cr whether the variance should be scaled by the expected value |
|
43 |
#' (see the "Statistical Specifications" vignette for more details) |
|
44 |
#' |
|
45 |
#' @export |
|
46 |
LongitudinalClaretBruno <- function( |
|
47 | ||
48 |
mu_b = prior_normal(log(60), 0.5), |
|
49 |
mu_g = prior_normal(log(1), 0.5), |
|
50 |
mu_c = prior_normal(log(0.4), 0.5), |
|
51 |
mu_p = prior_normal(log(2), 0.5), |
|
52 | ||
53 |
omega_b = prior_lognormal(log(0.2), 0.5), |
|
54 |
omega_g = prior_lognormal(log(0.2), 0.5), |
|
55 |
omega_c = prior_lognormal(log(0.2), 0.5), |
|
56 |
omega_p = prior_lognormal(log(0.2), 0.5), |
|
57 | ||
58 |
sigma = prior_lognormal(log(0.1), 0.5), |
|
59 | ||
60 |
scaled_variance = TRUE, |
|
61 |
centred = FALSE |
|
62 |
) { |
|
63 | ||
64 | 15x |
sf_model <- StanModule(decorated_render( |
65 | 15x |
.x = read_stan("lm-claret-bruno/model.stan"), |
66 | 15x |
scaled_variance = scaled_variance, |
67 | 15x |
centred = centred |
68 |
)) |
|
69 | ||
70 |
# Apply constraints |
|
71 | 15x |
omega_b <- set_limits(omega_b, lower = 0) |
72 | 15x |
omega_g <- set_limits(omega_g, lower = 0) |
73 | 15x |
omega_c <- set_limits(omega_c, lower = 0) |
74 | 15x |
omega_p <- set_limits(omega_p, lower = 0) |
75 | 15x |
sigma <- set_limits(sigma, lower = 0) |
76 | ||
77 | ||
78 | 15x |
parameters <- list( |
79 | 15x |
Parameter(name = "lm_clbr_mu_b", prior = mu_b, size = "n_studies"), |
80 | 15x |
Parameter(name = "lm_clbr_mu_g", prior = mu_g, size = "n_arms"), |
81 | 15x |
Parameter(name = "lm_clbr_mu_c", prior = mu_c, size = "n_arms"), |
82 | 15x |
Parameter(name = "lm_clbr_mu_p", prior = mu_p, size = "n_arms"), |
83 | ||
84 | 15x |
Parameter(name = "lm_clbr_omega_b", prior = omega_b, size = "n_studies"), |
85 | 15x |
Parameter(name = "lm_clbr_omega_g", prior = omega_g, size = "n_arms"), |
86 | 15x |
Parameter(name = "lm_clbr_omega_c", prior = omega_c, size = "n_arms"), |
87 | 15x |
Parameter(name = "lm_clbr_omega_p", prior = omega_p, size = "n_arms"), |
88 | ||
89 | 15x |
Parameter(name = "lm_clbr_sigma", prior = sigma, size = 1) |
90 |
) |
|
91 | ||
92 | 15x |
assert_flag(centred) |
93 | 15x |
parameters_extra <- if (centred) { |
94 | 2x |
list( |
95 | 2x |
Parameter( |
96 | 2x |
name = "lm_clbr_ind_b", |
97 | 2x |
prior = prior_init_only(prior_lognormal(median(mu_b), median(omega_b))), |
98 | 2x |
size = "n_subjects" |
99 |
), |
|
100 | 2x |
Parameter( |
101 | 2x |
name = "lm_clbr_ind_g", |
102 | 2x |
prior = prior_init_only(prior_lognormal(median(mu_g), median(omega_g))), |
103 | 2x |
size = "n_subjects" |
104 |
), |
|
105 | 2x |
Parameter( |
106 | 2x |
name = "lm_clbr_ind_c", |
107 | 2x |
prior = prior_init_only(prior_lognormal(median(mu_c), median(omega_c))), |
108 | 2x |
size = "n_subjects" |
109 |
), |
|
110 | 2x |
Parameter( |
111 | 2x |
name = "lm_clbr_ind_p", |
112 | 2x |
prior = prior_init_only(prior_lognormal(median(mu_p), median(omega_p))), |
113 | 2x |
size = "n_subjects" |
114 |
) |
|
115 |
) |
|
116 |
} else { |
|
117 | 13x |
list( |
118 | 13x |
Parameter(name = "lm_clbr_eta_b", prior = prior_std_normal(), size = "n_subjects"), |
119 | 13x |
Parameter(name = "lm_clbr_eta_g", prior = prior_std_normal(), size = "n_subjects"), |
120 | 13x |
Parameter(name = "lm_clbr_eta_c", prior = prior_std_normal(), size = "n_subjects"), |
121 | 13x |
Parameter(name = "lm_clbr_eta_p", prior = prior_std_normal(), size = "n_subjects") |
122 |
) |
|
123 |
} |
|
124 | 15x |
parameters <- append(parameters, parameters_extra) |
125 | ||
126 | 15x |
x <- LongitudinalModel( |
127 | 15x |
name = "Claret-Bruno", |
128 | 15x |
stan = merge( |
129 | 15x |
sf_model, |
130 | 15x |
StanModule("lm-claret-bruno/functions.stan") |
131 |
), |
|
132 | 15x |
parameters = do.call(ParameterList, parameters) |
133 |
) |
|
134 | 15x |
.LongitudinalClaretBruno(x) |
135 |
} |
|
136 | ||
137 | ||
138 | ||
139 |
#' @export |
|
140 |
enableLink.LongitudinalClaretBruno <- function(object, ...) { |
|
141 | 2x |
object@stan <- merge( |
142 | 2x |
object@stan, |
143 | 2x |
StanModule("lm-claret-bruno/link.stan") |
144 |
) |
|
145 | 2x |
object |
146 |
} |
|
147 | ||
148 |
#' @export |
|
149 |
linkDSLD.LongitudinalClaretBruno <- function(prior = prior_normal(0, 2), model, ...) { |
|
150 | 2x |
LinkComponent( |
151 | 2x |
key = "link_dsld", |
152 | 2x |
stan = StanModule("lm-claret-bruno/link_dsld.stan"), |
153 | 2x |
prior = prior |
154 |
) |
|
155 |
} |
|
156 | ||
157 |
#' @export |
|
158 |
linkTTG.LongitudinalClaretBruno <- function(prior = prior_normal(0, 2), model, ...) { |
|
159 | 1x |
LinkComponent( |
160 | 1x |
key = "link_ttg", |
161 | 1x |
stan = StanModule("lm-claret-bruno/link_ttg.stan"), |
162 | 1x |
prior = prior |
163 |
) |
|
164 |
} |
|
165 | ||
166 |
#' @export |
|
167 |
linkIdentity.LongitudinalClaretBruno <- function(prior = prior_normal(0, 2), model, ...) { |
|
168 | ! |
LinkComponent( |
169 | ! |
key = "link_identity", |
170 | ! |
stan = StanModule("lm-claret-bruno/link_identity.stan"), |
171 | ! |
prior = prior |
172 |
) |
|
173 |
} |
|
174 | ||
175 |
#' @export |
|
176 |
linkGrowth.LongitudinalClaretBruno <- function(prior = prior_normal(0, 2), model, ...) { |
|
177 | 1x |
LinkComponent( |
178 | 1x |
key = "link_growth", |
179 | 1x |
stan = StanModule("lm-claret-bruno/link_growth.stan"), |
180 | 1x |
prior = prior |
181 |
) |
|
182 |
} |
|
183 | ||
184 |
#' @rdname getPredictionNames |
|
185 |
#' @export |
|
186 |
getPredictionNames.LongitudinalClaretBruno <- function(object, ...) { |
|
187 | ! |
c("b", "g", "c", "p") |
188 |
} |
|
189 | ||
190 |
#' @export |
|
191 |
enableGQ.LongitudinalClaretBruno <- function(object, ...) { |
|
192 | 2x |
StanModule("lm-claret-bruno/quantities.stan") |
193 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include utilities.R |
|
3 |
NULL |
|
4 | ||
5 |
#' Re-used documentation for `DataSurvival` |
|
6 |
#' |
|
7 |
#' @param object ([`DataSurvival`]) \cr Survival Data. |
|
8 |
#' @param x ([`DataSurvival`]) \cr Survival Data. |
|
9 |
#' @param ... Not Used. |
|
10 |
#' |
|
11 |
#' @name DataSurvival-Shared |
|
12 |
#' @keywords internal |
|
13 |
NULL |
|
14 | ||
15 | ||
16 | ||
17 |
# DataSurvival-class ---- |
|
18 | ||
19 |
#' Survival Data Object and Constructor Function |
|
20 |
#' |
|
21 |
#' The [`DataSurvival`] class handles the processing of the survival data |
|
22 |
#' for fitting a [`JointModel`]. |
|
23 |
#' |
|
24 |
#' @slot data (`data.frame`)\cr See Arguments for details. |
|
25 |
#' @slot formula (`formula`)\cr See Arguments for details. |
|
26 |
#' |
|
27 |
#' @family DataObjects |
|
28 |
#' @family DataSurvival |
|
29 |
#' @exportClass DataSurvival |
|
30 |
#' @export DataSurvival |
|
31 |
.DataSurvival <- setClass( |
|
32 |
Class = "DataSurvival", |
|
33 |
representation = list( |
|
34 |
data = "data.frame", |
|
35 |
formula = "formula" |
|
36 |
) |
|
37 |
) |
|
38 | ||
39 |
#' @param data (`data.frame`)\cr the observed time-to-event data. |
|
40 |
#' @param formula (`formula`)\cr of the form `Surv(time, event) ~ cov1 + cov2 + ...`. |
|
41 |
#' See [survival::Surv()] for more details, though note that this package only supports right censoring. |
|
42 |
#' @rdname DataSurvival-class |
|
43 |
DataSurvival <- function(data, formula) { |
|
44 | 44x |
.DataSurvival( |
45 | 44x |
data = remove_missing_rows(data, formula), |
46 | 44x |
formula = formula |
47 |
) |
|
48 |
} |
|
49 | ||
50 |
setValidity( |
|
51 |
"DataSurvival", |
|
52 |
method = function(object) { |
|
53 |
dat <- object@data |
|
54 |
x <- extractVariableNames(object) |
|
55 |
dnames <- names(dat) |
|
56 |
if (nrow(object@data) == 0) { |
|
57 |
return("`data` should not have 0 rows") |
|
58 |
} |
|
59 |
if (length(x$frm) != 3) { |
|
60 |
return("`formula` should be a 2 sided formula") |
|
61 |
} |
|
62 |
LHS <- as.character(x$frm[[2]][[1]]) |
|
63 |
if (!(identical(LHS, "Surv") || identical(LHS, c("::", "survival", "Surv")))) { |
|
64 |
return("The LHS of `formula` should be a call to survival::Surv()") |
|
65 |
} |
|
66 |
for (v in c(x$time, x$event)) { |
|
67 |
if (! v %in% dnames) { |
|
68 |
return(sprintf("Variable %s is not in `data`", x$subject)) |
|
69 |
} |
|
70 |
} |
|
71 |
return(TRUE) |
|
72 |
} |
|
73 |
) |
|
74 | ||
75 | ||
76 | ||
77 | ||
78 | ||
79 | ||
80 |
#' @inheritParams DataSurvival-Shared |
|
81 |
#' @inherit extractVariableNames description title |
|
82 |
#' |
|
83 |
#' @returns |
|
84 |
#' A list with the following named elements: |
|
85 |
#' - `frm` (`formula`)\cr a symbolic description of the survival model to be fitted |
|
86 |
#' - `time` (`character`)\cr The name of the variable containing the event time |
|
87 |
#' - `event` (`character`) \cr The name of the variable containing the event status |
|
88 |
#' @export |
|
89 |
#' @family DataSurvival |
|
90 |
#' @family extractVariableNames |
|
91 |
#' @keywords internal |
|
92 |
extractVariableNames.DataSurvival <- function(object) { |
|
93 | 344x |
list( |
94 | 344x |
frm = object@formula, |
95 | 344x |
time = as.character(object@formula[[2]][[2]]), |
96 | 344x |
event = as.character(object@formula[[2]][[3]]) |
97 |
) |
|
98 |
} |
|
99 | ||
100 | ||
101 |
#' `DataSurvival` -> `data.frame` |
|
102 |
#' |
|
103 |
#' @inheritParams DataSurvival-Shared |
|
104 |
#' |
|
105 |
#' @description |
|
106 |
#' Converts a [`DataSurvival`] object into a `data.frame`. |
|
107 |
#' The subject variable is cast to factor. |
|
108 |
#' @family DataSurvival |
|
109 |
#' @export |
|
110 |
as.data.frame.DataSurvival <- function(x, ...) { |
|
111 | 344x |
x <- x@data |
112 | 344x |
rownames(x) <- NULL |
113 | 344x |
x |
114 |
} |
|
115 | ||
116 | ||
117 | ||
118 |
#' @rdname as_stan_list.DataObject |
|
119 |
#' @family DataSurvival |
|
120 |
#' @export |
|
121 |
as_stan_list.DataSurvival <- function(object, ...) { |
|
122 | 289x |
df <- as.data.frame(object) |
123 | 289x |
vars <- extractVariableNames(object) |
124 | ||
125 | 289x |
design_mat <- stats::model.matrix(vars$frm, data = df) |
126 | 289x |
remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE) |
127 | 289x |
design_mat <- design_mat[, -remove_index, drop = FALSE] |
128 | 289x |
rownames(design_mat) <- NULL |
129 | ||
130 |
# Parameters for efficient integration of hazard function -> survival function |
|
131 | 289x |
gh_parameters <- statmod::gauss.quad( |
132 | 289x |
n = getOption("jmpost.gauss_quad_n"), |
133 | 289x |
kind = "legendre" |
134 |
) |
|
135 | ||
136 | 289x |
model_data <- list( |
137 | 289x |
n_subject_event = sum(df[[vars$event]]), |
138 | 289x |
subject_event_index = which(df[[vars$event]] == 1), |
139 | 289x |
event_times = df[[vars$time]], |
140 | 289x |
p_os_cov_design = ncol(design_mat), |
141 | 289x |
os_cov_design = design_mat, |
142 | 289x |
n_nodes = length(gh_parameters$nodes), |
143 | 289x |
nodes = gh_parameters$nodes, |
144 | 289x |
weights = gh_parameters$weights |
145 |
) |
|
146 | 289x |
return(model_data) |
147 |
} |
|
148 | ||
149 |
#' @rdname as_stan_list.DataObject |
|
150 |
#' @export |
|
151 |
as.list.DataSurvival <- function(x, ...) { |
|
152 | 2x |
as_stan_list(x, ...) |
153 |
} |
|
154 | ||
155 |
#' @rdname harmonise |
|
156 |
harmonise.DataSurvival <- function(object, subject_var, subject_ord, ...) { |
|
157 | ||
158 | 20x |
data <- as.data.frame(object) |
159 | ||
160 | 20x |
assert_string(subject_var, na.ok = FALSE) |
161 | 20x |
assert_character(subject_ord, any.missing = FALSE) |
162 | 20x |
assert_that( |
163 | 20x |
subject_var %in% names(data), |
164 | 20x |
msg = sprintf("Subject variable `%s` not found in `survival`", subject_var) |
165 |
) |
|
166 | 19x |
assert_that( |
167 | 19x |
all(data[[subject_var]] %in% subject_ord), |
168 | 19x |
msg = "There are subjects in `survival` that are not present in `subjects`" |
169 |
) |
|
170 | 18x |
assert_that( |
171 | 18x |
all(subject_ord %in% data[[subject_var]]), |
172 | 18x |
msg = "There are subjects in `subjects` that are not present in `survival`" |
173 |
) |
|
174 | ||
175 | 17x |
data[[subject_var]] <- factor( |
176 | 17x |
as.character(data[[subject_var]]), |
177 | 17x |
levels = subject_ord |
178 |
) |
|
179 | ||
180 | 17x |
data_ord <- data[order(data[[subject_var]]), ] |
181 | ||
182 | 17x |
DataSurvival( |
183 | 17x |
data = data_ord, |
184 | 17x |
formula = object@formula |
185 |
) |
|
186 |
} |
|
187 | ||
188 | ||
189 | ||
190 |
#' `DataSurvival` -> Printable `Character` |
|
191 |
#' |
|
192 |
#' Converts [`DataSurvival`] object into a printable string. |
|
193 |
#' @inheritParams DataSurvival-Shared |
|
194 |
#' @family DataSurvival |
|
195 |
#' @param indent (`numeric`)\cr how much white space to prefix the print string with. |
|
196 |
#' @keywords internal |
|
197 |
#' @export |
|
198 |
as_print_string.DataSurvival <- function(object, indent = 1, ...) { |
|
199 | 2x |
template <- c( |
200 | 2x |
"Survival-Data Object:", |
201 | 2x |
" # of Rows = %d", |
202 | 2x |
" # of Columns = %d", |
203 | 2x |
" # of Events = %d", |
204 | 2x |
" Formula = %s" |
205 |
) |
|
206 | 2x |
pad <- rep(" ", indent) |> paste(collapse = "") |
207 | 2x |
template_padded <- paste(pad, template) |
208 | 2x |
vars <- extractVariableNames(object) |
209 | 2x |
sprintf( |
210 | 2x |
paste(template_padded, collapse = "\n"), |
211 | 2x |
nrow(object@data), |
212 | 2x |
ncol(object@data), |
213 | 2x |
sum(object@data[[vars$event]]), |
214 | 2x |
Reduce(paste, deparse(vars$frm)) |
215 |
) |
|
216 |
} |
|
217 | ||
218 |
#' @rdname show-object |
|
219 |
#' @export |
|
220 |
setMethod( |
|
221 |
f = "show", |
|
222 |
signature = "DataSurvival", |
|
223 |
definition = function(object) { |
|
224 | 1x |
string <- as_print_string(object) |
225 | 1x |
cat("\n", string, "\n\n") |
226 |
} |
|
227 |
) |
|
228 | ||
229 |
#' Build design matrix for prediction data |
|
230 |
#' |
|
231 |
#' @description |
|
232 |
#' This function takes a `DataSurvival` object and a `data.frame` object and generates |
|
233 |
#' a design matrix for the `data.frame` that has the identical structure to the |
|
234 |
#' design matrix of the `DataSurvival` object. |
|
235 |
#' |
|
236 |
#' This is used for predicting new data using a model that was trained on a different |
|
237 |
#' original data source |
|
238 |
#' |
|
239 |
#' @param olddata ([`DataSurvival`]) \cr The original data to be used as a template for the new data |
|
240 |
#' @param newdata ([`data.frame`]) \cr The new data to be used to generate the design matrix |
|
241 |
#' @importFrom stats .checkMFClasses terms delete.response model.frame model.matrix |
|
242 |
#' @importFrom survival coxph |
|
243 |
#' @keywords internal |
|
244 |
mirror_design_matrix <- function(olddata, newdata) { |
|
245 | 7x |
frm <- as_formula(olddata) |
246 |
# Dummy model to generate a bunch of meta information that we can use to |
|
247 |
# re-construct the design matrix |
|
248 | 7x |
model <- coxph(data = as.data.frame(olddata), formula = frm) |
249 | 7x |
model_terms <- delete.response(terms(model)) |
250 | 7x |
model_frame <- model.frame( |
251 | 7x |
model_terms, |
252 | 7x |
newdata, |
253 | 7x |
xlev = model$xlevels |
254 |
) |
|
255 |
if ( |
|
256 | 4x |
!is.null(data_classes <- attr(model_terms, "dataClasses"))) { |
257 | 4x |
.checkMFClasses(data_classes, model_frame) |
258 |
} |
|
259 | 3x |
design_mat <- model.matrix( |
260 | 3x |
model_terms, |
261 | 3x |
model_frame, |
262 | 3x |
contrasts.arg = model$contrasts |
263 |
) |
|
264 | 3x |
remove_index <- grep("(Intercept)", colnames(design_mat), fixed = TRUE) |
265 | 3x |
design_mat <- design_mat[, -remove_index, drop = FALSE] |
266 | 3x |
rownames(design_mat) <- NULL |
267 | 3x |
design_mat |
268 |
} |
|
269 | ||
270 | ||
271 |
#' @export |
|
272 |
as_formula.DataSurvival <- function(x, ...) { |
|
273 | 7x |
vars <- extractVariableNames(x) |
274 | 7x |
vars$frm |
275 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include utilities.R |
|
3 |
NULL |
|
4 | ||
5 |
#' Re-used documentation for `DataLongitudinal` |
|
6 |
#' |
|
7 |
#' @param object ([`DataLongitudinal`]) \cr Longitudinal Data. |
|
8 |
#' @param x ([`DataLongitudinal`]) \cr Longitudinal Data. |
|
9 |
#' @param ... Not Used. |
|
10 |
#' |
|
11 |
#' @name DataLongitudinal-Shared |
|
12 |
#' @keywords internal |
|
13 |
NULL |
|
14 | ||
15 | ||
16 |
# DataLongitudinal-class ---- |
|
17 | ||
18 |
#' Longitudinal Data Object and Constructor Function |
|
19 |
#' |
|
20 |
#' The [`DataLongitudinal`] class handles the processing of the longitudinal data for fitting a Joint Model. |
|
21 |
#' |
|
22 |
#' |
|
23 |
#' @slot data (`data.frame`)\cr See Arguments for details; Note that |
|
24 |
#' observations that contain missing values in the required variables are removed. |
|
25 |
#' @slot formula (`formula`)\cr See Arguments for details |
|
26 |
#' @slot threshold (`numeric`)\cr See Arguments for details |
|
27 |
#' |
|
28 |
#' @family DataObjects |
|
29 |
#' @family DataLongitudinal |
|
30 |
#' @export DataLongitudinal |
|
31 |
#' @exportClass DataLongitudinal |
|
32 |
.DataLongitudinal <- setClass( |
|
33 |
Class = "DataLongitudinal", |
|
34 |
representation = list( |
|
35 |
data = "data.frame", |
|
36 |
formula = "formula", |
|
37 |
threshold = "numeric_or_NULL" |
|
38 |
) |
|
39 |
) |
|
40 | ||
41 | ||
42 |
#' @param data (`data.frame`)\cr containing the observed longitudinal data. |
|
43 |
#' @param formula (`formula`)\cr of the form `outcome ~ time`, and cannot contain any additional covariates. |
|
44 |
#' @param threshold (`numeric`)\cr cut-off value to be used to declare an observation as censored |
|
45 |
#' (below detection limit). |
|
46 |
#' @rdname DataLongitudinal-class |
|
47 |
DataLongitudinal <- function(data, formula, threshold = NULL) { |
|
48 | 45x |
.DataLongitudinal( |
49 | 45x |
data = remove_missing_rows(data, formula), |
50 | 45x |
formula = formula, |
51 | 45x |
threshold = threshold |
52 |
) |
|
53 |
} |
|
54 | ||
55 |
setValidity( |
|
56 |
"DataLongitudinal", |
|
57 |
function(object) { |
|
58 |
if (!length(object@formula) == 3) { |
|
59 |
return("`formula` should be a 2 sided formula") |
|
60 |
} |
|
61 |
if (!length(object@formula[[3]]) == 1) { |
|
62 |
return("the RHS of `formula` should only have 1 value") |
|
63 |
} |
|
64 |
if (!length(object@threshold) <= 1) { |
|
65 |
return("`threshold` must be of length 1 or `NULL`") |
|
66 |
} |
|
67 |
vars <- extractVariableNames(object) |
|
68 |
vars$threshold <- NULL |
|
69 |
vars$frm <- NULL |
|
70 |
for (i in unlist(vars)) { |
|
71 |
if (! i %in% names(object@data)) { |
|
72 |
return(sprintf("Variable `%s` is not in data", i)) |
|
73 |
} |
|
74 |
} |
|
75 |
return(TRUE) |
|
76 |
} |
|
77 |
) |
|
78 | ||
79 | ||
80 | ||
81 | ||
82 |
#' @rdname harmonise |
|
83 |
harmonise.DataLongitudinal <- function(object, subject_var, subject_ord, ...) { |
|
84 | 23x |
data <- as.data.frame(object) |
85 | 23x |
vars <- extractVariableNames(object) |
86 | 23x |
assert_string(subject_var, na.ok = FALSE) |
87 | 23x |
assert_character(subject_ord, any.missing = FALSE) |
88 | 23x |
assert_that( |
89 | 23x |
subject_var %in% names(data), |
90 | 23x |
msg = sprintf("Subject variable `%s` not found in `longitudinal`", subject_var) |
91 |
) |
|
92 | 22x |
assert_that( |
93 | 22x |
all(data[[subject_var]] %in% subject_ord), |
94 | 22x |
msg = "There are subjects in `longitudinal` that are not present in `subjects`" |
95 |
) |
|
96 | 21x |
assert_that( |
97 | 21x |
all(subject_ord %in% data[[subject_var]]), |
98 | 21x |
msg = "There are subjects in `subjects` that are not present in `longitudinal`" |
99 |
) |
|
100 | 20x |
data[[subject_var]] <- factor( |
101 | 20x |
as.character(data[[subject_var]]), |
102 | 20x |
levels = subject_ord |
103 |
) |
|
104 | 20x |
data_re_ord <- order( |
105 | 20x |
data[[subject_var]], |
106 | 20x |
data[[vars$time]], |
107 | 20x |
data[[vars$outcome]] |
108 |
) |
|
109 | 20x |
data_ord <- data[data_re_ord, ] |
110 | 20x |
DataLongitudinal( |
111 | 20x |
data = data_ord, |
112 | 20x |
formula = object@formula, |
113 | 20x |
threshold = object@threshold |
114 |
) |
|
115 |
} |
|
116 | ||
117 | ||
118 | ||
119 |
#' `DataLongitudinal` -> `data.frame` |
|
120 |
#' |
|
121 |
#' @inheritParams DataLongitudinal-Shared |
|
122 |
#' |
|
123 |
#' @description |
|
124 |
#' Converts a [`DataLongitudinal`] object into a `data.frame`. |
|
125 |
#' The subject variable is cast to factor. |
|
126 |
#' @family DataLongitudinal |
|
127 |
#' @export |
|
128 |
as.data.frame.DataLongitudinal <- function(x, ...) { |
|
129 | 325x |
x <- x@data |
130 | 325x |
rownames(x) <- NULL |
131 | 325x |
x |
132 |
} |
|
133 | ||
134 | ||
135 | ||
136 | ||
137 |
#' @inheritParams DataLongitudinal-Shared |
|
138 |
#' @inherit extractVariableNames description title |
|
139 |
#' |
|
140 |
#' @returns |
|
141 |
#' A list with the following named elements: |
|
142 |
#' - `subject` (`character`)\cr The name of the variable containing the subject identifier |
|
143 |
#' - `frm` (`formula`)\cr of the form `outcome ~ time` |
|
144 |
#' - `time` (`character`)\cr The name of the variable containing the outcome time |
|
145 |
#' - `outcome` (`character`)\cr The name of the variable containing the outcome values |
|
146 |
#' - `threshold` (`numeric`)\cr cut-off value to be used to declare an observation as censored |
|
147 |
#' (below detection limit). |
|
148 |
#' @family DataLongitudinal |
|
149 |
#' @family extractVariableNames |
|
150 |
extractVariableNames.DataLongitudinal <- function(object) { |
|
151 | 349x |
list( |
152 | 349x |
frm = object@formula, |
153 | 349x |
time = as.character(object@formula[[3]]), |
154 | 349x |
outcome = as.character(object@formula[[2]]), |
155 | 349x |
threshold = object@threshold |
156 |
) |
|
157 |
} |
|
158 | ||
159 | ||
160 |
#' @rdname as_stan_list.DataObject |
|
161 |
#' @family DataLongitudinal |
|
162 |
#' @export |
|
163 |
as_stan_list.DataLongitudinal <- function(object, subject_var, ...) { |
|
164 | ||
165 | 279x |
df <- as.data.frame(object) |
166 | 279x |
vars <- extractVariableNames(object) |
167 | ||
168 | 279x |
assert_factor(df[[subject_var]]) |
169 | ||
170 | 279x |
mat_sld_index <- stats::model.matrix( |
171 | 279x |
stats::as.formula(paste("~ -1 + ", subject_var)), |
172 | 279x |
data = df |
173 |
) |> |
|
174 | 279x |
t() |
175 | ||
176 | 279x |
adj_threshold <- if (is.null(vars$threshold)) { |
177 | 56x |
-999999 |
178 |
} else { |
|
179 | 223x |
vars$threshold |
180 |
} |
|
181 | ||
182 | 279x |
index_obs <- which(df[[vars$outcome]] >= adj_threshold) |
183 | 279x |
index_cen <- which(df[[vars$outcome]] < adj_threshold) |
184 | ||
185 | 279x |
sparse_mat_inds_all_y <- rstan::extract_sparse_parts(mat_sld_index) |
186 | 279x |
sparse_mat_inds_obs_y <- rstan::extract_sparse_parts(mat_sld_index[, index_obs]) |
187 | 279x |
sparse_mat_inds_cens_y <- rstan::extract_sparse_parts(mat_sld_index[, index_cen]) |
188 | ||
189 | 279x |
model_data <- list( |
190 | 279x |
n_tumour_all = nrow(df), |
191 | ||
192 |
# Number of individuals and tumour assessments. |
|
193 | 279x |
n_tumour_obs = length(index_obs), |
194 | 279x |
n_tumour_cens = length(index_cen), |
195 | ||
196 |
# Index vectors |
|
197 | 279x |
subject_tumour_index = as.numeric(df[[subject_var]]), |
198 | 279x |
subject_tumour_index_obs = index_obs, |
199 | 279x |
subject_tumour_index_cens = index_cen, |
200 | ||
201 | 279x |
tumour_value = df[[vars$outcome]], |
202 | 279x |
tumour_time = df[[vars$time]], |
203 | 279x |
tumour_value_lloq = adj_threshold, |
204 | ||
205 |
# Sparse matrix parameters |
|
206 |
# Matrix of individuals x observed tumour assessments. |
|
207 | 279x |
n_mat_inds_obs_y = c( |
208 | 279x |
length(sparse_mat_inds_obs_y$w), |
209 | 279x |
length(sparse_mat_inds_obs_y$v), |
210 | 279x |
length(sparse_mat_inds_obs_y$u) |
211 |
), |
|
212 | 279x |
w_mat_inds_obs_y = sparse_mat_inds_obs_y$w, |
213 | 279x |
v_mat_inds_obs_y = sparse_mat_inds_obs_y$v, |
214 | 279x |
u_mat_inds_obs_y = sparse_mat_inds_obs_y$u, |
215 | ||
216 |
# Matrix of individuals x censored tumour assessments. |
|
217 | 279x |
n_mat_inds_cens_y = c( |
218 | 279x |
length(sparse_mat_inds_cens_y$w), |
219 | 279x |
length(sparse_mat_inds_cens_y$v), |
220 | 279x |
length(sparse_mat_inds_cens_y$u) |
221 |
), |
|
222 | 279x |
w_mat_inds_cens_y = sparse_mat_inds_cens_y$w, |
223 | 279x |
v_mat_inds_cens_y = sparse_mat_inds_cens_y$v, |
224 | 279x |
u_mat_inds_cens_y = sparse_mat_inds_cens_y$u, |
225 | ||
226 |
# Matrix of all individuals tumour assessments |
|
227 | 279x |
n_mat_inds_all_y = c( |
228 | 279x |
length(sparse_mat_inds_all_y$w), |
229 | 279x |
length(sparse_mat_inds_all_y$v), |
230 | 279x |
length(sparse_mat_inds_all_y$u) |
231 |
), |
|
232 | 279x |
w_mat_inds_all_y = sparse_mat_inds_all_y$w, |
233 | 279x |
v_mat_inds_all_y = sparse_mat_inds_all_y$v, |
234 | 279x |
u_mat_inds_all_y = sparse_mat_inds_all_y$u |
235 | ||
236 |
) |
|
237 | ||
238 | 279x |
return(model_data) |
239 |
} |
|
240 | ||
241 |
#' @rdname as_stan_list.DataObject |
|
242 |
#' @export |
|
243 |
as.list.DataLongitudinal <- function(x, ...) { |
|
244 | ! |
as_stan_list(x, ...) |
245 |
} |
|
246 | ||
247 | ||
248 |
#' `DataLongitudinal` -> Printable `Character` |
|
249 |
#' |
|
250 |
#' Converts [`DataLongitudinal`] object into a printable string. |
|
251 |
#' @inheritParams DataLongitudinal-Shared |
|
252 |
#' @family DataLongitudinal |
|
253 |
#' @param indent (`numeric`)\cr how much white space to prefix the print string with. |
|
254 |
#' @keywords internal |
|
255 |
#' @export |
|
256 |
as_print_string.DataLongitudinal <- function(object, indent = 1, ...) { |
|
257 | 2x |
template <- c( |
258 | 2x |
"Longitudinal-Data Object:", |
259 | 2x |
" # of Rows = %d", |
260 | 2x |
" # of Columns = %d", |
261 | 2x |
" # of Cen-Obvs = %d", |
262 | 2x |
" Formula = %s" |
263 |
) |
|
264 | 2x |
pad <- rep(" ", indent) |> paste(collapse = "") |
265 | 2x |
template_padded <- paste(pad, template) |
266 | 2x |
vars <- extractVariableNames(object) |
267 | 2x |
sprintf( |
268 | 2x |
paste(template_padded, collapse = "\n"), |
269 | 2x |
nrow(object@data), |
270 | 2x |
ncol(object@data), |
271 | 2x |
sum(object@data[[vars$outcome]] < vars$threshold), |
272 | 2x |
Reduce(paste, deparse(vars$frm)) |
273 |
) |
|
274 |
} |
|
275 | ||
276 |
#' @rdname show-object |
|
277 |
#' @export |
|
278 |
setMethod( |
|
279 |
f = "show", |
|
280 |
signature = "DataLongitudinal", |
|
281 |
definition = function(object) { |
|
282 | 1x |
string <- as_print_string(object) |
283 | 1x |
cat("\n", string, "\n\n") |
284 |
} |
|
285 |
) |
1 |
#' @include Grid.R |
|
2 |
#' @include GridFixed.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 |
#' @rdname Grid-Dev |
|
7 |
.GridGrouped <- setClass( |
|
8 |
"GridGrouped", |
|
9 |
contains = "Grid", |
|
10 |
slots = c( |
|
11 |
"groups" = "list", |
|
12 |
"times" = "numeric_or_NULL" |
|
13 |
) |
|
14 |
) |
|
15 | ||
16 |
#' @rdname Grid-Functions |
|
17 |
#' @export |
|
18 |
GridGrouped <- function(groups, times = NULL) { |
|
19 | 13x |
.GridGrouped( |
20 | 13x |
groups = groups, |
21 | 13x |
times = times |
22 |
) |
|
23 |
} |
|
24 | ||
25 | ||
26 |
setValidity( |
|
27 |
"GridGrouped", |
|
28 |
function(object) { |
|
29 |
if (!all(vapply(object@groups, is.character, logical(1)))) { |
|
30 |
return("Each element of `groups` must be a character vector") |
|
31 |
} |
|
32 |
gnames <- names(object@groups) |
|
33 |
gnames <- gnames[!is.na(gnames) & gnames != ""] |
|
34 |
if (length(gnames) != length(object@groups)) { |
|
35 |
return("Each element of `groups` must be named") |
|
36 |
} |
|
37 |
return(TRUE) |
|
38 |
} |
|
39 |
) |
|
40 | ||
41 | ||
42 |
#' @rdname Quant-Dev |
|
43 |
#' @export |
|
44 |
as.QuantityGenerator.GridGrouped <- function(object, data, ...) { |
|
45 | 17x |
assert_class(data, "DataJoint") |
46 | 17x |
data_list <- as.list(data) |
47 | 17x |
subjects_unique <- unique(unlist(object@groups)) |
48 | 17x |
assert_that( |
49 | 17x |
all(subjects_unique %in% names(data_list$subject_to_index)) |
50 |
) |
|
51 | 17x |
as.QuantityGenerator( |
52 | 17x |
GridFixed( |
53 | 17x |
times = object@times, |
54 | 17x |
subjects = subjects_unique |
55 |
), |
|
56 | 17x |
data = data |
57 |
) |
|
58 |
} |
|
59 | ||
60 | ||
61 |
#' @rdname Quant-Dev |
|
62 |
#' @export |
|
63 |
as.QuantityCollapser.GridGrouped <- function(object, data, ...) { |
|
64 | 8x |
assert_class(data, "DataJoint") |
65 | 8x |
data_list <- as.list(data) |
66 | 8x |
assert_that( |
67 | 8x |
all(unique(unlist(object@groups)) %in% names(data_list$subject_to_index)) |
68 |
) |
|
69 | ||
70 | 8x |
validate_time_grid(object@times) |
71 | ||
72 | 8x |
group_grid <- expand.grid( |
73 | 8x |
group = names(object@groups), |
74 | 8x |
time = object@times, |
75 | 8x |
stringsAsFactors = FALSE |
76 |
) |
|
77 | ||
78 | 8x |
generator <- as.QuantityGenerator(object, data) |
79 | ||
80 | 8x |
select_indexes <- mapply( |
81 | 8x |
function(group, time) { |
82 | 490x |
correct_subject <- generator@subjects %in% object@groups[[group]] |
83 | 490x |
correct_time <- generator@times == time |
84 | 490x |
seq_along(correct_time)[correct_subject & correct_time] |
85 |
}, |
|
86 | 8x |
group_grid$group, |
87 | 8x |
group_grid$time, |
88 | 8x |
SIMPLIFY = FALSE |
89 |
) |
|
90 | 8x |
names(select_indexes) <- NULL |
91 | ||
92 | 8x |
QuantityCollapser( |
93 | 8x |
times = group_grid$time, |
94 | 8x |
groups = group_grid$group, |
95 | 8x |
indexes = select_indexes |
96 |
) |
|
97 |
} |
|
98 | ||
99 |
#' @export |
|
100 |
as.list.GridGrouped <- function(x, ...) { |
|
101 | 1x |
x@groups |
102 |
} |
|
103 | ||
104 |
#' @rdname coalesceGridTime |
|
105 |
#' @export |
|
106 |
coalesceGridTime.GridGrouped <- function(object, times, ...) { |
|
107 | 10x |
if (is.null(object@times)) { |
108 | 2x |
object <- GridGrouped( |
109 | 2x |
groups = object@groups, |
110 | 2x |
times = times |
111 |
) |
|
112 |
} |
|
113 | 10x |
object |
114 |
} |
1 |
# "missing" = no argument provided |
|
2 |
# "NULL" = explicit NULL |
|
3 |
setClassUnion("empty", c("missing", "NULL")) |
|
4 |
setClassUnion("numeric_or_NULL", c("numeric", "NULL")) |
|
5 |
setClassUnion("character_or_NULL", c("character", "NULL")) |
|
6 | ||
7 |
# merge ---- |
|
8 | ||
9 |
#' `merge` |
|
10 |
#' |
|
11 |
#' Merge two `StanModule` or `ParameterList` objects. |
|
12 |
#' |
|
13 |
#' @param x first module. |
|
14 |
#' @param y second module. |
|
15 |
#' @param ... additional arguments. |
|
16 |
#' |
|
17 |
#' @export |
|
18 |
# Needs to be S4 for multiple dispatch ! |
|
19 |
setGeneric( |
|
20 |
name = "merge", |
|
21 |
def = function(x, y, ...) standardGeneric("merge") |
|
22 |
) |
|
23 | ||
24 | ||
25 |
# show ---- |
|
26 | ||
27 |
#' Printing of Different Classes |
|
28 |
#' |
|
29 |
#' These methods print objects of different classes. |
|
30 |
#' |
|
31 |
#' @name show |
|
32 |
#' @aliases show |
|
33 |
#' |
|
34 |
#' @param object what to print. |
|
35 |
#' |
|
36 |
#' @export |
|
37 |
NULL |
|
38 | ||
39 | ||
40 |
# write_stan ---- |
|
41 | ||
42 |
#' `write_stan` |
|
43 |
#' |
|
44 |
#' Write the Stan code for a Stan module. |
|
45 |
#' |
|
46 |
#' @param object the module. |
|
47 |
#' @param destination (`character` or `connection`)\cr Where to write stan code to. |
|
48 |
#' @param ... Additional arguments |
|
49 |
#' |
|
50 |
#' @export |
|
51 |
write_stan <- function(object, destination, ...) { |
|
52 | ! |
UseMethod("write_stan") |
53 |
} |
|
54 | ||
55 |
# compileStanModel ---- |
|
56 | ||
57 |
#' `compileStanModel` |
|
58 |
#' |
|
59 |
#' Compile the Stan module. |
|
60 |
#' |
|
61 |
#' @param object the module. |
|
62 |
#' |
|
63 |
#' @export |
|
64 |
compileStanModel <- function(object) { |
|
65 | 59x |
UseMethod("compileStanModel") |
66 |
} |
|
67 | ||
68 | ||
69 |
# sampleStanModel ---- |
|
70 | ||
71 |
#' `sampleStanModel` |
|
72 |
#' |
|
73 |
#' Sample from a Stan Module. |
|
74 |
#' |
|
75 |
#' @param object the module. |
|
76 |
#' @param ... additional arguments. |
|
77 |
#' |
|
78 |
#' @export |
|
79 |
sampleStanModel <- function(object, ...) { |
|
80 | 14x |
UseMethod("sampleStanModel") |
81 |
} |
|
82 | ||
83 | ||
84 |
# as.StanModule ---- |
|
85 | ||
86 |
#' `as.StanModule` |
|
87 |
#' |
|
88 |
#' Converts an object into a [`StanModule`]. |
|
89 |
#' |
|
90 |
#' @param object what to convert. |
|
91 |
#' @param ... additional options. |
|
92 |
#' @family as.StanModule |
|
93 |
#' @keywords internal |
|
94 |
as.StanModule <- function(object, ...) { |
|
95 | 2127x |
UseMethod("as.StanModule") |
96 |
} |
|
97 | ||
98 | ||
99 | ||
100 |
#' `getParameters` |
|
101 |
#' |
|
102 |
#' Extract any modelling parameters as a [`ParameterList`] object |
|
103 |
#' from a model. |
|
104 |
#' |
|
105 |
#' @param object where to obtain the parameters from. |
|
106 |
#' @param ... additional options. |
|
107 |
#' |
|
108 |
#' @export |
|
109 |
getParameters <- function(object, ...) { |
|
110 | 188x |
UseMethod("getParameters") |
111 |
} |
|
112 | ||
113 | ||
114 |
# extractVariableNames ---- |
|
115 | ||
116 |
#' Extract Mapping to Standardised Variable Names |
|
117 |
#' |
|
118 |
#' @description |
|
119 |
#' Extract a `list` that maps the variable names in a user-defined |
|
120 |
#' `data.frame` to standardised values. |
|
121 |
#' |
|
122 |
#' @param object the data object. |
|
123 |
#' @family extractVariableNames |
|
124 |
#' @keywords internal |
|
125 |
extractVariableNames <- function(object) { |
|
126 | 1645x |
UseMethod("extractVariableNames") |
127 |
} |
|
128 | ||
129 | ||
130 | ||
131 |
# initialValues ---- |
|
132 | ||
133 |
#' `initialValues` |
|
134 |
#' |
|
135 |
#' Obtain the `list` of initial values to be passed to the Stan sampler. |
|
136 |
#' |
|
137 |
#' @param object where to get the initial values from. |
|
138 |
#' @param n_chains the number of initial values to generate. See details. |
|
139 |
#' @param ... Not currently used. |
|
140 |
#' |
|
141 |
#' @details |
|
142 |
#' There are multiple ways of specifying initial values to Stan, see the `init` argument |
|
143 |
#' in [cmdstanr::model-method-sample] for full details. Within this package we supply |
|
144 |
#' initial values via a list of lists where each inner list contains the initial values |
|
145 |
#' for a single chain. As such the `n_chains` argument specifies the number of inner lists |
|
146 |
#' to generate. |
|
147 |
#' |
|
148 |
#' See the Vignette for further details of how to specify initial values. |
|
149 |
#' |
|
150 |
#' @export |
|
151 |
initialValues <- function(object, ...) { |
|
152 | 80479x |
UseMethod("initialValues") |
153 |
} |
|
154 | ||
155 | ||
156 |
# size ---- |
|
157 | ||
158 |
#' `size` |
|
159 |
#' |
|
160 |
#' Obtain the `list` of parameter sizes. |
|
161 |
#' |
|
162 |
#' @param object where to get the parameter sizes from. |
|
163 |
#' |
|
164 |
#' @keywords internal |
|
165 |
size <- function(object) { |
|
166 | 125x |
UseMethod("size") |
167 |
} |
|
168 | ||
169 | ||
170 |
# generateQuantities ---- |
|
171 | ||
172 |
#' `generateQuantities` |
|
173 |
#' |
|
174 |
#' Obtain the generated quantities from a Stan Model. |
|
175 |
#' |
|
176 |
#' @param object object to obtain generated quantities from |
|
177 |
#' @param ... additional options. |
|
178 |
#' |
|
179 |
#' @export |
|
180 |
generateQuantities <- function(object, ...) { |
|
181 | 31x |
UseMethod("generateQuantities") |
182 |
} |
|
183 | ||
184 | ||
185 |
#' Prepare Data Object |
|
186 |
#' |
|
187 |
#' @param object (`DataSubject` or `DataLongitudinal` or `DataSurvival`) \cr data object to "harmonise" |
|
188 |
#' @param subject_var (`character`) \cr the name of the variable containing the subject identifier. |
|
189 |
#' @param subject_ord (`character`) \cr the expected levels (in order) of the subject identifier. |
|
190 |
#' @param ... not used. |
|
191 |
#' |
|
192 |
#' @details |
|
193 |
#' This utility function prepares the datasets in the data objects in order to ensure they |
|
194 |
#' are consistent and compatible with each other. |
|
195 |
#' |
|
196 |
#' In particular it ensures that the `subject` variable, as specified by `DataSubject`, |
|
197 |
#' is available in `DataLongitudinal` and `DataSurvival` and that all levels are present |
|
198 |
#' in all 3 data objects. |
|
199 |
#' |
|
200 |
#' It also sorts the datasets to ensure that indexes are consistent e.g. index 1 for |
|
201 |
#' `DataSubject@data` corresponds to the same subject as index 1 for `DataSurvival@data`. |
|
202 |
#' For `DataLongitudinal` the data is additionally sorted by time and outcome value. |
|
203 |
#' |
|
204 |
#' @seealso [`DataJoint`], [`DataSurvival`], [`DataSubject`], [`DataLongitudinal`] |
|
205 |
#' |
|
206 |
#' @keywords internal |
|
207 |
#' @return Returns the original object but with the data standardised (see details) |
|
208 |
harmonise <- function(object, ...) { |
|
209 | 372x |
UseMethod("harmonise") |
210 |
} |
|
211 | ||
212 | ||
213 |
#' @rdname harmonise |
|
214 |
harmonise.default <- function(object, ...) { |
|
215 | 10x |
NULL |
216 |
} |
|
217 | ||
218 | ||
219 |
#' `as_stan_list` |
|
220 |
#' |
|
221 |
#' @description |
|
222 |
#' Extracts a list of data elements from an object to be used as input |
|
223 |
#' to a Stan Model |
|
224 |
#' |
|
225 |
#' @param object to be converted. |
|
226 |
#' @param ... additional options. |
|
227 |
#' |
|
228 |
#' @family as_stan_list |
|
229 |
#' @export |
|
230 |
as_stan_list <- function(object, ...) { |
|
231 | 1992x |
UseMethod("as_stan_list") |
232 |
} |
|
233 | ||
234 |
#' @rdname as_stan_list |
|
235 |
#' @export |
|
236 |
as_stan_list.default <- function(object, ...) { |
|
237 | 18x |
NULL |
238 |
} |
|
239 | ||
240 | ||
241 |
#' `as_print_string` |
|
242 |
#' |
|
243 |
#' @description |
|
244 |
#' Returns the character representation of an object which is suitable |
|
245 |
#' for printing to the console |
|
246 |
#' |
|
247 |
#' @param object to be converted to string. |
|
248 |
#' @param ... additional options. |
|
249 |
#' |
|
250 |
#' @family as_print_string |
|
251 |
#' @keywords internal |
|
252 |
as_print_string <- function(object, ...) { |
|
253 | 56x |
UseMethod("as_print_string") |
254 |
} |
|
255 | ||
256 |
#' Show an Object |
|
257 |
#' |
|
258 |
#' Prints an object to the console. |
|
259 |
#' |
|
260 |
#' @param object Object to be printed |
|
261 |
#' |
|
262 |
#' @name show-object |
|
263 |
NULL |
|
264 | ||
265 | ||
266 | ||
267 |
#' `brierScore` |
|
268 |
#' |
|
269 |
#' @description |
|
270 |
#' Returns the Brier Score for a given model |
|
271 |
#' |
|
272 |
#' @param object to calculate Brier Score for. |
|
273 |
#' @param ... additional options. |
|
274 |
#' |
|
275 |
#' @family brierScore |
|
276 |
#' @export |
|
277 |
brierScore <- function(object, ...) { |
|
278 | 1x |
UseMethod("brierScore") |
279 |
} |
|
280 | ||
281 | ||
282 | ||
283 |
#' Generate Simulated Observations |
|
284 |
#' |
|
285 |
#' @param object (`SimLongitudinal` or `SimSurvival`) \cr object to generate observations from. |
|
286 |
#' @param times_df (`data.frame`) \cr the times at which to generate observations. See details. |
|
287 |
#' |
|
288 |
#' @details |
|
289 |
#' The `times_df` argument should be a `data.frame` as created by `sampleSubjects` but |
|
290 |
#' replicated for each time point at which observations are to be generated. That is if you want |
|
291 |
#' to generate observations for times `c(0, 1, 2, 3)` then `times_df` should be created as: |
|
292 |
#' ``` |
|
293 |
#' subject_dat <- sampleSubjects(object, ...) |
|
294 |
#' times_df <- tidyr::expand_grid( |
|
295 |
#' subject_dat, |
|
296 |
#' time = c(0, 1, 2, 3) |
|
297 |
#' ) |
|
298 |
#' ``` |
|
299 |
#' |
|
300 |
#' @export |
|
301 |
sampleObservations <- function(object, times_df) { |
|
302 | 61x |
UseMethod("sampleObservations") |
303 |
} |
|
304 | ||
305 | ||
306 |
#' Generate Simulated Subjects |
|
307 |
#' |
|
308 |
#' @param object (`SimLongitudinal` or `SimSurvival`) \cr object to generate subjects from. |
|
309 |
#' @param subjects_df (`data.frame`) \cr the subjects to generate observations for. See details. |
|
310 |
#' |
|
311 |
#' @details |
|
312 |
#' The `subjects_df` argument should be a `data.frame` with 1 row per desired subject to create |
|
313 |
#' with the following columns: |
|
314 |
#' - `study` (`factor`) the study identifier. |
|
315 |
#' - `arm` (`factor`) the treatment arm identifier. |
|
316 |
#' - `subject` (`character`) the subject identifier. |
|
317 |
#' |
|
318 |
#' This method takes care of generating all the individual subject data required for the |
|
319 |
#' [`sampleObservations`] method to generate the observations. |
|
320 |
#' @export |
|
321 |
sampleSubjects <- function(object, subjects_df) { |
|
322 | 42x |
UseMethod("sampleSubjects") |
323 |
} |
|
324 | ||
325 | ||
326 |
#' Generate time windows for evaluating a hazard function |
|
327 |
#' |
|
328 |
#' @param object (`SurvivalModel`) \cr object to generate time windows for. |
|
329 |
#' @param ... Not used. |
|
330 |
#' |
|
331 |
hazardWindows <- function(object, ...) { |
|
332 | 19x |
UseMethod("hazardWindows") |
333 |
} |
|
334 | ||
335 |
#' @rdname Quant-Dev |
|
336 |
#' @export |
|
337 |
as.QuantityGenerator <- function(object, ...) { |
|
338 | 98x |
UseMethod("as.QuantityGenerator") |
339 |
} |
|
340 | ||
341 |
#' @rdname Quant-Dev |
|
342 |
#' @export |
|
343 |
as.QuantityCollapser <- function(object, ...) { |
|
344 | 37x |
UseMethod("as.QuantityCollapser") |
345 |
} |
|
346 | ||
347 | ||
348 |
#' Coalesce Time |
|
349 |
#' |
|
350 |
#' @param object ([`Grid`]) \cr object to coalesce time for. |
|
351 |
#' @param times (`numeric`) \cr the times to coalesce to. |
|
352 |
#' @param ... Not used |
|
353 |
#' |
|
354 |
#' Method used to replace NULL times on grid objects (if appropriate) |
|
355 |
#' |
|
356 |
#' @keywords internal |
|
357 |
coalesceGridTime <- function(object, times, ...) { |
|
358 | 37x |
UseMethod("coalesceGridTime") |
359 |
} |
|
360 |
#' @export |
|
361 |
coalesceGridTime.default <- function(object, times, ...) { |
|
362 | 2x |
object |
363 |
} |
|
364 | ||
365 | ||
366 |
#' Resolve a Promise |
|
367 |
#' |
|
368 |
#' @param object (`ANY`)\cr an object to resolve. |
|
369 |
#' @param ... (`ANY`)\cr additional arguments. |
|
370 |
#' |
|
371 |
#' If `object` is not a promise will just return itself else will resolve the promise |
|
372 |
#' and return the promised object. |
|
373 |
#' |
|
374 |
#' @export |
|
375 |
resolvePromise <- function(object, ...) { |
|
376 | 90x |
UseMethod("resolvePromise") |
377 |
} |
|
378 | ||
379 |
#' @rdname resolvePromise |
|
380 |
#' @export |
|
381 |
resolvePromise.default <- function(object, ...) { |
|
382 | ! |
object |
383 |
} |
|
384 | ||
385 |
#' Enable Link Generic |
|
386 |
#' |
|
387 |
#' @param object ([`LongitudinalModel`])\cr to enable link for. |
|
388 |
#' @param ... Not used. |
|
389 |
#' |
|
390 |
#' Optional hook method that is called on a [`LongitudinalModel`] only if a link method |
|
391 |
#' is provided to [`JointModel`]. This can be used to allow the model to include any |
|
392 |
#' optional stan code that is only required if there are links present. |
|
393 |
#' |
|
394 |
#' @return [`LongitudinalModel`] object |
|
395 |
#' |
|
396 |
#' @export |
|
397 |
enableLink <- function(object, ...) { |
|
398 | 20x |
UseMethod("enableLink") |
399 |
} |
|
400 |
#' @export |
|
401 |
enableLink.default <- function(object, ...) { |
|
402 | ! |
object |
403 |
} |
|
404 | ||
405 | ||
406 |
#' Enable Generated Quantities Generic |
|
407 |
#' |
|
408 |
#' @param object ([`StanModel`])\cr to enable generated quantities for. |
|
409 |
#' @param ... Not used. |
|
410 |
#' |
|
411 |
#' Optional hook method that is called on a [`StanModel`] if attempting to use |
|
412 |
#' either [`LongitudinalQuantities`] or [`SurvivalQuantities`] |
|
413 |
#' |
|
414 |
#' @return [`StanModule`] object |
|
415 |
#' |
|
416 |
#' @export |
|
417 |
enableGQ <- function(object, ...) { |
|
418 | 114x |
UseMethod("enableGQ") |
419 |
} |
|
420 |
#' @export |
|
421 |
enableGQ.default <- function(object, ...) { |
|
422 | 39x |
StanModule() |
423 |
} |
|
424 | ||
425 | ||
426 | ||
427 |
#' Get Prediction Names |
|
428 |
#' |
|
429 |
#' Utility function that returns the names of the required parameters for predicting |
|
430 |
#' survival quantities with [`GridPrediction`]. |
|
431 |
#' |
|
432 |
#' @param object (`LongitudinalModel`) \cr A longitudinal model object |
|
433 |
#' @param ... Not used. |
|
434 |
#' @export |
|
435 |
getPredictionNames <- function(object, ...) { |
|
436 | 6x |
UseMethod("getPredictionNames") |
437 |
} |
|
438 | ||
439 |
#' @rdname getPredictionNames |
|
440 |
getPredictionNames.default <- function(object, ...) { |
|
441 | 1x |
NULL |
442 |
} |
|
443 | ||
444 |
#' As Formula |
|
445 |
#' |
|
446 |
#' Utility wrapper function to convert an object to a formula. |
|
447 |
#' @param x (`ANY`) \cr object to convert to a formula. |
|
448 |
#' @param ... Not used. |
|
449 |
#' @export |
|
450 |
as_formula <- function(x, ...) { |
|
451 | 7x |
UseMethod("as_formula") |
452 |
} |
|
453 | ||
454 |
#' @importFrom stats as.formula |
|
455 |
#' @export |
|
456 |
as_formula.default <- function(x, ...) { |
|
457 | ! |
as.formula(x, ...) |
458 |
} |
|
459 | ||
460 | ||
461 |
#' Set Constraints |
|
462 |
#' |
|
463 |
#' Applies constraints to a prior distribution to ensure any sampled numbers |
|
464 |
#' from the distribution fall within the constraints |
|
465 |
#' |
|
466 |
#' @param object (`Prior`)\cr a prior distribution to apply constraints to |
|
467 |
#' @param lower (`numeric`)\cr lower constraint boundary |
|
468 |
#' @param upper (`numeric`)\cr upper constraint boundary |
|
469 |
#' |
|
470 |
#' @export |
|
471 |
set_limits <- function(object, lower = -Inf, upper = Inf) { |
|
472 | 370x |
UseMethod("set_limits") |
473 |
} |
1 | ||
2 | ||
3 | ||
4 |
#' jmpost settings |
|
5 |
#' |
|
6 |
#' @description |
|
7 |
#' Define settings that modify the behaviour of the `jmpost` package |
|
8 |
#' |
|
9 |
#' Each of the following are the name of options that can be set via: |
|
10 |
#' ``` |
|
11 |
#' options(<option_name> = <value>) |
|
12 |
#' ``` |
|
13 |
#' |
|
14 |
#' ## `jmpost.prior_shrinkage` |
|
15 |
#' |
|
16 |
#' Default = `0.5` |
|
17 |
#' |
|
18 |
#' By default all initial values are drawn as random sample from the respective prior |
|
19 |
#' distribution with a shrinkage factor towards the mean. That is: |
|
20 |
#' ``` |
|
21 |
#' initial_value = prior_mean * prior_shrinkage + (1 - prior_shrinkage) * prior_sample |
|
22 |
#' ``` |
|
23 |
#' This setting controls the shrinkage factor. A value of 0 means no shrinkage (i.e. |
|
24 |
#' pure random draw) whilst a value of 1 means the initial value is just the mean. |
|
25 |
#' |
|
26 |
#' ## `jmpost.cache_dir` |
|
27 |
#' |
|
28 |
#' Default = `tempfile()` |
|
29 |
#' |
|
30 |
#' Directory to store compiled stan models in. If not set, a temporary directory is used for |
|
31 |
#' the given R session. Can also be set via the environment variable `JMPOST_CACHE_DIR`. |
|
32 |
#' |
|
33 |
#' |
|
34 |
#' |
|
35 |
#' ## `jmpost.gauss_quad_n` |
|
36 |
#' |
|
37 |
#' Default = 15 |
|
38 |
#' |
|
39 |
#' In most cases the survival function of the joint model does not have a closed form |
|
40 |
#' and as such it is calculated by integrating the hazard function. `jmpost` estimates this |
|
41 |
#' via Gaussian Quadrature, in particular it uses [`statmod::gauss.quad`] with |
|
42 |
#' `kind = "legendre"` to create the nodes and weights. |
|
43 |
#' |
|
44 |
#' This option specifies the `n` argument in the call to [`statmod::gauss.quad`]. In general |
|
45 |
#' higher values of `n` lead to better accuracy of the approximation but at the cost of |
|
46 |
#' increased computational time. |
|
47 |
#' |
|
48 |
#' @examples |
|
49 |
#' \dontrun{ |
|
50 |
#' options(jmpost.prior_shrinkage = 0.5) |
|
51 |
#' } |
|
52 |
#' @name jmpost-settings |
|
53 |
set_options <- function() { |
|
54 | ||
55 | ! |
cache_dir <- Sys.getenv("JMPOST_CACHE_DIR") |
56 | ||
57 | ! |
if (cache_dir == "" || is.null(cache_dir)) { |
58 | ! |
cache_dir <- tempfile() |
59 |
} |
|
60 | ||
61 | ! |
current_opts <- names(options()) |
62 | ! |
jmpost_opts <- list( |
63 | ! |
jmpost.cache_dir = cache_dir, |
64 | ! |
jmpost.prior_shrinkage = 0.5, |
65 | ! |
jmpost.gauss_quad_n = 15 |
66 |
) |
|
67 | ! |
for (opt in names(jmpost_opts)) { |
68 | ! |
if (!opt %in% current_opts) { |
69 | ! |
options(jmpost_opts[opt]) |
70 |
} |
|
71 |
} |
|
72 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include Grid.R |
|
3 |
NULL |
|
4 | ||
5 |
#' @rdname Quant-Dev |
|
6 |
.QuantityGeneratorPrediction <- setClass( |
|
7 |
"QuantityGeneratorPrediction", |
|
8 |
contains = "QuantityGenerator", |
|
9 |
slots = c( |
|
10 |
"times" = "numeric", |
|
11 |
"newdata" = "data.frame", |
|
12 |
"params" = "list" |
|
13 |
) |
|
14 |
) |
|
15 | ||
16 | ||
17 |
#' @rdname Quant-Dev |
|
18 |
QuantityGeneratorPrediction <- function(times, newdata = NULL, params = NULL) { |
|
19 | 6x |
.QuantityGeneratorPrediction( |
20 | 6x |
times = times, |
21 | 6x |
newdata = newdata, |
22 | 6x |
params = params |
23 |
) |
|
24 |
} |
|
25 |
setValidity( |
|
26 |
"QuantityGeneratorPrediction", |
|
27 |
function(object) { |
|
28 |
if (length(object@times) != nrow(object@newdata)) { |
|
29 |
return("Length of `times` and `newdata` must be equal") |
|
30 |
} |
|
31 |
return(TRUE) |
|
32 |
} |
|
33 |
) |
|
34 | ||
35 | ||
36 | ||
37 | ||
38 |
#' @rdname as_stan_list.QuantityGenerator |
|
39 |
#' @export |
|
40 |
as_stan_list.QuantityGeneratorPrediction <- function(object, data, model, ...) { |
|
41 | 3x |
assert_that( |
42 | 3x |
is(data, "DataJoint") |
43 |
) |
|
44 | 3x |
ret <- list() |
45 | 3x |
data_list <- as_stan_list(data) |
46 | ||
47 | 3x |
ret[["gq_times"]] <- object@times |
48 | 3x |
ret[["gq_n_quant"]] <- length(object@times) |
49 | ||
50 |
# Get a list of which longutidunal parameters need to be defined based |
|
51 |
# on the selected longitudinal model |
|
52 | 3x |
par_names <- getPredictionNames(model@longitudinal) |
53 | 3x |
for (nam in par_names) { |
54 | 8x |
assert_that( |
55 | 8x |
nam %in% names(object@params), |
56 | 8x |
msg = sprintf("Parameter '%s' not found in `params`", nam) |
57 |
) |
|
58 | 8x |
assert_that( |
59 | 8x |
is.numeric(object@params[[nam]]), |
60 | 8x |
msg = sprintf("Parameter '%s' must be numeric", nam) |
61 |
) |
|
62 | 8x |
assert_that( |
63 | 8x |
length(object@params[[nam]]) == 1, |
64 | 8x |
msg = sprintf("Parameter '%s' must be length 1", nam) |
65 |
) |
|
66 |
} |
|
67 | ||
68 | 3x |
par_vals <- object@params[par_names] |
69 | 3x |
if (length(par_vals) == 0) { |
70 | 1x |
par_vals <- 0 |
71 | 1x |
par_names <- "null_model" |
72 |
} |
|
73 | ||
74 | 3x |
ret[["gq_n_par"]] <- length(par_names) |
75 | ||
76 |
# Replicate the longitudinal parameters so the same parameter values are used |
|
77 |
# for all observations that are being predicted |
|
78 | 3x |
ret[["gq_link_function_inputs"]] <- matrix( |
79 | 3x |
rep(unlist(par_vals), each = ret[["gq_n_quant"]]), |
80 | 3x |
ncol = ret[["gq_n_par"]], |
81 | 3x |
nrow = ret[["gq_n_quant"]] |
82 |
) |
|
83 | ||
84 |
# Create design matrix from new data ensuring that it has the same |
|
85 |
# structure as the original design matrix |
|
86 | 3x |
ret[["gq_os_cov_design"]] <- mirror_design_matrix( |
87 | 3x |
data@survival, |
88 | 3x |
object@newdata |
89 |
) |
|
90 | ||
91 |
# dummy pop indexes in order for stan code to actualy compile. In this setting |
|
92 |
# this matrix isn't actually used so doesn't matter what these values are |
|
93 |
# but don't want to have to burden individual longitudinal models with the |
|
94 |
# conditional logic to check if they are generating population quantities or not |
|
95 | 2x |
ret[["gq_long_pop_arm_index"]] <- rep(1, ret[["gq_n_quant"]]) |
96 | 2x |
ret[["gq_long_pop_study_index"]] <- rep(1, ret[["gq_n_quant"]]) |
97 | ||
98 | ||
99 |
# Sanity checks |
|
100 | 2x |
assert_that( |
101 | 2x |
nrow(ret[["gq_os_cov_design"]]) == ret[["gq_n_quant"]], |
102 | 2x |
ncol(ret[["gq_os_cov_design"]]) == data_list[["p_os_cov_design"]], |
103 | 2x |
all(!is.na(ret[["gq_link_function_inputs"]])) |
104 |
) |
|
105 | ||
106 | 2x |
return(ret) |
107 |
} |
1 |
#' @include Grid.R |
|
2 |
#' @include generics.R |
|
3 |
NULL |
|
4 | ||
5 | ||
6 |
#' @rdname Grid-Dev |
|
7 |
.GridPopulation <- setClass( |
|
8 |
"GridPopulation", |
|
9 |
contains = "Grid", |
|
10 |
slots = c( |
|
11 |
"times" = "numeric_or_NULL" |
|
12 |
) |
|
13 |
) |
|
14 | ||
15 |
#' @rdname Grid-Functions |
|
16 |
#' @export |
|
17 |
GridPopulation <- function(times = NULL) { |
|
18 | 3x |
.GridPopulation( |
19 | 3x |
times = times |
20 |
) |
|
21 |
} |
|
22 | ||
23 |
#' @rdname Quant-Dev |
|
24 |
#' @export |
|
25 |
as.QuantityGenerator.GridPopulation <- function(object, data, ...) { |
|
26 | ||
27 | 4x |
assert_class(data, "DataJoint") |
28 | 4x |
data_list <- as.list(data) |
29 | 4x |
validate_time_grid(object@times) |
30 | ||
31 | 4x |
n_times <- length(object@times) |
32 | 4x |
n_quant <- length(data_list$pop_study_index) |
33 | ||
34 | 4x |
QuantityGeneratorPopulation( |
35 | 4x |
times = rep(object@times, each = n_quant), |
36 | 4x |
arms = rep(names(data_list$arm_to_index)[data_list$pop_arm_index], n_times), |
37 | 4x |
studies = rep(names(data_list$study_to_index)[data_list$pop_study_index], n_times) |
38 |
) |
|
39 |
} |
|
40 | ||
41 |
#' @rdname Quant-Dev |
|
42 |
#' @export |
|
43 |
as.QuantityCollapser.GridPopulation <- function(object, data, ...) { |
|
44 | 2x |
assert_class(data, "DataJoint") |
45 | 2x |
data_list <- as.list(data) |
46 | 2x |
generator <- as.QuantityGenerator(object, data) |
47 | 2x |
QuantityCollapser( |
48 | 2x |
times = generator@times, |
49 | 2x |
groups = sprintf( |
50 | 2x |
"arm=%s; study=%s", |
51 | 2x |
generator@arms, |
52 | 2x |
generator@studies |
53 |
), |
|
54 | 2x |
indexes = as.list(seq_along(generator@times)) |
55 |
) |
|
56 |
} |
|
57 | ||
58 | ||
59 |
#' @export |
|
60 |
as.list.GridPopulation <- function(x, data, ...) { |
|
61 | ! |
stop("`as.list()` is not implemented for `GridPopulation` objects") |
62 |
} |
|
63 | ||
64 | ||
65 |
#' @rdname coalesceGridTime |
|
66 |
#' @export |
|
67 |
coalesceGridTime.GridPopulation <- function(object, times, ...) { |
|
68 | 2x |
if (is.null(object@times)) { |
69 | ! |
object <- GridPopulation( |
70 | ! |
times = times |
71 |
) |
|
72 |
} |
|
73 | 2x |
object |
74 |
} |
1 | ||
2 |
#' @include StanModule.R |
|
3 |
#' @include generics.R |
|
4 |
#' @include ParameterList.R |
|
5 |
#' @include DataJoint.R |
|
6 |
#' @include DataSurvival.R |
|
7 |
#' @include DataLongitudinal.R |
|
8 |
#' @include LongitudinalModel.R |
|
9 |
#' @include SurvivalModel.R |
|
10 |
#' @include Link.R |
|
11 |
#' @include constants.R |
|
12 |
NULL |
|
13 | ||
14 | ||
15 |
#' Re-used documentation for `JointModel-Shared` |
|
16 |
#' |
|
17 |
#' @param object ([`JointModel`]) \cr Joint model specification. |
|
18 |
#' @param x ([`JointModel`]) \cr Joint model specification. |
|
19 |
#' @param ... Not Used. |
|
20 |
#' |
|
21 |
#' @name JointModel-Shared |
|
22 |
#' @keywords internal |
|
23 |
NULL |
|
24 | ||
25 |
setClassUnion("LongitudinalModel_OR_NULL", c("LongitudinalModel", "NULL")) |
|
26 |
setClassUnion("SurvivalModel_OR_NULL", c("SurvivalModel", "NULL")) |
|
27 | ||
28 |
# JointModel-class ---- |
|
29 | ||
30 |
#' Joint Model Object and Constructor Function |
|
31 |
#' |
|
32 |
#' @slot longitudinal ([`LongitudinalModel`] or `NULL`)\cr the longitudinal model. |
|
33 |
#' @slot survival ([`SurvivalModel`] or `NULL`)\cr the survival model. |
|
34 |
#' @slot link (`Link`)\cr the link. |
|
35 |
#' @slot parameters (`ParameterList`)\cr the parameter specification. |
|
36 |
#' |
|
37 |
#' @family JointModel |
|
38 |
#' @export JointModel |
|
39 |
#' @exportClass JointModel |
|
40 |
.JointModel <- setClass( |
|
41 |
Class = "JointModel", |
|
42 |
slots = list( |
|
43 |
longitudinal = "LongitudinalModel_OR_NULL", |
|
44 |
survival = "SurvivalModel_OR_NULL", |
|
45 |
link = "Link", |
|
46 |
parameters = "ParameterList" |
|
47 |
) |
|
48 |
) |
|
49 | ||
50 |
#' @param longitudinal ([`LongitudinalModel`] or `NULL`)\cr the longitudinal model. |
|
51 |
#' @param survival ([`SurvivalModel`] or `NULL`)\cr the survival model. |
|
52 |
#' @param link (`Link`)\cr the link. |
|
53 |
#' @rdname JointModel-class |
|
54 |
JointModel <- function( |
|
55 |
longitudinal = NULL, |
|
56 |
survival = NULL, |
|
57 |
link = Link() |
|
58 |
) { |
|
59 | 49x |
link <- resolvePromise(Link(link), longitudinal) |
60 | ||
61 | 49x |
if (length(link) > 0) { |
62 | 20x |
longitudinal <- enableLink(longitudinal) |
63 |
} |
|
64 | ||
65 | 49x |
parameters <- Reduce( |
66 | 49x |
merge, |
67 | 49x |
list( |
68 | 49x |
getParameters(longitudinal), |
69 | 49x |
getParameters(survival), |
70 | 49x |
getParameters(link) |
71 |
) |
|
72 |
) |
|
73 | ||
74 | 49x |
.JointModel( |
75 | 49x |
longitudinal = longitudinal, |
76 | 49x |
survival = survival, |
77 | 49x |
link = link, |
78 | 49x |
parameters = parameters |
79 |
) |
|
80 |
} |
|
81 | ||
82 | ||
83 |
#' @export |
|
84 |
enableGQ.JointModel <- function(object, ...) { |
|
85 | 38x |
merge( |
86 | 38x |
enableGQ(object@survival), |
87 | 38x |
enableGQ(object@longitudinal) |
88 |
) |
|
89 |
} |
|
90 | ||
91 | ||
92 |
#' `JointModel` -> `StanModule` |
|
93 |
#' |
|
94 |
#' Converts a [`JointModel`] object to a [`StanModule`] object |
|
95 |
#' |
|
96 |
#' @inheritParams JointModel-Shared |
|
97 |
#' @family JointModel |
|
98 |
#' @family as.StanModule |
|
99 |
#' @export |
|
100 |
as.StanModule.JointModel <- function(object, ...) { |
|
101 | ||
102 | 87x |
base_model <- read_stan("base/base.stan") |
103 | ||
104 | 87x |
stan_full <- decorated_render( |
105 | 87x |
.x = base_model, |
106 | 87x |
longitudinal = add_missing_stan_blocks(as.list(object@longitudinal)), |
107 | 87x |
survival = add_missing_stan_blocks(as.list(object@survival)), |
108 | 87x |
link = add_missing_stan_blocks(as.list(object@link)), |
109 | 87x |
priors = add_missing_stan_blocks(as.list(object@parameters)), |
110 | 87x |
has_os_submodel = !is.null(object@survival), |
111 | 87x |
has_long_submodel = !is.null(object@longitudinal) |
112 |
) |
|
113 |
# Unresolved Jinja code within the longitudinal / Survival / Link |
|
114 |
# models won't be resolved by the above call to `decorated_render`. |
|
115 |
# Instead they it will just be inserted into the template asis. Thus |
|
116 |
# we run `decorated_render` again to resolve any lingering Jinja code |
|
117 |
# Main example being models that don't have any Jinja code but still |
|
118 |
# use the `decorated_render` constants `machine_double_eps`. |
|
119 | 87x |
stan_full <- decorated_render(.x = stan_full) |
120 | ||
121 | 87x |
x <- merge( |
122 | 87x |
StanModule("base/functions.stan"), |
123 | 87x |
StanModule(stan_full) |
124 |
) |
|
125 | ||
126 | 87x |
return(x) |
127 |
} |
|
128 | ||
129 | ||
130 | ||
131 |
#' `JointModel` -> `character` |
|
132 |
#' |
|
133 |
#' Renders a [`JointModel`] object to a stan program |
|
134 |
#' |
|
135 |
#' @inheritParams JointModel-Shared |
|
136 |
#' @family JointModel |
|
137 |
#' @export |
|
138 |
as.character.JointModel <- function(x, ...) { |
|
139 | 10x |
as.character(as.StanModule(x)) |
140 |
} |
|
141 | ||
142 | ||
143 |
# write_stan-JointModel ---- |
|
144 | ||
145 |
#' @rdname write_stan |
|
146 |
#' @export |
|
147 |
write_stan.JointModel <- function(object, destination, ...) { |
|
148 | ! |
if (is_connection(destination)) { |
149 | ! |
return(writeLines(as.character(object), con = destination)) |
150 |
} |
|
151 | ! |
fi <- file(destination, open = "w") |
152 | ! |
writeLines(as.character(object), con = fi) |
153 | ! |
close(fi) |
154 |
} |
|
155 | ||
156 | ||
157 |
# compileStanModel-JointModel ---- |
|
158 | ||
159 |
#' @rdname compileStanModel |
|
160 |
#' @export |
|
161 |
compileStanModel.JointModel <- function(object) { |
|
162 | 14x |
object |> |
163 | 14x |
as.StanModule() |> |
164 | 14x |
compileStanModel() |> |
165 | 14x |
invisible() |
166 |
} |
|
167 | ||
168 | ||
169 |
# sampleStanModel-JointModel ---- |
|
170 | ||
171 |
#' @rdname sampleStanModel |
|
172 |
#' |
|
173 |
#' @param data (`DataJoint` or `list`)\cr input data. |
|
174 |
#' @export |
|
175 |
sampleStanModel.JointModel <- function(object, data, ...) { |
|
176 | ||
177 | 14x |
assert_class(data, "DataJoint") |
178 | ||
179 | 14x |
if (!is.null(object@survival)) { |
180 | 11x |
assert_that( |
181 | 11x |
!is.null(data@survival), |
182 | 11x |
msg = "`DataSurvival` can't be missing if a `SurvivalModel` has been specified" |
183 |
) |
|
184 |
} |
|
185 | 14x |
if (!is.null(object@longitudinal)) { |
186 | 13x |
assert_that( |
187 | 13x |
!is.null(data@longitudinal), |
188 | 13x |
msg = "`DataLongitudinal` can't be missing if a `LongitudinalModel` has been specified" |
189 |
) |
|
190 |
} |
|
191 | ||
192 | 14x |
args <- list(...) |
193 | ||
194 | 14x |
args[["data"]] <- append( |
195 | 14x |
as_stan_list(data), |
196 | 14x |
as_stan_list(object@parameters) |
197 |
) |
|
198 | ||
199 | 14x |
args[["chains"]] <- if ("chains" %in% names(args)) { |
200 | 14x |
args[["chains"]] |
201 |
} else { |
|
202 |
# Magic constant from R/constants.R |
|
203 | ! |
CMDSTAN_DEFAULT_CHAINS |
204 |
} |
|
205 | ||
206 | 14x |
initial_values <- if ("init" %in% names(args)) { |
207 | ! |
args[["init"]] |
208 |
} else { |
|
209 | 14x |
initialValues(object, n_chains = args[["chains"]]) |
210 |
} |
|
211 | ||
212 | 14x |
args[["init"]] <- ensure_initial_values( |
213 | 14x |
initial_values, |
214 | 14x |
args[["data"]], |
215 | 14x |
object@parameters |
216 |
) |
|
217 | ||
218 | 14x |
model <- compileStanModel(object) |
219 | ||
220 | 14x |
results <- do.call( |
221 | 14x |
model$sample, |
222 | 14x |
args |
223 |
) |
|
224 | ||
225 | 14x |
.JointModelSamples( |
226 | 14x |
model = object, |
227 | 14x |
data = data, |
228 | 14x |
results = results |
229 |
) |
|
230 |
} |
|
231 | ||
232 | ||
233 |
#' Ensure that initial values are correctly specified |
|
234 |
#' |
|
235 |
#' @param initial_values (`list`)\cr A list of lists containing the initial values |
|
236 |
#' must be 1 list per desired chain. All elements should have identical names |
|
237 |
#' @param data (`list`)\cr specifies the size to expand each of our initial values to be. |
|
238 |
#' That is elements of size 1 in `initial_values` will be expanded to be the same |
|
239 |
#' size as the corresponding element in `data` by broadcasting the value. |
|
240 |
#' @param parameters ([`ParameterList`])\cr the parameters object |
|
241 |
#' |
|
242 |
#' @details |
|
243 |
#' This function is mostly a thin wrapper around `expand_initial_values` to |
|
244 |
#' enable easier unit testing. |
|
245 |
#' |
|
246 |
#' @keywords internal |
|
247 |
ensure_initial_values <- function(initial_values, data, parameters) { |
|
248 | 15x |
if (is.function(initial_values)) { |
249 | ! |
return(initial_values) |
250 |
} |
|
251 | ||
252 | 15x |
assert_class(data, "list") |
253 | 15x |
assert_class(parameters, "ParameterList") |
254 | 15x |
assert_class(initial_values, "list") |
255 | ||
256 | 15x |
values_sizes <- size(parameters) |
257 | 15x |
values_sizes_complete <- replace_with_lookup( |
258 | 15x |
values_sizes, |
259 | 15x |
data |
260 |
) |
|
261 | 15x |
lapply( |
262 | 15x |
initial_values, |
263 | 15x |
expand_initial_values, |
264 | 15x |
sizes = values_sizes_complete |
265 |
) |
|
266 |
} |
|
267 | ||
268 | ||
269 | ||
270 |
#' @rdname initialValues |
|
271 |
#' @export |
|
272 |
initialValues.JointModel <- function(object, n_chains, ...) { |
|
273 | 16x |
initialValues(object@parameters, n_chains) |
274 |
} |
|
275 | ||
276 | ||
277 |
pad_with_white_space <- function(x, pad = 4) { |
|
278 | 3x |
padding <- paste0(rep(" ", each = pad), collapse = "") |
279 | 3x |
x_sep <- x |> |
280 | 3x |
strsplit(split = "\n") |> |
281 | 3x |
unlist() |
282 | 3x |
x_padded <- paste(padding, x_sep) |> |
283 | 3x |
paste(collapse = "\n") |
284 | 3x |
return(x_padded) |
285 |
} |
|
286 | ||
287 | ||
288 |
#' @rdname show-object |
|
289 |
#' @export |
|
290 |
setMethod( |
|
291 |
f = "show", |
|
292 |
signature = "JointModel", |
|
293 |
definition = function(object) { |
|
294 | 1x |
survival_string <- if (is.null(object@survival)) { |
295 | ! |
"\n Not Specified\n" |
296 |
} else { |
|
297 | 1x |
as_print_string(object@survival) |> pad_with_white_space() |
298 |
} |
|
299 | ||
300 | 1x |
longitudinal_string <- if (is.null(object@longitudinal)) { |
301 | ! |
"\n Not Specified\n" |
302 |
} else { |
|
303 | 1x |
as_print_string(object@longitudinal) |> pad_with_white_space() |
304 |
} |
|
305 | ||
306 | 1x |
link_string <- as_print_string(object@link) |> pad_with_white_space() |
307 | ||
308 | 1x |
string <- "\nA Joint Model with:\n\n Survival:%s\n Longitudinal:%s\n Link:%s\n" |
309 | 1x |
cat(sprintf( |
310 | 1x |
string, |
311 | 1x |
survival_string, |
312 | 1x |
longitudinal_string, |
313 | 1x |
link_string |
314 |
)) |
|
315 |
} |
|
316 |
) |
1 | ||
2 |
#' `SimSurvival` Function Arguments |
|
3 |
#' |
|
4 |
#' The documentation lists all the conventional arguments for [`SimSurvival`] |
|
5 |
#' constructors. |
|
6 |
#' |
|
7 |
#' @param time_max (`number`)\cr the maximum time to simulate to. |
|
8 |
#' @param time_step (`number`)\cr the time interval between evaluating the log-hazard function. |
|
9 |
#' @param lambda_censor (`number`)\cr the censoring rate. |
|
10 |
#' @param beta_cont (`number`)\cr the continuous covariate coefficient. |
|
11 |
#' @param beta_cat (`numeric`)\cr the categorical covariate coefficients. |
|
12 |
#' @param loghazard (`function`)\cr the log hazard function. |
|
13 |
#' @param name (`character`)\cr the name of the object. |
|
14 |
#' @param ... Not Used. |
|
15 |
#' |
|
16 |
#' @section Hazard Evaluation: |
|
17 |
#' |
|
18 |
#' Event times are simulated by sampling a cumulative hazard limit from a \eqn{U(0, 1)} distribution |
|
19 |
#' for |
|
20 |
#' each subject and then counting how much hazard they've been exposed to by evaluating the |
|
21 |
#' log-hazard function at a set interval. The `time_max` argument sets the upper bound for the |
|
22 |
#' number of time points to evaluate the log-hazard function at with subjects who have not had an |
|
23 |
#' event being censored at `time_max`. The `time_step` argument sets the interval at which to |
|
24 |
#' evaluate the log-hazard function. Setting smaller values for `time_step` will increase the |
|
25 |
#' precision of the simulation at the cost of increased computation time. Likewise, setting large |
|
26 |
#' values for `time_max` will minimize the number of censored subjects at the cost of |
|
27 |
#' increased computation time. |
|
28 |
#' |
|
29 |
#' @name SimSurvival-Shared |
|
30 |
#' @keywords internal |
|
31 |
NULL |
|
32 | ||
33 | ||
34 |
#' Abstract Simulation Class for Survival Data |
|
35 |
#' |
|
36 |
#' @inheritParams SimSurvival-Shared |
|
37 |
#' @inheritSection SimSurvival-Shared Hazard Evaluation |
|
38 |
#' |
|
39 |
#' @slot time_max (`numeric`)\cr See arguments. |
|
40 |
#' @slot time_step (`numeric`)\cr See arguments. |
|
41 |
#' @slot lambda_censor (`numeric`)\cr See arguments. |
|
42 |
#' @slot beta_cont (`numeric`)\cr See arguments. |
|
43 |
#' @slot beta_cat (`numeric`)\cr See arguments. |
|
44 |
#' @slot loghazard (`function`)\cr See arguments. |
|
45 |
#' @slot name (`character`)\cr See arguments. |
|
46 |
#' |
|
47 |
#' @family SimSurvival |
|
48 |
#' @exportClass SimSurvival |
|
49 |
#' @name SimSurvival-class |
|
50 |
.SimSurvival <- setClass( |
|
51 |
"SimSurvival", |
|
52 |
slots = c( |
|
53 |
time_max = "numeric", |
|
54 |
time_step = "numeric", |
|
55 |
lambda_censor = "numeric", |
|
56 |
beta_cont = "numeric", |
|
57 |
beta_cat = "numeric", |
|
58 |
loghazard = "function", |
|
59 |
name = "character" |
|
60 |
) |
|
61 |
) |
|
62 | ||
63 |
#' @rdname SimSurvival-class |
|
64 |
#' @export |
|
65 |
SimSurvival <- function( |
|
66 |
time_max = 2000, |
|
67 |
time_step = 1, |
|
68 |
lambda_censor = 1 / 3000, |
|
69 |
beta_cont = 0.2, |
|
70 |
beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2), |
|
71 |
loghazard, |
|
72 |
name = "SimSurvival" |
|
73 |
) { |
|
74 | 22x |
.SimSurvival( |
75 | 22x |
time_max = time_max, |
76 | 22x |
time_step = time_step, |
77 | 22x |
lambda_censor = lambda_censor, |
78 | 22x |
beta_cont = beta_cont, |
79 | 22x |
beta_cat = beta_cat, |
80 | 22x |
loghazard = loghazard, |
81 | 22x |
name = name |
82 |
) |
|
83 |
} |
|
84 | ||
85 | ||
86 |
#' @rdname show-object |
|
87 |
#' @export |
|
88 |
setMethod( |
|
89 |
f = "show", |
|
90 |
signature = "SimSurvival", |
|
91 |
definition = function(object) { |
|
92 | 1x |
x <- sprintf("\nA %s Object\n\n", as_print_string(object)) |
93 | 1x |
cat(x) |
94 | 1x |
return(object) |
95 |
} |
|
96 |
) |
|
97 | ||
98 |
#' @rdname as_print_string |
|
99 |
as_print_string.SimSurvival <- function(object) { |
|
100 | 1x |
return(object@name) |
101 |
} |
|
102 | ||
103 | ||
104 |
#' Construct Time Intervals |
|
105 |
#' |
|
106 |
#' @param object (`SimSurvival`)\cr the survival simulation object to create evaluation points for. |
|
107 |
#' |
|
108 |
#' @return A `tibble` with `lower`, `upper`, `time`, `eval` and `width`. |
|
109 |
#' @keywords internal |
|
110 |
hazardWindows.SimSurvival <- function(object) { |
|
111 | 19x |
times <- seq(0, object@time_max, object@time_step) |
112 | 19x |
bound_lower <- times[-length(times)] |
113 | 19x |
bound_upper <- times[-1] |
114 | 19x |
bound_width <- bound_upper - bound_lower |
115 | 19x |
mid_point <- bound_upper - (bound_width / 2) |
116 | 19x |
tibble::tibble( |
117 | 19x |
lower = bound_lower, |
118 | 19x |
upper = bound_upper, |
119 | 19x |
midpoint = mid_point, |
120 | 19x |
width = bound_width |
121 |
) |
|
122 |
} |
|
123 | ||
124 |
#' @rdname sampleSubjects |
|
125 |
#' @export |
|
126 |
sampleSubjects.SimSurvival <- function(object, subjects_df) { |
|
127 | 19x |
subjects_df |> |
128 | 19x |
dplyr::mutate(cov_cont = stats::rnorm(dplyr::n())) |> |
129 | 19x |
dplyr::mutate(cov_cat = factor( |
130 | 19x |
sample(names(object@beta_cat), replace = TRUE, size = dplyr::n()), |
131 | 19x |
levels = names(object@beta_cat) |
132 |
)) |> |
|
133 | 19x |
dplyr::mutate(log_haz_cov = .data$cov_cont * object@beta_cont + object@beta_cat[.data$cov_cat]) |> |
134 | 19x |
dplyr::mutate(survival = stats::runif(dplyr::n())) |> |
135 | 19x |
dplyr::mutate(chazard_limit = -log(.data$survival)) |> |
136 | 19x |
dplyr::mutate(time_cen = stats::rexp(dplyr::n(), object@lambda_censor)) |
137 |
} |
|
138 | ||
139 | ||
140 |
#' @rdname sampleObservations |
|
141 |
#' @export |
|
142 |
sampleObservations.SimSurvival <- function(object, times_df) { |
|
143 | ||
144 | 19x |
assert_that( |
145 | 19x |
all(times_df$time >= 0), |
146 | 19x |
msg = "All time points must be greater than or equal to 0" |
147 |
) |
|
148 | ||
149 | 19x |
os_dat_chaz <- times_df |> |
150 | 19x |
dplyr::mutate(log_bl_haz = object@loghazard(.data$midpoint)) |> |
151 |
# Fix to avoid issue with log(0) = NaN values |
|
152 | 19x |
dplyr::mutate(log_bl_haz = dplyr::if_else(.data$midpoint == 0, -999, .data$log_bl_haz)) |> |
153 | 19x |
dplyr::mutate(hazard_instant = exp(.data$log_bl_haz + .data$log_haz_cov + .data$log_haz_link)) |> |
154 |
# Reset Inf values to large number to avoid NaN issues downstream |
|
155 |
# This is suitable as Hazard limits tend to be in the range of -10 to 10 so large numbers |
|
156 |
# are essentially equivalent to infinity for simulation purposes |
|
157 | 19x |
dplyr::mutate(hazard_instant = dplyr::if_else(.data$hazard_instant == Inf, 999, .data$hazard_instant)) |> |
158 | 19x |
dplyr::mutate(hazard_instant = dplyr::if_else(.data$hazard_instant == -Inf, -999, .data$hazard_instant)) |> |
159 | 19x |
dplyr::mutate(hazard_interval = .data$hazard_instant * .data$width) |> |
160 | 19x |
dplyr::group_by(.data$subject) |> |
161 | 19x |
dplyr::mutate(chazard = cumsum(.data$hazard_interval)) |> |
162 | 19x |
dplyr::ungroup() |
163 | ||
164 | 19x |
os_had_event <- os_dat_chaz |> |
165 | 19x |
dplyr::filter(.data$chazard >= .data$chazard_limit) |> |
166 | 19x |
dplyr::group_by(.data$subject) |> |
167 | 19x |
dplyr::slice(1) |> |
168 | 19x |
dplyr::ungroup() |> |
169 | 19x |
dplyr::mutate(event = 1) |
170 | ||
171 | 19x |
os_had_censor <- os_dat_chaz |> |
172 | 19x |
dplyr::filter(!.data$subject %in% os_had_event$subject) |> |
173 | 19x |
dplyr::group_by(.data$subject) |> |
174 | 19x |
dplyr::slice(dplyr::n()) |> |
175 | 19x |
dplyr::ungroup() |> |
176 | 19x |
dplyr::mutate(event = 0) |
177 | ||
178 | 19x |
if (!(nrow(os_had_censor) == 0)) { |
179 | 8x |
message(sprintf("INFO: %i subject(s) did not die before max(times)", nrow(os_had_censor))) |
180 |
} |
|
181 | ||
182 | 19x |
os_dat_complete <- os_had_event |> |
183 | 19x |
dplyr::bind_rows(os_had_censor) |> |
184 | 19x |
dplyr::mutate(real_time = .data$time) |> |
185 | 19x |
dplyr::mutate(event = dplyr::if_else(.data$real_time <= .data$time_cen, .data$event, 0)) |> |
186 | 19x |
dplyr::mutate(time = dplyr::if_else(.data$real_time <= .data$time_cen, .data$real_time, .data$time_cen)) |> |
187 | 19x |
dplyr::arrange(.data$subject) |
188 | ||
189 | 19x |
os_dat_complete[, c("subject", "study", "arm", "time", "event", "cov_cont", "cov_cat")] |
190 |
} |
|
191 | ||
192 | ||
193 |
#' Simulate Survival Data from a Weibull Proportional Hazard Model |
|
194 |
#' |
|
195 |
#' @param lambda (`number`)\cr the scale parameter. |
|
196 |
#' @param gamma (`number`)\cr the shape parameter. |
|
197 |
#' |
|
198 |
#' @inheritParams SimSurvival-Shared |
|
199 |
#' @inheritSection SimSurvival-Shared Hazard Evaluation |
|
200 |
#' |
|
201 |
#' @family SimSurvival |
|
202 |
#' |
|
203 |
#' @export |
|
204 |
SimSurvivalWeibullPH <- function( |
|
205 |
lambda, |
|
206 |
gamma, |
|
207 |
time_max = 2000, |
|
208 |
time_step = 1, |
|
209 |
lambda_censor = 1 / 3000, |
|
210 |
beta_cont = 0.2, |
|
211 |
beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2) |
|
212 |
) { |
|
213 | 3x |
SimSurvival( |
214 | 3x |
time_max = time_max, |
215 | 3x |
time_step = time_step, |
216 | 3x |
lambda_censor = lambda_censor, |
217 | 3x |
beta_cont = beta_cont, |
218 | 3x |
beta_cat = beta_cat, |
219 | 3x |
loghazard = function(time) { |
220 | 3x |
log(lambda) + log(gamma) + (gamma - 1) * log(time) |
221 |
}, |
|
222 | 3x |
name = "SimSurvivalWeibullPH" |
223 |
) |
|
224 |
} |
|
225 | ||
226 |
#' Simulate Survival Data from a Log-Logistic Proportional Hazard Model |
|
227 |
#' |
|
228 |
#' @param a (`number`)\cr the scale parameter. |
|
229 |
#' @param b (`number`)\cr the shape parameter. |
|
230 |
#' |
|
231 |
#' @inheritParams SimSurvival-Shared |
|
232 |
#' @inheritSection SimSurvival-Shared Hazard Evaluation |
|
233 |
#' |
|
234 |
#' @family SimSurvival |
|
235 |
#' @export |
|
236 |
SimSurvivalLogLogistic <- function( |
|
237 |
a, |
|
238 |
b, |
|
239 |
time_max = 2000, |
|
240 |
time_step = 1, |
|
241 |
lambda_censor = 1 / 3000, |
|
242 |
beta_cont = 0.2, |
|
243 |
beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2) |
|
244 |
) { |
|
245 | 1x |
SimSurvival( |
246 | 1x |
time_max = time_max, |
247 | 1x |
time_step = time_step, |
248 | 1x |
lambda_censor = lambda_censor, |
249 | 1x |
beta_cont = beta_cont, |
250 | 1x |
beta_cat = beta_cat, |
251 | 1x |
loghazard = function(time) { |
252 | 1x |
c1 <- - log(a) + log(b) + (b - 1) * (- log(a) + log(time)) |
253 | 1x |
c2 <- log(1 + (time / a)^b) |
254 | 1x |
return(c1 - c2) |
255 |
}, |
|
256 | 1x |
name = "SimSurvivalLogLogistic" |
257 |
) |
|
258 |
} |
|
259 | ||
260 | ||
261 | ||
262 |
#' Simulate Survival Data from a Exponential Proportional Hazard Model |
|
263 |
#' |
|
264 |
#' @param lambda (`number`)\cr the rate parameter. |
|
265 |
#' |
|
266 |
#' @inheritParams SimSurvival-Shared |
|
267 |
#' @inheritSection SimSurvival-Shared Hazard Evaluation |
|
268 |
#' |
|
269 |
#' @family SimSurvival |
|
270 |
#' |
|
271 |
#' @export |
|
272 |
SimSurvivalExponential <- function( |
|
273 |
lambda, |
|
274 |
time_max = 2000, |
|
275 |
time_step = 1, |
|
276 |
lambda_censor = 1 / 3000, |
|
277 |
beta_cont = 0.2, |
|
278 |
beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2) |
|
279 |
) { |
|
280 | 16x |
SimSurvival( |
281 | 16x |
time_max = time_max, |
282 | 16x |
time_step = time_step, |
283 | 16x |
lambda_censor = lambda_censor, |
284 | 16x |
beta_cont = beta_cont, |
285 | 16x |
beta_cat = beta_cat, |
286 | 16x |
loghazard = function(time) { |
287 | 16x |
log(lambda) |
288 |
}, |
|
289 | 16x |
name = "SimSurvivalExponential" |
290 |
) |
|
291 |
} |
|
292 | ||
293 | ||
294 |
#' Simulate Survival Data from a Gamma Proportional Hazard Model |
|
295 |
#' |
|
296 |
#' @param k (`number`)\cr the shape parameter. |
|
297 |
#' @param theta (`number`)\cr the scale parameter. |
|
298 |
#' |
|
299 |
#' @inheritParams SimSurvival-Shared |
|
300 |
#' @inheritSection SimSurvival-Shared Hazard Evaluation |
|
301 |
#' |
|
302 |
#' @family SimSurvival |
|
303 |
#' |
|
304 |
#' @importFrom stats dgamma pgamma |
|
305 |
#' |
|
306 |
#' @export |
|
307 |
SimSurvivalGamma <- function( |
|
308 |
k, |
|
309 |
theta, |
|
310 |
time_max = 2000, |
|
311 |
time_step = 1, |
|
312 |
lambda_censor = 1 / 3000, |
|
313 |
beta_cont = 0.2, |
|
314 |
beta_cat = c("A" = 0, "B" = -0.4, "C" = 0.2) |
|
315 |
) { |
|
316 | 1x |
SimSurvival( |
317 | 1x |
time_max = time_max, |
318 | 1x |
time_step = time_step, |
319 | 1x |
lambda_censor = lambda_censor, |
320 | 1x |
beta_cont = beta_cont, |
321 | 1x |
beta_cat = beta_cat, |
322 | 1x |
loghazard = function(time) { |
323 | 1x |
dgamma(time, k, scale = theta, log = TRUE) - |
324 | 1x |
pgamma(time, k, scale = theta, lower.tail = FALSE, log.p = TRUE) |
325 |
}, |
|
326 | 1x |
name = "SimSurvivalGamma" |
327 |
) |
|
328 |
} |
1 | ||
2 |
#' @include SimLongitudinal.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 |
#' Simulate Longitudinal Data from a Claret-Bruno Model |
|
7 |
#' |
|
8 |
#' @param times (`numeric`)\cr the times to generate observations at. |
|
9 |
#' @param sigma (`number`)\cr the variance of the longitudinal values. |
|
10 |
#' |
|
11 |
#' @param mu_b (`numeric`)\cr the mean population baseline sld value. |
|
12 |
#' @param mu_g (`numeric`)\cr the mean population growth rate. |
|
13 |
#' @param mu_c (`numeric`)\cr the mean population resistance rate. |
|
14 |
#' @param mu_p (`numeric`)\cr the mean population growth inhibition. |
|
15 |
#' |
|
16 |
#' @param omega_b (`number`)\cr the population standard deviation for the baseline sld value. |
|
17 |
#' @param omega_g (`number`)\cr the population standard deviation for the growth rate. |
|
18 |
#' @param omega_c (`number`)\cr the population standard deviation for the resistance rate. |
|
19 |
#' @param omega_p (`number`)\cr the population standard deviation for the growth inhibition. |
|
20 |
#' |
|
21 |
#' @param link_dsld (`number`)\cr the link coefficient for the derivative contribution. |
|
22 |
#' @param link_ttg (`number`)\cr the link coefficient for the time-to-growth contribution. |
|
23 |
#' @param link_identity (`number`)\cr the link coefficient for the SLD Identity contribution. |
|
24 |
#' @param link_growth (`number`)\cr the link coefficient for the growth parameter contribution. |
|
25 |
#' |
|
26 |
#' @param scaled_variance (`logical`)\cr whether the variance should be scaled by the expected value |
|
27 |
#' (see the "Statistical Specifications" vignette for more details) |
|
28 |
#' |
|
29 |
#' @slot sigma (`numeric`)\cr See arguments. |
|
30 |
#' |
|
31 |
#' @slot mu_b (`numeric`)\cr See arguments. |
|
32 |
#' @slot mu_g (`numeric`)\cr See arguments. |
|
33 |
#' @slot mu_c (`numeric`)\cr See arguments. |
|
34 |
#' @slot mu_p (`numeric`)\cr See arguments. |
|
35 |
#' |
|
36 |
#' @slot omega_b (`numeric`)\cr See arguments. |
|
37 |
#' @slot omega_g (`numeric`)\cr See arguments. |
|
38 |
#' @slot omega_c (`numeric`)\cr See arguments. |
|
39 |
#' @slot omega_p (`numeric`)\cr See arguments. |
|
40 |
#' |
|
41 |
#' @slot link_dsld (`numeric`)\cr See arguments. |
|
42 |
#' @slot link_ttg (`numeric`)\cr See arguments. |
|
43 |
#' @slot link_identity (`numeric`)\cr See arguments. |
|
44 |
#' @slot link_growth (`numeric`)\cr See arguments. |
|
45 |
#' |
|
46 |
#' @slot scaled_variance (`logical`)\cr See arguments. |
|
47 |
#' |
|
48 |
#' @family SimLongitudinal |
|
49 |
#' @name SimLongitudinalClaretBruno-class |
|
50 |
#' @exportClass SimLongitudinalClaretBruno |
|
51 |
.SimLongitudinalClaretBruno <- setClass( |
|
52 |
"SimLongitudinalClaretBruno", |
|
53 |
contains = "SimLongitudinal", |
|
54 |
slots = c( |
|
55 |
sigma = "numeric", |
|
56 |
mu_b = "numeric", |
|
57 |
mu_g = "numeric", |
|
58 |
mu_c = "numeric", |
|
59 |
mu_p = "numeric", |
|
60 |
omega_b = "numeric", |
|
61 |
omega_g = "numeric", |
|
62 |
omega_c = "numeric", |
|
63 |
omega_p = "numeric", |
|
64 |
link_dsld = "numeric", |
|
65 |
link_ttg = "numeric", |
|
66 |
link_identity = "numeric", |
|
67 |
link_growth = "numeric", |
|
68 |
scaled_variance = "logical" |
|
69 |
) |
|
70 |
) |
|
71 | ||
72 |
#' @rdname SimLongitudinalClaretBruno-class |
|
73 |
#' @export |
|
74 |
SimLongitudinalClaretBruno <- function( |
|
75 |
times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550) / 365, |
|
76 |
sigma = 0.01, |
|
77 |
mu_b = log(60), |
|
78 |
mu_g = log(c(0.9, 1.1)), |
|
79 |
mu_c = log(c(0.25, 0.35)), |
|
80 |
mu_p = log(c(1.5, 2)), |
|
81 |
omega_b = 0.2, |
|
82 |
omega_g = 0.2, |
|
83 |
omega_c = 0.2, |
|
84 |
omega_p = 0.2, |
|
85 |
link_dsld = 0, |
|
86 |
link_ttg = 0, |
|
87 |
link_identity = 0, |
|
88 |
link_growth = 0, |
|
89 |
scaled_variance = TRUE |
|
90 |
) { |
|
91 | ||
92 | 2x |
if (length(omega_b) == 1) omega_b <- rep(omega_b, length(mu_b)) |
93 | 2x |
if (length(omega_g) == 1) omega_g <- rep(omega_g, length(mu_g)) |
94 | 2x |
if (length(omega_c) == 1) omega_c <- rep(omega_c, length(mu_c)) |
95 | 2x |
if (length(omega_p) == 1) omega_p <- rep(omega_p, length(mu_p)) |
96 | ||
97 | 2x |
.SimLongitudinalClaretBruno( |
98 | 2x |
times = times, |
99 | 2x |
sigma = sigma, |
100 | 2x |
mu_b = mu_b, |
101 | 2x |
mu_g = mu_g, |
102 | 2x |
mu_c = mu_c, |
103 | 2x |
mu_p = mu_p, |
104 | 2x |
omega_b = omega_b, |
105 | 2x |
omega_g = omega_g, |
106 | 2x |
omega_c = omega_c, |
107 | 2x |
omega_p = omega_p, |
108 | 2x |
link_dsld = link_dsld, |
109 | 2x |
link_ttg = link_ttg, |
110 | 2x |
link_identity = link_identity, |
111 | 2x |
link_growth = link_growth, |
112 | 2x |
scaled_variance = scaled_variance |
113 |
) |
|
114 |
} |
|
115 | ||
116 | ||
117 |
setValidity( |
|
118 |
"SimLongitudinalClaretBruno", |
|
119 |
function(object) { |
|
120 |
par_lengths <- c( |
|
121 |
length(object@mu_g), |
|
122 |
length(object@mu_c), |
|
123 |
length(object@mu_p) |
|
124 |
) |
|
125 |
if (length(unique(par_lengths)) != 1) { |
|
126 |
return("The parameters `mu_g`, `mu_c` & `mu_p` must have the same length.") |
|
127 |
} |
|
128 |
pairs <- list( |
|
129 |
"omega_b" = "mu_b", |
|
130 |
"omega_g" = "mu_g", |
|
131 |
"omega_c" = "mu_c", |
|
132 |
"omega_p" = "mu_p" |
|
133 |
) |
|
134 |
for (i in seq_along(pairs)) { |
|
135 |
omega <- slot(object, names(pairs)[[i]]) |
|
136 |
mu <- slot(object, pairs[[i]]) |
|
137 |
if (!(length(omega) == length(mu))) { |
|
138 |
return( |
|
139 |
sprintf("`%s` must be length 1 or the same length as `%s`", omega, mu) |
|
140 |
) |
|
141 |
} |
|
142 |
} |
|
143 |
len_1_pars <- c( |
|
144 |
"sigma", |
|
145 |
"link_dsld", "link_ttg", "link_identity", |
|
146 |
"link_growth" |
|
147 |
) |
|
148 |
for (par in len_1_pars) { |
|
149 |
if (length(slot(object, par)) != 1) { |
|
150 |
return(sprintf("The `%s` parameter must be a length 1 numeric.", par)) |
|
151 |
} |
|
152 |
} |
|
153 |
return(TRUE) |
|
154 |
} |
|
155 |
) |
|
156 | ||
157 |
#' @rdname as_print_string |
|
158 |
as_print_string.SimLongitudinalClaretBruno <- function(object) { |
|
159 | 1x |
return("SimLongitudinalClaretBruno") |
160 |
} |
|
161 | ||
162 |
#' @rdname sampleObservations |
|
163 |
#' @export |
|
164 |
sampleObservations.SimLongitudinalClaretBruno <- function(object, times_df) { |
|
165 | 1x |
times_df |> |
166 | 1x |
dplyr::mutate(mu_sld = clbr_sld(.data$time, .data$ind_b, .data$ind_g, .data$ind_c, .data$ind_p)) |> |
167 | 1x |
dplyr::mutate(dsld = clbr_dsld(.data$time, .data$ind_b, .data$ind_g, .data$ind_c, .data$ind_p)) |> |
168 | 1x |
dplyr::mutate(ttg = clbr_ttg(.data$time, .data$ind_b, .data$ind_g, .data$ind_c, .data$ind_p)) |> |
169 | 1x |
dplyr::mutate(sld_sd = ifelse(object@scaled_variance, .data$mu_sld * object@sigma, object@sigma)) |> |
170 | 1x |
dplyr::mutate(sld = stats::rnorm(dplyr::n(), .data$mu_sld, .data$sld_sd)) |> |
171 | 1x |
dplyr::mutate( |
172 | 1x |
log_haz_link = |
173 | 1x |
(object@link_dsld * .data$dsld) + |
174 | 1x |
(object@link_ttg * .data$ttg) + |
175 | 1x |
(object@link_identity * .data$mu_sld) + |
176 | 1x |
(object@link_growth * log(.data$ind_g)) |
177 |
) |
|
178 |
} |
|
179 | ||
180 | ||
181 |
#' @rdname sampleSubjects |
|
182 |
#' @export |
|
183 |
sampleSubjects.SimLongitudinalClaretBruno <- function(object, subjects_df) { |
|
184 | 1x |
assert_that( |
185 | 1x |
is.factor(subjects_df$study), |
186 | 1x |
is.factor(subjects_df$arm), |
187 | 1x |
length(levels(subjects_df$study)) == length(object@mu_b), |
188 | 1x |
length(levels(subjects_df$arm)) == length(object@mu_g), |
189 | 1x |
length(levels(subjects_df$arm)) == length(object@mu_c), |
190 | 1x |
length(levels(subjects_df$arm)) == length(object@mu_p) |
191 |
) |
|
192 | ||
193 | 1x |
res <- subjects_df |> |
194 | 1x |
dplyr::distinct(.data$subject, .data$arm, .data$study) |> |
195 | 1x |
dplyr::mutate(study_idx = as.numeric(.data$study)) |> |
196 | 1x |
dplyr::mutate(arm_idx = as.numeric(.data$arm)) |> |
197 | 1x |
dplyr::mutate(ind_b = stats::rlnorm( |
198 | 1x |
dplyr::n(), |
199 | 1x |
object@mu_b[.data$study_idx], |
200 | 1x |
object@omega_b[.data$study_idx] |
201 |
)) |> |
|
202 | 1x |
dplyr::mutate(ind_g = stats::rlnorm( |
203 | 1x |
dplyr::n(), |
204 | 1x |
object@mu_g[.data$arm_idx], |
205 | 1x |
object@omega_g[.data$arm_idx] |
206 |
)) |> |
|
207 | 1x |
dplyr::mutate(ind_c = stats::rlnorm( |
208 | 1x |
dplyr::n(), |
209 | 1x |
object@mu_c[.data$arm_idx], |
210 | 1x |
object@omega_c[.data$arm_idx] |
211 |
)) |> |
|
212 | 1x |
dplyr::mutate(ind_p = stats::rlnorm( |
213 | 1x |
dplyr::n(), |
214 | 1x |
object@mu_p[.data$arm_idx], |
215 | 1x |
object@omega_p[.data$arm_idx] |
216 |
)) |
|
217 | ||
218 | 1x |
res[, c("subject", "arm", "study", "ind_b", "ind_g", "ind_c", "ind_p")] |
219 |
} |
|
220 | ||
221 | ||
222 |
#' Claret-Bruno Functionals |
|
223 |
#' |
|
224 |
#' @param t (`numeric`)\cr time grid. |
|
225 |
#' @param b (`number`)\cr baseline sld. |
|
226 |
#' @param g (`number`)\cr growth rate. |
|
227 |
#' @param c (`number`)\cr resistance rate. |
|
228 |
#' @param p (`number`)\cr growth inhibition. |
|
229 |
#' |
|
230 |
#' @returns The function results. |
|
231 |
#' @keywords internal |
|
232 |
clbr_sld <- function(t, b, g, c, p) { |
|
233 | 2x |
p <- ifelse(t >= 0, p, 0) |
234 | 2x |
b * exp((g * t) - (p / c) * (1 - exp(-c * t))) |
235 |
} |
|
236 | ||
237 |
#' @rdname clbr_sld |
|
238 |
clbr_ttg <- function(t, b, g, c, p) { |
|
239 | 1x |
log(p / g) / c |
240 |
} |
|
241 | ||
242 |
#' @rdname clbr_sld |
|
243 |
clbr_dsld <- function(t, b, g, c, p) { |
|
244 | 1x |
lt0 <- b * g * exp(g * t) |
245 | 1x |
gt0 <- (g - p * exp(-c * t)) * clbr_sld(t, b, g, c, p) |
246 | 1x |
ifelse(t >= 0, gt0, lt0) |
247 |
} |
1 |
#' @include generics.R |
|
2 |
NULL |
|
3 | ||
4 | ||
5 | ||
6 |
#' Standard Links |
|
7 |
#' |
|
8 |
#' @param prior ([`Prior`]) \cr A [`Prior`] object. |
|
9 |
#' @param model ([`LongitudinalModel`]) \cr A [`LongitudinalModel`] object. |
|
10 |
#' @param ... Not used. |
|
11 |
#' |
|
12 |
#' @description |
|
13 |
#' These functions are used to enable the use of the corresponding link function between |
|
14 |
#' the survival and longitudinal models in a joint model. Note that the exact implementation |
|
15 |
#' of the link function is model specific, see |
|
16 |
#' \code{vignette("Statistical Specifications", package = "jmpost")} for more details. |
|
17 |
#' |
|
18 |
#' @name standard-link-user |
|
19 |
NULL |
|
20 | ||
21 | ||
22 | ||
23 | ||
24 |
#' @describeIn standard-link-user No link (fit the survival and longitudinal models independently) |
|
25 |
#' @export |
|
26 |
linkNone <- function() { |
|
27 | 1x |
Link() |
28 |
} |
|
29 | ||
30 | ||
31 |
#' @describeIn standard-link-user Time to growth link |
|
32 |
#' @export |
|
33 |
linkTTG <- function(prior, model = PromiseLongitudinalModel(), ...) { |
|
34 | 12x |
UseMethod("linkTTG", model) |
35 |
} |
|
36 |
#' @export |
|
37 |
linkTTG.PromiseLongitudinalModel <- function(prior = prior_normal(0, 2), model, ...) { |
|
38 | 5x |
PromiseLinkComponent(fun = linkTTG, prior = prior, key = "link_ttg") |
39 |
} |
|
40 |
#' @export |
|
41 |
linkTTG.default <- function(prior, model, ...) { |
|
42 | 1x |
stop(sprintf("Method `linkTTG` is not available for `%s`", class(model)[[1]])) |
43 |
} |
|
44 | ||
45 | ||
46 | ||
47 | ||
48 |
#' @describeIn standard-link-user Derivative of the SLD over time link |
|
49 |
#' @export |
|
50 |
linkDSLD <- function(prior, model = PromiseLongitudinalModel(), ...) { |
|
51 | 35x |
UseMethod("linkDSLD", model) |
52 |
} |
|
53 |
#' @export |
|
54 |
linkDSLD.PromiseLongitudinalModel <- function(prior = prior_normal(0, 2), model, ...) { |
|
55 | 18x |
PromiseLinkComponent(fun = linkDSLD, prior = prior, key = "link_dsld") |
56 |
} |
|
57 |
#' @export |
|
58 |
linkDSLD.default <- function(prior, model, ...) { |
|
59 | ! |
stop(sprintf("Method `linkDSLD` is not available for `%s`", class(model)[[1]])) |
60 |
} |
|
61 | ||
62 | ||
63 | ||
64 | ||
65 |
#' @describeIn standard-link-user Current SLD value link |
|
66 |
#' @export |
|
67 |
linkIdentity <- function(prior, model = PromiseLongitudinalModel(), ...) { |
|
68 | 8x |
UseMethod("linkIdentity", model) |
69 |
} |
|
70 |
#' @export |
|
71 |
linkIdentity.PromiseLongitudinalModel <- function(prior = prior_normal(0, 2), model, ...) { |
|
72 | 3x |
PromiseLinkComponent(fun = linkIdentity, prior = prior, key = "link_identity") |
73 |
} |
|
74 |
#' @export |
|
75 |
linkIdentity.default <- function(prior, model, ...) { |
|
76 | ! |
stop(sprintf("Method `linkIdentity` is not available for `%s`", class(model)[[1]])) |
77 |
} |
|
78 | ||
79 | ||
80 |
#' @describeIn standard-link-user Growth Parameter link |
|
81 |
#' @export |
|
82 |
linkGrowth <- function(prior, model = PromiseLongitudinalModel(), ...) { |
|
83 | 18x |
UseMethod("linkGrowth", model) |
84 |
} |
|
85 |
#' @export |
|
86 |
linkGrowth.PromiseLongitudinalModel <- function(prior = prior_normal(0, 2), model, ...) { |
|
87 | 9x |
PromiseLinkComponent(fun = linkGrowth, prior = prior, key = "link_growth") |
88 |
} |
|
89 |
#' @export |
|
90 |
linkGrowth.default <- function(prior, model, ...) { |
|
91 | ! |
stop(sprintf("Method `linkGrowth` is not available for `%s`", class(model)[[1]])) |
92 |
} |
|
93 | ||
94 | ||
95 |
#' @describeIn standard-link-user Shrinkage Parameter link |
|
96 |
#' @export |
|
97 |
linkShrinkage <- function(prior, model = PromiseLongitudinalModel(), ...) { |
|
98 | 12x |
UseMethod("linkShrinkage", model) |
99 |
} |
|
100 |
#' @export |
|
101 |
linkShrinkage.PromiseLongitudinalModel <- function(prior = prior_normal(0, 2), model, ...) { |
|
102 | 6x |
PromiseLinkComponent(fun = linkShrinkage, prior = prior, key = "link_shrinkage") |
103 |
} |
|
104 |
#' @export |
|
105 |
linkShrinkage.default <- function(prior, model, ...) { |
|
106 | ! |
stop(sprintf("Method `linkShrinkage` is not available for `%s`", class(model)[[1]])) |
107 |
} |
1 |
#' @include DataSurvival.R |
|
2 |
#' @include DataLongitudinal.R |
|
3 |
#' @include DataSubject.R |
|
4 |
NULL |
|
5 | ||
6 | ||
7 |
#' Re-used documentation for `DataJoint` |
|
8 |
#' |
|
9 |
#' @param object ([`DataJoint`]) \cr Survival and Longitudinal Data. |
|
10 |
#' @param x ([`DataJoint`]) \cr Survival and Longitudinal Data. |
|
11 |
#' @param ... Not Used. |
|
12 |
#' |
|
13 |
#' @name DataJoint-Shared |
|
14 |
#' @keywords internal |
|
15 |
NULL |
|
16 | ||
17 |
setClassUnion("DataLongitudinal_or_NULL", c("DataLongitudinal", "NULL")) |
|
18 |
setClassUnion("DataSurvival_or_NULL", c("DataSurvival", "NULL")) |
|
19 | ||
20 | ||
21 |
# DataJoint-class ---- |
|
22 | ||
23 |
#' @title |
|
24 |
#' Joint Data Object and Constructor Function |
|
25 |
#' |
|
26 |
#' @description |
|
27 |
#' The `DataJoint` class handles combining data from a [`DataSurvival`] object and a |
|
28 |
#' [`DataLongitudinal`] object. |
|
29 |
#' |
|
30 |
#' @slot subject (`DataSubject`)\cr See Argument for details. |
|
31 |
#' @slot survival (`DataSurvival`)\cr See Argument for details. |
|
32 |
#' @slot longitudinal (`DataLongitudinal`)\cr See Argument for details. |
|
33 |
#' |
|
34 |
#' @family DataObjects |
|
35 |
#' @family DataJoint |
|
36 |
#' @export DataJoint |
|
37 |
#' @exportClass DataJoint |
|
38 |
.DataJoint <- setClass( |
|
39 |
Class = "DataJoint", |
|
40 |
representation = list( |
|
41 |
subject = "DataSubject", |
|
42 |
survival = "DataSurvival_or_NULL", |
|
43 |
longitudinal = "DataLongitudinal_or_NULL" |
|
44 |
) |
|
45 |
) |
|
46 | ||
47 |
#' @param subject (`DataSubject`)\cr object created by [DataSubject()]. |
|
48 |
#' @param survival (`DataSurvival`)\cr object created by [DataSurvival()]. |
|
49 |
#' @param longitudinal (`DataLongitudinal`)\cr object created by [DataLongitudinal()]. |
|
50 |
#' @rdname DataJoint-class |
|
51 |
DataJoint <- function(subject, survival = NULL, longitudinal = NULL) { |
|
52 | ||
53 | 29x |
subject_suited <- harmonise(subject) |
54 | 28x |
vars <- extractVariableNames(subject) |
55 | 28x |
subject_var <- vars$subject |
56 | 28x |
subject_ord <- levels(as.data.frame(subject_suited)[[vars$subject]]) |
57 | ||
58 | 28x |
survival_suited <- harmonise( |
59 | 28x |
survival, |
60 | 28x |
subject_var = subject_var, |
61 | 28x |
subject_ord = subject_ord |
62 |
) |
|
63 | ||
64 | 25x |
longitudinal_suited <- harmonise( |
65 | 25x |
longitudinal, |
66 | 25x |
subject_var = subject_var, |
67 | 25x |
subject_ord = subject_ord |
68 |
) |
|
69 | ||
70 | 22x |
.DataJoint( |
71 | 22x |
subject = subject_suited, |
72 | 22x |
survival = survival_suited, |
73 | 22x |
longitudinal = longitudinal_suited |
74 |
) |
|
75 |
} |
|
76 | ||
77 | ||
78 | ||
79 |
setValidity( |
|
80 |
Class = "DataJoint", |
|
81 |
method = function(object) { |
|
82 |
vars <- extractVariableNames(object@subject) |
|
83 |
subject_var <- vars$subject |
|
84 |
subject_ord <- as.character(as.data.frame(object@subject)[[vars$subject]]) |
|
85 |
if (!is.null(object@survival)) { |
|
86 |
survival_df <- as.data.frame(object@survival) |
|
87 |
if (!subject_var %in% names(survival_df)) { |
|
88 |
return(sprintf("Unable to find `%s` in `survival`", sujbect_var)) |
|
89 |
} |
|
90 |
if (!all(survival_df[[subject_var]] %in% subject_ord)) { |
|
91 |
return("There are subjects in `survival` that are not in `subject`") |
|
92 |
} |
|
93 |
if (!nrow(survival_df) == length(unique(survival_df[[subject_var]]))) { |
|
94 |
return("There are duplicate subjects in `survival`") |
|
95 |
} |
|
96 |
} |
|
97 |
if (!is.null(object@longitudinal)) { |
|
98 |
long_df <- as.data.frame(object@longitudinal) |
|
99 |
if (!subject_var %in% names(long_df)) { |
|
100 |
return(sprintf("Unable to find `%s` in `longitudinal`", sujbect_var)) |
|
101 |
} |
|
102 |
if (!all(long_df[[subject_var]] %in% subject_ord)) { |
|
103 |
return("There are subjects in `longitudinal` that are not in `subject`") |
|
104 |
} |
|
105 |
} |
|
106 |
subject_df <- as.data.frame(object@subject) |
|
107 |
if (!subject_var %in% names(subject_df)) { |
|
108 |
return(sprintf("Unable to find `%s` in `subject`", sujbect_var)) |
|
109 |
} |
|
110 |
if (!nrow(subject_df) == length(unique(subject_df[[subject_var]]))) { |
|
111 |
return("There are duplicate subjects in `subject`") |
|
112 |
} |
|
113 |
return(TRUE) |
|
114 |
} |
|
115 |
) |
|
116 | ||
117 | ||
118 |
# DataJoint-as.list ---- |
|
119 | ||
120 | ||
121 | ||
122 | ||
123 |
#' Data Object -> `list` |
|
124 |
#' |
|
125 |
#' @param object (`DataSubject` or `DataLongitudinal` or `DataSurvival`) \cr |
|
126 |
#' data object to convert to a `list`. |
|
127 |
#' @param x (`DataSubject` or `DataLongitudinal` or `DataSurvival`) \cr |
|
128 |
#' data object to convert to a `list`. |
|
129 |
#' @param subject_var (`character`) \cr the name of the variable |
|
130 |
#' containing the subject identifier. |
|
131 |
#' @param ... not used. |
|
132 |
#' |
|
133 |
#' @description |
|
134 |
#' Coerces a data object into a `list` of data components required |
|
135 |
#' for fitting a [`JointModel`]. See the "Extending jmpost" vignette for more details. |
|
136 |
#' |
|
137 |
#' @name as_stan_list.DataObject |
|
138 |
#' @family as_stan_list |
|
139 |
#' @family DataJoint |
|
140 |
#' @export |
|
141 |
as_stan_list.DataJoint <- function(object, ...) { |
|
142 | 289x |
vars <- extractVariableNames(object@subject) |
143 | 289x |
subject_var <- vars$subject |
144 | 289x |
as_stan_list(object@subject) |> |
145 | 289x |
append(as_stan_list(object@survival)) |> |
146 | 289x |
append(as_stan_list( |
147 | 289x |
object@longitudinal, |
148 | 289x |
subject_var = subject_var |
149 |
)) |
|
150 |
} |
|
151 | ||
152 |
#' @rdname as_stan_list.DataObject |
|
153 |
#' @export |
|
154 |
as.list.DataJoint <- function(x, ...) { |
|
155 | 241x |
as_stan_list(x, ...) |
156 |
} |
|
157 | ||
158 | ||
159 | ||
160 |
#' Subsetting `DataJoint` as a `data.frame` |
|
161 |
#' |
|
162 |
#' @param x (`DataJoint`) \cr object created by [DataJoint()]. |
|
163 |
#' @param subjects (`character` or `list`)\cr subjects that you wish to subset the `data.frame` |
|
164 |
#' to contain. See details. |
|
165 |
#' @param ... Not used. |
|
166 |
#' |
|
167 |
#' @description |
|
168 |
#' |
|
169 |
#' Coerces the object into a `data.frame` containing just event times and status |
|
170 |
#' filtering for specific subjects If `subjects` is a list then an additional variable `group` will be added |
|
171 |
#' onto the dataset specifying which group the row belongs to. |
|
172 |
#' |
|
173 |
#' @examples |
|
174 |
#' \dontrun{ |
|
175 |
#' subjects <- c("SUB1", "SUB2", "SUB3", "SUB4") |
|
176 |
#' subset(x, subjects) |
|
177 |
#' |
|
178 |
#' groups <- list( |
|
179 |
#' "g1" = c("SUB1", "SUB3", "SUB4"), |
|
180 |
#' "g2" = c("SUB2", "SUB3") |
|
181 |
#' ) |
|
182 |
#' subset(x, groups) |
|
183 |
#' } |
|
184 |
#' @family DataJoint |
|
185 |
#' @export |
|
186 |
subset.DataJoint <- function(x, subjects, ...) { |
|
187 | 2x |
data <- as.list(x) |
188 | 2x |
dat <- data.frame( |
189 | 2x |
time = data[["event_times"]], |
190 | 2x |
event = as.numeric(seq_along(data[["event_times"]]) %in% data[["subject_event_index"]]), |
191 | 2x |
subject = names(data[["subject_to_index"]]) |
192 |
) |
|
193 | 2x |
subset_and_add_grouping(dat, subjects) |
194 |
} |
|
195 | ||
196 | ||
197 | ||
198 |
#' `subset_and_add_grouping` |
|
199 |
#' |
|
200 |
#' @param dat (`data.frame`) \cr must have a column called `subject` which corresponds to the |
|
201 |
#' values passed to `groupings`. |
|
202 |
#' @param groupings (`character` or `list`)\cr subjects that you wish to subset the dataset |
|
203 |
#' to contain. If `groupings` is a list then an additional variable `group` will be added |
|
204 |
#' onto the dataset specifying which group the row belongs to. |
|
205 |
#' |
|
206 |
#' @details |
|
207 |
#' Example of usage |
|
208 |
#' ``` |
|
209 |
#' subjects <- c("SUB1", "SUB2", "SUB3", "SUB4") |
|
210 |
#' subset_and_add_grouping(dat, subjects) |
|
211 |
#' |
|
212 |
#' groups <- list( |
|
213 |
#' "g1" = c("SUB1", "SUB3", "SUB4"), |
|
214 |
#' "g2" = c("SUB2", "SUB3") |
|
215 |
#' ) |
|
216 |
#' subset_and_add_grouping(dat, groups) |
|
217 |
#' ``` |
|
218 |
#' |
|
219 |
#' @keywords internal |
|
220 |
subset_and_add_grouping <- function(dat, groupings) { |
|
221 | 8x |
groupings <- decompose_subjects(groupings, dat$subject)$groups |
222 | 5x |
dat_subset_list <- lapply( |
223 | 5x |
seq_along(groupings), |
224 | 5x |
\(i) { |
225 | 13x |
dat_reduced <- dat[dat$subject %in% groupings[[i]], , drop = FALSE] |
226 | 13x |
dat_reduced[["group"]] <- names(groupings)[[i]] |
227 | 13x |
dat_reduced |
228 |
} |
|
229 |
) |
|
230 | 5x |
x <- Reduce(rbind, dat_subset_list) |
231 | 5x |
row.names(x) <- NULL |
232 | 5x |
x |
233 |
} |
|
234 | ||
235 | ||
236 |
#' Extract Observed Longitudinal Values |
|
237 |
#' |
|
238 |
#' Utility function to extract the observed longitudinal values from a [`DataJoint`] object |
|
239 |
#' @param object ([`DataJoint`])\cr data used to fit a [`JointModel`]. |
|
240 |
#' @return A data.frame with the following columns |
|
241 |
#' - `subject` (`character`)\cr The subject identifier |
|
242 |
#' - `time` (`numeric`)\cr The time at which the observation occurred |
|
243 |
#' - `Yob` (`numeric`)\cr The observed value |
|
244 |
#' @keywords internal |
|
245 |
extract_observed_values <- function(object) { |
|
246 | 2x |
assert_class(object, "DataJoint") |
247 | 2x |
data <- as.list(object) |
248 | 2x |
x <- data.frame( |
249 | 2x |
subject = names(data$subject_to_index)[data$subject_tumour_index], |
250 | 2x |
time = data$tumour_time, |
251 | 2x |
Yob = data$tumour_value |
252 |
) |
|
253 | 2x |
row.names(x) <- NULL |
254 | 2x |
x |
255 |
} |
|
256 | ||
257 |
#' @rdname show-object |
|
258 |
#' @export |
|
259 |
setMethod( |
|
260 |
f = "show", |
|
261 |
signature = "DataJoint", |
|
262 |
definition = function(object) { |
|
263 | 1x |
string_survival <- if (is.null(object@survival)) { |
264 | ! |
" Survival-Data Object:\n Not Specified" |
265 |
} else { |
|
266 | 1x |
as_print_string(object@survival, indent = 5) |
267 |
} |
|
268 | ||
269 | 1x |
string_longitudinal <- if (is.null(object@longitudinal)) { |
270 | ! |
" Longitudinal-Data Object:\n Not Specified" |
271 |
} else { |
|
272 | 1x |
as_print_string(object@longitudinal, indent = 5) |
273 |
} |
|
274 | ||
275 | 1x |
template <- c( |
276 | 1x |
"Joint-Data Object Containing:", |
277 |
"", |
|
278 | 1x |
as_print_string(object@subject, indent = 5), |
279 |
"", |
|
280 | 1x |
string_survival, |
281 |
"", |
|
282 | 1x |
string_longitudinal |
283 |
) |
|
284 | 1x |
cat("\n", paste(template, collapse = "\n"), "\n\n") |
285 |
} |
|
286 |
) |
1 | ||
2 |
#' Abstract Simulation Class for Longitudinal Data |
|
3 |
#' |
|
4 |
#' @param times (`numeric`) the times to generate observations at. |
|
5 |
#' |
|
6 |
#' @description |
|
7 |
#' This class exists to be extended by other classes that simulate longitudinal data. |
|
8 |
#' It is not intended to be used directly. |
|
9 |
#' @name SimLongitudinal-class |
|
10 |
#' @family SimLongitudinal |
|
11 |
#' @exportClass SimLongitudinal |
|
12 |
.SimLongitudinal <- setClass( |
|
13 |
"SimLongitudinal", |
|
14 |
slots = list( |
|
15 |
times = "numeric" |
|
16 |
) |
|
17 |
) |
|
18 | ||
19 |
#' @rdname SimLongitudinal-class |
|
20 |
#' @export |
|
21 |
SimLongitudinal <- function(times = seq(0, 100, 50)) { |
|
22 | ! |
.SimLongitudinal(times = times) |
23 |
} |
|
24 | ||
25 | ||
26 |
#' @rdname show-object |
|
27 |
#' @export |
|
28 |
setMethod( |
|
29 |
f = "show", |
|
30 |
signature = "SimLongitudinal", |
|
31 |
definition = function(object) { |
|
32 | 4x |
x <- sprintf("\nA %s Object\n\n", as_print_string(object)) |
33 | 4x |
cat(x) |
34 | 4x |
return(object) |
35 |
} |
|
36 |
) |
|
37 | ||
38 |
#' @rdname as_print_string |
|
39 |
as_print_string.SimLongitudinal <- function(object) { |
|
40 | ! |
return("SimLongitudinal") |
41 |
} |
1 | ||
2 |
#' Re-used documentation for `Quantities` |
|
3 |
#' |
|
4 |
#' @param x ([`Quantities`]) \cr generated quantities. |
|
5 |
#' @param object ([`Quantities`]) \cr generated quantities. |
|
6 |
#' @param type (`character`)\cr sets the `type` variable. |
|
7 |
#' @param conf.level (`numeric`) \cr confidence level of the interval. |
|
8 |
#' @param ... not used. |
|
9 |
#' |
|
10 |
#' @keywords internal |
|
11 |
#' @name Quantities-Shared |
|
12 |
NULL |
|
13 | ||
14 | ||
15 |
#' Generated Quantities Container |
|
16 |
#' |
|
17 |
#' A simple wrapper around a `matrix` to store required metadata |
|
18 |
#' |
|
19 |
#' @param quantities (`matrix`)\cr of generated quantities. |
|
20 |
#' @param times (`numeric`)\cr labels specifying which time point the quantity was generated at. |
|
21 |
#' @param groups (`character`)\cr labels for which group the quantity belongs to. |
|
22 |
#' |
|
23 |
#' @slot quantities (`matrix`)\cr See Arguments for details. |
|
24 |
#' @slot times (`numeric`)\cr See Arguments for details. |
|
25 |
#' @slot groups (`character`)\cr See Arguments for details. |
|
26 |
#' |
|
27 |
#' @details |
|
28 |
#' Each row of the matrix represents a sample and each column represents a distinct quantity. |
|
29 |
#' As such the number of columns in the matrix should equal the length of `times` and `groups` |
|
30 |
#' which provide metadata for who the quantity belongs to and at what time point it was generated at. |
|
31 |
#' |
|
32 |
#' @keywords internal |
|
33 |
#' @name Quantities-class |
|
34 |
#' @family Quantities |
|
35 |
.Quantities <- setClass( |
|
36 |
"Quantities", |
|
37 |
slots = list( |
|
38 |
"quantities" = "matrix", |
|
39 |
"times" = "numeric", |
|
40 |
"groups" = "character" |
|
41 |
) |
|
42 |
) |
|
43 |
#' @rdname Quantities-class |
|
44 |
Quantities <- function(quantities, times, groups) { |
|
45 | 34x |
.Quantities( |
46 | 34x |
quantities = quantities, |
47 | 34x |
times = times, |
48 | 34x |
groups = groups |
49 |
) |
|
50 |
} |
|
51 | ||
52 |
setValidity( |
|
53 |
Class = "Quantities", |
|
54 |
method = function(object) { |
|
55 |
if (length(object@times) != length(object@groups)) { |
|
56 |
return("Length of `times` must be equal to the length of `groups`") |
|
57 |
} |
|
58 |
if (length(object@times) != ncol(object@quantities)) { |
|
59 |
return("Length of `times` must be equal to the number of columns in `quantities`") |
|
60 |
} |
|
61 |
return(TRUE) |
|
62 |
} |
|
63 |
) |
|
64 | ||
65 | ||
66 | ||
67 |
#' @export |
|
68 |
dim.Quantities <- function(x) { |
|
69 | 9x |
dim(x@quantities) |
70 |
} |
|
71 | ||
72 | ||
73 |
#' `Quantities` -> `data.frame` |
|
74 |
#' |
|
75 |
#' @inheritParams Quantities-Shared |
|
76 |
#' |
|
77 |
#' @keywords internal |
|
78 |
#' @family Quantities |
|
79 |
#' @export |
|
80 |
as.data.frame.Quantities <- function(x, ...) { |
|
81 | 2x |
data.frame( |
82 | 2x |
group = rep(x@groups, each = nrow(x@quantities)), |
83 | 2x |
time = rep(x@times, each = nrow(x@quantities)), |
84 | 2x |
values = as.vector(x@quantities) |
85 |
) |
|
86 |
} |
|
87 | ||
88 | ||
89 |
#' summary |
|
90 |
#' |
|
91 |
#' @description |
|
92 |
#' This method returns a summary statistic `data.frame` of the quantities. Note that this |
|
93 |
#' is just an internal utility method in order to share common code between |
|
94 |
#' [LongitudinalQuantities] and [SurvivalQuantities] |
|
95 |
#' |
|
96 |
#' @inheritParams Quantities-Shared |
|
97 |
#' |
|
98 |
#' @returns |
|
99 |
#' A `data.frame` with the following variables: |
|
100 |
#' - `median` (`numeric`) \cr the median value of the quantity. |
|
101 |
#' - `lower` (`numeric`) \cr the lower CI value of the quantity. |
|
102 |
#' - `upper` (`numeric`) \cr the upper CI value of the quantity. |
|
103 |
#' - `time` (`numeric`) \cr the time point which the quantity is for. |
|
104 |
#' - `group` (`character`) \cr which group the quantity belongs to. |
|
105 |
#' - `type` (`character`) \cr what type of quantity is it. |
|
106 |
#' |
|
107 |
#' @keywords internal |
|
108 |
#' @family Quantities |
|
109 |
#' @export |
|
110 |
summary.Quantities <- function(object, conf.level = 0.95, ...) { |
|
111 | 32x |
quantities_summarised <- samples_median_ci( |
112 | 32x |
object@quantities, |
113 | 32x |
level = conf.level |
114 |
) |
|
115 | ||
116 | 32x |
quantities_summarised$group <- object@groups |
117 | 32x |
quantities_summarised$time <- object@times |
118 | 32x |
quantities_summarised[, c("group", "time", "median", "lower", "upper")] |
119 |
} |
|
120 | ||
121 | ||
122 | ||
123 |
#' Create Grouped Quantities |
|
124 |
#' |
|
125 |
#' This function takes a matrix of quantity samples and aggregates them by calculating the |
|
126 |
#' pointwise average. |
|
127 |
#' |
|
128 |
#' @param quantities_raw (`matrix`)\cr of samples with 1 row per sample and 1 column per |
|
129 |
#' distinct quantity. |
|
130 |
#' |
|
131 |
#' @param collapser ([`QuantityCollapser`])\cr specifies which columns to combine together. |
|
132 |
#' |
|
133 |
#' @details |
|
134 |
#' This function essentially implements the group wise average by collapsing multiple columns |
|
135 |
#' together based on the specification provided by the `QuantityCollapser` object. |
|
136 |
#' The [Grid-Dev] page provides an example of what this function implements |
|
137 |
#' |
|
138 |
#' @keywords internal |
|
139 |
collapse_quantities <- function(quantities_raw, collapser) { |
|
140 | 34x |
assert_class(quantities_raw, "matrix") |
141 | 34x |
assert_class(collapser, "QuantityCollapser") |
142 | ||
143 | 34x |
quantities <- matrix( |
144 | 34x |
NA, |
145 | 34x |
nrow = nrow(quantities_raw), |
146 | 34x |
ncol = length(collapser) |
147 |
) |
|
148 | ||
149 | 34x |
for (idx in seq_len(length(collapser))) { |
150 | 13104x |
quantities[, idx] <- quantities_raw[ |
151 |
, |
|
152 | 13104x |
collapser@indexes[[idx]], |
153 | 13104x |
drop = FALSE |
154 | 13104x |
] |> rowMeans() |
155 |
} |
|
156 | ||
157 | 34x |
return(quantities) |
158 |
} |
|
159 | ||
160 |
#' Extract Survival Quantities |
|
161 |
#' |
|
162 |
#' Utility function to extract generated quantities from a [cmdstanr::CmdStanGQ] object. |
|
163 |
#' Multiple quantities are generated by default so this is a convenience function to extract |
|
164 |
#' the desired ones and return them them as a user friendly [posterior::draws_matrix] object |
|
165 |
#' |
|
166 |
#' @param gq (`CmdStanGQ`) \cr a [cmdstanr::CmdStanGQ] object created by [generateQuantities()]. |
|
167 |
#' @param type (`character`)\cr quantity to be generated. |
|
168 |
#' Must be one of `surv`, `haz`, `loghaz`, `cumhaz`, `lm_identity`. |
|
169 |
#' @keywords internal |
|
170 |
extract_quantities <- function(gq, type = c("surv", "haz", "loghaz", "cumhaz", "lm_identity")) { |
|
171 | 35x |
type <- match.arg(type) |
172 | 35x |
assert_class(gq, "CmdStanGQ") |
173 | 35x |
meta <- switch(type, |
174 | 35x |
surv = list("log_surv_fit_at_time_grid", exp), |
175 | 35x |
cumhaz = list("log_surv_fit_at_time_grid", \(x) -x), |
176 | 35x |
haz = list("log_haz_fit_at_time_grid", exp), |
177 | 35x |
loghaz = list("log_haz_fit_at_time_grid", identity), |
178 | 35x |
lm_identity = list("y_fit_at_time_grid", identity) |
179 |
) |
|
180 | 35x |
result <- gq$draws(meta[[1]], format = "draws_matrix") |
181 | 35x |
result_transformed <- meta[[2]](result) |
182 | 35x |
cnames <- colnames(result_transformed) |
183 | 35x |
colnames(result_transformed) <- gsub(meta[[1]], "quantity", cnames) |
184 | 35x |
result_transformed |
185 |
} |
|
186 | ||
187 | ||
188 |
#' `Quantities` -> Printable `Character` |
|
189 |
#' |
|
190 |
#' Converts [`Quantities`] object into a printable string. |
|
191 |
#' @inheritParams Quantities-Shared |
|
192 |
#' @family Quantities |
|
193 |
#' @keywords internal |
|
194 |
#' @export |
|
195 |
as_print_string.Quantities <- function(object, indent = 1, ...) { |
|
196 | 1x |
template <- c( |
197 | 1x |
"Quantities Object:", |
198 | 1x |
" # of samples = %d", |
199 | 1x |
" # of quantities = %d" |
200 |
) |
|
201 | 1x |
pad <- rep(" ", indent) |> paste(collapse = "") |
202 | 1x |
template_padded <- paste(pad, template) |
203 | 1x |
sprintf( |
204 | 1x |
paste(template_padded, collapse = "\n"), |
205 | 1x |
nrow(object), |
206 | 1x |
ncol(object) |
207 |
) |
|
208 |
} |
|
209 | ||
210 | ||
211 |
#' @rdname show-object |
|
212 |
#' @export |
|
213 |
setMethod( |
|
214 |
f = "show", |
|
215 |
signature = "Quantities", |
|
216 |
definition = function(object) { |
|
217 | 1x |
string <- as_print_string(object) |
218 | 1x |
cat("\n", string, "\n\n") |
219 |
} |
|
220 |
) |
1 | ||
2 |
.onAttach <- function(libname, pkgname) { |
|
3 | 4x |
if (!is_cmdstanr_available()) { |
4 | ! |
packageStartupMessage( |
5 | ! |
"jmpost uses cmdstanr for compiling and sampling from models, but it does not seem to be installed.\n", |
6 | ! |
"To install:\n", |
7 | ! |
"install.packages(\"cmdstanr\", repos = c(\"https://stan-dev.r-universe.dev/\", getOption(\"repos\")))" |
8 |
) |
|
9 | 4x |
} else if (is.null(cmdstanr::cmdstan_version(error_on_NA = FALSE))) { |
10 | ! |
possible_paths <- unique(c( |
11 | ! |
cmdstanr::cmdstan_default_install_path(), |
12 | ! |
Sys.getenv("CMDSTAN"), |
13 | ! |
Sys.getenv("CMDSTAN_PATH"), |
14 | ! |
"/root/.cmdstan", |
15 | ! |
"~/.cmdstan" |
16 |
)) |
|
17 | ! |
possible_paths <- possible_paths[dir.exists(possible_paths)] |
18 | ||
19 | ! |
if (length(possible_paths)) { |
20 | ! |
for (try_path in possible_paths) { |
21 | ! |
new_path <- tryCatch( |
22 | ! |
suppressMessages(cmdstanr::set_cmdstan_path(try_path)), |
23 | ! |
warning = function(w) NULL, |
24 | ! |
error = function(e) NULL |
25 |
) |
|
26 |
} |
|
27 | ! |
if (!is.null(new_path)) { |
28 | ! |
packageStartupMessage("CmdStan path set to: ", new_path) |
29 |
} |
|
30 |
} else { |
|
31 | ! |
packageStartupMessage("jmpost could not identify CmdStan path. Please use cmdstanr::set_cmdstan_path()") |
32 |
} |
|
33 |
} |
|
34 | 4x |
return(invisible(NULL)) |
35 |
} |
|
36 | ||
37 |
.onLoad <- function(...) { |
|
38 | ! |
set_options() |
39 | ! |
s3_register("cmdstanr::as.CmdStanMCMC", "JointModelSamples") |
40 |
} |
|
41 | ||
42 |
# This only exists to silence the false positive R CMD CHECK warning about |
|
43 |
# importing but not using the posterior package. posterior is a dependency |
|
44 |
# of rcmdstan that we use a lot implicitly. Also we link to their documentation |
|
45 |
# pages in ours |
|
46 |
.never_run <- function() { |
|
47 | ! |
posterior::as_draws() |
48 |
} |
1 |
#' @include StanModel.R |
|
2 |
NULL |
|
3 | ||
4 |
# LongitudinalModel-class ---- |
|
5 | ||
6 |
#' `LongitudinalModel` |
|
7 |
#' |
|
8 |
#' This class extends the general [`StanModel`] class to comprise the longitudinal |
|
9 |
#' model specification. |
|
10 |
#' |
|
11 |
#' @exportClass LongitudinalModel |
|
12 |
.LongitudinalModel <- setClass( |
|
13 |
Class = "LongitudinalModel", |
|
14 |
contains = "StanModel" |
|
15 |
) |
|
16 | ||
17 |
# LongitudinalModel-constructors ---- |
|
18 | ||
19 |
#' @rdname LongitudinalModel-class |
|
20 |
#' |
|
21 |
#' @inheritParams stanmodel_arguments |
|
22 |
#' |
|
23 |
#' @export |
|
24 |
LongitudinalModel <- function( |
|
25 |
stan = StanModule(), |
|
26 |
parameters = ParameterList(), |
|
27 |
name = "<Unnamed>", |
|
28 |
... |
|
29 |
) { |
|
30 | 85x |
base_stan <- read_stan("base/longitudinal.stan") |
31 | ||
32 | 85x |
stan_full <- decorated_render( |
33 | 85x |
.x = base_stan, |
34 | 85x |
stan = add_missing_stan_blocks(as.list(stan)) |
35 |
) |
|
36 | ||
37 | 85x |
.LongitudinalModel( |
38 | 85x |
StanModel( |
39 | 85x |
stan = StanModule(stan_full), |
40 | 85x |
parameters = parameters, |
41 | 85x |
name = name, |
42 |
... |
|
43 |
) |
|
44 |
) |
|
45 |
} |
|
46 | ||
47 |
#' @export |
|
48 |
as_print_string.LongitudinalModel <- function(object, ...) { |
|
49 | 5x |
string <- sprintf( |
50 | 5x |
"\n%s Longitudinal Model with parameters:\n%s\n\n", |
51 | 5x |
object@name, |
52 | 5x |
paste(" ", as_print_string(object@parameters)) |> paste(collapse = "\n") |
53 |
) |
|
54 | 5x |
return(string) |
55 |
} |
1 |
#' @include LongitudinalModel.R |
|
2 |
#' @include StanModule.R |
|
3 |
#' @include generics.R |
|
4 |
#' @include ParameterList.R |
|
5 |
#' @include Parameter.R |
|
6 |
#' @include Link.R |
|
7 |
NULL |
|
8 | ||
9 |
# LongitudinalGSF-class ---- |
|
10 | ||
11 |
#' `LongitudinalGSF` |
|
12 |
#' |
|
13 |
#' This class extends the general [`LongitudinalModel`] class for using the |
|
14 |
#' Generalized Stein-Fojo (GSF) model for the longitudinal outcome. |
|
15 |
#' |
|
16 |
#' @section Available Links: |
|
17 |
#' - [`linkDSLD()`] |
|
18 |
#' - [`linkTTG()`] |
|
19 |
#' - [`linkIdentity()`] |
|
20 |
#' - [`linkGrowth()`] |
|
21 |
#' @exportClass LongitudinalGSF |
|
22 |
.LongitudinalGSF <- setClass( |
|
23 |
Class = "LongitudinalGSF", |
|
24 |
contains = "LongitudinalModel" |
|
25 |
) |
|
26 | ||
27 |
# LongitudinalGSF-constructors ---- |
|
28 | ||
29 |
#' @rdname LongitudinalGSF-class |
|
30 |
#' |
|
31 |
#' @param mu_bsld (`Prior`)\cr for the mean baseline value `mu_bsld`. |
|
32 |
#' @param mu_ks (`Prior`)\cr for the mean shrinkage rate `mu_ks`. |
|
33 |
#' @param mu_kg (`Prior`)\cr for the mean growth rate `mu_kg`. |
|
34 |
#' @param mu_phi (`Prior`)\cr for the mean proportion of cells affected by the treatment `mu_phi`. |
|
35 |
#' |
|
36 |
#' @param omega_bsld (`Prior`)\cr for the baseline value standard deviation `omega_bsld`. |
|
37 |
#' @param omega_ks (`Prior`)\cr for the shrinkage rate standard deviation `omega_ks`. |
|
38 |
#' @param omega_kg (`Prior`)\cr for the growth rate standard deviation `omega_kg`. |
|
39 |
#' @param omega_phi (`Prior`)\cr for the standard deviation of the proportion of cells |
|
40 |
#' affected by the treatment `omega_phi`. |
|
41 |
#' |
|
42 |
#' @param sigma (`Prior`)\cr for the variance of the longitudinal values `sigma`. |
|
43 |
#' |
|
44 |
#' @param centred (`logical`)\cr whether to use the centred parameterization. |
|
45 |
#' @param scaled_variance (`logical`)\cr whether the variance should be scaled by the expected value |
|
46 |
#' (see the "Statistical Specifications" vignette for more details) |
|
47 |
#' |
|
48 |
#' @importFrom stats qlogis |
|
49 |
#' @export |
|
50 |
LongitudinalGSF <- function( |
|
51 | ||
52 |
mu_bsld = prior_normal(log(60), 1), |
|
53 |
mu_ks = prior_normal(log(0.5), 1), |
|
54 |
mu_kg = prior_normal(log(0.3), 1), |
|
55 |
mu_phi = prior_normal(qlogis(0.5), 1), |
|
56 | ||
57 |
omega_bsld = prior_lognormal(log(0.2), 1), |
|
58 |
omega_ks = prior_lognormal(log(0.2), 1), |
|
59 |
omega_kg = prior_lognormal(log(0.2), 1), |
|
60 |
omega_phi = prior_lognormal(log(0.2), 1), |
|
61 | ||
62 |
sigma = prior_lognormal(log(0.1), 1), |
|
63 | ||
64 |
scaled_variance = TRUE, |
|
65 |
centred = FALSE |
|
66 |
) { |
|
67 | ||
68 | 27x |
gsf_model <- StanModule(decorated_render( |
69 | 27x |
.x = read_stan("lm-gsf/model.stan"), |
70 | 27x |
centred = centred, |
71 | 27x |
scaled_variance = scaled_variance |
72 |
)) |
|
73 | ||
74 |
# Apply constraints |
|
75 | 27x |
omega_bsld <- set_limits(omega_bsld, lower = 0) |
76 | 27x |
omega_ks <- set_limits(omega_ks, lower = 0) |
77 | 27x |
omega_kg <- set_limits(omega_kg, lower = 0) |
78 | 27x |
omega_phi <- set_limits(omega_phi, lower = 0) |
79 | 27x |
sigma <- set_limits(sigma, lower = 0) |
80 | ||
81 | ||
82 | 27x |
parameters <- list( |
83 | 27x |
Parameter(name = "lm_gsf_mu_bsld", prior = mu_bsld, size = "n_studies"), |
84 | 27x |
Parameter(name = "lm_gsf_mu_ks", prior = mu_ks, size = "n_arms"), |
85 | 27x |
Parameter(name = "lm_gsf_mu_kg", prior = mu_kg, size = "n_arms"), |
86 | 27x |
Parameter(name = "lm_gsf_mu_phi", prior = mu_phi, size = "n_arms"), |
87 | ||
88 | 27x |
Parameter(name = "lm_gsf_omega_bsld", prior = omega_bsld, size = "n_studies"), |
89 | 27x |
Parameter(name = "lm_gsf_omega_ks", prior = omega_ks, size = "n_arms"), |
90 | 27x |
Parameter(name = "lm_gsf_omega_kg", prior = omega_kg, size = "n_arms"), |
91 | 27x |
Parameter(name = "lm_gsf_omega_phi", prior = omega_phi, size = "n_arms"), |
92 | ||
93 | 27x |
Parameter(name = "lm_gsf_sigma", prior = sigma, size = 1) |
94 |
) |
|
95 | ||
96 | 27x |
assert_flag(centred) |
97 | 27x |
parameters_extra <- if (centred) { |
98 | 4x |
list( |
99 | 4x |
Parameter( |
100 | 4x |
name = "lm_gsf_psi_bsld", |
101 | 4x |
prior = prior_init_only(prior_lognormal(median(mu_bsld), median(omega_bsld))), |
102 | 4x |
size = "n_subjects" |
103 |
), |
|
104 | 4x |
Parameter( |
105 | 4x |
name = "lm_gsf_psi_ks", |
106 | 4x |
prior = prior_init_only(prior_lognormal(median(mu_ks), median(omega_ks))), |
107 | 4x |
size = "n_subjects" |
108 |
), |
|
109 | 4x |
Parameter( |
110 | 4x |
name = "lm_gsf_psi_kg", |
111 | 4x |
prior = prior_init_only(prior_lognormal(median(mu_kg), median(omega_kg))), |
112 | 4x |
size = "n_subjects" |
113 |
), |
|
114 | 4x |
Parameter( |
115 | 4x |
name = "lm_gsf_psi_phi_logit", |
116 | 4x |
prior = prior_init_only(prior_normal(median(mu_phi), median(omega_phi))), |
117 | 4x |
size = "n_subjects" |
118 |
) |
|
119 |
) |
|
120 |
} else { |
|
121 | 23x |
list( |
122 | 23x |
Parameter(name = "lm_gsf_eta_tilde_bsld", prior = prior_std_normal(), size = "n_subjects"), |
123 | 23x |
Parameter(name = "lm_gsf_eta_tilde_ks", prior = prior_std_normal(), size = "n_subjects"), |
124 | 23x |
Parameter(name = "lm_gsf_eta_tilde_kg", prior = prior_std_normal(), size = "n_subjects"), |
125 | 23x |
Parameter(name = "lm_gsf_eta_tilde_phi", prior = prior_std_normal(), size = "n_subjects") |
126 |
) |
|
127 |
} |
|
128 | 27x |
parameters <- append(parameters, parameters_extra) |
129 | ||
130 | 27x |
x <- LongitudinalModel( |
131 | 27x |
name = "Generalized Stein-Fojo", |
132 | 27x |
stan = merge( |
133 | 27x |
gsf_model, |
134 | 27x |
StanModule("lm-gsf/functions.stan") |
135 |
), |
|
136 | 27x |
parameters = do.call(ParameterList, parameters) |
137 |
) |
|
138 | 27x |
.LongitudinalGSF(x) |
139 |
} |
|
140 | ||
141 | ||
142 | ||
143 |
#' @export |
|
144 |
enableGQ.LongitudinalGSF <- function(object, ...) { |
|
145 | 7x |
StanModule("lm-gsf/quantities.stan") |
146 |
} |
|
147 | ||
148 | ||
149 |
#' @export |
|
150 |
enableLink.LongitudinalGSF <- function(object, ...) { |
|
151 | 10x |
object@stan <- merge( |
152 | 10x |
object@stan, |
153 | 10x |
StanModule("lm-gsf/link.stan") |
154 |
) |
|
155 | 10x |
object |
156 |
} |
|
157 | ||
158 |
#' @export |
|
159 |
linkDSLD.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) { |
|
160 | 7x |
LinkComponent( |
161 | 7x |
key = "link_dsld", |
162 | 7x |
stan = StanModule("lm-gsf/link_dsld.stan"), |
163 | 7x |
prior = prior |
164 |
) |
|
165 |
} |
|
166 | ||
167 |
#' @export |
|
168 |
linkTTG.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) { |
|
169 | 4x |
LinkComponent( |
170 | 4x |
key = "link_ttg", |
171 | 4x |
stan = StanModule("lm-gsf/link_ttg.stan"), |
172 | 4x |
prior = prior |
173 |
) |
|
174 |
} |
|
175 | ||
176 |
#' @export |
|
177 |
linkIdentity.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) { |
|
178 | 3x |
LinkComponent( |
179 | 3x |
key = "link_identity", |
180 | 3x |
stan = StanModule("lm-gsf/link_identity.stan"), |
181 | 3x |
prior = prior |
182 |
) |
|
183 |
} |
|
184 | ||
185 |
#' @export |
|
186 |
linkGrowth.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) { |
|
187 | 6x |
LinkComponent( |
188 | 6x |
key = "link_growth", |
189 | 6x |
stan = StanModule("lm-gsf/link_growth.stan"), |
190 | 6x |
prior = prior |
191 |
) |
|
192 |
} |
|
193 | ||
194 | ||
195 |
#' @export |
|
196 |
linkShrinkage.LongitudinalGSF <- function(prior = prior_normal(0, 2), model, ...) { |
|
197 | 5x |
LinkComponent( |
198 | 5x |
key = "link_shrinkage", |
199 | 5x |
stan = StanModule("lm-gsf/link_shrinkage.stan"), |
200 | 5x |
prior = prior |
201 |
) |
|
202 |
} |
|
203 | ||
204 |
#' @rdname getPredictionNames |
|
205 |
#' @export |
|
206 |
getPredictionNames.LongitudinalGSF <- function(object, ...) { |
|
207 | 3x |
c("b", "s", "g", "phi") |
208 |
} |
1 |
#' @include generics.R |
|
2 |
#' @include Prior.R |
|
3 |
NULL |
|
4 | ||
5 | ||
6 |
#' `Parameter` Function Arguments |
|
7 |
#' |
|
8 |
#' The documentation lists all the conventional arguments for [`Parameter`] |
|
9 |
#' constructors. |
|
10 |
#' |
|
11 |
#' @param x ([`Parameter`])\cr a prior Distribution |
|
12 |
#' @param object ([`Parameter`])\cr a prior Distribution |
|
13 |
#' @param ... Not Used. |
|
14 |
#' |
|
15 |
#' @name Parameter-Shared |
|
16 |
#' @keywords internal |
|
17 |
NULL |
|
18 | ||
19 | ||
20 |
setClassUnion(name = "numeric_OR_character", c("numeric", "character")) |
|
21 | ||
22 |
# Parameter-class ---- |
|
23 | ||
24 |
#' `Parameter` |
|
25 |
#' |
|
26 |
#' Stores the name, the prior distribution and the size of a parameter. |
|
27 |
#' If `size` is a string then this indicates the name of the variable |
|
28 |
#' within the stan data object that specifies the size of this parameter. |
|
29 |
#' |
|
30 |
#' @slot name (`string`)\cr of the parameter. |
|
31 |
#' @slot prior (`Prior`)\cr for the parameter. |
|
32 |
#' @slot size (`numeric` or `string`)\cr dimension of the parameter. |
|
33 |
#' |
|
34 |
#' @family Parameter |
|
35 |
#' @exportClass Parameter |
|
36 |
#' @export Parameter |
|
37 |
.Parameter <- setClass( |
|
38 |
Class = "Parameter", |
|
39 |
slots = list( |
|
40 |
"name" = "character", |
|
41 |
"prior" = "Prior", |
|
42 |
"size" = "numeric_OR_character" |
|
43 |
) |
|
44 |
) |
|
45 |
#' @param prior (`Prior`)\cr for the parameter. |
|
46 |
#' @param name (`string`)\cr of the parameter. |
|
47 |
#' @param size (`numeric` or `string`)\cr dimension of the parameter. |
|
48 |
#' @rdname Parameter-class |
|
49 |
Parameter <- function(prior, name, size = 1) { |
|
50 | 1056x |
.Parameter( |
51 | 1056x |
prior = prior, |
52 | 1056x |
name = name, |
53 | 1056x |
size = size |
54 |
) |
|
55 |
} |
|
56 |
setValidity( |
|
57 |
Class = "Parameter", |
|
58 |
method = function(object) { |
|
59 |
if (!length(object@name) == 1) { |
|
60 |
return("Name must be a length 1 character vector") |
|
61 |
} |
|
62 |
if (is.character(object@size)) { |
|
63 |
if (!length(object@size) == 1) { |
|
64 |
return("Size must be a numeric vector or length 1 character vector") |
|
65 |
} |
|
66 |
} |
|
67 |
return(TRUE) |
|
68 |
} |
|
69 |
) |
|
70 | ||
71 | ||
72 |
#' `Parameter` -> `StanModule` |
|
73 |
#' |
|
74 |
#' Converts a [`Parameter`] object to a [`StanModule`] object |
|
75 |
#' |
|
76 |
#' @inheritParams Parameter-Shared |
|
77 |
#' |
|
78 |
#' @family Parameter |
|
79 |
#' @family as.StanModule |
|
80 |
#' @export |
|
81 |
as.StanModule.Parameter <- function(object, ...) { |
|
82 | 882x |
as.StanModule(object@prior, name = object@name) |
83 |
} |
|
84 | ||
85 | ||
86 |
#' `Parameter` -> `list` |
|
87 |
#' |
|
88 |
#' Converts a Parameter object to a list of parameter data values |
|
89 |
#' for a Stan model. |
|
90 |
#' |
|
91 |
#' @inheritParams Parameter-Shared |
|
92 |
#' |
|
93 |
#' @family as_stan_list |
|
94 |
#' @family Parameter |
|
95 |
#' @export |
|
96 |
as_stan_list.Parameter <- function(object, ...) { |
|
97 | 374x |
as_stan_list(object@prior, name = object@name) |
98 |
} |
|
99 | ||
100 | ||
101 |
#' Parameter Getter Functions |
|
102 |
#' |
|
103 |
#' @param x (`Paramater`) \cr A model parameter |
|
104 |
#' @param object (`Paramater`) \cr A model parameter |
|
105 |
#' @param ... Not used. |
|
106 |
#' |
|
107 |
#' @description |
|
108 |
#' Getter functions for the slots of a [`Parameter`] object |
|
109 |
#' @family Parameter |
|
110 |
#' @name Parameter-Getter-Methods |
|
111 |
NULL |
|
112 | ||
113 |
#' @describeIn Parameter-Getter-Methods The parameter's name |
|
114 |
#' @export |
|
115 | 10262x |
names.Parameter <- function(x) x@name |
116 | ||
117 |
#' @describeIn Parameter-Getter-Methods The parameter's initial values |
|
118 |
#' @export |
|
119 | 9845x |
initialValues.Parameter <- function(object, ...) initialValues(object@prior) |
120 | ||
121 |
#' @describeIn Parameter-Getter-Methods The parameter's dimensionality |
|
122 |
#' @export |
|
123 | 110x |
size.Parameter <- function(object) object@size |
124 | ||
125 | ||
126 |
#' `Parameter` -> `Character` |
|
127 |
#' |
|
128 |
#' Converts a [`Parameter`] object to a character vector |
|
129 |
#' @inheritParams Parameter-Shared |
|
130 |
#' @family Parameter |
|
131 |
#' @export |
|
132 |
as.character.Parameter <- function(x, ...) { |
|
133 | 69x |
paste0(x@name, " ~ ", as.character(x@prior)) |
134 |
} |
|
135 | ||
136 | ||
137 |
#' @rdname show-object |
|
138 |
#' @export |
|
139 |
setMethod( |
|
140 |
f = "show", |
|
141 |
signature = "Parameter", |
|
142 |
definition = function(object) { |
|
143 | 1x |
x <- sprintf("\nParameter Object:\n %s\n\n", as.character(object)) |
144 | 1x |
cat(x) |
145 | 1x |
return(object) |
146 |
} |
|
147 |
) |
1 | ||
2 |
#' @include Grid.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 | ||
7 |
#' @rdname Grid-Dev |
|
8 |
.GridEven <- setClass( |
|
9 |
"GridEven", |
|
10 |
contains = "Grid", |
|
11 |
slots = c( |
|
12 |
"subjects" = "character", |
|
13 |
"length.out" = "numeric" |
|
14 |
) |
|
15 |
) |
|
16 | ||
17 | ||
18 |
#' @rdname Grid-Functions |
|
19 |
#' @export |
|
20 |
GridEven <- function(subjects = NULL, length.out = 30) { |
|
21 | 1x |
.GridEven( |
22 | 1x |
subjects = subjects, |
23 | 1x |
length.out = length.out |
24 |
) |
|
25 |
} |
|
26 | ||
27 | ||
28 |
setValidity( |
|
29 |
"GridEven", |
|
30 |
function(object) { |
|
31 |
if (length(object@length.out) != 1 || all(object@length.out <= 0)) { |
|
32 |
return("The `length.out` argument must be a positive integer") |
|
33 |
} |
|
34 |
} |
|
35 |
) |
|
36 | ||
37 | ||
38 |
#' @rdname Quant-Dev |
|
39 |
#' @export |
|
40 |
as.QuantityGenerator.GridEven <- function(object, data, ...) { |
|
41 | 2x |
assert_class(data, "DataJoint") |
42 | 2x |
data_list <- as.list(data) |
43 | 2x |
subjects <- unlist(as.list(object, data = data), use.names = FALSE) |
44 | 2x |
assert_that( |
45 | 2x |
all(subjects %in% names(data_list$subject_to_index)), |
46 | 2x |
msg = "All subject names must be in the `DataSubject` object" |
47 |
) |
|
48 | ||
49 | 2x |
spec <- lapply( |
50 | 2x |
subjects, |
51 | 2x |
\(sub) { |
52 | 4x |
subject_index <- data_list$subject_to_index[[sub]] |
53 | 4x |
time_index <- data_list$subject_tumour_index == subject_index |
54 | 4x |
subject_times <- data_list$tumour_time[time_index] |
55 | 4x |
seq(min(subject_times), max(subject_times), length.out = object@length.out) |
56 |
} |
|
57 |
) |
|
58 | 2x |
names(spec) <- subjects |
59 | ||
60 | 2x |
as.QuantityGenerator( |
61 | 2x |
GridManual(spec), |
62 | 2x |
data = data |
63 |
) |
|
64 |
} |
|
65 | ||
66 | ||
67 |
#' @rdname Quant-Dev |
|
68 |
#' @export |
|
69 |
as.QuantityCollapser.GridEven <- function(object, data, ...) { |
|
70 | 1x |
generator <- as.QuantityGenerator(object, data) |
71 | 1x |
QuantityCollapser( |
72 | 1x |
times = generator@times, |
73 | 1x |
groups = generator@subjects, |
74 | 1x |
indexes = as.list(seq_along(generator@times)) |
75 |
) |
|
76 |
} |
|
77 | ||
78 | ||
79 |
#' @export |
|
80 |
as.list.GridEven <- function(x, data, ...) { |
|
81 | 2x |
subjects_to_list(x@subjects, data) |
82 |
} |
1 |
#' @include LongitudinalModel.R |
|
2 |
#' @include Link.R |
|
3 |
NULL |
|
4 | ||
5 |
# LongitudinalRandomSlope-class ---- |
|
6 | ||
7 |
#' `LongitudinalRandomSlope` |
|
8 |
#' |
|
9 |
#' This class extends the general [`LongitudinalModel`] class for using the |
|
10 |
#' random slope linear model for the longitudinal outcome. |
|
11 |
#' |
|
12 |
#' @section Available Links: |
|
13 |
#' - [`linkDSLD()`] |
|
14 |
#' - [`linkIdentity()`] |
|
15 |
#' @exportClass LongitudinalRandomSlope |
|
16 |
.LongitudinalRandomSlope <- setClass( |
|
17 |
Class = "LongitudinalRandomSlope", |
|
18 |
contains = "LongitudinalModel" |
|
19 |
) |
|
20 | ||
21 | ||
22 |
# LongitudinalRandomSlope-constructors ---- |
|
23 | ||
24 |
#' @rdname LongitudinalRandomSlope-class |
|
25 |
#' |
|
26 |
#' @param intercept (`Prior`)\cr for the `intercept`. |
|
27 |
#' @param slope_mu (`Prior`)\cr for the population slope `slope_mu`. |
|
28 |
#' @param slope_sigma (`Prior`)\cr for the random slope standard deviation `slope_sigma`. |
|
29 |
#' @param sigma (`Prior`)\cr for the variance of the longitudinal values `sigma`. |
|
30 |
#' |
|
31 |
#' @export |
|
32 |
LongitudinalRandomSlope <- function( |
|
33 |
intercept = prior_normal(30, 10), |
|
34 |
slope_mu = prior_normal(1, 3), |
|
35 |
slope_sigma = prior_lognormal(0, 1.5), |
|
36 |
sigma = prior_lognormal(0, 1.5) |
|
37 |
) { |
|
38 | ||
39 | 27x |
stan <- StanModule( |
40 | 27x |
x = "lm-random-slope/model.stan" |
41 |
) |
|
42 | ||
43 |
# Apply constriants |
|
44 | 27x |
sigma <- set_limits(sigma, lower = 0) |
45 | 27x |
slope_sigma <- set_limits(slope_sigma, lower = 0) |
46 | ||
47 | 27x |
.LongitudinalRandomSlope( |
48 | 27x |
LongitudinalModel( |
49 | 27x |
name = "Random Slope", |
50 | 27x |
stan = stan, |
51 | 27x |
parameters = ParameterList( |
52 | 27x |
Parameter(name = "lm_rs_intercept", prior = intercept, size = "n_studies"), |
53 | 27x |
Parameter(name = "lm_rs_slope_mu", prior = slope_mu, size = "n_arms"), |
54 | 27x |
Parameter(name = "lm_rs_slope_sigma", prior = slope_sigma, size = 1), |
55 | 27x |
Parameter(name = "lm_rs_sigma", prior = sigma, size = 1), |
56 | 27x |
Parameter( |
57 | 27x |
name = "lm_rs_ind_rnd_slope", |
58 | 27x |
prior = prior_init_only(prior_normal(median(slope_mu), median(slope_sigma))), |
59 | 27x |
size = "n_subjects" |
60 |
) |
|
61 |
) |
|
62 |
) |
|
63 |
) |
|
64 |
} |
|
65 | ||
66 | ||
67 |
#' @export |
|
68 |
enableGQ.LongitudinalRandomSlope <- function(object, ...) { |
|
69 | 26x |
StanModule("lm-random-slope/quantities.stan") |
70 |
} |
|
71 | ||
72 |
#' @export |
|
73 |
enableLink.LongitudinalRandomSlope <- function(object, ...) { |
|
74 | 5x |
object@stan <- merge( |
75 | 5x |
object@stan, |
76 | 5x |
StanModule("lm-random-slope/link.stan") |
77 |
) |
|
78 | 5x |
object |
79 |
} |
|
80 | ||
81 | ||
82 |
#' @export |
|
83 |
linkDSLD.LongitudinalRandomSlope <- function(prior = prior_normal(0, 2), model, ...) { |
|
84 | 6x |
LinkComponent( |
85 | 6x |
key = "link_dsld", |
86 | 6x |
stan = StanModule("lm-random-slope/link_dsld.stan"), |
87 | 6x |
prior = prior |
88 |
) |
|
89 |
} |
|
90 | ||
91 |
#' @export |
|
92 |
linkIdentity.LongitudinalRandomSlope <- function(prior = prior_normal(0, 2), model, ...) { |
|
93 | 2x |
LinkComponent( |
94 | 2x |
key = "link_identity", |
95 | 2x |
stan = StanModule("lm-random-slope/link_identity.stan"), |
96 | 2x |
prior = prior |
97 |
) |
|
98 |
} |
|
99 | ||
100 |
#' @export |
|
101 |
linkGrowth.LongitudinalRandomSlope <- function(prior = prior_normal(0, 2), model, ...) { |
|
102 | ! |
LinkComponent( |
103 | ! |
key = "link_growth", |
104 | ! |
stan = StanModule("lm-random-slope/link_growth.stan"), |
105 | ! |
prior = prior |
106 |
) |
|
107 |
} |
|
108 | ||
109 |
#' @rdname getPredictionNames |
|
110 |
#' @export |
|
111 |
getPredictionNames.LongitudinalRandomSlope <- function(object, ...) { |
|
112 | 1x |
c("intercept", "slope") |
113 |
} |
1 |
#' @include SurvivalModel.R |
|
2 |
NULL |
|
3 | ||
4 | ||
5 |
#' `SurvivalGamma` |
|
6 |
#' |
|
7 |
#' This class extends the general [`SurvivalModel`] class for using the |
|
8 |
#' Gamma survival model. |
|
9 |
#' |
|
10 |
#' @exportClass SurvivalGamma |
|
11 |
.SurvivalGamma <- setClass( |
|
12 |
Class = "SurvivalGamma", |
|
13 |
contains = "SurvivalModel" |
|
14 |
) |
|
15 | ||
16 |
# SurvivalGamma-constructors ---- |
|
17 | ||
18 |
#' @rdname SurvivalGamma-class |
|
19 |
#' |
|
20 |
#' @param k (`Prior`)\cr for the shape `k`. |
|
21 |
#' @param theta (`Prior`)\cr for the scale `theta`. |
|
22 |
#' @param beta (`Prior`)\cr for covariates coefficients `beta`. |
|
23 |
#' |
|
24 |
#' @export |
|
25 |
SurvivalGamma <- function( |
|
26 |
k = prior_gamma(2, 0.5), |
|
27 |
theta = prior_gamma(2, 0.5), |
|
28 |
beta = prior_normal(0, 2) |
|
29 |
) { |
|
30 | ||
31 | 3x |
k <- set_limits(k, lower = 0) |
32 | 3x |
theta <- set_limits(theta, lower = 0) |
33 | ||
34 | 3x |
.SurvivalGamma( |
35 | 3x |
SurvivalModel( |
36 | 3x |
name = "Gamma", |
37 | 3x |
stan = StanModule(x = "sm-gamma/model.stan"), |
38 | 3x |
parameters = ParameterList( |
39 | 3x |
Parameter(name = "sm_gamma_k", prior = k, size = 1), |
40 | 3x |
Parameter(name = "sm_gamma_theta", prior = theta, size = 1), |
41 | 3x |
Parameter(name = "beta_os_cov", prior = beta, size = "p_os_cov_design") |
42 |
) |
|
43 |
) |
|
44 |
) |
|
45 |
} |
1 |
#' @include Grid.R |
|
2 |
#' @include generics.R |
|
3 |
NULL |
|
4 | ||
5 | ||
6 |
#' @rdname Grid-Dev |
|
7 |
.GridFixed <- setClass( |
|
8 |
"GridFixed", |
|
9 |
contains = "Grid", |
|
10 |
slots = c( |
|
11 |
"subjects" = "character_or_NULL", |
|
12 |
"times" = "numeric_or_NULL" |
|
13 |
) |
|
14 |
) |
|
15 | ||
16 |
#' @rdname Grid-Functions |
|
17 |
#' @export |
|
18 |
GridFixed <- function(subjects = NULL, times = NULL) { |
|
19 | 42x |
.GridFixed( |
20 | 42x |
subjects = subjects, |
21 | 42x |
times = times |
22 |
) |
|
23 |
} |
|
24 | ||
25 |
#' @rdname Quant-Dev |
|
26 |
#' @export |
|
27 |
as.QuantityGenerator.GridFixed <- function(object, data, ...) { |
|
28 | ||
29 | 54x |
assert_class(data, "DataJoint") |
30 | 54x |
data_list <- as.list(data) |
31 | 54x |
subjects <- unlist(as.list(object, data = data), use.names = FALSE) |
32 | ||
33 | 54x |
validate_time_grid(object@times) |
34 | 54x |
subject_times <- expand.grid( |
35 | 54x |
subject = subjects, |
36 | 54x |
time = object@times, |
37 | 54x |
stringsAsFactors = FALSE |
38 |
) |
|
39 | ||
40 | 54x |
QuantityGeneratorSubject( |
41 | 54x |
times = subject_times$time, |
42 | 54x |
subjects = subject_times$subject |
43 |
) |
|
44 |
} |
|
45 | ||
46 |
#' @rdname Quant-Dev |
|
47 |
#' @export |
|
48 |
as.QuantityCollapser.GridFixed <- function(object, data, ...) { |
|
49 | 18x |
generator <- as.QuantityGenerator(object, data) |
50 | 18x |
QuantityCollapser( |
51 | 18x |
times = generator@times, |
52 | 18x |
groups = generator@subjects, |
53 | 18x |
indexes = as.list(seq_along(generator@times)) |
54 |
) |
|
55 |
} |
|
56 | ||
57 | ||
58 |
#' @export |
|
59 |
as.list.GridFixed <- function(x, data, ...) { |
|
60 | 54x |
subjects_to_list(x@subjects, data) |
61 |
} |
|
62 | ||
63 |
#' @rdname coalesceGridTime |
|
64 |
#' @export |
|
65 |
coalesceGridTime.GridFixed <- function(object, times, ...) { |
|
66 | 19x |
if (is.null(object@times)) { |
67 | 5x |
object <- GridFixed( |
68 | 5x |
subjects = object@subjects, |
69 | 5x |
times = times |
70 |
) |
|
71 |
} |
|
72 | 19x |
object |
73 |
} |
1 | ||
2 |
#' @include Grid.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 | ||
7 |
#' @rdname Grid-Dev |
|
8 |
.GridManual <- setClass( |
|
9 |
"GridManual", |
|
10 |
contains = "Grid", |
|
11 |
slots = c( |
|
12 |
"spec" = "list" |
|
13 |
) |
|
14 |
) |
|
15 | ||
16 | ||
17 |
#' @rdname Grid-Functions |
|
18 |
#' @export |
|
19 |
GridManual <- function(spec) { |
|
20 | 5x |
.GridManual( |
21 | 5x |
spec = spec |
22 |
) |
|
23 |
} |
|
24 | ||
25 | ||
26 |
setValidity( |
|
27 |
"GridManual", |
|
28 |
function(object) { |
|
29 |
subject_names <- names(object@spec) |
|
30 |
subject_names_valid <- subject_names[!is.na(subject_names) & subject_names != ""] |
|
31 |
if (length(subject_names_valid) != length(object@spec)) { |
|
32 |
return("Each element of `subjects` must be named") |
|
33 |
} |
|
34 |
for (times in object@spec) { |
|
35 |
if (!is.numeric(times)) { |
|
36 |
return("Each element of `spec` must be a numeric vector") |
|
37 |
} |
|
38 |
if (length(times) != length(unique(times))) { |
|
39 |
return("Each time vector per subject must be unique") |
|
40 |
} |
|
41 |
} |
|
42 |
return(TRUE) |
|
43 |
} |
|
44 |
) |
|
45 | ||
46 | ||
47 |
#' @rdname Quant-Dev |
|
48 |
#' @export |
|
49 |
as.QuantityGenerator.GridManual <- function(object, data, ...) { |
|
50 | 8x |
assert_class(data, "DataJoint") |
51 | 8x |
data_list <- as.list(data) |
52 | 8x |
assert_that( |
53 | 8x |
all(names(object@spec) %in% names(data_list$subject_to_index)), |
54 | 8x |
msg = "All subject names must be in the `DataSubject` object" |
55 |
) |
|
56 | 8x |
lens <- vapply(object@spec, length, numeric(1)) |
57 | 8x |
QuantityGeneratorSubject( |
58 | 8x |
times = unlist(object@spec, use.names = FALSE), |
59 | 8x |
subjects = rep(names(object@spec), lens) |
60 |
) |
|
61 |
} |
|
62 | ||
63 | ||
64 |
#' @rdname Quant-Dev |
|
65 |
#' @export |
|
66 |
as.QuantityCollapser.GridManual <- function(object, data, ...) { |
|
67 | 3x |
generator <- as.QuantityGenerator(object, data) |
68 | 3x |
QuantityCollapser( |
69 | 3x |
times = generator@times, |
70 | 3x |
groups = generator@subjects, |
71 | 3x |
indexes = as.list(seq_along(generator@times)) |
72 |
) |
|
73 |
} |
|
74 | ||
75 | ||
76 |
#' @export |
|
77 |
as.list.GridManual <- function(x, data, ...) { |
|
78 | ! |
subs <- as.list(names(x@spec)) |
79 | ! |
names(subs) <- names(x@spec) |
80 | ! |
subs |
81 |
} |
1 |
#' @include SurvivalModel.R |
|
2 |
NULL |
|
3 | ||
4 |
# SurvivalLogLogistic-class ---- |
|
5 | ||
6 |
#' `SurvivalLogLogistic` |
|
7 |
#' |
|
8 |
#' This class extends the general [`SurvivalModel`] class for using the |
|
9 |
#' log-logistic survival model. |
|
10 |
#' |
|
11 |
#' @exportClass SurvivalLogLogistic |
|
12 |
.SurvivalLogLogistic <- setClass( |
|
13 |
Class = "SurvivalLogLogistic", |
|
14 |
contains = "SurvivalModel" |
|
15 |
) |
|
16 | ||
17 |
# SurvivalLogLogistic-constructors ---- |
|
18 | ||
19 |
#' @rdname SurvivalLogLogistic-class |
|
20 |
#' |
|
21 |
#' @param a (`Prior`)\cr Prior distribution for the scale parameter `a`. |
|
22 |
#' @param b (`Prior`)\cr Prior distribution for the shape parameter `b`. |
|
23 |
#' @param beta (`Prior`)\cr Prior distribution for covariates coefficients `beta`. |
|
24 |
#' |
|
25 |
#' @export |
|
26 |
SurvivalLogLogistic <- function( |
|
27 |
a = prior_lognormal(log(0.1), 5), |
|
28 |
b = prior_gamma(2, 5), |
|
29 |
beta = prior_normal(0, 2) |
|
30 |
) { |
|
31 | 8x |
.SurvivalLogLogistic( |
32 | 8x |
SurvivalModel( |
33 | 8x |
name = "Log-Logistic", |
34 | 8x |
stan = StanModule("sm-loglogistic/model.stan"), |
35 | 8x |
parameters = ParameterList( |
36 | 8x |
Parameter(name = "sm_loglogis_a", prior = a, size = 1), |
37 | 8x |
Parameter(name = "sm_loglogis_b", prior = b, size = 1), |
38 | 8x |
Parameter(name = "beta_os_cov", prior = beta, size = "p_os_cov_design") |
39 |
) |
|
40 |
) |
|
41 |
) |
|
42 |
} |
1 |
#' @include StanModule.R |
|
2 |
#' @include ParameterList.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 |
#' `StanModel` Function Arguments |
|
7 |
#' |
|
8 |
#' The documentation lists all the conventional arguments for wrappers around |
|
9 |
#' [StanModel()]. |
|
10 |
#' |
|
11 |
#' @param stan (`StanModule`)\cr code containing the Stan code specification. |
|
12 |
#' @param parameters (`ParameterList`)\cr the parameter specification. |
|
13 |
#' @param parameter (`ParameterList`)\cr the (single) parameter specification. |
|
14 |
#' @param name (`character`)\cr display name for the model object. |
|
15 |
#' @param ... additional arguments for [StanModel()]. |
|
16 |
#' |
|
17 |
#' @name stanmodel_arguments |
|
18 |
#' @keywords internal |
|
19 |
NULL |
|
20 | ||
21 |
# StanModel-class ---- |
|
22 | ||
23 | ||
24 |
#' Stan Model Object and Constructor Function |
|
25 |
#' |
|
26 |
#' @slot stan (`StanModule`)\cr See Arguments. |
|
27 |
#' @slot parameters (`ParameterList`)\cr See Arguments. |
|
28 |
#' @slot name (`character`)\cr display name for the model object. |
|
29 |
#' |
|
30 |
#' @export StanModel |
|
31 |
#' @exportClass StanModel |
|
32 |
#' @family StanModel |
|
33 |
.StanModel <- setClass( |
|
34 |
Class = "StanModel", |
|
35 |
slots = list( |
|
36 |
"stan" = "StanModule", |
|
37 |
"parameters" = "ParameterList", |
|
38 |
"name" = "character" |
|
39 |
) |
|
40 |
) |
|
41 | ||
42 |
# StanModel-constructor ---- |
|
43 | ||
44 |
#' @inheritParams stanmodel_arguments |
|
45 |
#' @rdname StanModel-class |
|
46 |
StanModel <- function(stan, parameters, name = "<Unnamed>") { |
|
47 | 127x |
.StanModel( |
48 | 127x |
stan = stan, |
49 | 127x |
parameters = parameters, |
50 | 127x |
name = name |
51 |
) |
|
52 |
} |
|
53 | ||
54 |
# as.list-StanModel ---- |
|
55 | ||
56 |
#' `StanModel` -> `list` |
|
57 |
#' @description |
|
58 |
#' Returns a named list where each element of the list corresponds |
|
59 |
#' to a Stan modelling block e.g. `data`, `model`, etc. |
|
60 |
#' @param x ([`StanModel`])\cr A Stan Model |
|
61 |
#' @param ... Not Used. |
|
62 |
#' @family StanModel |
|
63 |
#' @export |
|
64 |
as.list.StanModel <- function(x, ...) { |
|
65 | 151x |
as.list(x@stan) |
66 |
} |
|
67 | ||
68 |
# getParameters-StanModel ---- |
|
69 | ||
70 |
#' @rdname getParameters |
|
71 |
#' @export |
|
72 | 80x |
getParameters.StanModel <- function(object, ...) object@parameters |
73 | ||
74 | ||
75 |
#' @export |
|
76 |
as_print_string.StanModel <- function(object, ...) { |
|
77 | 1x |
string <- sprintf( |
78 | 1x |
"\n%s Model Object with parameters:\n%s\n\n", |
79 | 1x |
object@name, |
80 | 1x |
paste(" ", as_print_string(object@parameters)) |> paste(collapse = "\n") |
81 |
) |
|
82 | 1x |
return(string) |
83 |
} |
|
84 | ||
85 |
#' @rdname show-object |
|
86 |
#' @export |
|
87 |
setMethod( |
|
88 |
f = "show", |
|
89 |
signature = "StanModel", |
|
90 |
definition = function(object) { |
|
91 | 9x |
cat(as_print_string(object)) |
92 |
} |
|
93 |
) |
|
94 | ||
95 |
#' @rdname initialValues |
|
96 |
#' @export |
|
97 |
initialValues.StanModel <- function(object, n_chains, ...) { |
|
98 | 24x |
initialValues(object@parameters, n_chains) |
99 |
} |
1 |
#' @include StanModule.R |
|
2 |
#' @include LongitudinalModel.R |
|
3 |
#' @include ParameterList.R |
|
4 |
#' @include generics.R |
|
5 |
#' @include Prior.R |
|
6 |
NULL |
|
7 | ||
8 | ||
9 | ||
10 | ||
11 |
#' `LinkComponent` Function Arguments |
|
12 |
#' |
|
13 |
#' This exists to contain all the common arguments for [`LinkComponent`] methods. |
|
14 |
#' |
|
15 |
#' @param stan (`StanModule`)\cr Stan code. |
|
16 |
#' @param x ([`LinkComponent`])\cr a link component. |
|
17 |
#' @param object ([`LinkComponent`])\cr a link component. |
|
18 |
#' @param ... Not Used. |
|
19 |
#' |
|
20 |
#' @name LinkComponent-Shared |
|
21 |
#' @keywords internal |
|
22 |
NULL |
|
23 | ||
24 | ||
25 | ||
26 | ||
27 |
#' `LinkComponent` |
|
28 |
#' |
|
29 |
#' @slot stan (`StanModule`)\cr See Arguments. |
|
30 |
#' @slot name (`character`)\cr See Arguments. |
|
31 |
#' @slot parameters (`ParameterList`)\cr The parameter specification. |
|
32 |
#' |
|
33 |
#' @param stan (`StanModule`)\cr Stan code. See Details. |
|
34 |
#' @param prior (`Prior`)\cr The prior for the scaling coeficient. |
|
35 |
#' @param key (`character`)\cr Link identifier. See Details. |
|
36 |
#' |
|
37 |
#' @details |
|
38 |
#' |
|
39 |
#' This object provides key information needed to construct a link contribution in the |
|
40 |
#' survival model based on the parameters of the longitudinal model. |
|
41 |
#' |
|
42 |
#' Each link component defines a stan function of the longitudinal model parameters which is |
|
43 |
#' multiplied by a model coefficient and added to the survival models hazard function. |
|
44 |
#' |
|
45 |
#' For full details about the specification of a `LinkComponent` please see |
|
46 |
#' \code{vignette("extending-jmpost", package = "jmpost")}. |
|
47 |
#' |
|
48 |
#' @inheritParams stanmodel_arguments |
|
49 |
#' @family LinkComponent |
|
50 |
#' @name LinkComponent-class |
|
51 |
#' @exportClass Link |
|
52 |
.LinkComponent <- setClass( |
|
53 |
Class = "LinkComponent", |
|
54 |
slots = list( |
|
55 |
"stan" = "StanModule", |
|
56 |
"parameters" = "ParameterList", |
|
57 |
"key" = "character" |
|
58 |
) |
|
59 |
) |
|
60 | ||
61 | ||
62 |
#' @rdname LinkComponent-class |
|
63 |
#' @export |
|
64 |
LinkComponent <- function(stan, prior, key, ...) { |
|
65 | 46x |
.LinkComponent( |
66 | 46x |
stan = stan, |
67 | 46x |
key = key, |
68 | 46x |
parameters = ParameterList(Parameter(name = key, prior = prior, size = 1)), |
69 |
... |
|
70 |
) |
|
71 |
} |
|
72 | ||
73 | ||
74 | ||
75 | ||
76 |
#' @family LinkComponent |
|
77 |
#' @rdname getParameters |
|
78 |
#' @export |
|
79 |
getParameters.LinkComponent <- function(object, ...) { |
|
80 | 40x |
object@parameters |
81 |
} |
|
82 | ||
83 | ||
84 |
#' @family LinkComponent |
|
85 |
#' @rdname initialValues |
|
86 |
#' @export |
|
87 |
initialValues.LinkComponent <- function(object, n_chains, ...) { |
|
88 | ! |
initialValues(object@parameters, n_chains) |
89 |
} |
|
90 | ||
91 | ||
92 | ||
93 | ||
94 |
#' `LinkComponent` -> `StanModule` |
|
95 |
#' |
|
96 |
#' Converts a [`LinkComponent`] object to a [`StanModule`] object |
|
97 |
#' |
|
98 |
#' @inheritParams LinkComponent-Shared |
|
99 |
#' |
|
100 |
#' @family LinkComponent |
|
101 |
#' @family as.StanModule |
|
102 |
#' @export |
|
103 |
as.StanModule.LinkComponent <- function(object, ...) { |
|
104 | 53x |
object@stan |
105 |
} |
|
106 | ||
107 | ||
108 | ||
109 |
#' `LinkComponent` -> `list` |
|
110 |
#' |
|
111 |
#' @inheritParams LinkComponent-Shared |
|
112 |
#' |
|
113 |
#' @description |
|
114 |
#' Returns a named list where each element of the list corresponds |
|
115 |
#' to a Stan modelling block e.g. `data`, `model`, etc. |
|
116 |
#' |
|
117 |
#' @family LinkComponent |
|
118 |
#' @export |
|
119 |
as.list.LinkComponent <- function(x, ...) { |
|
120 | ! |
stan <- as.StanModule(x, ...) |
121 | ! |
as.list(stan) |
122 |
} |
|
123 | ||
124 |
#' @family LinkComponent |
|
125 |
#' @export |
|
126 |
as_print_string.LinkComponent <- function(object, ...) { |
|
127 | 2x |
as_print_string(object@parameters) |
128 |
} |
|
129 | ||
130 | ||
131 |
#' @rdname show-object |
|
132 |
#' @export |
|
133 |
setMethod( |
|
134 |
f = "show", |
|
135 |
signature = "LinkComponent", |
|
136 |
definition = function(object) { |
|
137 | 1x |
cat( |
138 | 1x |
paste0( |
139 | 1x |
"\nLinkComponent with parameter:\n ", |
140 | 1x |
as_print_string(object), "\n\n" |
141 |
) |
|
142 |
) |
|
143 |
} |
|
144 |
) |
|
145 | ||
146 |
#' @family LinkComponent |
|
147 |
#' @export |
|
148 |
names.LinkComponent <- function(x, ...) { |
|
149 | 80x |
names(x@parameters) |
150 |
} |
1 |
#' @include Grid.R |
|
2 |
#' @include generics.R |
|
3 |
NULL |
|
4 | ||
5 |
#' @rdname Grid-Dev |
|
6 |
.GridObserved <- setClass( |
|
7 |
"GridObserved", |
|
8 |
contains = "Grid", |
|
9 |
slots = c( |
|
10 |
"subjects" = "character_or_NULL" |
|
11 |
) |
|
12 |
) |
|
13 | ||
14 | ||
15 |
#' @rdname Grid-Functions |
|
16 |
#' @export |
|
17 |
GridObserved <- function(subjects = NULL) { |
|
18 | 2x |
.GridObserved( |
19 | 2x |
subjects = subjects |
20 |
) |
|
21 |
} |
|
22 | ||
23 |
#' @rdname Quant-Dev |
|
24 |
#' @export |
|
25 |
as.QuantityGenerator.GridObserved <- function(object, data, ...) { |
|
26 | 4x |
assert_class(data, "DataJoint") |
27 | 4x |
data_list <- as.list(data) |
28 | 4x |
subjects <- unlist(as.list(object, data = data), use.names = FALSE) |
29 | 4x |
unique_visits <- tapply(data_list$tumour_time, data_list$subject_tumour_index, unique) |
30 | 4x |
subject_visits <- unique_visits[data_list$subject_to_index[subjects]] |
31 | 4x |
visit_lengths <- vapply(subject_visits, length, numeric(1)) |
32 | 4x |
QuantityGeneratorSubject( |
33 | 4x |
times = unlist(subject_visits, use.names = FALSE), |
34 | 4x |
subjects = rep(subjects, visit_lengths) |
35 |
) |
|
36 |
} |
|
37 | ||
38 |
#' @rdname Quant-Dev |
|
39 |
#' @export |
|
40 |
as.QuantityCollapser.GridObserved <- function(object, data, ...) { |
|
41 | 2x |
generator <- as.QuantityGenerator(object, data) |
42 | ||
43 | 2x |
QuantityCollapser( |
44 | 2x |
times = generator@times, |
45 | 2x |
groups = generator@subjects, |
46 | 2x |
indexes = as.list(seq_along(generator@times)) |
47 |
) |
|
48 |
} |
|
49 | ||
50 |
#' @export |
|
51 |
as.list.GridObserved <- function(x, data, ...) { |
|
52 | 4x |
subjects_to_list(x@subjects, data) |
53 |
} |
1 |
#' @include StanModel.R |
|
2 |
NULL |
|
3 | ||
4 |
# SurvivalModel-class ---- |
|
5 | ||
6 |
#' `SurvivalModel` |
|
7 |
#' |
|
8 |
#' This class extends the general [`StanModel`] class to comprise the survival |
|
9 |
#' model specification. |
|
10 |
#' |
|
11 |
#' @exportClass SurvivalModel |
|
12 |
.SurvivalModel <- setClass( |
|
13 |
Class = "SurvivalModel", |
|
14 |
contains = "StanModel" |
|
15 |
) |
|
16 | ||
17 |
# SurvivalModel-constructors ---- |
|
18 | ||
19 |
#' @rdname SurvivalModel-class |
|
20 |
#' |
|
21 |
#' @inheritParams stanmodel_arguments |
|
22 |
#' |
|
23 |
#' @export |
|
24 |
SurvivalModel <- function( |
|
25 |
stan = StanModule(), |
|
26 |
parameters = ParameterList(), |
|
27 |
name = "<Unnamed>", |
|
28 |
... |
|
29 |
) { |
|
30 | 41x |
base_stan <- read_stan("base/survival.stan") |
31 | 41x |
stan_full <- decorated_render( |
32 | 41x |
.x = base_stan, |
33 | 41x |
stan = add_missing_stan_blocks(as.list(stan)) |
34 |
) |
|
35 | 41x |
.SurvivalModel( |
36 | 41x |
StanModel( |
37 | 41x |
name = name, |
38 | 41x |
stan = StanModule(stan_full), |
39 | 41x |
parameters = parameters, |
40 |
... |
|
41 |
) |
|
42 |
) |
|
43 |
} |
|
44 | ||
45 |
#' @export |
|
46 |
as_print_string.SurvivalModel <- function(object, ...) { |
|
47 | 5x |
string <- sprintf( |
48 | 5x |
"\n%s Survival Model with parameters:\n%s\n\n", |
49 | 5x |
object@name, |
50 | 5x |
paste(" ", as_print_string(object@parameters)) |> paste(collapse = "\n") |
51 |
) |
|
52 | 5x |
return(string) |
53 |
} |
1 | ||
2 | ||
3 |
#' Promise |
|
4 |
#' |
|
5 |
#' Abstract class for promise objects to inherit off of |
|
6 |
#' @aliases Promise |
|
7 |
#' @exportClass Promise |
|
8 |
.Promise <- setClass("Promise") |
|
9 | ||
10 | ||
11 |
#' Promise of a `LongitudinalModel` |
|
12 |
#' |
|
13 |
#' An object that promises to resolve to a [`LongitudinalModel`] object. |
|
14 |
#' |
|
15 |
#' @exportClass PromiseLongitudinalModel |
|
16 |
.PromiseLongitudinalModel <- setClass( |
|
17 |
"PromiseLongitudinalModel", |
|
18 |
contains = "Promise" |
|
19 |
) |
|
20 | ||
21 |
#' @rdname PromiseLongitudinalModel-class |
|
22 |
#' @export |
|
23 |
PromiseLongitudinalModel <- function() { |
|
24 | 41x |
.PromiseLongitudinalModel() |
25 |
} |
|
26 | ||
27 | ||
28 | ||
29 | ||
30 |
#' Promise of a `LinkComponent` |
|
31 |
#' |
|
32 |
#' An object that promises to resolve to a [`LinkComponent`] object. |
|
33 |
#' Inheriting from [`Promise`] and [`LinkComponent`]. |
|
34 |
#' |
|
35 |
#' @slot fun (`function`) \cr a function that returns a `LinkComponent`. See details. |
|
36 |
#' |
|
37 |
#' @param fun (`function`) \cr a function that returns a `LinkComponent`. See details. |
|
38 |
#' @inheritParams LinkComponent |
|
39 |
#' |
|
40 |
#' @details |
|
41 |
#' |
|
42 |
#' The `fun` slot should be a function of signature `function(prior, model)` and should return |
|
43 |
#' a [`LinkComponent`] object. An error will be thrown if the returned [`LinkComponent`] object |
|
44 |
#' does not have the same `key` slot value as the original `PromiseLinkComponent`. |
|
45 |
#' |
|
46 |
#' @exportClass PromiseLinkComponent |
|
47 |
.PromiseLinkComponent <- setClass( |
|
48 |
"PromiseLinkComponent", |
|
49 |
contains = c("Promise", "LinkComponent"), |
|
50 |
slots = list( |
|
51 |
fun = "function" |
|
52 |
) |
|
53 |
) |
|
54 | ||
55 |
#' @rdname PromiseLinkComponent-class |
|
56 |
#' @export |
|
57 |
PromiseLinkComponent <- function(fun, prior, key) { |
|
58 | 43x |
.PromiseLinkComponent( |
59 | 43x |
fun = fun, |
60 | 43x |
stan = StanModule(), |
61 | 43x |
parameters = ParameterList(Parameter(name = key, prior = prior, size = 1)), |
62 | 43x |
key = key |
63 |
) |
|
64 |
} |
|
65 | ||
66 | ||
67 |
#' @export |
|
68 |
as.StanModule.PromiseLinkComponent <- function(object, model, ...) { |
|
69 | 1x |
resolved_object <- resolvePromise(object, model = model) |
70 | 1x |
as.StanModule(resolved_object, ...) |
71 |
} |
|
72 | ||
73 |
#' Resolve a `PromiseLinkComponent` |
|
74 |
#' |
|
75 |
#' Resolves a [`PromiseLinkComponent`] object to a [`LinkComponent`] object. |
|
76 |
#' An error will be thrown if the returned [`LinkComponent`] object |
|
77 |
#' does not have the same `key` slot value as the original [`PromiseLinkComponent`]. |
|
78 |
#' |
|
79 |
#' @param object ([`PromiseLinkComponent`]) \cr the promise to resolve |
|
80 |
#' @param model ([`LongitudinalModel`]) \cr the model to resolve the promise with |
|
81 |
#' @param ... Not used. |
|
82 |
#' @return ([`LinkComponent`]) \cr the resolved `LinkComponent` object |
|
83 |
#' |
|
84 |
#' @export |
|
85 |
resolvePromise.PromiseLinkComponent <- function(object, model, ...) { |
|
86 | 40x |
x <- object@fun( |
87 | 40x |
prior = object@parameters@parameters[[1]]@prior, |
88 | 40x |
model = model |
89 |
) |
|
90 | 40x |
assert_that( |
91 | 40x |
is(x, "LinkComponent"), |
92 | 40x |
msg = "Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object" |
93 |
) |
|
94 | 40x |
assert_that( |
95 | 40x |
names(object) == names(x), |
96 | 40x |
msg = paste( |
97 | 40x |
"Resolved `PromiseLinkComponent` did not produce a `LinkComponent` object", |
98 | 40x |
"with the same key as the promise" |
99 |
) |
|
100 |
) |
|
101 | 39x |
x |
102 |
} |
1 | ||
2 |
#' @include SimLongitudinal.R |
|
3 |
#' @include generics.R |
|
4 |
NULL |
|
5 | ||
6 |
#' Simulate Longitudinal Data from a Random Slope Model |
|
7 |
#' |
|
8 |
#' @param times (`numeric`)\cr the times to generate observations at. |
|
9 |
#' @param intercept (`number`)\cr the mean baseline value for each study. |
|
10 |
#' @param slope_mu (`numeric`)\cr the population slope for each treatment arm. |
|
11 |
#' @param slope_sigma (`number`)\cr the random slope standard deviation. |
|
12 |
#' @param sigma (`number`)\cr the variance of the longitudinal values. |
|
13 |
#' @param link_dsld (`number`)\cr the link coefficient for the DSLD contribution. |
|
14 |
#' @param link_identity (`number`)\cr the link coefficient for the identity contribution. |
|
15 |
#' |
|
16 |
#' @slot intercept (`numeric`)\cr See arguments. |
|
17 |
#' @slot slope_mu (`numeric`)\cr See arguments. |
|
18 |
#' @slot slope_sigma (`numeric`)\cr See arguments. |
|
19 |
#' @slot sigma (`numeric`)\cr See arguments. |
|
20 |
#' @slot link_dsld (`numeric`)\cr See arguments. |
|
21 |
#' @slot link_identity (`numeric`)\cr See arguments. |
|
22 |
#' |
|
23 |
#' @family SimLongitudinal |
|
24 |
#' @name SimLongitudinalRandomSlope-class |
|
25 |
#' @exportClass SimLongitudinalRandomSlope |
|
26 |
.SimLongitudinalRandomSlope <- setClass( |
|
27 |
"SimLongitudinalRandomSlope", |
|
28 |
contains = "SimLongitudinal", |
|
29 |
slots = c( |
|
30 |
intercept = "numeric", |
|
31 |
slope_mu = "numeric", |
|
32 |
slope_sigma = "numeric", |
|
33 |
sigma = "numeric", |
|
34 |
link_dsld = "numeric", |
|
35 |
link_identity = "numeric" |
|
36 |
) |
|
37 |
) |
|
38 | ||
39 |
#' @rdname SimLongitudinalRandomSlope-class |
|
40 |
#' @export |
|
41 |
SimLongitudinalRandomSlope <- function( |
|
42 |
times = c(-100, -50, 0, 50, 100, 150, 250, 350, 450, 550), |
|
43 |
intercept = 50, |
|
44 |
slope_mu = c(0.01, 0.03), |
|
45 |
slope_sigma = 0.5, |
|
46 |
sigma = 2, |
|
47 |
link_dsld = 0, |
|
48 |
link_identity = 0 |
|
49 |
) { |
|
50 | 15x |
.SimLongitudinalRandomSlope( |
51 | 15x |
times = times, |
52 | 15x |
intercept = intercept, |
53 | 15x |
slope_mu = slope_mu, |
54 | 15x |
slope_sigma = slope_sigma, |
55 | 15x |
sigma = sigma, |
56 | 15x |
link_dsld = link_dsld, |
57 | 15x |
link_identity = link_identity |
58 |
) |
|
59 |
} |
|
60 | ||
61 |
#' @rdname as_print_string |
|
62 |
as_print_string.SimLongitudinalRandomSlope <- function(object) { |
|
63 | 1x |
return("SimLongitudinalRandomSlope") |
64 |
} |
|
65 | ||
66 |
#' @rdname sampleObservations |
|
67 |
#' @export |
|
68 |
sampleObservations.SimLongitudinalRandomSlope <- function(object, times_df) { |
|
69 | 27x |
times_df |> |
70 | 27x |
dplyr::mutate(err = stats::rnorm(dplyr::n(), 0, object@sigma)) |> |
71 | 27x |
dplyr::mutate(sld_mu = .data$intercept + .data$slope_ind * .data$time) |> |
72 | 27x |
dplyr::mutate(sld = .data$sld_mu + .data$err) |> |
73 | 27x |
dplyr::mutate( |
74 | 27x |
log_haz_link = |
75 | 27x |
object@link_dsld * .data$slope_ind + |
76 | 27x |
object@link_identity * .data$sld_mu |
77 |
) |
|
78 |
} |
|
79 | ||
80 |
#' @rdname sampleSubjects |
|
81 |
#' @export |
|
82 |
sampleSubjects.SimLongitudinalRandomSlope <- function(object, subjects_df) { |
|
83 | 14x |
assert_that( |
84 | 14x |
is.factor(subjects_df[["study"]]), |
85 | 14x |
is.factor(subjects_df[["arm"]]) |
86 |
) |
|
87 | ||
88 | 14x |
assert_that( |
89 | 14x |
length(object@slope_mu) == length(unique(subjects_df[["arm"]])), |
90 | 14x |
msg = "`length(slope_mu)` should be equal to the number of unique arms" |
91 |
) |
|
92 | ||
93 | 14x |
assert_that( |
94 | 14x |
length(object@intercept) == length(unique(subjects_df[["study"]])), |
95 | 14x |
msg = "`length(intercept)` should be equal to the number of unique studies" |
96 |
) |
|
97 | ||
98 | 14x |
assert_that( |
99 | 14x |
nrow(subjects_df) == length(unique(subjects_df[["subject"]])), |
100 | 14x |
msg = "The number of rows in `subjects_df` should be equal to the number of unique subjects" |
101 |
) |
|
102 | ||
103 | 14x |
subjects_df |> |
104 | 14x |
dplyr::mutate(intercept = object@intercept[as.numeric(.data$study)]) |> |
105 | 14x |
dplyr::mutate(slope_ind = stats::rnorm( |
106 | 14x |
n = dplyr::n(), |
107 | 14x |
mean = object@slope_mu[as.numeric(.data$arm)], |
108 | 14x |
sd = object@slope_sigma |
109 |
)) |
|
110 |
} |
1 | ||
2 |
#' Define Simulation Group |
|
3 |
#' |
|
4 |
#' Specifies a simulation group to be used by [`SimJointData()`]. |
|
5 |
#' |
|
6 |
#' @param n (`numeric`)\cr number of subjects in the group. |
|
7 |
#' @param arm (`character`)\cr treatment arm. |
|
8 |
#' @param study (`character`)\cr study name. |
|
9 |
#' |
|
10 |
#' @slot n (`numeric`)\cr See arguments. |
|
11 |
#' @slot arm (`character`)\cr See arguments. |
|
12 |
#' @slot study (`character`)\cr See arguments. |
|
13 |
#' |
|
14 |
#' @examples |
|
15 |
#' SimGroup(n = 50, arm = "Arm-A", study = "Study-1") |
|
16 |
#' @name SimGroup-class |
|
17 |
#' @exportClass SimGroup |
|
18 |
.SimGroup <- setClass( |
|
19 |
"SimGroup", |
|
20 |
slots = c( |
|
21 |
n = "numeric", |
|
22 |
arm = "character", |
|
23 |
study = "character" |
|
24 |
) |
|
25 |
) |
|
26 | ||
27 |
#' @export |
|
28 |
#' @rdname SimGroup-class |
|
29 |
SimGroup <- function(n, arm, study) { |
|
30 | 46x |
.SimGroup( |
31 | 46x |
n = n, |
32 | 46x |
arm = arm, |
33 | 46x |
study = study |
34 |
) |
|
35 |
} |
|
36 | ||
37 | ||
38 |
setValidity( |
|
39 |
"SimGroup", |
|
40 |
function(object) { |
|
41 |
if (length(object@n) != 1) { |
|
42 |
return("`n` must be a length 1 integer") |
|
43 |
} |
|
44 |
if (length(object@arm) != 1) { |
|
45 |
return("`arm` must be a length 1 string") |
|
46 |
} |
|
47 |
if (length(object@study) != 1) { |
|
48 |
return("`study` must be a length 1 string") |
|
49 |
} |
|
50 |
if (any(object@n < 1) | any(object@n %% 1 != 0)) { |
|
51 |
return("`n` must be positive integer") |
|
52 |
} |
|
53 |
return(TRUE) |
|
54 |
} |
|
55 |
) |
1 |
#' @include SurvivalModel.R |
|
2 |
NULL |
|
3 | ||
4 |
# SurvivalWeibullPH-class ---- |
|
5 | ||
6 |
#' `SurvivalWeibullPH` |
|
7 |
#' |
|
8 |
#' This class extends the general [`SurvivalModel`] class for using the |
|
9 |
#' Weibull proportional hazards survival model. |
|
10 |
#' |
|
11 |
#' @exportClass SurvivalWeibullPH |
|
12 |
.SurvivalWeibullPH <- setClass( |
|
13 |
Class = "SurvivalWeibullPH", |
|
14 |
contains = "SurvivalModel" |
|
15 |
) |
|
16 | ||
17 |
# SurvivalWeibullPH-constructors ---- |
|
18 | ||
19 |
#' @rdname SurvivalWeibullPH-class |
|
20 |
#' |
|
21 |
#' @param lambda (`Prior`)\cr for the scale `lambda`. |
|
22 |
#' @param gamma (`Prior`)\cr for the shape `gamma`. |
|
23 |
#' @param beta (`Prior`)\cr for covariates coefficients `beta`. |
|
24 |
#' |
|
25 |
#' @export |
|
26 |
SurvivalWeibullPH <- function( |
|
27 |
lambda = prior_gamma(2, 0.5), |
|
28 |
gamma = prior_gamma(2, 0.5), |
|
29 |
beta = prior_normal(0, 2) |
|
30 |
) { |
|
31 | ||
32 | 16x |
lambda <- set_limits(lambda, lower = 0) |
33 | 16x |
gamma <- set_limits(gamma, lower = 0) |
34 | ||
35 | 16x |
.SurvivalWeibullPH( |
36 | 16x |
SurvivalModel( |
37 | 16x |
name = "Weibull-PH", |
38 | 16x |
stan = StanModule(x = "sm-weibull-ph/model.stan"), |
39 | 16x |
parameters = ParameterList( |
40 | 16x |
Parameter(name = "sm_weibull_ph_lambda", prior = lambda, size = 1), |
41 | 16x |
Parameter(name = "sm_weibull_ph_gamma", prior = gamma, size = 1), |
42 | 16x |
Parameter(name = "beta_os_cov", prior = beta, size = "p_os_cov_design") |
43 |
) |
|
44 |
) |
|
45 |
) |
|
46 |
} |
1 |
#' @include SurvivalModel.R |
|
2 |
NULL |
|
3 | ||
4 |
# SurvivalExponential-class ---- |
|
5 | ||
6 |
#' `SurvivalExponential` |
|
7 |
#' |
|
8 |
#' This class extends the general [`SurvivalModel`] class for using the |
|
9 |
#' exponential survival model. |
|
10 |
#' |
|
11 |
#' @exportClass SurvivalExponential |
|
12 |
.SurvivalExponential <- setClass( |
|
13 |
Class = "SurvivalExponential", |
|
14 |
contains = "SurvivalModel" |
|
15 |
) |
|
16 | ||
17 |
# SurvivalExponential-constructors ---- |
|
18 | ||
19 |
#' @rdname SurvivalExponential-class |
|
20 |
#' |
|
21 |
#' @param lambda (`Prior`)\cr for the exponential rate `lambda`. |
|
22 |
#' @param beta (`Prior`)\cr for covariates coefficients `beta`. |
|
23 |
#' |
|
24 |
#' @export |
|
25 |
SurvivalExponential <- function( |
|
26 |
lambda = prior_gamma(2, 5), |
|
27 |
beta = prior_normal(0, 2) |
|
28 |
) { |
|
29 | 14x |
.SurvivalExponential( |
30 | 14x |
SurvivalModel( |
31 | 14x |
name = "Exponential", |
32 | 14x |
stan = StanModule("sm-exponential/model.stan"), |
33 | 14x |
parameters = ParameterList( |
34 | 14x |
Parameter(name = "sm_exp_lambda", prior = lambda, size = 1), |
35 | 14x |
Parameter(name = "beta_os_cov", prior = beta, size = "p_os_cov_design") |
36 |
) |
|
37 |
) |
|
38 |
) |
|
39 |
} |