1 |
#' Events by Term Plot |
|
2 |
#' |
|
3 |
#' This function plots commonly occurred events by number of unique subjects with events. |
|
4 |
#' It creates basic summary of events and compares event occurrences between comparison |
|
5 |
#' and reference arms, and can be used for events data such as Adverse Events. |
|
6 |
#' |
|
7 |
#' @inheritParams argument_convention |
|
8 |
#' @param id (`vector`)\cr contains subject identifier. Length of \code{id} must be the |
|
9 |
#' same as the length or number of rows of \code{terms}. Usually it is \code{ADAE$USUBJID}. |
|
10 |
#' @param term \code{character} or \code{factor} vector, or \code{data.frame} \cr |
|
11 |
#' Represents events information. \code{term} can be a \code{data.frame} produced |
|
12 |
#' by \code{create_flag_vars}, with each column being a \code{logical} event indicator |
|
13 |
#' @param arm_N (\code{numeric} vector)\cr |
|
14 |
#' Contains information of the number of patients in the levels of \code{arm}. This is useful |
|
15 |
#' if there are patients that have no adverse events can be accounted for with this argument. |
|
16 |
#' @param ref \code{character} indicates the name of the reference arm. Default is the first |
|
17 |
#' level of \code{arm}. |
|
18 |
#' @param trt \code{character} indicates the name of the treatment arm. Default is the second |
|
19 |
#' level of \code{arm}. |
|
20 |
#' @param sort_by \code{character} indicates how each \code{term} is sorted in the plot. |
|
21 |
#' Choose from `"term"` for alphabetic terms, `"riskdiff"` for risk difference, and `"meanrisk"` |
|
22 |
#' for mean risk. Default is "term". |
|
23 |
#' @param rate_range Numeric \code{vector} of length 2. Range for overall rate display |
|
24 |
#' @param diff_range Numeric \code{vector} of length 2. Range for rate difference display |
|
25 |
#' @param reversed \code{logical} whether to reverse the sorting by \code{sort_by}. |
|
26 |
#' Default is FALSE. |
|
27 |
#' @param axis_side \code{character} the side of the axis label, "left" or "right". Default is "left". |
|
28 |
#' @param color Color for the plot. \code{vector} of length 2. Color for reference and |
|
29 |
#' treatment arms respectively. Default set to \code{c("blue", "red")}. |
|
30 |
#' @param shape Shape for the plot. \code{vector} of length 2. Shape for reference and |
|
31 |
#' treatment arms respectively. Default set to \code{c(16, 17)} per |
|
32 |
#' \code{\link[ggplot2]{scale_shape}}. |
|
33 |
#' @details there is no equivalent STREAM output |
|
34 |
#' |
|
35 |
#' @return grob object |
|
36 |
#' |
|
37 |
#' @export |
|
38 |
#' |
|
39 |
#' @author Liming Li (Lil128) \email{liming.li@roche.com} |
|
40 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
41 |
#' |
|
42 |
#' @examples |
|
43 |
#' library(dplyr) |
|
44 |
#' library(grid) |
|
45 |
#' library(nestcolor) |
|
46 |
#' |
|
47 |
#' ADSL <- osprey::rADSL |
|
48 |
#' ADAE <- osprey::rADAE |
|
49 |
#' |
|
50 |
#' # add additional dummy causality flags |
|
51 |
#' ADAE <- ADAE %>% |
|
52 |
#' mutate(AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X")) %>% |
|
53 |
#' mutate(AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo")) |
|
54 |
#' attr(ADAE[["AEREL1"]], "label") <- "AE related to A: Drug X" |
|
55 |
#' attr(ADAE[["AEREL2"]], "label") <- "AE related to B: Placebo" |
|
56 |
#' |
|
57 |
#' term <- ADAE$AEDECOD |
|
58 |
#' id <- ADAE$USUBJID |
|
59 |
#' arm <- ADAE$ACTARMCD |
|
60 |
#' arm_N <- table(ADSL$ACTARMCD) |
|
61 |
#' ref <- "ARM A" |
|
62 |
#' trt <- "ARM C" |
|
63 |
#' |
|
64 |
#' # Example 1 |
|
65 |
#' p1 <- g_events_term_id( |
|
66 |
#' term, |
|
67 |
#' id, |
|
68 |
#' arm, |
|
69 |
#' arm_N |
|
70 |
#' ) |
|
71 |
#' grid::grid.newpage() |
|
72 |
#' grid::grid.draw(p1) |
|
73 |
#' |
|
74 |
#' # Example 2 |
|
75 |
#' p2 <- g_events_term_id( |
|
76 |
#' term, |
|
77 |
#' id, |
|
78 |
#' arm, |
|
79 |
#' arm_N, |
|
80 |
#' trt = trt, |
|
81 |
#' ref = ref, |
|
82 |
#' sort_by = "riskdiff", |
|
83 |
#' diff_ci_method = "ac", |
|
84 |
#' conf_level = 0.9 |
|
85 |
#' ) |
|
86 |
#' grid::grid.newpage() |
|
87 |
#' grid::grid.draw(p2) |
|
88 |
#' |
|
89 |
#' # Example 3 |
|
90 |
#' p3 <- g_events_term_id( |
|
91 |
#' term, |
|
92 |
#' id, |
|
93 |
#' arm, |
|
94 |
#' arm_N, |
|
95 |
#' sort_by = "meanrisk", |
|
96 |
#' axis_side = "right", |
|
97 |
#' fontsize = 5 |
|
98 |
#' ) |
|
99 |
#' grid::grid.newpage() |
|
100 |
#' grid::grid.draw(p3) |
|
101 |
#' |
|
102 |
#' # Example 4 |
|
103 |
#' term <- create_flag_vars(ADAE) |
|
104 |
#' g_events_term_id( |
|
105 |
#' term, |
|
106 |
#' id, |
|
107 |
#' arm, |
|
108 |
#' arm_N, |
|
109 |
#' fontsize = 3 |
|
110 |
#' ) |
|
111 |
g_events_term_id <- function(term, |
|
112 |
id, |
|
113 |
arm, |
|
114 |
arm_N, # nolint |
|
115 |
ref = levels(arm)[1], |
|
116 |
trt = levels(arm)[2], |
|
117 |
sort_by = c("term", "riskdiff", "meanrisk"), |
|
118 |
rate_range = c(0, 1), |
|
119 |
diff_range = c(-1, 1), |
|
120 |
reversed = FALSE, |
|
121 |
conf_level = 0.95, |
|
122 |
diff_ci_method = |
|
123 |
c("wald", "waldcc", "ac", "score", "scorecc", "mn", "mee", "blj", "ha", "beal"), |
|
124 |
axis_side = c("left", "right"), |
|
125 |
color = c(getOption("ggplot2.discrete.colour"), "blue", "red")[1:2], |
|
126 |
shape = c(16, 17), |
|
127 |
fontsize = 4, |
|
128 |
draw = TRUE) { |
|
129 | ! |
if (is.data.frame(term)) { |
130 | ! |
term_levels <- factor(colnames(term), levels = rev(colnames(term))) |
131 | ! |
term <- data.frame(t(term)) |
132 | ! |
term <- lapply(term, function(x) { |
133 | ! |
term_levels[x] |
134 |
}) |
|
135 | ! |
df <- tibble::tibble(id, arm, term) %>% |
136 | ! |
tidyr::unnest(term) |
137 |
} else { |
|
138 | ! |
term_levels <- `if`(is.factor(term), levels(term), unique(term)) |
139 | ! |
df <- tibble::tibble(id, arm, term) |
140 |
} |
|
141 | ||
142 |
# argument validation |
|
143 | ! |
sort_by <- match.arg(sort_by) |
144 | ! |
diff_ci_method <- match.arg(diff_ci_method) |
145 | ! |
axis_side <- match.arg(axis_side) |
146 | ||
147 | ! |
checkmate::assert_factor(arm, min.levels = 2) |
148 | ! |
stopifnot( |
149 | ! |
"invalid arguments: check that the length of id, term and arm are identical" = |
150 | ! |
length(id) == length(term) && length(term) == length(arm) |
151 |
) |
|
152 | ! |
stopifnot("invalid arguments: trt and ref need to be from arm" = all(c(trt, ref) %in% unique(arm))) |
153 | ! |
checkmate::assert_numeric(rate_range, len = 2, any.missing = FALSE) |
154 | ! |
checkmate::assert_numeric(diff_range, len = 2, any.missing = FALSE) |
155 | ! |
checkmate::assert_flag(reversed) |
156 | ! |
checkmate::assert_number(conf_level, lower = 0.5, upper = 1) |
157 | ! |
checkmate::assert_character(color, len = 2, any.missing = FALSE) |
158 | ! |
checkmate::assert_numeric(shape, len = 2, any.missing = FALSE) |
159 | ! |
checkmate::assert_numeric(fontsize, lower = 0, any.missing = FALSE) |
160 | ||
161 |
# construct calculations |
|
162 | ! |
arms <- c(ref, trt) |
163 | ! |
df_n <- data.frame(arm_N) |
164 | ! |
names(df_n) <- c("arm", "total") |
165 | ! |
df_n <- df_n[df_n$arm %in% arms, ] |
166 | ! |
ref_total <- df_n %>% |
167 | ! |
filter(arm == ref) %>% |
168 | ! |
select("total") %>% |
169 | ! |
pull() |
170 | ! |
trt_total <- df_n %>% |
171 | ! |
filter(arm == trt) %>% |
172 | ! |
select("total") %>% |
173 | ! |
pull() |
174 | ||
175 |
# create full cartesian of (arms) X (term levels) with 0 count to have full list of all possible combination |
|
176 |
# this is done in order to secure further calls |
|
177 | ! |
df_full <- cbind(expand.grid(arm = arms, term = term_levels), N = 0) |
178 | ||
179 | ! |
df_reshaped <- df %>% |
180 | ! |
distinct() %>% |
181 | ! |
filter(arm %in% arms) %>% |
182 | ! |
group_by(arm, term) %>% |
183 | ! |
summarise(N = n()) %>% |
184 | ! |
ungroup() %>% |
185 | ! |
rbind(df_full) %>% |
186 | ! |
group_by(arm, term) %>% |
187 | ! |
summarise(N = sum(.data$N)) %>% |
188 | ! |
mutate(arm = ifelse(arm == trt, "trt_count", "ref_count")) %>% |
189 | ! |
tidyr::pivot_wider(names_from = arm, values_from = "N", values_fill = list(N = 0)) |
190 | ||
191 | ! |
df_ci <- df_reshaped %>% |
192 | ! |
group_by(term) %>% |
193 | ! |
do( |
194 | ! |
data.frame( |
195 | ! |
t(c( |
196 | ! |
DescTools::BinomDiffCI( |
197 | ! |
.data$trt_count, |
198 | ! |
trt_total, |
199 | ! |
.data$ref_count, |
200 | ! |
ref_total, |
201 | ! |
conf_level, |
202 | ! |
method = diff_ci_method |
203 | ! |
)[1, ], # wald |
204 | ! |
meanrisk = (.data$trt_count + .data$ref_count) / (trt_total + ref_total) |
205 |
)) |
|
206 |
) |
|
207 |
) %>% |
|
208 | ! |
ungroup() %>% |
209 | ! |
rename(riskdiff = "est", lower_ci = "lwr.ci", upper_ci = "upr.ci") |
210 | ||
211 | ! |
df_risk <- df_reshaped %>% |
212 | ! |
group_by(term) %>% |
213 | ! |
do( |
214 | ! |
data.frame( |
215 | ! |
risk = c(.data$trt_count / trt_total, .data$ref_count / ref_total), |
216 | ! |
arm = c(trt, ref) |
217 |
) |
|
218 |
) %>% |
|
219 | ! |
ungroup() |
220 | ||
221 | ! |
names(color) <- arms |
222 | ! |
names(shape) <- arms |
223 | ||
224 |
# if diff_range specified, limit terms |
|
225 | ! |
terms_needed <- df_ci %>% |
226 | ! |
filter( |
227 | ! |
.data$riskdiff > diff_range[1] & |
228 | ! |
.data$riskdiff < diff_range[2] & |
229 | ! |
.data$meanrisk > rate_range[1] & |
230 | ! |
.data$meanrisk < rate_range[2] |
231 |
) %>% |
|
232 | ! |
select(term) %>% |
233 | ! |
distinct() %>% |
234 | ! |
pull() %>% |
235 | ! |
as.character() |
236 | ||
237 | ! |
if (length(terms_needed) == 0) { |
238 | ! |
ret <- grid::textGrob("All Observations are filtered out") |
239 | ! |
if (draw) { |
240 | ! |
grid::grid.draw(ret) |
241 |
} |
|
242 | ! |
return(invisible(ret)) |
243 |
} |
|
244 | ||
245 |
# sorting |
|
246 | ! |
if (sort_by == "term") { |
247 | ! |
terms_needed <- sort(terms_needed, decreasing = TRUE) |
248 |
} else { |
|
249 | ! |
terms_needed <- df_ci %>% |
250 | ! |
arrange(.data[[sort_by]]) %>% |
251 | ! |
filter(term %in% terms_needed) %>% |
252 | ! |
select(term) %>% |
253 | ! |
pull() |
254 |
} |
|
255 | ||
256 | ! |
if (reversed) { |
257 | ! |
terms_needed <- rev(terms_needed) |
258 |
} |
|
259 | ||
260 | ! |
df_ci <- df_ci %>% |
261 | ! |
filter(term %in% terms_needed) %>% |
262 | ! |
mutate(term = factor(term, terms_needed)) |
263 | ! |
df_risk <- df_risk %>% |
264 | ! |
filter(term %in% terms_needed) %>% |
265 | ! |
mutate(term = factor(term, terms_needed)) |
266 | ! |
terms_label <- vapply( |
267 | ! |
lapply(terms_needed, strwrap, width = 30), |
268 | ! |
paste, |
269 | ! |
FUN.VALUE = character(1), |
270 | ! |
collapse = "\n" |
271 |
) |
|
272 | ||
273 | ! |
mytheme <- theme_osprey(axis_side = axis_side, fontsize = fontsize) |
274 | ||
275 | ! |
labels <- stats::setNames(sprintf("%s\n(N = %i)", df_n$arm, df_n$total), df_n$arm) |
276 | ||
277 | ! |
y_axis <- scale_y_discrete( |
278 | ! |
limits = terms_needed, |
279 | ! |
breaks = terms_needed, |
280 | ! |
labels = terms_label, |
281 | ! |
position = axis_side |
282 |
) |
|
283 | ||
284 | ! |
p1 <- ggplot(df_risk) + |
285 | ! |
geom_point( |
286 | ! |
aes( |
287 | ! |
y = term, |
288 | ! |
x = .data$risk, |
289 | ! |
group = arm, |
290 | ! |
color = arm, |
291 | ! |
shape = arm |
292 |
), |
|
293 | ! |
size = fontsize * 0.7 |
294 |
) + |
|
295 | ! |
mytheme + |
296 | ! |
ggtitle("Proportion") + |
297 | ! |
scale_color_manual(values = color, labels = labels) + |
298 | ! |
scale_shape_manual(values = shape, labels = labels) + |
299 | ! |
y_axis |
300 | ||
301 | ! |
p2 <- ggplot(df_ci) + |
302 | ! |
geom_point(mapping = aes(y = term, x = .data$riskdiff), size = fontsize * 0.7) + |
303 | ! |
geom_vline(data = NULL, xintercept = 0, linetype = 2) + |
304 | ! |
mytheme + |
305 | ! |
geom_errorbarh(mapping = aes(xmax = .data$upper_ci, xmin = .data$lower_ci, y = term), height = 0.4) + |
306 | ! |
y_axis + |
307 | ! |
ggtitle("Risk Difference") |
308 | ||
309 | ! |
axis_name <- sprintf("axis-%s", substr(axis_side, 1, 1)) |
310 | ||
311 | ! |
p1_parts <- ggplotGrob(p1) |
312 | ! |
p2_parts <- ggplotGrob(p2) |
313 | ||
314 | ! |
mylegend <- grob_part(grob_part(p1_parts, "guide-box"), "guides") |
315 | ! |
axis <- grob_part(p1_parts, axis_name) |
316 | ||
317 | ! |
less_risk <- grid::textGrob( |
318 | ! |
"Favor\nTreatment", |
319 | ! |
just = "left", |
320 | ! |
x = grid::unit(fontsize * .pt, "pt"), |
321 | ! |
gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold") |
322 |
) |
|
323 | ! |
more_risk <- grid::textGrob( |
324 | ! |
"Favor\nControl", |
325 | ! |
just = "right", |
326 | ! |
x = grid::unit(1, "npc") - grid::unit(fontsize * .pt, "pt"), |
327 | ! |
gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold") |
328 |
) |
|
329 | ||
330 | ! |
risk_label <- gridExtra::arrangeGrob(less_risk, more_risk, nrow = 1) |
331 | ! |
title1 <- grob_part(p1_parts, "title") |
332 | ! |
title2 <- grob_part(p2_parts, "title") |
333 | ! |
panel1 <- grob_part(p1_parts, "panel") |
334 | ! |
panel2 <- grob_part(p2_parts, "panel") |
335 | ! |
axis_b1 <- grob_part(p1_parts, "axis-b") |
336 | ! |
axis_b2 <- grob_part(p2_parts, "axis-b") |
337 | ||
338 | ! |
grobs <- list( |
339 | ! |
title1, |
340 | ! |
title2, |
341 | ! |
axis, |
342 | ! |
panel1, |
343 | ! |
panel2, |
344 | ! |
axis_b1, |
345 | ! |
axis_b2, |
346 | ! |
mylegend, |
347 | ! |
risk_label |
348 |
) |
|
349 | ||
350 | ! |
if (axis_side == "left") { |
351 | ! |
layout_matrix <- rbind( |
352 | ! |
c(NA, 1, NA, 2), |
353 | ! |
c(3, 4, NA, 5), |
354 | ! |
c(NA, 6, NA, 7), |
355 | ! |
c(8, 8, NA, 9) |
356 |
) |
|
357 | ! |
widths <- grid::unit.c(grid::grobWidth(axis), grid::unit(c(1, 2 * fontsize, 1), c("null", "pt", "null"))) |
358 |
} else { |
|
359 | ! |
layout_matrix <- rbind( |
360 | ! |
c(1, NA, 2, NA), |
361 | ! |
c(4, NA, 5, 3), |
362 | ! |
c(6, NA, 7, NA), |
363 | ! |
c(8, NA, 9, NA) |
364 |
) |
|
365 | ! |
widths <- grid::unit.c(grid::unit(c(1, 10, 1), c("null", "pt", "null")), grid::grobWidth(axis)) |
366 |
} |
|
367 | ||
368 | ! |
heights <- grid::unit.c( |
369 | ! |
grid::grobHeight(title1), |
370 | ! |
grid::unit(1, "null"), |
371 | ! |
grid::grobHeight(axis_b1), |
372 | ! |
max(grid::grobHeight(mylegend), grid::grobHeight(more_risk)) |
373 |
) |
|
374 | ||
375 | ! |
ret <- gridExtra::arrangeGrob( |
376 | ! |
grobs = grobs, |
377 | ! |
nrow = 4, |
378 | ! |
ncol = 4, |
379 | ! |
layout_matrix = layout_matrix, |
380 | ! |
heights = heights, |
381 | ! |
widths = widths |
382 |
) |
|
383 | ||
384 | ! |
ret <- grob_add_padding(ret) |
385 | ||
386 | ! |
if (draw) { |
387 | ! |
grid::grid.draw(ret) |
388 |
} |
|
389 | ! |
invisible(ret) |
390 |
} |
|
391 | ||
392 | ||
393 |
#' create `AE` overview flags |
|
394 |
#' @param df data frame of `AE` |
|
395 |
#' @param fatal `AE` with fatal outcome derivation |
|
396 |
#' @param serious Serious `AE` derivation. |
|
397 |
#' @param serious_withdrawl Serious `AE` leading to withdrawal derivation |
|
398 |
#' @param serious_modified Serious `AE` leading to dose modification derivation |
|
399 |
#' @param serious_related Related Serious `AE` derivation |
|
400 |
#' @param withdrawl `AE` leading to withdrawal derivation |
|
401 |
#' @param modified `AE` leading to dose modification derivation |
|
402 |
#' @param related Related `AE` derivation |
|
403 |
#' @param related_withdrawl Related `AE` leading to withdrawal derivation |
|
404 |
#' @param related_modified Related `AE` leading to dose modification derivation |
|
405 |
#' @param ctc35 Grade 3-5 `AE` derivation |
|
406 |
#' @param ... named expressions used to generate categories |
|
407 |
#' @details in this function, all flags are expressions calls, for simpler usage. |
|
408 |
#' @export |
|
409 |
#' @examples |
|
410 |
#' library(dplyr) |
|
411 |
#' |
|
412 |
#' ADAE <- osprey::rADAE |
|
413 |
#' |
|
414 |
#' # add additional dummy causality flags |
|
415 |
#' ADAE <- ADAE %>% |
|
416 |
#' mutate(AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X")) %>% |
|
417 |
#' mutate(AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo")) |
|
418 |
#' attr(ADAE[["AEREL1"]], "label") <- "AE related to A: Drug X" |
|
419 |
#' attr(ADAE[["AEREL2"]], "label") <- "AE related to B: Placebo" |
|
420 |
#' |
|
421 |
#' create_flag_vars(ADAE) |
|
422 |
#' # create other flags |
|
423 |
#' create_flag_vars(ADAE, `AENSER` = AESER != "Y") |
|
424 |
#' # remove flags that are not needed |
|
425 |
#' create_flag_vars(ADAE, fatal = NULL) |
|
426 |
create_flag_vars <- function(df, |
|
427 |
# nolint start |
|
428 |
fatal = AESDTH == "Y", |
|
429 |
serious = AESER == "Y", |
|
430 |
serious_withdrawl = AESER == "Y" & |
|
431 |
grepl("DRUG WITHDRAWN", AEACN), |
|
432 |
serious_modified = AESER == "Y" & |
|
433 |
grepl("DRUG (INTERRUPTED|INCREASED|REDUCED)", AEACN), |
|
434 |
serious_related = AESER == "Y" & AEREL == "Y", |
|
435 |
withdrawl = grepl("DRUG WITHDRAWN", AEACN), |
|
436 |
modified = grepl("DRUG (INTERRUPTED|INCREASED|REDUCED)", AEACN), |
|
437 |
related = AEREL == "Y", |
|
438 |
related_withdrawl = AEREL == "Y" & grepl("DRUG WITHDRAWN", AEACN), |
|
439 |
related_modified = AEREL == "Y" & |
|
440 |
grepl("DRUG (INTERRUPTED|INCREASED|REDUCED)", AEACN), |
|
441 |
ctc35 = AETOXGR %in% c("3", "4", "5"), |
|
442 |
# nolint end |
|
443 |
...) { |
|
444 | ! |
AESDTH <- AESER <- AEACN <- AEREL <- AETOXGR <- NULL # nolint |
445 | ! |
args <- |
446 | ! |
eval(substitute( |
447 | ! |
alist( |
448 | ! |
"AE with fatal outcome" = fatal, |
449 | ! |
"Serious AE" = serious, |
450 | ! |
"Serious AE leading to withdrawal" = serious_withdrawl, |
451 | ! |
"Serious AE leading to dose modification" = serious_modified, |
452 | ! |
"Related Serious AE" = serious_related, |
453 | ! |
"AE leading to withdrawal" = withdrawl, |
454 | ! |
"AE leading to dose modification" = modified, |
455 | ! |
"Related AE" = related, |
456 | ! |
"Related AE leading to withdrawal" = related_withdrawl, |
457 | ! |
"Related AE leading to dose modification" = related_modified, |
458 | ! |
"Grade 3-5 AE" = ctc35 |
459 |
) |
|
460 |
)) |
|
461 | ! |
args <- c(args, eval(substitute(alist(...)))) |
462 | ! |
stopifnot(all(names(args) != "")) # all elements in ... should be named |
463 | ! |
argnames <- unique(names(args)) |
464 | ! |
df <- as.data.frame(df) |
465 | ! |
ret <- lapply(argnames, function(t) { |
466 | ! |
tryCatch( |
467 | ! |
expr = { |
468 | ! |
with(df, eval(args[[t]])) |
469 |
}, |
|
470 | ! |
error = function(w) { |
471 | ! |
NULL |
472 |
}, |
|
473 | ! |
warning = function(w) { |
474 | ! |
NULL |
475 |
} |
|
476 |
) |
|
477 |
}) |
|
478 | ! |
names(ret) <- argnames |
479 | ! |
valid <- vapply(argnames, function(x) { |
480 | ! |
valid <- length(ret[[x]]) > 0 |
481 | ! |
if (!valid) { |
482 | ! |
warning(sprintf( |
483 | ! |
"%s with calculation %s not valid", |
484 | ! |
x, |
485 | ! |
as.character(as.expression(args[[x]])) |
486 |
)) |
|
487 |
} |
|
488 | ! |
valid |
489 | ! |
}, FUN.VALUE = TRUE) |
490 | ! |
do.call(data.frame, args = list(ret[valid], check.names = FALSE)) |
491 |
} |
1 |
#' Applies STREAM style filtering to datasets |
|
2 |
#' |
|
3 |
#' One of `slref` or `anl` need to be specified. The conversion from `SAS` code in filters dataset may not work in all |
|
4 |
#' cases. In case of failure a sensible error message should be returned. |
|
5 |
#' |
|
6 |
#' @param slref The subject level data frame (typically `ADSL`) |
|
7 |
#' @param anl The analysis data frame |
|
8 |
#' @param suffix The suffix to apply in quotes (e.g. `"ITT_PFSINV"`) |
|
9 |
#' @param slref_keep Variables to keep from `slref` (e.g. `c("REGION", "SEX")`) |
|
10 |
#' @param usubjid The unique subject identifier variable in quotes (e.g. `"USUBJID"`) |
|
11 |
#' @param filters The name of the filters dataset |
|
12 |
#' |
|
13 |
#' @return \code{dataframe} object |
|
14 |
#' @author Iain Bennett |
|
15 |
#' @export |
|
16 |
#' @examples |
|
17 |
#' ADSL <- osprey::rADSL |
|
18 |
#' ADTTE <- osprey::rADTTE |
|
19 |
#' filters <- as.data.frame(rbind( |
|
20 |
#' c(ID = "IT", FLTTARGET = "SLREF", FLTWHERE = "where 1 eq 1"), |
|
21 |
#' c(ID = "BIO", FLTTARGET = "SLREF", FLTWHERE = "where BMRKR1 ge 4.3"), |
|
22 |
#' c(ID = "M", FLTTARGET = "SLREF", FLTWHERE = "where SEX eq 'M'"), |
|
23 |
#' c(ID = "PFS", FLTTARGET = "ANL", FLTWHERE = "where PARAMCD eq 'PFS'"), |
|
24 |
#' c(ID = "OS", FLTTARGET = "ANL", FLTWHERE = "where PARAMCD eq 'OS'") |
|
25 |
#' )) |
|
26 |
#' |
|
27 |
#' ANL <- stream_filter( |
|
28 |
#' slref = ADSL, |
|
29 |
#' anl = ADTTE, |
|
30 |
#' suffix = "IT_PFS_BIO", |
|
31 |
#' filters = filters |
|
32 |
#' ) |
|
33 |
stream_filter <- function(slref = NULL, anl = NULL, filters, suffix, slref_keep = NULL, usubjid = "USUBJID") { |
|
34 | ! |
actual_suffix <- NULL |
35 | ||
36 | ! |
if (is.null(anl) && is.null(slref)) { |
37 | ! |
stop("At least one of anl= or slref= must be provided") |
38 |
} |
|
39 | ||
40 | ! |
if (is.null(anl)) { |
41 | ! |
anl <- slref |
42 |
} |
|
43 | ||
44 | ! |
if (is.null(slref)) { |
45 | ! |
slref <- anl |
46 |
} |
|
47 | ||
48 | ! |
asl_out <- slref |
49 | ! |
anl_out <- anl |
50 | ||
51 |
# step 1 get a list of filters |
|
52 | ||
53 | ! |
filters_to_apply <- strsplit(suffix, split = "_", fixed = TRUE) %>% |
54 | ! |
unlist() |
55 | ||
56 | ! |
n_filters <- length(filters_to_apply) |
57 | ||
58 | ! |
for (i in 1:n_filters) { |
59 | ! |
this_filter <- filters_to_apply[i] |
60 | ||
61 |
# find filter meta data |
|
62 | ||
63 | ! |
this_filter_df <- unique(dplyr::filter(filters, .data$ID == this_filter)) |
64 | ||
65 | ! |
if (nrow(this_filter_df) == 0) { |
66 | ! |
stop(paste("Filter", this_filter, "not found in filters")) |
67 |
} |
|
68 | ||
69 | ! |
if (nrow(this_filter_df) > 1) { |
70 | ! |
warning(paste("Filter", this_filter, "is duplicated in filters")) |
71 | ! |
this_filter_df <- slice(this_filter_df, 1) |
72 |
} |
|
73 | ||
74 |
# try and convert where clause from sas to R |
|
75 | ! |
this_sasclause <- this_filter_df$FLTWHERE |
76 | ! |
this_rclause <- stream_filter_convwhere(this_sasclause) |
77 | ||
78 | ! |
msg1 <- paste("\nSAS code:", this_sasclause, "\nwas converted to\nR code:", this_rclause) |
79 | ||
80 |
# what is the target df? |
|
81 | ||
82 | ! |
if (this_filter_df$FLTTARGET == "ANL") { |
83 | ! |
this_df <- anl_out |
84 |
} |
|
85 | ||
86 | ! |
if (this_filter_df$FLTTARGET == "SLREF") { |
87 | ! |
this_df <- asl_out |
88 |
} |
|
89 | ||
90 |
# try and apply the filtering |
|
91 | ! |
new_df <- NULL |
92 | ||
93 | ! |
new_df <- try( |
94 | ! |
filter_(this_df, this_rclause), |
95 | ! |
silent = TRUE |
96 |
) |
|
97 | ||
98 | ! |
if (is(new_df, "try-error")) { |
99 |
# failed - retain original dataset |
|
100 | ! |
warning(paste("\nFilter ID=", this_filter, "was NOT applied.", msg1, "\n Error message:", new_df)) |
101 | ! |
cat(paste("\nFilter ID=", this_filter, "was NOT applied.", msg1, "\n Error message:", new_df)) |
102 | ! |
new_df <- this_df |
103 |
} else { |
|
104 |
# success |
|
105 | ! |
msg2 <- paste0( |
106 | ! |
"\n", |
107 | ! |
nrow(new_df), |
108 | ! |
" of ", |
109 | ! |
nrow(this_df), |
110 | ! |
" observations selected from ", this_filter_df$FLTTARGET |
111 |
) |
|
112 | ! |
cat(paste("\nFilter", this_filter, "applied", msg1, msg2, "\n")) |
113 | ! |
actual_suffix <- if (is.null(actual_suffix)) { |
114 | ! |
this_filter |
115 |
} else { |
|
116 | ! |
paste(actual_suffix, this_filter, sep = "_") |
117 |
} |
|
118 |
} |
|
119 | ||
120 |
# update the output data sets |
|
121 | ! |
if (this_filter_df$FLTTARGET == "ANL") { |
122 | ! |
anl_out <- new_df |
123 | ! |
} else if (this_filter_df$FLTTARGET == "SLREF") { |
124 | ! |
asl_out <- new_df |
125 |
} |
|
126 |
} |
|
127 | ||
128 |
# finished filtering - combine results data |
|
129 |
# what variables to keep from SLREF? |
|
130 | ! |
slref_keep <- if (is.null(slref_keep)) { |
131 | ! |
usubjid |
132 |
} else { |
|
133 | ! |
unique(c(slref_keep, usubjid)) |
134 |
} |
|
135 | ||
136 |
# keep these variables only |
|
137 | ! |
asl_out <- transmute_(asl_out, paste(slref_keep, collapse = ",")) |
138 | ||
139 |
# use inner join to apply both slref and anl restrictions |
|
140 | ! |
rc <- inner_join(asl_out, anl_out, by = usubjid) |
141 | ||
142 |
# report out what was applied in case of errors |
|
143 | ! |
actual_suffix <- ifelse(is.null(actual_suffix), " ", actual_suffix) |
144 | ||
145 | ! |
if (actual_suffix == suffix) { |
146 | ! |
cat(paste0("\nSuffix ", suffix, " was applied")) |
147 |
} else { |
|
148 | ! |
cat(paste0("\nNot all filters applied. \n", actual_suffix, " was applied instead of ", suffix)) |
149 |
} |
|
150 | ! |
cat(paste0("\n", nrow(rc), " of ", nrow(anl), " observations selected from ANL\n")) |
151 | ||
152 |
# return the filtered dataset |
|
153 | ! |
return(rc) |
154 |
} |
|
155 | ||
156 |
#' Replicates the use of index function in `SAS` for logic options |
|
157 |
#' |
|
158 |
#' Assumption is that use in filters is to only resolve true vs false |
|
159 |
#' Primarily for use with stream_filter and related `stream_filter_convwhere` functions |
|
160 |
#' @param string1 The string to search within - can be a vector |
|
161 |
#' @param string2 The string to search for - must have length 1 |
|
162 |
#' |
|
163 |
#' @return \code{boolean} indicator |
|
164 |
#' @author Iain Bennett |
|
165 |
#' @export |
|
166 |
#' |
|
167 |
#' @examples |
|
168 |
#' AEACN <- c("DRUG MODIFIED", "DRUG STOPPED", "DOSE/DRUG MODIFIED") |
|
169 |
#' stream_filter_index(AEACN, "DRUG MODIFIED") |
|
170 |
stream_filter_index <- function(string1, string2) { |
|
171 | ! |
rc <- regexpr(string2, string1, fixed = TRUE) |
172 | ! |
rc <- ifelse(rc == -1, FALSE, TRUE) |
173 | ! |
return(rc) |
174 |
} |
|
175 | ||
176 | ||
177 |
#' Convert `SAS` code to R code |
|
178 |
#' |
|
179 |
#' Will convert following `SAS` operators: `eq, =, le, lt, ge, gt, index` |
|
180 |
#' Will convert following logic: and, or, () |
|
181 |
#' Will convert all unquoted values to upper case (assumed to be variable names) |
|
182 |
#' All quoted values will be returned with single quotes - may fail if have quotes within quotes |
|
183 |
#' @param x a character string of `SAS` code |
|
184 |
#' |
|
185 |
#' @return a character string of R code |
|
186 |
#' @author Iain Bennett |
|
187 |
#' @export |
|
188 |
#' |
|
189 |
#' @examples |
|
190 |
#' |
|
191 |
#' stream_filter_convwhere(x = "where X in (1 2 3 4) and Y gt 4 ") |
|
192 |
#' stream_filter_convwhere(x = "where X = \"fred\" and Y gt 4 ") |
|
193 |
stream_filter_convwhere <- function(x) { |
|
194 |
# convert double quotes to single quotes. May fail if quoted values exist. |
|
195 | ! |
this_rclause <- gsub("\"", "'", x, fixed = TRUE) |
196 | ||
197 |
# convert non quoted values to upper case |
|
198 | ||
199 | ! |
this_rclause_quotes <- strsplit(paste0(" ", this_rclause, " "), split = "'", fixed = TRUE) %>% |
200 | ! |
unlist() |
201 | ||
202 | ! |
inquotes <- rep(c(0, 1), length.out = length(this_rclause_quotes)) |
203 | ||
204 | ! |
for (j in seq_along(inquotes)) { |
205 |
# try and convert logic outside quotes |
|
206 | ! |
if (inquotes[j] == 0) { |
207 | ! |
this_rclause_quotes[j] <- toupper(this_rclause_quotes[j]) |
208 | ! |
this_rclause_quotes[j] <- gsub("=", "==", this_rclause_quotes[j], fixed = TRUE) |
209 | ! |
this_rclause_quotes[j] <- gsub(" EQ ", " == ", this_rclause_quotes[j], fixed = TRUE) |
210 | ! |
this_rclause_quotes[j] <- gsub(" NE ", " != ", this_rclause_quotes[j], fixed = TRUE) |
211 | ! |
this_rclause_quotes[j] <- gsub(" LE ", " <= ", this_rclause_quotes[j], fixed = TRUE) |
212 | ! |
this_rclause_quotes[j] <- gsub(" LT ", " < ", this_rclause_quotes[j], fixed = TRUE) |
213 | ! |
this_rclause_quotes[j] <- gsub(" GE ", " >= ", this_rclause_quotes[j], fixed = TRUE) |
214 | ! |
this_rclause_quotes[j] <- gsub(" GT ", " > ", this_rclause_quotes[j], fixed = TRUE) |
215 | ! |
this_rclause_quotes[j] <- gsub(" AND ", " & ", this_rclause_quotes[j], fixed = TRUE) |
216 | ! |
this_rclause_quotes[j] <- gsub(" OR ", " || ", this_rclause_quotes[j], fixed = TRUE) |
217 | ! |
this_rclause_quotes[j] <- gsub(" IN ", " %in% c", this_rclause_quotes[j], fixed = TRUE) |
218 | ! |
this_rclause_quotes[j] <- gsub("WHERE ", " ", this_rclause_quotes[j], fixed = TRUE) |
219 | ! |
this_rclause_quotes[j] <- gsub("INDEX(", " stream_filter_index(", this_rclause_quotes[j], fixed = TRUE) |
220 | ! |
this_rclause_quotes[j] <- gsub("UPCASE(", " toupper(", this_rclause_quotes[j], fixed = TRUE) |
221 | ! |
this_rclause_quotes[j] <- gsub("DATEPART(", " as.Date(", this_rclause_quotes[j], fixed = TRUE) |
222 |
} |
|
223 |
} |
|
224 | ||
225 |
# collapse back to have quoted |
|
226 | ! |
this_rclause <- paste(this_rclause_quotes, collapse = "'") |
227 | ||
228 |
# if contains an in statement need to ensure commas exist |
|
229 | ! |
if (grepl(" %in% c", this_rclause, fixed = TRUE)) { |
230 |
# get the clause (assume only 1 per filter...) |
|
231 | ! |
temp1_str <- strsplit(this_rclause, split = " %in% c(", fixed = TRUE) %>% |
232 | ! |
unlist() |
233 | ||
234 | ! |
if (length(temp1_str) != 2) { |
235 | ! |
stop("ERROR - function can't handle multiple IN operators.") |
236 |
} else { |
|
237 | ! |
left_str <- temp1_str[1] |
238 | ! |
in_right_str <- temp1_str[2] |
239 | ||
240 |
# find quoted items bracket |
|
241 | ! |
temp2_str <- strsplit(in_right_str, split = "'", fixed = TRUE) %>% |
242 | ! |
unlist() |
243 | ! |
inquotes <- rep(c(0, 1), length.out = length(temp2_str)) |
244 | ||
245 |
# find first not quoted right bracket |
|
246 | ||
247 | ! |
right_idxv <- which(inquotes == 0 & grepl(")", temp2_str, fixed = TRUE)) |
248 | ! |
right_idxc <- regexpr(")", temp2_str[right_idxv], fixed = TRUE) |
249 | ||
250 | ! |
temp3_str <- temp2_str |
251 | ||
252 | ! |
temp3_str[right_idxv] <- substr(temp2_str[right_idxv], right_idxc, nchar(temp2_str[right_idxv])) |
253 | ||
254 | ! |
right_str <- temp3_str[right_idxv:length(temp3_str)] %>% |
255 | ! |
paste(collapse = "'") |
256 | ||
257 | ! |
in_idx <- regexpr(right_str, in_right_str, fixed = TRUE) %>% |
258 | ! |
as.numeric() |
259 | ||
260 | ! |
in_str <- substr(in_right_str, 1, in_idx - 1) |
261 | ||
262 |
# now have left.str, in.str and right.str that contain seperate code parts |
|
263 |
# need to check the list of in and remove any commas to later replace between each element |
|
264 |
# first get any unquoted spaces or commas and split these |
|
265 | ||
266 | ! |
temp4_str <- strsplit(in_str, split = "'", fixed = TRUE) %>% |
267 | ! |
unlist() |
268 | ! |
inquotes <- rep(c(0, 1), length.out = length(temp4_str)) |
269 | ||
270 | ! |
unquoted <- temp4_str[which(inquotes == 0)] |
271 | ! |
quoted_items <- temp4_str[which(inquotes == 1)] |
272 | ||
273 |
# seperate any items unqouted |
|
274 | ! |
temp5_str <- strsplit(unquoted, split = ",", fixed = TRUE) %>% |
275 | ! |
unlist() %>% |
276 | ! |
strsplit(split = " ", fixed = TRUE) %>% |
277 | ! |
unlist() |
278 | ||
279 | ! |
unquoted_items <- temp5_str[which(!(temp5_str %in% ""))] |
280 | ||
281 |
# should now have two vectors of strings |
|
282 |
# unquoted.items and quoted.items |
|
283 |
# first add the quoted items back in quoted.items <- unquoted.items |
|
284 | ! |
if (length(quoted_items) > 0) { |
285 | ! |
quoted_items <- paste0("'", quoted_items, "'") |
286 |
} |
|
287 | ||
288 |
# now collapse both strings adding commas |
|
289 | ||
290 | ! |
all_items <- c(quoted_items, unquoted_items) %>% |
291 | ! |
paste(collapse = " , ") |
292 | ||
293 |
# rebuild the complete code piece |
|
294 | ! |
this_rclause <- paste0(left_str, " %in% c(", all_items, right_str) |
295 |
} |
|
296 |
} |
|
297 | ! |
return(this_rclause) |
298 |
} |
1 |
#' Output decorated grob (`gTree`) objects as PDF |
|
2 |
#' |
|
3 |
#' This is an utility function to output a decorated grob (`gTree`) object |
|
4 |
#' |
|
5 |
#' @param grobs a grid grob (`gTree`) object, optionally `NULL` if only a grob with |
|
6 |
#' the decoration should be shown. |
|
7 |
#' @param outpath specify full path to output pdf to `BCE` or `BEE` |
|
8 |
#' @param pagesize name of `pagesize` (print size) and orientation, accepted values include |
|
9 |
#' \code{"a4.landscape"}, \code{"a4.portrait"}, \code{"letter.portrait"} and |
|
10 |
#' \code{"letter.landscape"} (default) |
|
11 |
#' |
|
12 |
#' @return a pdf file |
|
13 |
#' @seealso [grobs2pdf()] |
|
14 |
#' @export |
|
15 |
#' |
|
16 |
#' @author Chendi Liao (liaoc10) \email{chendi.liao@roche.com} |
|
17 |
#' |
|
18 |
#' @examples |
|
19 |
#' \dontrun{ |
|
20 |
#' library(ggplot2) |
|
21 |
#' g <- with(iris, { |
|
22 |
#' list( |
|
23 |
#' ggplotGrob(qplot(Sepal.Length, Sepal.Width, col = Species)), |
|
24 |
#' ggplotGrob(qplot(Sepal.Length, Petal.Length, col = Species)), |
|
25 |
#' ggplotGrob(qplot(Sepal.Length, Petal.Width, col = Species)) |
|
26 |
#' ) |
|
27 |
#' }) |
|
28 |
#' |
|
29 |
#' # output to pdf |
|
30 |
#' g %>% as_pdf("~/example_aspdf1.pdf") |
|
31 |
#' } |
|
32 |
as_pdf <- function(grobs, |
|
33 |
outpath, |
|
34 |
pagesize = "letter.landscape") { |
|
35 | ! |
paper_sizes <- paper_size(pagesize) |
36 | ! |
paper_width <- paper_sizes[1] |
37 | ! |
paper_height <- paper_sizes[2] |
38 | ||
39 |
# Output to PDF |
|
40 | ! |
grDevices::pdf(outpath, width = paper_width, height = paper_height) |
41 | ||
42 | ! |
lapply(grobs, function(x) { |
43 | ! |
grid::grid.newpage() |
44 | ! |
grid::grid.draw(x) |
45 |
}) |
|
46 | ||
47 | ! |
grDevices::dev.off() |
48 |
} |
|
49 | ||
50 |
paper_size <- function(pagesize) { |
|
51 | ! |
if (pagesize == "a4.landscape") { |
52 | ! |
paper_width <- 11.7 |
53 | ! |
paper_height <- 8.3 |
54 | ! |
} else if (pagesize == "a4.portrait") { |
55 | ! |
paper_width <- 8.3 |
56 | ! |
paper_height <- 11.7 |
57 | ! |
} else if (pagesize == "letter.portrait") { |
58 | ! |
paper_width <- 8.5 |
59 | ! |
paper_height <- 11 |
60 | ! |
} else if (pagesize == "letter.landscape") { |
61 | ! |
paper_width <- 11 |
62 | ! |
paper_height <- 8.5 |
63 |
} else { |
|
64 | ! |
paper_width <- 11 |
65 | ! |
paper_height <- 8.5 |
66 |
} |
|
67 | ! |
return(c(paper_width, paper_height)) |
68 |
} |
|
69 | ||
70 |
#' Decorate grob (`gTree`) objects then outputs as `IDM` compatible PDF |
|
71 |
#' |
|
72 |
#' This is an utility function to decorated grob (`gTree`) object with titles and |
|
73 |
#' footnotes in accordance with `IDM` specification and export as PDF file with |
|
74 |
#' full path to program and the output for easy tracking and archiving. |
|
75 |
#' |
|
76 |
#' @param grobs A grid grob (`gTree`) object, optionally `NULL` if only a |
|
77 |
#' grob with the decoration should be shown |
|
78 |
#' @param titles Vector of character strings. Vector elements are separated by a |
|
79 |
#' newline and strings are wrapped according to the page with |
|
80 |
#' @param footnotes Vector of character string. Same rules as for \code{titles} |
|
81 |
#' @param progpath Specify the full path to the R program that generate the |
|
82 |
#' grobs and the PDF |
|
83 |
#' @param outpath Specify full path to output pdf to `BCE` or `BEE` |
|
84 |
#' @param fontsize Base font size used in pdf, default set to 9. Font size for |
|
85 |
#' title is set to \code{fontsize} + 1 (default = 10) and for footnotes set to |
|
86 |
#' \code{fontsize} - 1 (default = 8) |
|
87 |
#' @param pagesize name of paper size and orientation, accepted values include |
|
88 |
#' \code{"a4.landscape"}, \code{"a4.portrait"}, \code{"letter.portrait"} and |
|
89 |
#' \code{"letter.landscape"} (default) |
|
90 |
#' |
|
91 |
#' @return a pdf file |
|
92 |
#' |
|
93 |
#' @export |
|
94 |
#' |
|
95 |
#' @author Chendi Liao (liaoc10) \email{chendi.liao@roche.com} |
|
96 |
#' |
|
97 |
#' @examples |
|
98 |
#' \dontrun{ |
|
99 |
#' library(ggplot2) |
|
100 |
#' library(tern) |
|
101 |
#' |
|
102 |
#' g <- with(iris, { |
|
103 |
#' list( |
|
104 |
#' ggplotGrob(qplot(Sepal.Length, Sepal.Width, col = Species)), |
|
105 |
#' ggplotGrob(qplot(Sepal.Length, Petal.Length, col = Species)), |
|
106 |
#' ggplotGrob(qplot(Sepal.Length, Petal.Width, col = Species)) |
|
107 |
#' ) |
|
108 |
#' }) |
|
109 |
#' |
|
110 |
#' grobs2pdf( |
|
111 |
#' grobs = g, |
|
112 |
#' titles = "Visualization of Iris Data", |
|
113 |
#' footnotes = "This is a footnote", |
|
114 |
#' progpath = "~/example_prog.R", |
|
115 |
#' outpath = "~/example_grobs2pdf.pdf" |
|
116 |
#' ) |
|
117 |
#' } |
|
118 |
#' |
|
119 |
grobs2pdf <- function(grobs, |
|
120 |
titles, |
|
121 |
footnotes, |
|
122 |
progpath, |
|
123 |
outpath, |
|
124 |
fontsize = 9, |
|
125 |
pagesize = "letter.landscape") { |
|
126 | ! |
if (!requireNamespace("tern", quietly = TRUE)) { |
127 | ! |
stop("This function requires the R package tern to be available - please install the package.") |
128 |
} |
|
129 | ||
130 |
# Loads rapid.base.settings list and a few other |
|
131 | ||
132 |
# Page type (default is letter.landscape, options=a4.portrait, a4.landscape, letter.portrait, letter.landscape) |
|
133 | ! |
if (pagesize == "a4.landscape") { |
134 | ! |
top_margin <- 1.44 |
135 | ! |
bottom_margin <- 0.83 |
136 | ! |
left_margin <- 1.3 |
137 | ! |
right_margin <- 1.32 |
138 | ! |
} else if (pagesize == "a4.portrait") { |
139 | ! |
top_margin <- 1.32 |
140 | ! |
bottom_margin <- 1.3 |
141 | ! |
left_margin <- 1.44 |
142 | ! |
right_margin <- 0.83 |
143 | ! |
} else if (pagesize == "letter.portrait") { |
144 | ! |
top_margin <- 0.95 |
145 | ! |
bottom_margin <- 0.98 |
146 | ! |
left_margin <- 1.5 |
147 | ! |
right_margin <- 1.0 |
148 | ! |
} else if (pagesize == "letter.landscape") { |
149 | ! |
top_margin <- 1.5 |
150 | ! |
bottom_margin <- 1.0 |
151 | ! |
left_margin <- 0.98 |
152 | ! |
right_margin <- 0.95 |
153 |
} else { |
|
154 | ! |
top_margin <- 1.5 |
155 | ! |
bottom_margin <- 1.0 |
156 | ! |
left_margin <- 0.98 |
157 | ! |
right_margin <- 0.95 |
158 |
} |
|
159 | ||
160 | ! |
paper_sizes <- paper_size(pagesize) |
161 | ! |
paper_width <- paper_sizes[1] |
162 | ! |
paper_height <- paper_sizes[2] |
163 | ||
164 |
## Adding log text to footnotes |
|
165 | ! |
log1 <- paste0("Program: ", progpath, "; Output: ", outpath) # nolint |
166 | ! |
log2 <- paste0(format(Sys.time(), "%d%b%Y %H:%M %Z"), ", generated by ", Sys.getenv("USER")) # nolint |
167 | ! |
logtext <- paste(mget(ls(pattern = "log")), collapse = "\n") |
168 | ||
169 |
## Make the grobs |
|
170 | ! |
if (!is.list(grobs)) { |
171 | ! |
grobs <- list(grobs) |
172 |
} |
|
173 | ||
174 |
## Decorate grobs |
|
175 | ! |
dg <- tern::decorate_grob_set( |
176 | ! |
grobs = grobs, |
177 | ! |
titles = titles, |
178 | ! |
footnotes = paste(footnotes, logtext, sep = "\n\n"), |
179 | ! |
outer_margins = grid::unit(c(0, 0, 0, 0), "lines"), |
180 | ! |
padding = grid::unit(0.5, "lines"), |
181 | ! |
gp_titles = grid::gpar(fontsize = fontsize + 1, fontface = 2, lineheight = 1), |
182 | ! |
gp_footnotes = grid::gpar(fontsize = fontsize - 1, fontface = 1, lineheight = 1), |
183 | ! |
gp = grid::gpar(fontsize = fontsize), |
184 | ! |
vp = grid::viewport( |
185 | ! |
x = grid::unit(left_margin, "inches"), |
186 | ! |
y = grid::unit(bottom_margin, "inches"), |
187 | ! |
width = grid::unit(paper_width - left_margin - right_margin, "inches"), |
188 | ! |
height = grid::unit(paper_height - top_margin - bottom_margin, "inches"), |
189 | ! |
just = c("left", "bottom"), |
190 | ! |
name = "OuterMargin" |
191 |
) |
|
192 |
) |
|
193 | ||
194 |
# Output as PDF |
|
195 | ! |
as_pdf( |
196 | ! |
grobs = dg, |
197 | ! |
outpath = outpath, |
198 | ! |
pagesize = pagesize |
199 |
) |
|
200 |
} |
|
201 | ||
202 |
#' Extract specific part of a `ggplot` or grob |
|
203 |
#' |
|
204 |
#' @param gplot_grob `ggplot` or grob object |
|
205 |
#' @param part name of the part to be extracted. `NA` will return `zeroGrob()` |
|
206 |
#' |
|
207 |
grob_part <- function(gplot_grob, part) { |
|
208 |
if (is.na(part)) { |
|
209 |
return(zeroGrob()) |
|
210 |
} |
|
211 |
stopifnot(length(part) == 1 && is.character(part)) |
|
212 |
index <- match(part, gplot_grob$layout$name) |
|
213 |
if (is.na(index)) { |
|
214 |
stop(c( |
|
215 |
part, " not in plot object. Allowed parts are ", |
|
216 |
paste(gplot_grob$layout$name, collapse = ", ") |
|
217 |
)) |
|
218 |
} |
|
219 |
grob <- gplot_grob$grobs[[index]] |
|
220 |
return(grob) |
|
221 |
} |
|
222 | ||
223 |
#' Add padding to grob |
|
224 |
#' @param grob grob object |
|
225 |
#' @param pad_v padding to add vertically |
|
226 |
#' @param pad_h padding to add horizontally |
|
227 |
#' @keywords internal |
|
228 |
#' |
|
229 |
grob_add_padding <- function(grob, pad_v = grid::unit(5, "pt"), pad_h = grid::unit(5, "pt")) { |
|
230 | ! |
ret <- gtable::gtable( |
231 | ! |
heights = grid::unit.c(pad_v, grid::unit(1, "null"), pad_v), |
232 | ! |
widths = grid::unit.c(pad_h, grid::unit(1, "null"), pad_h) |
233 |
) |
|
234 |
# t, b, l, r, z arguments do not need modification |
|
235 |
# same effect can be achieved by modifying pad_v and pad_h |
|
236 | ! |
ret <- gtable::gtable_add_grob(ret, grob, t = 2, b = 2, l = 2, r = 2, z = 1, name = "panel") |
237 | ! |
ret <- gtable::gtable_add_grob(ret, grid::rectGrob(), t = 1, b = 3, l = 1, r = 3, z = 0, name = "background") |
238 | ! |
return(ret) |
239 |
} |
|
240 | ||
241 |
#' this theme is used across many figures. can be safely removed if update the theme in each function |
|
242 |
#' @param axis_side axis position |
|
243 |
#' @param fontsize font size in 'mm' |
|
244 |
#' @keywords internal |
|
245 |
#' |
|
246 |
theme_osprey <- function(axis_side = "left", fontsize = 4) { |
|
247 |
theme( |
|
248 |
panel.background = element_rect(fill = "white", colour = "white"), |
|
249 |
panel.grid.major.y = element_line(colour = "grey50", linetype = 2), |
|
250 |
panel.border = element_rect(colour = "black", fill = NA, size = 1), |
|
251 |
axis.title = element_blank(), |
|
252 |
legend.title = element_blank(), |
|
253 |
legend.position = "bottom", |
|
254 |
axis.ticks.y = element_blank(), |
|
255 |
axis.text = element_text(color = "black", size = fontsize * .pt), |
|
256 |
axis.text.y = element_text(hjust = ifelse(axis_side == "left", 1, 0)), |
|
257 |
text = element_text(size = fontsize * .pt, face = "bold", color = "black"), |
|
258 |
legend.text = element_text(size = fontsize * .pt), |
|
259 |
plot.title = element_text(hjust = 0.5) |
|
260 |
) |
|
261 |
} |
|
262 | ||
263 |
check_same_N <- function(..., omit_null = TRUE) { # nolint |
|
264 | ! |
dots <- list(...) |
265 | ||
266 | ! |
n_list <- Map( |
267 | ! |
function(x, name) { |
268 | ! |
if (is.null(x)) { |
269 | ! |
if (omit_null) { |
270 | ! |
NA_integer_ |
271 |
} else { |
|
272 | ! |
stop("arg", name, "is not supposed to be NULL") |
273 |
} |
|
274 | ! |
} else if (is.data.frame(x)) { |
275 | ! |
nrow(x) |
276 | ! |
} else if (is.atomic(x)) { |
277 | ! |
length(x) |
278 |
} else { |
|
279 | ! |
stop("data structure for ", name, "is currently not supported") |
280 |
} |
|
281 |
}, |
|
282 | ! |
dots, names(dots) |
283 |
) |
|
284 | ||
285 | ! |
n <- stats::na.omit(unlist(n_list)) |
286 | ||
287 | ! |
if (length(unique(n)) > 1) { |
288 | ! |
sel <- which(n != n[1]) |
289 | ! |
stop("dimension mismatch:", paste(names(n)[sel], collapse = ", "), " do not have N=", n[1]) |
290 |
} |
|
291 | ||
292 | ! |
TRUE |
293 |
} |
|
294 | ||
295 |
to_n <- function(x, n) { |
|
296 | ! |
if (is.null(x)) { |
297 | ! |
NULL |
298 | ! |
} else if (length(x) == 1) { |
299 | ! |
rep(x, n) |
300 | ! |
} else if (length(x) == n) { |
301 | ! |
x |
302 |
} else { |
|
303 | ! |
stop("dimension mismatch") |
304 |
} |
|
305 |
} |
|
306 | ||
307 |
#' Extract specific part of a `ggplot` or grob |
|
308 |
#' |
|
309 |
#' @param gplot_grob `ggplot` or grob object |
|
310 |
#' @param part name of the part to be extracted. `NA` will return `zeroGrob()` |
|
311 |
#' @keywords internal |
|
312 |
#' |
|
313 |
grob_part <- function(gplot_grob, part) { |
|
314 | ! |
if (is.na(part)) { |
315 | ! |
return(zeroGrob()) |
316 |
} |
|
317 | ! |
stopifnot(length(part) == 1 && is.character(part)) |
318 | ! |
index <- match(part, gplot_grob$layout$name) |
319 | ! |
if (is.na(index)) { |
320 | ! |
stop(c( |
321 | ! |
part, " not in plot object. Allowed parts are ", |
322 | ! |
paste(gplot_grob$layout$name, collapse = ", ") |
323 |
)) |
|
324 |
} |
|
325 | ! |
grob <- gplot_grob$grobs[[index]] |
326 | ||
327 | ! |
return(grob) |
328 |
} |
|
329 | ||
330 |
#' Extract specific parts of a `ggplot` or grob |
|
331 |
#' |
|
332 |
#' @param gplot `ggplot` or grob object |
|
333 |
#' @param parts names vector of the parts to be extracted. |
|
334 |
#' @keywords internal |
|
335 |
#' |
|
336 |
grob_parts <- function(gplot, parts) { |
|
337 | ! |
stopifnot("gplot must inherit from class 'ggplot' or 'grob'" = inherits(gplot, c("ggplot", "grob"))) |
338 | ||
339 | ! |
if (is(gplot, "ggplot")) { |
340 | ! |
gplot_grob <- ggplotGrob(gplot) |
341 | ! |
} else if (is(gplot, "grob")) { |
342 | ! |
gplot_grob <- gplot |
343 |
} |
|
344 | ! |
ret <- lapply(parts, grob_part, gplot = gplot_grob) |
345 | ! |
names(ret) <- parts |
346 | ! |
return(ret) |
347 |
} |
|
348 | ||
349 | ||
350 |
#' this theme is used across many figures. can be safely removed if update the theme in each function |
|
351 |
#' @param axis_side axis position |
|
352 |
#' @param fontsize font size in 'mm' |
|
353 |
#' @param blank whether to have blank or background with grids and borders |
|
354 |
theme_osprey <- function(axis_side = "left", fontsize = 4, blank = FALSE) { |
|
355 | ! |
theme( |
356 | ! |
panel.background = element_rect(fill = "white", colour = "white"), |
357 | ! |
panel.grid.major.y = if (blank) element_blank() else element_line(colour = "grey50", linetype = 2), |
358 | ! |
panel.border = if (blank) element_blank() else element_rect(colour = "black", fill = NA, size = 1), |
359 | ! |
axis.title = element_blank(), |
360 | ! |
legend.title = element_blank(), |
361 | ! |
legend.position = "bottom", |
362 | ! |
axis.ticks.y = element_blank(), |
363 | ! |
axis.ticks.x.top = element_blank(), |
364 | ! |
axis.text = element_text(color = "black", size = fontsize * .pt), |
365 | ! |
axis.text.y = element_text(hjust = ifelse(axis_side == "left", 0, 1)), |
366 | ! |
text = element_text(size = fontsize * .pt, face = "bold", color = "black"), |
367 | ! |
legend.text = element_text(size = fontsize * .pt), |
368 | ! |
plot.title = element_text(hjust = 0.5) |
369 |
) |
|
370 |
} |
1 |
#' Butterfly Plot |
|
2 |
#' |
|
3 |
#' The butterfly plot is often used in Early Development (ED) and is an opposed |
|
4 |
#' barplot that shows instances of `AE`s or # of patients by category separated by |
|
5 |
#' a dichotomization variable. Each bar can be color coded according |
|
6 |
#' to a variable of choice and sorted according to either alphabetical order or the |
|
7 |
#' maximum count. |
|
8 |
#' |
|
9 |
#' @param category vector of y values |
|
10 |
#' @param right_flag vector of \code{logical} of the same length as \code{category}. |
|
11 |
#' used to filter \code{category} for the right side of the barplot. |
|
12 |
#' to maintain backward compatibility, a vector of 1s and 0s would also work. |
|
13 |
#' @param left_flag vector of \code{logical} of the same length as \code{category}. |
|
14 |
#' used to filter \code{category} for the left side of the barplot. |
|
15 |
#' to maintain backward compatibility, a vector of 1s and 0s would also work. |
|
16 |
#' @param group_names string vector of length 2 with desired names of dichotomization variables |
|
17 |
#' required format : first name corresponds to the name of the right side |
|
18 |
#' second name corresponds to name of the left side |
|
19 |
#' default: will extract column names from group |
|
20 |
#' @param block_count string - what to count by (ex: # of `AE`s or # of patients) |
|
21 |
#' @param block_color vector - color coding of bar segments |
|
22 |
#' @param id unique subject identifier variable. |
|
23 |
#' @param facet_rows vector defines what variable is used to split the |
|
24 |
#' plot into rows, default here is NULL |
|
25 |
#' @param x_label string of text for x axis label, default is block_count |
|
26 |
#' @param y_label string of text for y axis label, default is `AE` Derived Terms |
|
27 |
#' @param legend_label \code{character} for legend label, default is `"AETOXGR"` |
|
28 |
#' @param sort_by character string that defines the ordering of the class and term |
|
29 |
#' variables in the output table, |
|
30 |
#' options: `"alphabetical"`, `"count"`, `"left"`, `"right"`, default here is set to `"count"` |
|
31 |
#' @param show_legend `logical(1)` of whether color coding legend is included, |
|
32 |
#' default here is FALSE |
|
33 |
#' |
|
34 |
#' @details there is no equivalent STREAM output |
|
35 |
#' |
|
36 |
#' @return `ggplot` object |
|
37 |
#' |
|
38 |
#' @export |
|
39 |
#' |
|
40 |
#' @template author_zhanc107 |
|
41 |
#' @template author_qit3 |
|
42 |
#' |
|
43 |
#' @examples |
|
44 |
#' library(dplyr) |
|
45 |
#' library(nestcolor) |
|
46 |
#' |
|
47 |
#' ADSL <- osprey::rADSL %>% |
|
48 |
#' select(USUBJID, STUDYID, SEX, ARM, RACE) %>% |
|
49 |
#' dplyr::filter(SEX %in% c("F", "M")) |
|
50 |
#' ADAE <- osprey::rADAE %>% select(USUBJID, STUDYID, AEBODSYS, AETOXGR) |
|
51 |
#' |
|
52 |
#' ANL <- left_join(ADAE, ADSL, by = c("STUDYID", "USUBJID")) |
|
53 |
#' ANL <- ANL %>% |
|
54 |
#' dplyr::mutate(flag1 = ifelse(RACE == "ASIAN", 1, 0)) %>% |
|
55 |
#' dplyr::mutate(flag2 = ifelse(SEX == "M", 1, 0)) |
|
56 |
#' ANL <- na.omit(ANL) |
|
57 |
#' # Example 1, # of AEs |
|
58 |
#' g_butterfly( |
|
59 |
#' category = ANL$AEBODSYS, |
|
60 |
#' right_flag = ANL$flag1, |
|
61 |
#' left_flag = ANL$flag2, |
|
62 |
#' group_names = c("flag1 Asian", "flag2 M"), |
|
63 |
#' block_count = "# of AEs", |
|
64 |
#' block_color = ANL$AETOXGR, |
|
65 |
#' id = ANL$USUBJID, |
|
66 |
#' x_label = "# of AEs", |
|
67 |
#' y_label = "AE Body System", |
|
68 |
#' legend_label = "AETOXGR", |
|
69 |
#' sort_by = "count", |
|
70 |
#' show_legend = TRUE |
|
71 |
#' ) |
|
72 |
#' |
|
73 |
#' # Example 2, # of patients with facet |
|
74 |
#' g_butterfly( |
|
75 |
#' category = ANL$AEBODSYS, |
|
76 |
#' right_flag = ANL$flag1, |
|
77 |
#' left_flag = ANL$flag2, |
|
78 |
#' group_names = c("flag1 Asian", "flag2 M"), |
|
79 |
#' block_count = "# of patients", |
|
80 |
#' block_color = ANL$AETOXGR, |
|
81 |
#' facet_rows = ANL$ARM, |
|
82 |
#' id = ANL$USUBJID, |
|
83 |
#' x_label = "# of patients", |
|
84 |
#' y_label = "AE Derived Terms", |
|
85 |
#' legend_label = "AETOXGR", |
|
86 |
#' sort_by = "count", |
|
87 |
#' show_legend = TRUE |
|
88 |
#' ) |
|
89 |
g_butterfly <- function(category, |
|
90 |
right_flag, |
|
91 |
left_flag, |
|
92 |
id = NULL, |
|
93 |
group_names = NULL, |
|
94 |
block_count = c("# of patients", "# of AEs"), |
|
95 |
block_color = NULL, |
|
96 |
facet_rows = NULL, |
|
97 |
x_label = block_count, |
|
98 |
y_label = "AE Derived Terms", |
|
99 |
legend_label = "AETOXGR", |
|
100 |
sort_by = c("count", "alphabetical", "right", "left"), |
|
101 |
show_legend = TRUE) { |
|
102 | ! |
stopifnot( |
103 | ! |
"invalid arguments: check that the length of input arguments are identical" = |
104 | ! |
length(category) == length(right_flag) && length(right_flag) == length(left_flag) |
105 |
) |
|
106 | ! |
stopifnot( |
107 | ! |
"invalid arguments: right_flag or left_flag contains values other than 1/TRUE or 0/FALSE" = |
108 | ! |
all(union(right_flag, left_flag) %in% c(1, 0)) |
109 |
) |
|
110 | ! |
stopifnot( |
111 | ! |
"invalid arguments: right_flag and left_flag contain only 0/FALSE values" = |
112 | ! |
any(union(right_flag, left_flag) == 1) |
113 |
) |
|
114 | ! |
stopifnot( |
115 | ! |
"invalid arguments: check that the length of block_color is equal as other inputs" = |
116 | ! |
is.null(block_color) || length(block_color) == length(category) |
117 |
) |
|
118 | ! |
block_count <- match.arg(block_count) |
119 | ! |
checkmate::assert_character(id, null.ok = isFALSE(block_count == "# of patients")) |
120 | ||
121 | ! |
stopifnot( |
122 | ! |
"invalid arguments: check that the length of block_color is equal as other inputs" = |
123 | ! |
is.null(id) || length(id) == length(category) |
124 |
) |
|
125 | ! |
stopifnot( |
126 | ! |
"invalid arguments: check that the length of block_color is equal as other inputs" = |
127 | ! |
is.null(facet_rows) || |
128 | ! |
(length(facet_rows) == length(category)) || |
129 | ! |
(is.data.frame(facet_rows) && nrow(facet_rows) == length(category)) |
130 |
) |
|
131 | ! |
checkmate::assert_string(x_label) |
132 | ! |
checkmate::assert_string(y_label) |
133 | ! |
checkmate::assert_string(legend_label) |
134 | ! |
sort_by <- match.arg(sort_by) |
135 | ||
136 |
# set up data------- |
|
137 | ! |
dat <- data.frame(y = stringr::str_wrap(category, width = 30), r_flag = right_flag, l_flag = left_flag) |
138 | ||
139 | ! |
groups <- "y" |
140 | ||
141 | ! |
if (!is.null(id)) { |
142 | ! |
dat$id <- id |
143 |
} |
|
144 | ! |
if (!is.null(facet_rows)) { |
145 | ! |
facet_rows <- interaction(facet_rows) |
146 | ! |
dat$f_rows <- facet_rows |
147 | ! |
groups <- c(groups, "f_rows") |
148 |
} |
|
149 | ! |
if (!is.null(block_color)) { |
150 | ! |
dat$bar_color <- block_color |
151 | ! |
groups <- c(groups, "bar_color") |
152 |
} |
|
153 | ||
154 | ! |
get_counts <- function(.data, block_count) { |
155 | ! |
if (block_count == "# of patients") { |
156 | ! |
length(unique(.data$id)) |
157 | ! |
} else if (block_count == "# of AEs") { |
158 | ! |
n() |
159 |
} |
|
160 |
} |
|
161 | ! |
highest_grade <- function(.data, block_count) { |
162 | ! |
if (block_count == "# of patients" && "bar_color" %in% colnames(.data)) { |
163 | ! |
.data %>% |
164 | ! |
dplyr::group_by(.data$y, .data$id) %>% |
165 | ! |
dplyr::filter(.data$bar_color == sort(.data$bar_color, decreasing = TRUE)[1]) |
166 |
} else { |
|
167 | ! |
.data |
168 |
} |
|
169 |
} |
|
170 | ||
171 | ! |
counts_r <- dat %>% |
172 | ! |
dplyr::filter(.data$r_flag == 1) %>% |
173 | ! |
highest_grade(block_count) %>% |
174 | ! |
dplyr::group_by_at(groups) %>% |
175 | ! |
dplyr::summarize(n_i = get_counts(.data, block_count)) %>% |
176 | ! |
dplyr::group_by_at(setdiff(groups, "bar_color")) %>% |
177 | ! |
dplyr::mutate(label_ypos = rev(cumsum(rev(.data$n_i)))) |
178 | ||
179 | ! |
counts_l <- dat %>% |
180 | ! |
filter(.data$l_flag == 1) %>% |
181 | ! |
highest_grade(block_count) %>% |
182 | ! |
dplyr::group_by_at(groups) %>% |
183 | ! |
dplyr::summarize(n_i = get_counts(.data, block_count)) %>% |
184 | ! |
dplyr::group_by_at(setdiff(groups, "bar_color")) %>% |
185 | ! |
dplyr::mutate(label_ypos = rev(cumsum(rev(.data$n_i)))) |
186 | ||
187 | ! |
total_label_pos_r <- counts_r %>% |
188 | ! |
dplyr::group_by_at(setdiff(groups, "bar_color")) %>% |
189 | ! |
dplyr::summarize(label_ypos = max(.data$label_ypos)) |
190 | ||
191 | ! |
total_label_pos_l <- counts_l %>% |
192 | ! |
dplyr::group_by_at(setdiff(groups, "bar_color")) %>% |
193 | ! |
dplyr::summarize(label_ypos = max(.data$label_ypos)) |
194 | ||
195 | ! |
total_text_ann_r <- dat %>% |
196 | ! |
dplyr::filter(.data$r_flag == 1) %>% |
197 | ! |
dplyr::group_by_at(setdiff(groups, "bar_color")) %>% |
198 | ! |
dplyr::summarize(n = get_counts(.data, block_count)) %>% |
199 | ! |
dplyr::left_join(total_label_pos_r, by = setdiff(groups, "bar_color")) |
200 | ||
201 | ! |
total_text_ann_l <- dat %>% |
202 | ! |
dplyr::filter(.data$l_flag == 1) %>% |
203 | ! |
dplyr::group_by_at(setdiff(groups, "bar_color")) %>% |
204 | ! |
dplyr::summarize(n = get_counts(.data, block_count)) %>% |
205 | ! |
dplyr::left_join(total_label_pos_l, by = setdiff(groups, "bar_color")) |
206 | ||
207 | ||
208 | ! |
if (sort_by == "alphabetical") { |
209 | ! |
levels_all <- unique(sort(as.character(union(counts_l$y, counts_r$y)), decreasing = TRUE)) |
210 | ! |
counts_r$y <- factor(counts_r$y, levels = levels_all) |
211 | ! |
counts_l$y <- factor(counts_l$y, levels = levels_all) |
212 | ! |
} else if (sort_by == "count") { |
213 | ! |
tot <- dplyr::bind_rows(total_text_ann_r, total_text_ann_l) %>% |
214 | ! |
dplyr::group_by(.data$y) %>% |
215 | ! |
dplyr::summarize(n = sum(n)) %>% |
216 | ! |
dplyr::arrange(n) |
217 | ||
218 | ! |
counts_r$y <- factor(counts_r$y, levels = tot$y) |
219 | ! |
counts_l$y <- factor(counts_l$y, levels = tot$y) |
220 | ! |
} else if (sort_by == "right") { |
221 | ! |
tot <- dplyr::full_join(total_text_ann_r, select(total_text_ann_l, -n), by = "y") %>% |
222 | ! |
dplyr::group_by(.data$y) %>% |
223 | ! |
dplyr::summarize(n = sum(n, na.rm = TRUE)) %>% |
224 | ! |
dplyr::arrange(n) |
225 | ||
226 | ! |
counts_r$y <- factor(counts_r$y, levels = tot$y) |
227 | ! |
counts_l$y <- factor(counts_l$y, levels = tot$y) |
228 | ! |
} else if (sort_by == "left") { |
229 | ! |
tot <- dplyr::full_join(total_text_ann_l, select(total_text_ann_r, -n), by = "y") %>% |
230 | ! |
dplyr::group_by(.data$y) %>% |
231 | ! |
dplyr::summarize(n = sum(n, na.rm = TRUE)) %>% |
232 | ! |
dplyr::arrange(n) |
233 | ||
234 | ! |
counts_r$y <- factor(counts_r$y, levels = tot$y) |
235 | ! |
counts_l$y <- factor(counts_l$y, levels = tot$y) |
236 |
} |
|
237 | ||
238 | ! |
max_c <- max(c(total_text_ann_r$label_ypos, total_text_ann_l$label_ypos)) |
239 | ||
240 | ! |
if (is.null(group_names)) { |
241 | ! |
g_r <- "" |
242 | ! |
g_l <- "" |
243 |
} else { |
|
244 | ! |
g_r <- group_names[1] |
245 | ! |
g_l <- group_names[2] |
246 |
} |
|
247 | ||
248 |
# plot butterfly plot -------------------- |
|
249 | ! |
if (!is.null(block_color)) { |
250 | ! |
pl <- ggplot(NULL, aes_string(x = "y")) + |
251 | ! |
geom_bar(data = counts_r, aes_string(y = "n_i", fill = "bar_color"), stat = "identity") + |
252 | ! |
geom_bar(data = counts_l, aes_string(y = "-n_i", fill = "bar_color"), stat = "identity") + |
253 | ! |
geom_text(data = counts_r, aes_string(y = "label_ypos", label = "n_i"), hjust = 0.9) + |
254 | ! |
geom_text(data = counts_l, aes_string(y = "-label_ypos", label = "n_i"), hjust = -0.9) + |
255 | ! |
geom_text(data = total_text_ann_r, aes_string(y = "label_ypos", label = "n"), fontface = "bold", hjust = -1) + |
256 | ! |
geom_text( |
257 | ! |
data = total_text_ann_l, aes_string(y = "-label_ypos - 0.4", label = "n"), |
258 | ! |
fontface = "bold", hjust = 0.9 |
259 |
) + |
|
260 | ! |
geom_hline(yintercept = 0, colour = "black", lwd = 0.4) + |
261 | ! |
coord_flip() + |
262 | ! |
scale_y_continuous(labels = abs, limits = (max_c * 1.2) * c(-1, 1)) + |
263 | ! |
labs(x = y_label, y = block_count, fill = legend_label) |
264 |
} else { |
|
265 | ! |
pl <- ggplot(NULL, aes_string(x = "y")) + |
266 | ! |
geom_bar(data = counts_r, aes_string(y = "n_i"), stat = "identity") + |
267 | ! |
geom_bar(data = counts_l, aes_string(y = "-n_i"), stat = "identity") + |
268 | ! |
geom_hline(yintercept = 0, colour = "black", lwd = 0.4) + |
269 | ! |
geom_text(data = total_text_ann_r, aes_string(y = "label_ypos", label = "n"), fontface = "bold", hjust = -1) + |
270 | ! |
geom_text( |
271 | ! |
data = total_text_ann_l, aes_string(y = "-label_ypos - 0.4", label = "n"), |
272 | ! |
fontface = "bold", hjust = 0.9 |
273 |
) + |
|
274 | ! |
coord_flip() + |
275 | ! |
scale_y_continuous(labels = abs, limits = (max_c * 1.2) * c(-1, 1)) + |
276 | ! |
labs(x = y_label, y = block_count, fill = legend_label) |
277 |
} |
|
278 | ||
279 | ! |
if (!is.null(facet_rows)) { |
280 | ! |
pl <- pl + facet_wrap(~f_rows, ncol = 1) |
281 |
} |
|
282 | ||
283 | ! |
pl <- pl + |
284 | ! |
theme_bw() + |
285 | ! |
theme( |
286 | ! |
strip.background = element_rect(colour = "white", fill = "white"), |
287 | ! |
strip.text.x = element_text(color = "black", size = 14), |
288 | ! |
title = element_text(size = 9), |
289 | ! |
axis.title = element_text(size = 20), |
290 | ! |
axis.text = element_text(color = "black", size = 9), |
291 | ! |
legend.text = element_text(size = 9), |
292 | ! |
legend.title = element_text(size = 9), |
293 | ! |
panel.grid.major.y = element_line(colour = "gray", linetype = "dotted"), |
294 | ! |
plot.margin = grid::unit(c(1.5, 1, 1, 1), "cm"), |
295 | ! |
legend.position = if (show_legend) "right" else "none" |
296 |
) + |
|
297 | ! |
scale_x_discrete(limits = levels(counts_r$y)) |
298 | ||
299 |
# labs pl <- pl + labs(title = stringr::str_wrap(g2, width = 30)) |
|
300 | ! |
g_0 <- ggplotGrob(pl) |
301 | ||
302 | ! |
g_1 <- gtable::gtable_add_grob( |
303 | ! |
g_0, |
304 | ! |
grid::grid.text( |
305 | ! |
stringr::str_wrap(g_r, width = 30), |
306 | ! |
x = 1, just = "center", hjust = 1, gp = grid::gpar(fontsize = 11) |
307 |
), |
|
308 | ! |
t = 1.5, l = g_0$layout[grep("axis-r", g_0$layout$name)[1], 2], b = 3, name = "right-title", clip = "off" |
309 |
) |
|
310 | ! |
g_2 <- gtable::gtable_add_grob( |
311 | ! |
g_1, |
312 | ! |
grid::grid.text( |
313 | ! |
stringr::str_wrap(g_l, width = 30), |
314 | ! |
x = 1, just = "center", hjust = 0, gp = grid::gpar(fontsize = 11) |
315 |
), |
|
316 | ! |
t = 1.5, l = g_0$layout[grep("axis-l", g_0$layout$name)[1], 2], b = 3, name = "left-title", clip = "off" |
317 |
) |
|
318 | ! |
grid::grid.draw(g_2) |
319 | ! |
invisible(g_2) |
320 |
} |
1 |
#' Adverse Event Category Plot |
|
2 |
#' |
|
3 |
#' Draw adverse event category plot. |
|
4 |
#' @inheritParams argument_convention |
|
5 |
#' @param id (`vector`)\cr contains subject identifier. Usually it is \code{ADAE$USUBJID}. |
|
6 |
#' @param arm_sl (`vector`)\cr contains the subject level treatment variable. |
|
7 |
#' For example, \code{ADSL$ACTARM}. |
|
8 |
#' @param subgroups (`data.frame`)\cr Variables to conduct analysis. |
|
9 |
#' @param subgroups_sl (`data.frame`)\cr Subject level variables to conduct analysis. |
|
10 |
#' Usually from `ADSL`. |
|
11 |
#' @param ref (`character`)\cr indicates the name of the reference arm. Default is the first |
|
12 |
#' level of \code{arm}. |
|
13 |
#' @param trt (`character`)\cr indicates the name of the treatment arm. Default is the second |
|
14 |
#' level of \code{arm}. |
|
15 |
#' @param indent (`numeric`)\cr non-negative integer where 0 means that the subgroup levels should not be indented |
|
16 |
#' @param subgroups_levels (`list`)\cr A nested named list of variables to conduct analysis. |
|
17 |
#' The names of the nested lists are used to show as the label. |
|
18 |
#' The children lists should start with "Total" = variable label, |
|
19 |
#' followed by labels for each level of said variable. See example for reference. |
|
20 |
#' @param xmax (`numeric`)\cr maximum range for the x-axis. |
|
21 |
#' x-axis range will be automatically assigned based on risk output when `xmax` is less than or equal to 0. |
|
22 |
#' `xmax` is 0 by default |
|
23 |
#' @param arm_n (`logical`)\cr whether to display the N in each arm. |
|
24 |
#' |
|
25 |
#' @author Liming Li (Lil128) \email{liming.li@roche.com} |
|
26 |
#' |
|
27 |
#' @details there is no equivalent STREAM output |
|
28 |
#' |
|
29 |
#' @return grob object |
|
30 |
#' |
|
31 |
#' @export |
|
32 |
#' |
|
33 |
#' @examples |
|
34 |
#' library(grid) |
|
35 |
#' ADAE <- osprey::rADAE |
|
36 |
#' ADSL <- osprey::rADSL |
|
37 |
#' |
|
38 |
#' id <- ADAE$USUBJID |
|
39 |
#' arm <- ADAE$ACTARMCD |
|
40 |
#' arm_sl <- as.character(ADSL$ACTARMCD) |
|
41 |
#' subgroups_sl <- ADSL[, c("SEX", "RACE", "STRATA1")] |
|
42 |
#' subgroups <- ADAE[, c("SEX", "RACE", "STRATA1")] |
|
43 |
#' subgroups_levels <- list( |
|
44 |
#' RACE = list( |
|
45 |
#' "Total" = "Race", |
|
46 |
#' "AMERICAN INDIAN OR ALASKA NATIVE" = "American", |
|
47 |
#' "WHITE" = "White", |
|
48 |
#' "ASIAN" = "Asian", |
|
49 |
#' "BLACK OR AFRICAN AMERICAN" = "African" |
|
50 |
#' ), |
|
51 |
#' STRATA1 = list( |
|
52 |
#' "Total" = "Strata", |
|
53 |
#' "A" = "TypeA", |
|
54 |
#' "B" = "TypeB", |
|
55 |
#' "C" = "Typec" |
|
56 |
#' ), |
|
57 |
#' SEX = list( |
|
58 |
#' "Total" = "Sex", |
|
59 |
#' "M" = "Male", |
|
60 |
#' "F" = "Female" |
|
61 |
#' ) |
|
62 |
#' ) |
|
63 |
#' # Example 1 |
|
64 |
#' p1 <- g_ae_sub(id, |
|
65 |
#' arm, |
|
66 |
#' arm_sl, |
|
67 |
#' subgroups, |
|
68 |
#' subgroups_sl, |
|
69 |
#' trt = "ARM A", |
|
70 |
#' ref = "ARM C", |
|
71 |
#' subgroups_levels = subgroups_levels, |
|
72 |
#' arm_n = FALSE |
|
73 |
#' ) |
|
74 |
#' grid::grid.newpage() |
|
75 |
#' |
|
76 |
#' # Example 2: display number of patients in each arm |
|
77 |
#' p2 <- g_ae_sub(id, |
|
78 |
#' arm, |
|
79 |
#' arm_sl, |
|
80 |
#' subgroups, |
|
81 |
#' subgroups_sl, |
|
82 |
#' trt = "ARM A", |
|
83 |
#' ref = "ARM C", |
|
84 |
#' subgroups_levels = subgroups_levels, |
|
85 |
#' arm_n = TRUE |
|
86 |
#' ) |
|
87 |
#' grid::grid.newpage() |
|
88 |
#' |
|
89 |
#' # Example 3: preprocess data to only include treatment and control arm patients |
|
90 |
#' trt <- "ARM A" |
|
91 |
#' ref <- "ARM C" |
|
92 |
#' ADAE <- osprey::rADAE |
|
93 |
#' ADSL <- osprey::rADSL %>% filter(ACTARMCD %in% c(trt, ref)) |
|
94 |
#' id <- ADAE$USUBJID |
|
95 |
#' arm <- ADAE$ACTARMCD |
|
96 |
#' arm_sl <- as.character(ADSL$ACTARMCD) |
|
97 |
#' subgroups_sl <- ADSL[, c("SEX", "RACE", "STRATA1")] |
|
98 |
#' subgroups <- ADAE[, c("SEX", "RACE", "STRATA1")] |
|
99 |
#' subgroups_levels <- list( |
|
100 |
#' RACE = list( |
|
101 |
#' "Total" = "Race", |
|
102 |
#' "AMERICAN INDIAN OR ALASKA NATIVE" = "American", |
|
103 |
#' "WHITE" = "White", |
|
104 |
#' "ASIAN" = "Asian", |
|
105 |
#' "BLACK OR AFRICAN AMERICAN" = "African" |
|
106 |
#' ), |
|
107 |
#' STRATA1 = list( |
|
108 |
#' "Total" = "Strata", |
|
109 |
#' "A" = "TypeA", |
|
110 |
#' "B" = "TypeB", |
|
111 |
#' "C" = "Typec" |
|
112 |
#' ), |
|
113 |
#' SEX = list( |
|
114 |
#' "Total" = "Sex", |
|
115 |
#' "M" = "Male", |
|
116 |
#' "F" = "Female" |
|
117 |
#' ) |
|
118 |
#' ) |
|
119 |
#' p3 <- g_ae_sub(id, |
|
120 |
#' arm, |
|
121 |
#' arm_sl, |
|
122 |
#' subgroups, |
|
123 |
#' subgroups_sl, |
|
124 |
#' trt, |
|
125 |
#' ref, |
|
126 |
#' subgroups_levels = subgroups_levels, |
|
127 |
#' arm_n = FALSE |
|
128 |
#' ) |
|
129 |
g_ae_sub <- function(id, |
|
130 |
arm, |
|
131 |
arm_sl, |
|
132 |
subgroups, |
|
133 |
subgroups_sl, |
|
134 |
trt = levels(arm)[1], |
|
135 |
ref = levels(arm)[2], |
|
136 |
indent = 4, |
|
137 |
subgroups_levels = NULL, |
|
138 |
xmax = 0, |
|
139 |
conf_level = 0.95, |
|
140 |
diff_ci_method = c( |
|
141 |
"wald", "waldcc", "ac", "score", "scorecc", |
|
142 |
"mn", "mee", "blj", "ha", "beal" |
|
143 |
), |
|
144 |
fontsize = 4, |
|
145 |
arm_n = FALSE, |
|
146 |
draw = TRUE) { |
|
147 | ! |
diff_ci_method <- match.arg(diff_ci_method) |
148 | ||
149 | ! |
if (!is.null(subgroups_levels)) { |
150 | ! |
labels <- unlist(subgroups_levels) |
151 | ! |
label_df <- |
152 | ! |
tibble( |
153 | ! |
level = stringr::str_replace_all(names(labels), "\\.", "__"), |
154 | ! |
label = labels |
155 |
) %>% |
|
156 | ! |
bind_rows(c(level = "TOTAL__Total", label = "Overall")) %>% |
157 | ! |
mutate( |
158 | ! |
indents = stringr::str_dup(" ", if_else( |
159 | ! |
stringr::str_detect(.data$level, "__Total"), 0, indent |
160 |
)), |
|
161 |
# create label with indents if not total |
|
162 | ! |
label = paste0(.data$indents, .data$label) |
163 |
) |
|
164 |
} |
|
165 | ! |
stopifnot("invalid arguments: check that the length of id and arm are identical" = length(id) == length(arm)) |
166 | ! |
checkmate::assert_character(arm_sl, min.len = 2) |
167 | ! |
stopifnot("invalid arguments: trt and ref need to be from arm" = all(c(trt, ref) %in% unique(arm))) |
168 | ! |
checkmate::assert_number(conf_level, lower = 0.5, upper = 1) |
169 | ! |
checkmate::assert_number(fontsize, lower = 0) |
170 | ! |
checkmate::assert_data_frame(subgroups) |
171 | ! |
stopifnot( |
172 | ! |
"invalid argument: subgroups needs to be a data.frame with nrow = length(arm)" = |
173 | ! |
nrow(subgroups) == length(arm) |
174 |
) |
|
175 | ! |
checkmate::assert_data_frame(subgroups_sl) |
176 | ! |
stopifnot( |
177 | ! |
"invalid argument: subgroups_sl need to be a data.frame with nrow = length(arm_sl)" = |
178 | ! |
nrow(subgroups_sl) == length(arm_sl) |
179 |
) |
|
180 | ! |
checkmate::assert_number(indent, lower = 0, finite = TRUE) |
181 | ! |
checkmate::assert_number(xmax) |
182 | ! |
stopifnot( |
183 | ! |
"invalid argument: please only use the subgroups column names as the lists names in subgroups_levels" = |
184 | ! |
all(names(subgroups_levels) %in% names(lapply(subgroups, levels))) |
185 |
) |
|
186 | ||
187 | ! |
stopifnot( |
188 | ! |
"invalid argument: please only include levels in subgroups columns in the nested subgroups_levels" = |
189 | ! |
all(unlist(lapply(names(subgroups_levels), function(level_name) { |
190 | ! |
all(names(subgroups_levels[[level_name]]) %in% c("Total", levels(subgroups[, level_name] %>% dplyr::pull()))) |
191 |
}))) |
|
192 |
) |
|
193 | ||
194 | ! |
checkmate::assert_flag(arm_n) |
195 | ||
196 | ! |
subgroups <- subgroups %>% |
197 | ! |
mutate_all(as.character) %>% |
198 | ! |
mutate(TOTAL = "Total") |
199 | ||
200 | ! |
arms <- c(trt, ref) |
201 | ! |
xs <- syms(paste("count", arms, sep = "__")) |
202 | ! |
ns <- syms(paste("total", arms, sep = "__")) |
203 | ! |
rs <- syms(paste("risk", arms, sep = "__")) |
204 | ||
205 | ! |
x1 <- xs[[1]] |
206 | ! |
n1 <- ns[[1]] |
207 | ! |
x2 <- xs[[2]] |
208 | ! |
n2 <- ns[[2]] |
209 | ! |
r1 <- rs[[1]] |
210 | ! |
r2 <- rs[[2]] |
211 | ||
212 | ! |
df_ref <- tibble(arm = c(ref, trt)) |
213 | ||
214 |
# a wide data frame contains event counts by arm in each subgroup |
|
215 | ! |
df <- cbind(id = id, arm = arm, subgroups) %>% |
216 | ! |
filter(arm %in% c(ref, trt)) %>% |
217 | ! |
unique() %>% |
218 | ! |
tidyr::pivot_longer( |
219 | ! |
names_to = "strata", |
220 | ! |
cols = colnames(subgroups), |
221 | ! |
values_to = "value" |
222 |
) %>% |
|
223 | ! |
group_by(arm, .data$strata, .data$value) %>% |
224 | ! |
summarise(n = n()) %>% |
225 | ! |
full_join(df_ref, by = "arm") %>% |
226 | ! |
tidyr::replace_na(list(n = 0)) %>% |
227 | ! |
ungroup() %>% |
228 | ! |
tidyr::pivot_wider( |
229 | ! |
id_cols = c("strata", "value"), |
230 | ! |
names_from = "arm", |
231 | ! |
values_from = "n", |
232 | ! |
names_prefix = "count__", |
233 | ! |
values_fill = list(n = 0) |
234 |
) |
|
235 | ||
236 |
# a wide data frame contains total counts by arm in each subgroup |
|
237 | ! |
df_sl <- cbind(arm = arm_sl, subgroups_sl) %>% |
238 | ! |
filter(arm %in% c(ref, trt)) %>% |
239 | ! |
mutate(TOTAL = "Total") %>% |
240 | ! |
tidyr::pivot_longer( |
241 | ! |
names_to = "strata", |
242 | ! |
cols = c(colnames(subgroups_sl), "TOTAL"), |
243 | ! |
values_to = "value" |
244 |
) %>% |
|
245 | ! |
group_by(arm, .data$strata, .data$value) %>% |
246 | ! |
summarise(n = n()) %>% |
247 | ! |
ungroup() %>% |
248 | ! |
tidyr::pivot_wider( |
249 | ! |
id_cols = c("strata", "value"), |
250 | ! |
names_from = "arm", |
251 | ! |
values_from = "n", |
252 | ! |
names_prefix = "total__", |
253 | ! |
values_fill = list(n = 0) |
254 |
) |
|
255 | ||
256 |
# calculate the risk difference and risk difference CI in each subgroup |
|
257 | ! |
df <- df %>% |
258 | ! |
left_join(df_sl, by = c("strata", "value")) %>% |
259 | ! |
group_by(.data$strata, .data$value) %>% |
260 | ! |
mutate( |
261 | ! |
!!r1 := !!x1 / !!n1, |
262 | ! |
!!r2 := !!x2 / !!n2, |
263 | ! |
lower = DescTools::BinomDiffCI( |
264 | ! |
!!x1, !!n1, !!x2, !!n2, |
265 | ! |
conf_level, |
266 | ! |
method = diff_ci_method |
267 | ! |
)[2], |
268 | ! |
upper = DescTools::BinomDiffCI( |
269 | ! |
!!x1, !!n1, !!x2, !!n2, |
270 | ! |
conf_level, |
271 | ! |
method = diff_ci_method |
272 | ! |
)[3], |
273 | ! |
riskdiff = !!r1 - !!r2 |
274 |
) %>% |
|
275 | ! |
tidyr::pivot_longer( |
276 | ! |
matches("__"), |
277 | ! |
names_to = c(".value", "arm"), |
278 | ! |
names_sep = "__" |
279 |
) %>% |
|
280 | ! |
ungroup() %>% |
281 | ! |
tidyr::unite("level", "strata", "value", remove = FALSE, sep = "__") |
282 | ||
283 |
# create label for plotting |
|
284 | ! |
level_format_df <- df %>% |
285 | ! |
select("strata", "value") %>% |
286 | ! |
unique() %>% |
287 | ! |
group_by(.data$strata) %>% |
288 | ! |
summarise(value = paste(c("Total", .data$value), collapse = ",")) %>% |
289 | ! |
tidyr::separate_rows("value", sep = ",") %>% |
290 | ! |
unique() %>% |
291 | ! |
tidyr::unite("level", "strata", "value", sep = "__", remove = FALSE) %>% |
292 | ! |
mutate(order = if_else(.data$strata == "TOTAL", integer(1), -row_number())) %>% |
293 | ! |
arrange(order) |
294 | ||
295 | ! |
if (is.null(subgroups_levels)) { |
296 | ! |
level_format_df <- level_format_df %>% |
297 | ! |
mutate(label = if_else( |
298 | ! |
.data$strata == "TOTAL", |
299 | ! |
"Overall", |
300 | ! |
if_else(.data$value == "Total", .data$strata, paste0(stringr::str_c( |
301 | ! |
rep(" ", indent), |
302 | ! |
collapse = "" |
303 | ! |
), .data$value)) |
304 |
)) |
|
305 |
} else { |
|
306 | ! |
level_format_df <- level_format_df %>% |
307 | ! |
inner_join(label_df, by = "level") |
308 |
} |
|
309 | ||
310 | ! |
df <- df %>% |
311 | ! |
semi_join(level_format_df, by = "level") |
312 | ||
313 | ! |
mytheme <- theme_osprey(fontsize = fontsize, blank = TRUE) |
314 | ||
315 | ! |
y_axis <- |
316 | ! |
scale_y_discrete( |
317 | ! |
limits = level_format_df$level, |
318 | ! |
breaks = level_format_df$level, |
319 | ! |
labels = level_format_df$label |
320 |
) |
|
321 | ||
322 | ! |
df_risk <- df %>% |
323 | ! |
select("level", "lower", "upper", "riskdiff") %>% |
324 | ! |
unique() |
325 | ! |
if (xmax <= 0) { |
326 | ! |
xmax <- max(abs(df_risk$upper), abs(df_risk$lower), na.rm = TRUE) |
327 |
} |
|
328 | ! |
p1 <- |
329 | ! |
ggplot(df_risk) + |
330 | ! |
geom_point( |
331 | ! |
aes(x = .data$riskdiff, y = .data$level), |
332 | ! |
size = fontsize |
333 |
) + |
|
334 | ! |
geom_vline( |
335 | ! |
data = NULL, |
336 | ! |
xintercept = 0, |
337 | ! |
linetype = 1, |
338 | ! |
color = "grey" |
339 |
) + |
|
340 | ! |
geom_errorbarh( |
341 | ! |
aes(xmin = .data$lower, xmax = .data$upper, y = .data$level), |
342 | ! |
height = 0.3 |
343 |
) + |
|
344 | ! |
mytheme + |
345 | ! |
theme( |
346 | ! |
axis.ticks.x = element_line(), |
347 | ! |
axis.line.x = element_line() |
348 |
) + |
|
349 | ! |
y_axis + |
350 | ! |
coord_cartesian(xlim = c(-xmax, xmax)) |
351 | ! |
p1_grob <- ggplotGrob(p1) |
352 | ||
353 | ! |
df_total <- df %>% |
354 | ! |
group_by(.data$level) %>% |
355 | ! |
summarise(n = sum(.data$total)) %>% |
356 | ! |
mutate(percent = n / length(arm_sl) * 100) |
357 | ||
358 | ! |
if (arm_n) { |
359 | ! |
df_byarm <- df %>% |
360 | ! |
group_by(.data$level, .data$arm) %>% |
361 | ! |
summarise(n = sum(.data$total)) %>% |
362 | ! |
tidyr::pivot_wider(names_from = arm, values_from = n) %>% |
363 | ! |
rename(n_trt = matches(trt), n_ref = matches(ref)) |
364 | ||
365 | ! |
df_total <- df_total %>% |
366 | ! |
left_join(df_byarm, by = "level") %>% |
367 | ! |
mutate( |
368 | ! |
percent_trt = .data$n_trt / .data$n * 100, |
369 | ! |
percent_ref = .data$n_ref / .data$n * 100 |
370 |
) |
|
371 |
} |
|
372 | ||
373 | ! |
p2 <- ggplot(df_total) + |
374 | ! |
geom_text(aes( |
375 | ! |
x = "Patients(%)", |
376 | ! |
y = .data$level, |
377 | ! |
label = sprintf("%i (%.1f)", n, .data$percent) |
378 | ! |
), size = fontsize) + |
379 | ! |
mytheme + |
380 | ! |
y_axis + |
381 | ! |
scale_x_discrete(position = "top") |
382 | ||
383 | ! |
p2_grob <- ggplotGrob(p2) |
384 | ||
385 | ! |
if (arm_n) { |
386 | ! |
p2_trt <- ggplot(df_total) + |
387 | ! |
geom_text(aes( |
388 | ! |
x = "TRT", |
389 | ! |
y = .data$level, |
390 | ! |
label = sprintf("%i", .data$n_trt) |
391 | ! |
), size = fontsize) + |
392 | ! |
mytheme + |
393 | ! |
theme(axis.text.y = element_blank()) + |
394 | ! |
y_axis + |
395 | ! |
scale_x_discrete(position = "top") |
396 | ||
397 | ! |
p2_ref <- ggplot(df_total) + |
398 | ! |
geom_text(aes( |
399 | ! |
x = "CONT", |
400 | ! |
y = .data$level, |
401 | ! |
label = sprintf("%i", .data$n_ref) |
402 | ! |
), size = fontsize) + |
403 | ! |
mytheme + |
404 | ! |
theme(axis.text.y = element_blank()) + |
405 | ! |
y_axis + |
406 | ! |
scale_x_discrete(position = "top") |
407 | ||
408 | ! |
p2_trt_grob <- ggplotGrob(p2_trt) |
409 | ! |
p2_ref_grob <- ggplotGrob(p2_ref) |
410 |
} |
|
411 | ||
412 | ! |
df_ci <- df %>% |
413 | ! |
tidyr::pivot_wider( |
414 | ! |
names_from = "arm", |
415 | ! |
values_from = "risk", |
416 | ! |
id_cols = c("level", "lower", "upper", "riskdiff") |
417 |
) %>% |
|
418 | ! |
tidyr::pivot_longer( |
419 | ! |
names_to = "x", |
420 | ! |
values_to = "v", |
421 | ! |
cols = c("lower", "upper", "riskdiff", matches(trt), matches(ref)) |
422 |
) %>% |
|
423 | ! |
mutate(vlabel = sprintf("%.2f", .data$v)) |
424 | ||
425 | ||
426 | ! |
labels <- c("TRT", "CONT", "Diff", "Lower", "Upper") |
427 | ! |
p3 <- ggplot(df_ci) + |
428 | ! |
geom_text(aes(x = .data$x, y = .data$level, label = .data$vlabel), size = fontsize) + |
429 | ! |
mytheme + |
430 | ! |
y_axis + |
431 | ! |
scale_x_discrete( |
432 | ! |
limits = c(trt, ref, "riskdiff", "lower", "upper"), |
433 | ! |
labels = labels, |
434 | ! |
position = "top" |
435 |
) |
|
436 | ||
437 | ! |
p3_grob <- ggplotGrob(p3) |
438 | ||
439 | ! |
grobs <- grob_parts(p1_grob, "axis-l") |
440 | ! |
grobs <- append(grobs, grob_parts(p2_grob, c("axis-t", "panel"))) |
441 | ! |
if (arm_n) { |
442 | ! |
grobs <- append(grobs, grob_parts(p2_trt_grob, c("axis-t", "panel"))) |
443 | ! |
grobs <- append(grobs, grob_parts(p2_ref_grob, c("axis-t", "panel"))) |
444 |
} |
|
445 | ! |
grobs <- append(grobs, grob_parts(p1_grob, c("panel", "axis-b"))) |
446 | ! |
grobs <- append(grobs, grob_parts(p3_grob, c("axis-t", "panel"))) |
447 | ! |
less_risk <- grid::textGrob( |
448 | ! |
"Favor\nTreatment", |
449 | ! |
just = "centre", |
450 | ! |
x = grid::unit(fontsize * .pt, "pt"), |
451 | ! |
gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold") |
452 |
) |
|
453 | ! |
more_risk <- grid::textGrob( |
454 | ! |
"Favor\nControl", |
455 | ! |
just = "centre", |
456 | ! |
x = grid::unit(1, "npc") - grid::unit(fontsize * .pt, "pt"), |
457 | ! |
gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold") |
458 |
) |
|
459 | ! |
risk_label <- gridExtra::arrangeGrob(less_risk, more_risk, nrow = 1) |
460 | ! |
grobs <- append(grobs, list( |
461 | ! |
grid::textGrob( |
462 | ! |
"Risk Difference (CI)", |
463 | ! |
just = "centre", |
464 | ! |
x = grid::unit(0.5, "npc"), |
465 | ! |
y = grid::unit(0.5, "npc"), |
466 | ! |
gp = grid::gpar(fontsize = fontsize * .pt, fontface = "bold") |
467 |
), |
|
468 | ! |
risk_label |
469 |
)) |
|
470 | ||
471 | ! |
widths <- if (arm_n) { |
472 | ! |
grid::unit.c( |
473 | ! |
grid::grobWidth(grobs[[1]]), |
474 | ! |
grid::unit( |
475 | ! |
c(14 * fontsize, rep(10 * fontsize, 2), 1, 50 * fontsize), |
476 | ! |
c(rep("pt", 3), "null", "pt") |
477 |
) |
|
478 |
) |
|
479 |
} else { |
|
480 | ! |
grid::unit.c( |
481 | ! |
grid::grobWidth(grobs[[1]]), |
482 | ! |
grid::unit( |
483 | ! |
c(14 * fontsize, 1, 50 * fontsize), |
484 | ! |
c("pt", "null", "pt") |
485 |
) |
|
486 |
) |
|
487 |
} |
|
488 | ||
489 | ! |
heights <- if (arm_n) { |
490 | ! |
grid::unit.c( |
491 | ! |
grid::grobHeight(grobs[[10]]), |
492 | ! |
grid::unit(1, "null"), |
493 | ! |
rep(grid::grobHeight(grobs[[9]]), 3), |
494 | ! |
grid::unit(fontsize * .pt, "pt") |
495 |
) |
|
496 |
} else { |
|
497 | ! |
grid::unit.c( |
498 | ! |
grid::grobHeight(grobs[[6]]), |
499 | ! |
grid::unit(1, "null"), |
500 | ! |
grid::grobHeight(grobs[[5]]), |
501 | ! |
grid::unit(fontsize * .pt * 3, "pt") |
502 |
) |
|
503 |
} |
|
504 | ||
505 | ! |
boldfont <- grid::gpar( |
506 | ! |
fontsize = fontsize * 4, |
507 | ! |
fontface = "bold", |
508 | ! |
lineheight = 1 |
509 |
) |
|
510 | ! |
layout_matrix <- if (arm_n) { |
511 | ! |
rbind( |
512 | ! |
c(NA, 2, 4, 6, 12, 10), |
513 | ! |
c(1, 3, 5, 7, 8, 11), |
514 | ! |
c(NA, NA, NA, NA, 9, NA), |
515 | ! |
c(NA, NA, NA, NA, 13, NA) |
516 |
) |
|
517 |
} else { |
|
518 | ! |
rbind( |
519 | ! |
c(NA, 2, 8, 6), |
520 | ! |
c(1, 3, 4, 7), |
521 | ! |
c(NA, NA, 5, NA), |
522 | ! |
c(NA, NA, 9, NA) |
523 |
) |
|
524 |
} |
|
525 | ||
526 | ! |
ret <- gridExtra::arrangeGrob( |
527 | ! |
grobs = grobs, |
528 | ! |
layout_matrix = layout_matrix, |
529 | ! |
heights = heights, |
530 | ! |
widths = widths, |
531 | ! |
clip = "on" |
532 |
) |
|
533 | ! |
if (draw) { |
534 | ! |
grid::grid.draw(ret) |
535 |
} |
|
536 | ! |
invisible(ret) |
537 |
} |
1 |
#' Waterfall Plot |
|
2 |
#' |
|
3 |
#' Waterfall plot is often used in Early Development (ED) to present each individual patient’s best |
|
4 |
#' response to a particular drug based on a parameter. |
|
5 |
#' |
|
6 |
#' @param bar_id (`vector`)\cr contains IDs to identify each bar |
|
7 |
#' @param bar_height numeric vector to be plotted as height of each bar |
|
8 |
#' @param sort_by (`vector`)\cr used to sort bars, default is `NULL` in which case bars are ordered |
|
9 |
#' by decreasing height |
|
10 |
#' @param col_by (`vector`)\cr used to color bars, default is `NULL` in which case bar_id is taken if |
|
11 |
#' the argument \code{bar_color_opt} is provided |
|
12 |
#' @param bar_color_opt (`vector`)\cr |
|
13 |
#' aesthetic values to map color values (named vector to map color values to each name). |
|
14 |
#' If not `NULL`, please make sure this contains all possible values for \code{col_by} values, |
|
15 |
#' otherwise default `ggplot` color will be assigned, please note that `NULL` needs to be specified |
|
16 |
#' in this case |
|
17 |
#' @param anno_txt (`dataframe`)\cr |
|
18 |
#' contains subject-level variables to be displayed as annotation below the waterfall plot, |
|
19 |
#' default is `NULL` |
|
20 |
#' @param href_line (`numeric vector`)\cr to plot horizontal reference lines, default is `NULL` |
|
21 |
#' @param facet_by (`vector`)\cr to facet plot and annotation table, default is `NULL` |
|
22 |
#' @param show_datavalue (`boolean`)\cr controls whether value of bar height is shown, default is \code{TRUE} |
|
23 |
#' @param add_label (`vector`)\cr of one subject-level variable to be added to each bar except for bar_height, |
|
24 |
#' default is `NULL` |
|
25 |
#' @param gap_point (`numeric`)\cr value for adding bar break when some bars are significantly higher than |
|
26 |
#' others, default is `NULL` |
|
27 |
#' @param ytick_at (`numeric`)\cr optional bar height axis interval, default is 20 |
|
28 |
#' @param y_label (`string`)\cr label for bar height axis, default is "Best % Change from Baseline" |
|
29 |
#' @param title (`string`)\cr displayed as plot title, default is "Waterfall Plot" |
|
30 |
#' |
|
31 |
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com} |
|
32 |
#' @template author_qit3 |
|
33 |
#' |
|
34 |
#' @return plot object |
|
35 |
#' |
|
36 |
#' @export |
|
37 |
#' |
|
38 |
#' @examples |
|
39 |
#' library(tidyr) |
|
40 |
#' library(dplyr) |
|
41 |
#' library(nestcolor) |
|
42 |
#' |
|
43 |
#' g_waterfall( |
|
44 |
#' bar_id = letters[1:3], bar_height = c(3, 5, -1), |
|
45 |
#' bar_color_opt = c("red", "green", "blue") |
|
46 |
#' ) |
|
47 |
#' |
|
48 |
#' # Example 1 |
|
49 |
#' ADSL <- osprey::rADSL[1:15, ] |
|
50 |
#' ADRS <- osprey::rADRS %>% |
|
51 |
#' filter(USUBJID %in% ADSL$USUBJID) |
|
52 |
#' ADTR <- osprey::rADTR %>% |
|
53 |
#' filter(USUBJID %in% ADSL$USUBJID) %>% |
|
54 |
#' select(USUBJID, PCHG) %>% |
|
55 |
#' group_by(USUBJID) %>% |
|
56 |
#' slice(which.min(PCHG)) |
|
57 |
#' |
|
58 |
#' TR_SL <- inner_join(ADSL, ADTR, by = "USUBJID", multiple = "all") |
|
59 |
#' |
|
60 |
#' SUB_ADRS <- ADRS %>% |
|
61 |
#' filter(PARAMCD == "BESRSPI" | PARAMCD == "INVET") %>% |
|
62 |
#' select(USUBJID, PARAMCD, AVALC, AVISIT, ADY) %>% |
|
63 |
#' spread(PARAMCD, AVALC) |
|
64 |
#' |
|
65 |
#' ANL <- TR_SL %>% |
|
66 |
#' left_join(SUB_ADRS, by = "USUBJID", multiple = "all") %>% |
|
67 |
#' mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) |
|
68 |
#' |
|
69 |
#' anno_txt_vars <- c("TRTDURD", "BESRSPI", "INVET", "SEX", "BMRKR2") |
|
70 |
#' |
|
71 |
#' g_waterfall( |
|
72 |
#' bar_height = ANL$PCHG, |
|
73 |
#' bar_id = sub(".*-", "", ANL$USUBJID), |
|
74 |
#' col_by = ANL$SEX, |
|
75 |
#' sort_by = ANL$ARM, |
|
76 |
#' # bar_color_opt = c("F" = "red", "M" = "green", "U" = "blue"), |
|
77 |
#' anno_txt = ANL[, anno_txt_vars], |
|
78 |
#' facet_by = NULL, |
|
79 |
#' href_line = c(-30, 20), |
|
80 |
#' add_label = ANL$BESRSPI, |
|
81 |
#' ytick_at = 20, |
|
82 |
#' gap_point = NULL, |
|
83 |
#' show_datavalue = TRUE, |
|
84 |
#' y_label = "Best % Change from Baseline", |
|
85 |
#' title = "Waterfall Plot" |
|
86 |
#' ) |
|
87 |
#' |
|
88 |
#' # Example 2 facetting |
|
89 |
#' anno_txt_vars <- c("BESRSPI", "INVET") |
|
90 |
#' |
|
91 |
#' g_waterfall( |
|
92 |
#' bar_id = sub(".*-", "", ANL$USUBJID), |
|
93 |
#' bar_height = ANL$PCHG, |
|
94 |
#' sort_by = ANL$COUNTRY, |
|
95 |
#' col_by = ANL$SEX, |
|
96 |
#' bar_color_opt = c("F" = "tomato", "M" = "skyblue3", "U" = "darkgreen"), |
|
97 |
#' anno_txt = ANL[, anno_txt_vars], |
|
98 |
#' facet_by = ANL$STRATA2, |
|
99 |
#' href_line = c(-30, 20), |
|
100 |
#' add_label = ANL$BESRSPI, |
|
101 |
#' ytick_at = 20, |
|
102 |
#' gap_point = 260, |
|
103 |
#' y_label = "Best % Change from Baseline", |
|
104 |
#' title = "Waterfall Plot" |
|
105 |
#' ) |
|
106 |
#' |
|
107 |
#' # Example 3 extreme value |
|
108 |
#' ANL$PCHG[3] <- 99 |
|
109 |
#' ANL$PCHG[5] <- 199 |
|
110 |
#' ANL$PCHG[7] <- 599 |
|
111 |
#' ANL$BESRSPI[3] <- "PD" |
|
112 |
#' ANL$BESRSPI[5] <- "PD" |
|
113 |
#' ANL$BESRSPI[7] <- "PD" |
|
114 |
#' |
|
115 |
#' g_waterfall( |
|
116 |
#' bar_id = sub(".*-", "", ANL$USUBJID), |
|
117 |
#' bar_height = ANL$PCHG, |
|
118 |
#' sort_by = ANL$ARM, |
|
119 |
#' col_by = ANL$SEX, |
|
120 |
#' bar_color_opt = c("F" = "tomato", "M" = "skyblue3", "U" = "darkgreen"), |
|
121 |
#' anno_txt = ANL[, anno_txt_vars], |
|
122 |
#' facet_by = NULL, |
|
123 |
#' href_line = c(-30, 20), |
|
124 |
#' add_label = ANL$BESRSPI, |
|
125 |
#' ytick_at = 20, |
|
126 |
#' gap_point = 260, |
|
127 |
#' y_label = "Best % Change from Baseline", |
|
128 |
#' title = "Waterfall Plot" |
|
129 |
#' ) |
|
130 |
#' |
|
131 |
g_waterfall <- function(bar_id, |
|
132 |
bar_height, |
|
133 |
sort_by = NULL, |
|
134 |
col_by = NULL, |
|
135 |
bar_color_opt = NULL, |
|
136 |
anno_txt = NULL, |
|
137 |
href_line = NULL, |
|
138 |
facet_by = NULL, |
|
139 |
show_datavalue = TRUE, |
|
140 |
add_label = NULL, |
|
141 |
gap_point = NULL, |
|
142 |
ytick_at = 20, |
|
143 |
y_label = "Best % Change from Baseline", |
|
144 |
title = "Waterfall Plot") { |
|
145 |
# check data |
|
146 | ! |
check_input_length <- c(nrow(data.frame(bar_id)), nrow(data.frame(bar_height))) |
147 | ||
148 | ! |
if (length(unique(check_input_length)) > 1) { |
149 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
150 |
} |
|
151 | ||
152 | ! |
if (any(check_input_length == 0)) { |
153 | ! |
stop("invalid arguments: check that inputs are not null") |
154 |
} |
|
155 | ||
156 | ! |
if (!is.null(bar_color_opt)) { |
157 | ! |
if (is.null(col_by)) { |
158 | ! |
col_by <- bar_id |
159 |
} else { |
|
160 | ! |
ls1 <- levels(factor(col_by)) |
161 | ! |
ls2 <- names(bar_color_opt) |
162 | ! |
if (length(intersect(ls1, ls2)) == 0) { |
163 | ! |
stop("invalid argument: check that the col_by and bar_color_opt have overlapping categories") |
164 | ! |
} else if (length(ls2) < length(ls1)) { |
165 | ! |
stop("invalid argument: More categories in col_by than the ones listed in bar_color_opt") |
166 |
} |
|
167 |
} |
|
168 |
} |
|
169 | ||
170 | ! |
if (!is.null(sort_by)) check_same_N(bar_id = bar_id, bar_height = bar_height, sort_by = sort_by) |
171 | ! |
if (!is.null(col_by)) check_same_N(bar_id = bar_id, bar_height = bar_height, col_by = col_by) |
172 | ||
173 | ! |
facet_plot <- function(bar_id = bar_id, |
174 | ! |
bar_height = bar_height, |
175 | ! |
sort_by = sort_by, |
176 | ! |
col_by = col_by, |
177 | ! |
bar_color_opt = bar_color_opt, |
178 | ! |
anno_txt = anno_txt, |
179 | ! |
href_line = href_line, |
180 | ! |
facet_by = facet_by, |
181 | ! |
show_datavalue = show_datavalue, |
182 | ! |
add_label = add_label, |
183 | ! |
gap_point = gap_point, |
184 | ! |
ytick_at = ytick_at, |
185 | ! |
y_label = y_label, |
186 | ! |
title = title) { |
187 |
# Data for plot |
|
188 | ! |
bar_data <- data.frame( |
189 | ! |
bar_id, |
190 | ! |
bar_height, |
191 | ! |
add_label = if (is.null(add_label)) to_n("x", length(bar_height)) else to_n(add_label, length(bar_height)), |
192 | ! |
sort_by = if (is.null(sort_by)) to_n("x", length(bar_height)) else to_n(sort_by, length(bar_height)), |
193 | ! |
col_by = if (is.null(col_by)) to_n("x", length(bar_height)) else to_n(col_by, length(bar_height)) |
194 |
) |
|
195 | ||
196 |
# if sort by a variable, reorder bar_id by sort var and then bar length; otherwise sort by bar length |
|
197 | ! |
if (!is.null(sort_by)) { |
198 | ! |
bar_data$bar_id <- factor( |
199 | ! |
bar_data$bar_id, |
200 | ! |
levels = unique(bar_data$bar_id[order(bar_data$sort_by, bar_data$bar_height, decreasing = TRUE)]) |
201 |
) |
|
202 |
} else { |
|
203 | ! |
bar_data$bar_id <- factor( |
204 | ! |
bar_data$bar_id, |
205 | ! |
levels = unique(bar_data$bar_id[order(bar_data$bar_height, decreasing = TRUE)]) |
206 |
) |
|
207 |
} |
|
208 | ||
209 |
# bar_id has already been sorted based on bar_height so keeping the 1st entry is equivalent to keeping |
|
210 |
# the best % change from baseline |
|
211 | ! |
bar_data <- bar_data %>% distinct(bar_id, .keep_all = TRUE) |
212 | ||
213 |
# plot bar plot |
|
214 | ! |
if (is.null(gap_point)) { |
215 | ! |
ybreaks <- seq( |
216 | ! |
ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at), |
217 | ! |
ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at), |
218 | ! |
by = ytick_at |
219 |
) |
|
220 | ||
221 | ! |
p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) + |
222 | ! |
geom_col(position = "identity", aes(fill = col_by)) + |
223 | ! |
scale_y_continuous(breaks = ybreaks) + |
224 | ! |
scale_x_discrete(expand = expansion(add = 0.5)) + |
225 | ! |
geom_hline(yintercept = 0, colour = "black") + |
226 | ! |
theme_bw() + |
227 | ! |
theme( |
228 | ! |
panel.background = element_blank(), |
229 | ! |
panel.grid = element_blank(), |
230 | ! |
axis.line = element_line(colour = "black"), |
231 | ! |
axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5), |
232 | ! |
axis.title.x = element_blank() |
233 |
) + |
|
234 | ! |
ylab(y_label) |
235 | ! |
} else if (all(is.na(bar_data$bar_height))) { |
236 | ! |
ybreaks <- seq(ytick_at * -2, ytick_at * 2, by = ytick_at) |
237 | ||
238 | ! |
p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) + |
239 | ! |
geom_col(position = "identity", aes(fill = col_by)) + |
240 | ! |
scale_y_continuous(breaks = ybreaks) + |
241 | ! |
scale_x_discrete(expand = expansion(add = 0.5)) + |
242 | ! |
geom_hline(yintercept = 0, colour = "black") + |
243 | ! |
theme_bw() + |
244 | ! |
theme( |
245 | ! |
panel.background = element_blank(), |
246 | ! |
panel.grid = element_blank(), |
247 | ! |
axis.line = element_line(colour = "black"), |
248 | ! |
axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5), |
249 | ! |
axis.title.x = element_blank() |
250 |
) + |
|
251 | ! |
ylab(y_label) |
252 | ! |
} else if (max(bar_data$bar_height, na.rm = TRUE) <= gap_point) { |
253 | ! |
ybreaks <- seq( |
254 | ! |
ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at), |
255 | ! |
ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at), |
256 | ! |
by = ytick_at |
257 |
) |
|
258 | ||
259 | ! |
p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_height)) + |
260 | ! |
geom_col(position = "identity", aes(fill = col_by)) + |
261 | ! |
scale_y_continuous(breaks = ybreaks) + |
262 | ! |
scale_x_discrete(expand = expansion(add = 0.5)) + |
263 | ! |
geom_hline(yintercept = 0, colour = "black") + |
264 | ! |
theme_bw() + |
265 | ! |
theme( |
266 | ! |
panel.background = element_blank(), |
267 | ! |
panel.grid = element_blank(), |
268 | ! |
axis.line = element_line(colour = "black"), |
269 | ! |
axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5), |
270 | ! |
axis.title.x = element_blank() |
271 |
) + |
|
272 | ! |
ylab(y_label) |
273 |
} else { |
|
274 | ! |
length_cut <- ytick_at * |
275 | ! |
floor(0.8 * (min(bar_data$bar_height[bar_data$bar_height > gap_point], na.rm = TRUE) - gap_point) / ytick_at) |
276 | ||
277 | ! |
cut_fun <- function(x) { |
278 | ! |
if (is.na(x)) { |
279 | ! |
x <- x |
280 | ! |
} else if (x > gap_point) { |
281 | ! |
x <- x - length_cut |
282 |
} else { |
|
283 | ! |
x <- x |
284 |
} |
|
285 |
} |
|
286 | ||
287 | ! |
bar_data$new_bar_height <- sapply(bar_data$bar_height, cut_fun) |
288 | ||
289 | ! |
ylabel1 <- seq( |
290 | ! |
ytick_at * floor(min(bar_data$bar_height, na.rm = TRUE) / ytick_at), |
291 | ! |
ytick_at * floor(gap_point / ytick_at), |
292 | ! |
by = ytick_at |
293 |
) |
|
294 | ! |
ylabel2 <- seq( |
295 | ! |
ytick_at * floor((gap_point + length_cut) / ytick_at), |
296 | ! |
ytick_at * ceiling(max(bar_data$bar_height, na.rm = TRUE) / ytick_at), |
297 | ! |
by = ytick_at |
298 |
) |
|
299 | ||
300 | ! |
ybreaks <- seq( |
301 | ! |
ytick_at * floor(min(bar_data$new_bar_height, na.rm = TRUE) / ytick_at), |
302 | ! |
ytick_at * ceiling(max(bar_data$new_bar_height, na.rm = TRUE) / ytick_at), |
303 | ! |
by = ytick_at |
304 |
) |
|
305 | ||
306 | ! |
if (length(ylabel1) + length(ylabel2) == length(ybreaks)) { |
307 | ! |
ylabels <- c(ylabel1, ylabel2) |
308 |
} else { |
|
309 | ! |
dif <- length(ylabel1) + length(ylabel2) - length(ybreaks) |
310 | ! |
ylabel2 <- ylabel2[-(1:dif)] # nolint |
311 | ! |
ylabels <- c(ylabel1, ylabel2) |
312 |
} |
|
313 | ||
314 | ! |
p <- ggplot(data = bar_data, aes_string(x = "bar_id", y = "new_bar_height")) + |
315 | ! |
geom_col(position = "identity", aes(fill = col_by)) + |
316 | ! |
geom_rect(aes(xmin = 0.5, xmax = length(bar_id), ymin = gap_point, ymax = gap_point + 3), fill = "white") + |
317 | ! |
scale_y_continuous(breaks = ybreaks, labels = ylabels) + |
318 | ! |
scale_x_discrete(expand = expansion(add = 0.5)) + |
319 | ! |
geom_hline(yintercept = 0, colour = "black") + |
320 | ! |
theme_bw() + |
321 | ! |
theme( |
322 | ! |
panel.background = element_blank(), |
323 | ! |
panel.grid = element_blank(), |
324 | ! |
axis.line = element_line(colour = "black"), |
325 | ! |
axis.text.x = element_text(angle = 90, hjust = 0, vjust = 0.5), |
326 | ! |
axis.title.x = element_blank() |
327 |
) + |
|
328 | ! |
ylab(y_label) |
329 |
} |
|
330 | ||
331 | ! |
if (show_datavalue == TRUE) { |
332 | ! |
p <- p + geom_text( |
333 | ! |
label = format(bar_data$bar_height, digits = 1), |
334 | ! |
size = 2.5, |
335 | ! |
vjust = ifelse(bar_data$bar_height >= 0, -0.5, 1.5) |
336 |
) |
|
337 |
} |
|
338 | ||
339 | ! |
if (!is.null(add_label)) { |
340 | ! |
p <- p + geom_text( |
341 | ! |
aes(x = bar_id, y = 0, label = add_label), |
342 | ! |
size = 3, |
343 | ! |
vjust = ifelse(bar_data$bar_height >= 0, 1.5, -0.5) |
344 |
) |
|
345 |
} |
|
346 | ||
347 | ! |
if (is.null(col_by)) { |
348 | ! |
p <- p + guides(fill = "none") |
349 |
} else { |
|
350 | ! |
p <- p + guides(fill = guide_legend("Bar Color", order = 1, ncol = 1)) + |
351 | ! |
theme( |
352 | ! |
legend.title = element_text(size = 9), |
353 | ! |
legend.text = element_text(size = 9), |
354 | ! |
legend.key = element_rect(fill = NA) |
355 |
) |
|
356 |
} |
|
357 | ||
358 | ! |
if (is.null(bar_color_opt) && !is.null(getOption("ggplot2.discrete.colour"))) { |
359 | ! |
bar_color_opt <- getOption("ggplot2.discrete.colour") |
360 |
} |
|
361 | ! |
if (!is.null(bar_color_opt)) { |
362 | ! |
p <- p + scale_fill_manual(values = bar_color_opt) |
363 |
} |
|
364 | ||
365 |
# plot reference lines |
|
366 | ! |
if (!is.null(href_line)) { |
367 | ! |
p <- p + geom_hline(yintercept = href_line, linetype = "dashed", color = "red") |
368 |
} |
|
369 | ||
370 |
# add plot title |
|
371 | ! |
if (is.null(facet_by)) { |
372 | ! |
p <- p + |
373 | ! |
labs(title = title) + |
374 | ! |
theme(plot.title = element_text(face = "bold")) |
375 |
} else { |
|
376 | ! |
p <- p + |
377 | ! |
labs(title = paste(title, "-", as.character(unique(facet_by)))) + |
378 | ! |
theme(plot.title = element_text(face = "bold")) |
379 |
} |
|
380 | ||
381 | ! |
if (!is.null(anno_txt)) { |
382 | ! |
t_anno <- data.frame( |
383 | ! |
bar_id, |
384 | ! |
bar_height, |
385 | ! |
sort_by = if (is.null(sort_by)) to_n("x", length(bar_height)) else to_n(sort_by, length(bar_height)), |
386 | ! |
anno_txt |
387 |
) |
|
388 | ||
389 |
# if sort by a variable, reorder bar_id; otherwise sort by bar length |
|
390 | ! |
if (!is.null(sort_by)) { |
391 | ! |
t_anno$bar_id <- factor( |
392 | ! |
t_anno$bar_id, |
393 | ! |
levels = unique(t_anno$bar_id[order(t_anno$sort_by, t_anno$bar_height, decreasing = TRUE)]) |
394 |
) |
|
395 |
} else { |
|
396 | ! |
t_anno$bar_id <- factor( |
397 | ! |
t_anno$bar_id, |
398 | ! |
levels = unique(t_anno$bar_id[order(t_anno$bar_height, decreasing = TRUE)]) |
399 |
) |
|
400 |
} |
|
401 | ||
402 |
# bar_id has already been sorted based on bar_height so keeping the 1st entry is equivalent to keeping |
|
403 |
# the best % change from baseline |
|
404 | ! |
t_anno <- t_anno %>% distinct(bar_id, .keep_all = TRUE) |
405 | ! |
t_anno <- t_anno[order(t_anno$bar_id), ] |
406 | ! |
t_anno <- t_anno[, -c(1, 2, 3)] |
407 | ||
408 | ! |
t_anno <- t(t_anno) |
409 | ||
410 | ! |
my_theme <- gridExtra::ttheme_default( |
411 | ! |
core = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)), |
412 | ! |
rowhead = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)), |
413 | ! |
padding = grid::unit(c(0, 4), "mm") |
414 |
) |
|
415 | ||
416 | ! |
tb <- gridExtra::tableGrob( |
417 | ! |
t_anno, |
418 | ! |
rows = NULL, |
419 | ! |
cols = NULL, |
420 | ! |
theme = my_theme |
421 |
) |
|
422 | ||
423 | ! |
tb$widths <- grid::unit(rep(1 / (ncol(tb)), ncol(tb)), "null") |
424 | ! |
tb <- gtable::gtable_add_grob( |
425 | ! |
tb, |
426 | ! |
grobs = grid::rectGrob(gp = grid::gpar(fill = NA, lwd = 2)), |
427 | ! |
t = 1, b = nrow(tb), l = 1, r = ncol(tb) |
428 |
) |
|
429 | ||
430 | ! |
t_anno_name <- names(anno_txt) |
431 | ! |
tb_rowname <- gridExtra::tableGrob( |
432 | ! |
t_anno_name, |
433 | ! |
rows = NULL, |
434 | ! |
cols = NULL, |
435 | ! |
theme = gridExtra::ttheme_minimal( |
436 | ! |
core = list(bg_params = list(fill = NA, col = NA), fg_params = list(cex = 0.8)) |
437 |
) |
|
438 |
) |
|
439 | ||
440 |
# grab plot and table as one plot |
|
441 | ! |
g0 <- ggplotGrob(p) |
442 | ! |
g1 <- gtable::gtable_add_rows(g0, sum(tb$heights), pos = -1) |
443 | ! |
g2 <- gtable::gtable_add_grob( |
444 | ! |
g1, |
445 | ! |
tb, |
446 | ! |
t = -1, |
447 | ! |
l = g1$layout[g1$layout$name == "panel", 2], |
448 | ! |
r = g1$layout[g1$layout$name == "panel", 4] |
449 |
) |
|
450 | ! |
g3 <- gtable::gtable_add_cols(g2, tb_rowname$widths, pos = 0) |
451 | ! |
g <- gtable::gtable_add_grob(g3, tb_rowname, t = -1, l = 2) |
452 |
} else { |
|
453 | ! |
p <- p + |
454 | ! |
theme(axis.title.x = element_text()) + |
455 | ! |
labs(x = "Unique Subject ID") |
456 | ! |
g <- ggplotGrob(p) |
457 |
} |
|
458 | ! |
g |
459 |
} |
|
460 | ||
461 | ! |
if (is.null(facet_by)) { |
462 | ! |
gt <- facet_plot( |
463 | ! |
bar_id = bar_id, |
464 | ! |
bar_height = bar_height, |
465 | ! |
sort_by = sort_by, |
466 | ! |
col_by = col_by, |
467 | ! |
bar_color_opt = bar_color_opt, |
468 | ! |
anno_txt = anno_txt, |
469 | ! |
href_line = href_line, |
470 | ! |
facet_by = facet_by, |
471 | ! |
show_datavalue = show_datavalue, |
472 | ! |
add_label = add_label, |
473 | ! |
gap_point = gap_point, |
474 | ! |
ytick_at = ytick_at, |
475 | ! |
y_label = y_label, |
476 | ! |
title = title |
477 |
) |
|
478 |
} else { |
|
479 | ! |
facet_by <- factor(facet_by) |
480 | ! |
g_list <- rep(list(NA), length(levels(facet_by))) |
481 | ! |
for (i in seq_along(levels(facet_by))) { |
482 | ! |
facet_level <- levels(facet_by)[i] |
483 | ! |
g_list[[i]] <- facet_plot( |
484 | ! |
bar_id = bar_id[facet_by == facet_level], |
485 | ! |
bar_height = bar_height[facet_by == facet_level], |
486 | ! |
sort_by = sort_by[facet_by == facet_level], |
487 | ! |
col_by = col_by[facet_by == facet_level], |
488 | ! |
bar_color_opt = bar_color_opt, |
489 | ! |
anno_txt = anno_txt[facet_by == facet_level, , drop = FALSE], |
490 | ! |
href_line = href_line, |
491 | ! |
facet_by = facet_by[facet_by == facet_level], |
492 | ! |
show_datavalue = show_datavalue, |
493 | ! |
add_label = add_label[facet_by == facet_level], |
494 | ! |
gap_point = gap_point, |
495 | ! |
ytick_at = ytick_at, |
496 | ! |
y_label = y_label, |
497 | ! |
title = title |
498 |
) |
|
499 |
} |
|
500 | ||
501 | ! |
gt <- gridExtra::grid.arrange(grobs = g_list, ncol = 1, nrow = length(levels(facet_by))) |
502 |
} |
|
503 | ||
504 | ! |
grid::grid.newpage() |
505 | ! |
grid::grid.draw(gt) |
506 | ! |
invisible(gt) |
507 |
} |
1 |
#' `Swimlane` Plot |
|
2 |
#' |
|
3 |
#' `Swimlane` plot is often used in Early Development (ED) and displays individual |
|
4 |
#' patient bar plot with markers of events and patient level annotation |
|
5 |
#' |
|
6 |
#' @param bar_id vector of IDs to identify each bar |
|
7 |
#' @param bar_length numeric vector to be plotted as length for each bar |
|
8 |
#' @param sort_by vector to sort bars |
|
9 |
#' @param col_by vector to color bars |
|
10 |
#' @param marker_id vector of IDs to identify markers within each bar. Default is the same as bar_id. |
|
11 |
#' @param marker_pos numeric vector to specify position for each marker point |
|
12 |
#' @param marker_shape vector to specify shape for markers |
|
13 |
#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name) |
|
14 |
#' @param marker_color vector to specify color for markers |
|
15 |
#' @param marker_color_opt aesthetic values to map shape values (named vector to map shape values to each name) |
|
16 |
#' @param anno_txt dataframe of subject-level variables to be displayed as annotation on the left |
|
17 |
#' @param xref_line numeric vector to plot reference lines |
|
18 |
#' @param xtick_at optional break interval of bar length axis |
|
19 |
#' @param xlab label for bar length |
|
20 |
#' @param title string to be displayed as plot title |
|
21 |
#' |
|
22 |
#' @template author_qit3 |
|
23 |
#' @return plot object |
|
24 |
#' |
|
25 |
#' @export |
|
26 |
#' |
|
27 |
#' @examples |
|
28 |
#' # Example 1 |
|
29 |
#' library(dplyr) |
|
30 |
#' library(nestcolor) |
|
31 |
#' |
|
32 |
#' ADSL <- osprey::rADSL[1:20, ] |
|
33 |
#' ADRS <- filter(rADRS, PARAMCD == "OVRINV") |
|
34 |
#' ANL <- left_join(ADSL, ADRS, by = c("STUDYID", "USUBJID"), multiple = "all") |
|
35 |
#' anno_txt <- ADSL[, c("ARMCD", "SEX")] |
|
36 |
#' |
|
37 |
#' g_swimlane( |
|
38 |
#' bar_id = ADSL$USUBJID, |
|
39 |
#' bar_length = as.integer(ADSL$TRTEDTM - ADSL$TRTSDTM), |
|
40 |
#' sort_by = ADSL$ARM, |
|
41 |
#' col_by = ADSL$ARM, |
|
42 |
#' marker_id = ANL$USUBJID, |
|
43 |
#' marker_pos = ANL$ADY, |
|
44 |
#' marker_shape = ANL$AVALC, |
|
45 |
#' marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "NE" = 4), |
|
46 |
#' marker_color = NULL, |
|
47 |
#' marker_color_opt = NULL, |
|
48 |
#' anno_txt = anno_txt, |
|
49 |
#' xref_line = c(50, 100), |
|
50 |
#' xtick_at = waiver(), |
|
51 |
#' xlab = "Time from First Treatment (Day)", |
|
52 |
#' title = "Swimlane Plot" |
|
53 |
#' ) |
|
54 |
#' |
|
55 |
#' # Example 2 |
|
56 |
#' library(dplyr) |
|
57 |
#' library(nestcolor) |
|
58 |
#' |
|
59 |
#' ADSL <- osprey::rADSL[1:20, ] |
|
60 |
#' ADRS <- osprey::rADRS |
|
61 |
#' |
|
62 |
#' anno_txt_vars <- c("ARMCD", "SEX", "COUNTRY") |
|
63 |
#' anno_txt <- ADSL[, anno_txt_vars] |
|
64 |
#' |
|
65 |
#' # markers from ADRS |
|
66 |
#' ADRS <- dplyr::filter(ADRS, PARAMCD == "OVRINV") %>% select(USUBJID, ADY, AVALC) |
|
67 |
#' |
|
68 |
#' # markers from ADSL - discontinuation |
|
69 |
#' ADS <- ADSL %>% |
|
70 |
#' dplyr::filter(EOSSTT == "Discontinued" | DCSREAS != "") %>% |
|
71 |
#' select(USUBJID, EOSDY, DCSREAS) %>% |
|
72 |
#' dplyr::rename(ADY = EOSDY, AVALC = DCSREAS) |
|
73 |
#' |
|
74 |
#' # combine ADRS with ADS records as one data for markers and join with ADSL |
|
75 |
#' ANL <- inner_join(ADSL, rbind(ADRS, ADS), by = "USUBJID", multiple = "all") |
|
76 |
#' |
|
77 |
#' g_swimlane( |
|
78 |
#' bar_id = sub(".*-", "", ADSL$USUBJID), |
|
79 |
#' bar_length = as.integer(ADSL$TRTEDTM - ADSL$TRTSDTM), |
|
80 |
#' sort_by = NULL, |
|
81 |
#' col_by = ADSL$ARMCD, |
|
82 |
#' marker_id = sub(".*-", "", ANL$USUBJID), |
|
83 |
#' marker_pos = ANL$ADY, |
|
84 |
#' marker_shape = ANL$AVALC, |
|
85 |
#' marker_shape_opt = c( |
|
86 |
#' "CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "NE" = 0, |
|
87 |
#' "Adverse Event" = 7, "Death" = 8, "Physician Decision" = 9, "Progressive Disease" = 10, |
|
88 |
#' "Symptomatic Deterioation" = 11, "Withdrawal by Subject" = 12 |
|
89 |
#' ), |
|
90 |
#' marker_color = ANL$AVALC, |
|
91 |
#' marker_color_opt = c( |
|
92 |
#' "CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red", |
|
93 |
#' "NE" = "grey", "Adverse Event" = "orange", "Death" = "black", "Physician Decision" = "navy", |
|
94 |
#' "Progressive Disease" = "purple", "Symptomatic Deterioation" = "cyan", |
|
95 |
#' "Withdrawal by Subject" = "darkred" |
|
96 |
#' ), |
|
97 |
#' anno_txt = anno_txt, |
|
98 |
#' xref_line = c(50, 100), |
|
99 |
#' xtick_at = waiver(), |
|
100 |
#' xlab = "Time from First Treatment (Day)", |
|
101 |
#' title = "Swimlane Plot" |
|
102 |
#' ) |
|
103 |
g_swimlane <- function(bar_id, |
|
104 |
bar_length, |
|
105 |
sort_by = NULL, |
|
106 |
col_by = NULL, |
|
107 |
marker_id = NULL, |
|
108 |
marker_pos = NULL, |
|
109 |
marker_shape = NULL, |
|
110 |
marker_shape_opt = NULL, |
|
111 |
marker_color = NULL, |
|
112 |
marker_color_opt = NULL, |
|
113 |
anno_txt = NULL, |
|
114 |
xref_line = NULL, |
|
115 |
xtick_at = waiver(), |
|
116 |
xlab, |
|
117 |
title) { |
|
118 |
# check data |
|
119 | ! |
if (!is.null(sort_by)) { |
120 | ! |
check_same_N(bar_id = bar_id, bar_length = bar_length, sort_by = sort_by) |
121 |
} |
|
122 | ! |
if (!is.null(col_by)) { |
123 | ! |
check_same_N(bar_id = bar_id, bar_length = bar_length, col_by = col_by) |
124 |
} |
|
125 | ||
126 | ! |
if (!is.null(marker_id) && length(which(!marker_id %in% bar_id)) > 0) { |
127 | ! |
stop("marker_id ", marker_id[which(!marker_id %in% bar_id)], " is not in bar_id") |
128 |
} |
|
129 | ||
130 | ! |
if (!is.null(marker_id) && !is.null(marker_pos)) { |
131 | ! |
check_same_N(marker_id = marker_id, marker_pos = marker_pos) |
132 |
} |
|
133 | ! |
if (!is.null(marker_id) && !is.null(marker_shape)) { |
134 | ! |
check_same_N(marker_id = marker_id, marker_shape = marker_shape) |
135 |
} |
|
136 | ! |
if (!is.null(marker_id) && !is.null(marker_color)) { |
137 | ! |
check_same_N(marker_id = marker_id, marker_color = marker_color) |
138 |
} |
|
139 | ! |
if (!is.null(xref_line) && (!is.numeric(xref_line) || length(xref_line) == 0)) { |
140 | ! |
stop("xref_line must be a non-empty numeric vector or NULL") |
141 |
} |
|
142 | ||
143 |
# data for plot |
|
144 | ! |
bar_data <- data.frame( |
145 | ! |
bar_id, |
146 | ! |
bar_length, |
147 | ! |
sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)), |
148 | ! |
col_by = if (is.null(col_by)) "x" else to_n(col_by, length(bar_length)) |
149 |
) |
|
150 | ||
151 |
# data for marker |
|
152 | ! |
if (is.null(marker_id)) marker_id <- bar_id |
153 | ! |
marker_data <- data.frame( |
154 | ! |
marker_id, |
155 | ! |
marker_pos = if (is.null(marker_pos)) "x" else to_n(marker_pos, length(marker_id)), |
156 | ! |
marker_shape = if (is.null(marker_shape)) "x" else to_n(marker_shape, length(marker_id)), |
157 | ! |
marker_color = if (is.null(marker_color)) "x" else to_n(marker_color, length(marker_id)) |
158 |
) |
|
159 | ||
160 |
# if sort by a variable, reorder bar_id by sort var and then bar length; otherwise sort by bar length |
|
161 | ! |
if (!is.null(sort_by)) { |
162 | ! |
bar_data$bar_id <- factor(bar_data$bar_id, |
163 | ! |
levels = rev(unique(bar_data$bar_id[order(bar_data$sort_by, -bar_data$bar_length)])) |
164 |
) |
|
165 |
} else { |
|
166 | ! |
bar_data$bar_id <- factor(bar_data$bar_id, |
167 | ! |
levels = rev(unique(bar_data$bar_id[order(-bar_data$bar_length)])) |
168 |
) |
|
169 |
} |
|
170 | ||
171 |
# labeling |
|
172 | ! |
xlabel <- deparse(substitute(bar_length)) |
173 | ! |
xlab <- if (is.null(xlab)) xlabel else xlab |
174 | ||
175 |
# plot bar plot first |
|
176 | ! |
p <- ggplot(data = bar_data, aes(x = bar_id, y = bar_length)) + |
177 | ! |
geom_bar(stat = "identity", aes(fill = col_by)) + |
178 | ! |
coord_flip(xlim = c(1, length(unique(bar_id)) + 1)) + |
179 | ! |
theme_bw() + |
180 | ! |
theme( |
181 | ! |
panel.background = element_blank(), |
182 | ! |
panel.grid = element_blank(), |
183 | ! |
axis.line = element_line(colour = "black"), |
184 | ! |
axis.text.y = element_blank(), |
185 | ! |
axis.title.y = element_blank() |
186 |
) + |
|
187 |
# Note ylab as we have coord_flip above |
|
188 | ! |
ylab(xlab) |
189 | ||
190 | ! |
if (is.null(col_by)) { |
191 | ! |
p <- p + guides(fill = "none") |
192 |
} else { |
|
193 | ! |
p <- p + |
194 | ! |
guides(fill = guide_legend("Bar Color", order = 1, ncol = 1)) + |
195 | ! |
theme( |
196 | ! |
legend.title = element_text(size = 8), |
197 | ! |
legend.text = element_text(size = 8), |
198 | ! |
legend.key = element_rect(fill = NA), |
199 | ! |
legend.key.size = grid::unit(1, "line"), |
200 | ! |
legend.spacing.y = grid::unit(0, "cm"), |
201 | ! |
legend.key.height = grid::unit(1, "line") |
202 |
) |
|
203 |
} |
|
204 | ||
205 | ! |
limits_x <- NULL |
206 | ||
207 |
# plot marker |
|
208 | ! |
if (!is.null(marker_pos)) { |
209 | ! |
p <- p + geom_point( |
210 | ! |
data = marker_data, |
211 | ! |
aes(x = marker_id, y = marker_pos, shape = marker_shape, color = marker_color), |
212 | ! |
size = 2.5, na.rm = TRUE |
213 |
) |
|
214 | ! |
limits_x <- c(0, max(bar_length, marker_pos, na.rm = TRUE) + 5) |
215 | ||
216 | ! |
if (!is.null(marker_shape)) { |
217 | ! |
p <- p + guides(shape = guide_legend("Marker Shape", order = 2)) |
218 |
} else { |
|
219 | ! |
p <- p + guides(shape = "none") |
220 |
} |
|
221 | ||
222 | ! |
if (!is.null(marker_color)) { |
223 | ! |
p <- p + guides(color = guide_legend("Marker Color", order = 3)) |
224 |
} else { |
|
225 | ! |
p <- p + guides(color = "none") |
226 |
} |
|
227 | ||
228 | ! |
p <- p + |
229 | ! |
scale_shape_manual( |
230 | ! |
name = "Marker Shape", |
231 | ! |
breaks = levels(factor(marker_data$marker_shape)), |
232 | ! |
values = if (!is.null(marker_shape_opt)) marker_shape_opt else c(15:25, 0:14) |
233 |
) |
|
234 | ||
235 | ! |
if (is.null(marker_color_opt)) { |
236 | ! |
if (!is.null(getOption("ggplot2.discrete.colour"))) { |
237 | ! |
marker_color_opt <- getOption("ggplot2.discrete.colour")[-seq_len(length(unique(col_by)))] |
238 |
} else { |
|
239 | ! |
marker_color_opt <- c("x" = "black") |
240 |
} |
|
241 |
} |
|
242 | ||
243 | ! |
p <- p + scale_color_manual( |
244 | ! |
name = "Marker Color", |
245 | ! |
breaks = levels(factor(marker_data$marker_color)), |
246 | ! |
values = marker_color_opt |
247 |
) |
|
248 |
} |
|
249 | ||
250 |
# plot reference lines |
|
251 | ! |
if (!is.null(xref_line)) { |
252 | ! |
x_axis_min <- pmax(ggplot_build(p)$layout$panel_params[[1]]$x.range[1], 0) |
253 | ! |
x_axis_max <- pmax(ggplot_build(p)$layout$panel_params[[1]]$x.range[2], 0) |
254 | ! |
xref_line_min <- min(xref_line) |
255 | ! |
xref_line_max <- max(xref_line) |
256 | ! |
min_res <- min(c(limits_x[1], x_axis_min, xref_line_min)) |
257 | ! |
max_res <- max(c(limits_x[2], x_axis_max, xref_line_max)) |
258 | ! |
p <- p + geom_hline(yintercept = xref_line, linetype = "dashed", color = "red") + |
259 | ! |
scale_y_continuous( |
260 | ! |
limits = c(min_res, max_res), |
261 | ! |
breaks = xtick_at, |
262 | ! |
expand = c(`if`(min_res == xref_line_min, .01, 0), `if`(max_res == xref_line_max, .01, 0)) |
263 |
) |
|
264 |
} else { |
|
265 | ! |
if (!is.null(limits_x)) { |
266 | ! |
p <- p + scale_y_continuous(limits = limits_x, breaks = xtick_at, expand = c(0, 0)) |
267 |
} |
|
268 |
} |
|
269 | ||
270 |
# plot title and labels |
|
271 | ! |
if (!is.null(title)) { |
272 | ! |
p <- p + |
273 | ! |
labs(title = title) + |
274 | ! |
theme(plot.title = element_text(face = "bold")) |
275 |
} |
|
276 | ||
277 | ||
278 |
# create annotation as a separate table plot |
|
279 | ! |
if (is.null(anno_txt)) { |
280 | ! |
t <- data.frame(bar_id, bar_length, |
281 | ! |
sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)) |
282 |
) |
|
283 |
} else { |
|
284 | ! |
t <- data.frame(bar_id, bar_length, |
285 | ! |
sort_by = if (is.null(sort_by)) "x" else to_n(sort_by, length(bar_length)), |
286 | ! |
anno_txt |
287 |
) |
|
288 |
} |
|
289 | ||
290 |
# if sort by a variable, reorder bar_id; otherwise sort by bar length |
|
291 | ! |
if (!is.null(sort_by)) { |
292 | ! |
t <- t[with(t, order(sort_by, -bar_length, levels(as.factor(bar_id)))), -c(2, 3)] |
293 |
} else { |
|
294 | ! |
t <- t[with(t, order(-bar_length, levels(as.factor(bar_id)))), -c(2, 3)] |
295 |
} |
|
296 | ||
297 | ! |
t <- as.data.frame(t) |
298 | ! |
colnames(t)[1] <- " " |
299 | ||
300 | ! |
my_theme <- gridExtra::ttheme_default( |
301 | ! |
core = list( |
302 | ! |
bg_params = list(fill = NA, col = NA), |
303 | ! |
fg_params = list(cex = 0.8) |
304 |
), |
|
305 | ! |
colhead = list( |
306 | ! |
bg_params = list(fill = NA, col = NA), |
307 | ! |
fg_params = list(cex = 0.8) |
308 |
) |
|
309 |
) |
|
310 | ! |
tb <- gridExtra::tableGrob(t, rows = NULL, theme = my_theme) |
311 | ! |
tb$heights <- grid::unit(rep(1 / nrow(tb), nrow(tb)), "null") |
312 | ||
313 |
# grab plot and table as one plot |
|
314 | ! |
g0 <- ggplotGrob(p) |
315 | ! |
g1 <- gtable::gtable_add_cols(g0, sum(tb$widths), 0) |
316 | ! |
g <- gtable::gtable_add_grob(g1, tb, t = g1$layout[g1$layout$name == "panel", 1], l = 1) |
317 | ||
318 | ! |
grid::grid.newpage() |
319 | ! |
grid::grid.draw(g) |
320 | ! |
invisible(g) |
321 |
} |
1 |
#' Hy's Law Plot |
|
2 |
#' |
|
3 |
#' A scatter plot typically used to display maximum total bilirubin values (`TBL`) |
|
4 |
#' versus maximum alanine transaminase (`ALT`) values. |
|
5 |
#' |
|
6 |
#' @param id unique subject identifier. |
|
7 |
#' @param term the term of the observation. |
|
8 |
#' @param aval analysis value. |
|
9 |
#' @param arm treatment arm. Used as fill color in the plot. |
|
10 |
#' @param term_selected string vector of length 2 - the two terms selected to be |
|
11 |
#' used in the plot. First value corresponds to parameter plotted on the |
|
12 |
#' x-axis. Second value corresponds to that plotted on the y-axis. |
|
13 |
#' @param anrhi the high limit of normal range. |
|
14 |
#' @param folds numeric vector of length two. Indicates the position of the |
|
15 |
#' reference lines to be drawn. Default c(3, 2) corresponds to a line at |
|
16 |
#' position 3 on the x-axis and 2 on the y-axis. |
|
17 |
#' @param text string vector of length four with the label to be shown on each |
|
18 |
#' quadrant. First value corresponds to label shown in the bottom left |
|
19 |
#' quadrant. Subsequent values move through the graph clockwise. |
|
20 |
#' @param caption string of text for footnote. Details of methodology can be |
|
21 |
#' shown here. |
|
22 |
#' @param title string of text for plot title. |
|
23 |
#' @param xlab string of text for x axis label. |
|
24 |
#' @param ylab string of text for y axis label. |
|
25 |
#' |
|
26 |
#' @details |
|
27 |
#' This graphic is based upon the `eDISH` (evaluation of Drug Induced Serious |
|
28 |
#' Hepatotoxicity) plot of Watkins et. al. in a 2008 publication from Hepatology. |
|
29 |
#' Maximum values are defined as the maximum post-baseline value at any time |
|
30 |
#' during the entire length of the observation period. Both axes are in log |
|
31 |
#' scale to control for the dispersion of the data. The values are plotted in |
|
32 |
#' 'times upper limit of normal' where a value of 1 would mean that the result |
|
33 |
#' was normal. Any value above or below 1 would be considered above the upper |
|
34 |
#' limit or normal or below the upper limit of normal respectively. For |
|
35 |
#' instance, a value of 3 would be read as '3 times the upper limit of normal'. |
|
36 |
#' Reference lines are included to determine various states, based upon clinical |
|
37 |
#' interpretation of the values and includes the following: |
|
38 |
#' |
|
39 |
#' * Hyperbilirubinemia `TBL` at least 2 `xULN` and `ALT` less than 3 `xULN` |
|
40 |
#' * Normal Range `TBL` <= 1 `xULN` and `ALT` <= 1 `xULN` |
|
41 |
#' * Temple’s Corollary `TBL` <= 1 `xULN` and `ALT` at least 3 `xULN` |
|
42 |
#' * Possible Hy's Law `TBL` at least 2 `xULN` and `ALT` at least 3 `xULN` |
|
43 |
#' |
|
44 |
#' This plot can easily be adjusted for other lab parameters and reference |
|
45 |
#' ranges as needed. Consultation with a clinical expert to determine which |
|
46 |
#' associations would be clinically meaningful and how to interpret those |
|
47 |
#' associations is recommended. |
|
48 |
#' |
|
49 |
#' There is no equivalent STREAM output. |
|
50 |
#' |
|
51 |
#' @return plot object |
|
52 |
#' |
|
53 |
#' @export |
|
54 |
#' |
|
55 |
#' @template author_withycok |
|
56 |
#' @template author_frankla4 |
|
57 |
#' @template author_holmesw |
|
58 |
#' |
|
59 |
#' @examples |
|
60 |
#' library(dplyr) |
|
61 |
#' library(nestcolor) |
|
62 |
#' |
|
63 |
#' # Note: CRP is being used in place of Bilirubin here because this is the only available data |
|
64 |
#' adsl <- osprey::rADSL |
|
65 |
#' adlb <- osprey::rADLB %>% mutate(ANRHI = 50) |
|
66 |
#' |
|
67 |
#' # Example 1, - Hy's law template (3 and 2 X ULN) |
|
68 |
#' g_hy_law( |
|
69 |
#' id = adlb$USUBJID, |
|
70 |
#' term = adlb$PARAMCD, |
|
71 |
#' aval = adlb$AVAL, |
|
72 |
#' arm = adlb$ARM, |
|
73 |
#' term_selected = c("ALT", "CRP"), |
|
74 |
#' anrhi = adlb$ANRHI, |
|
75 |
#' folds = c(3, 2), |
|
76 |
#' text = c("Normal Range", "Hyperbilirubinemia", "Possible Hy's Law Range", "Temple's Corollary"), |
|
77 |
#' caption = paste( |
|
78 |
#' "Maximum values are those maximum values that occur", |
|
79 |
#' "post-baseline (no time constraints and not necessarily concurrent events)." |
|
80 |
#' ), |
|
81 |
#' title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase", |
|
82 |
#' xlab = "Maximum Alanine Aminotransferase (/ULN)", |
|
83 |
#' ylab = "Maximum Total Bilirubin (/ULN)" |
|
84 |
#' ) |
|
85 |
#' |
|
86 |
#' # Example 2, - change the quadrant lines and labels |
|
87 |
#' g_hy_law( |
|
88 |
#' id = adlb$USUBJID, |
|
89 |
#' term = adlb$PARAMCD, |
|
90 |
#' aval = adlb$AVAL, |
|
91 |
#' arm = adlb$ARM, |
|
92 |
#' term_selected = c("ALT", "CRP"), |
|
93 |
#' anrhi = adlb$ANRHI, |
|
94 |
#' folds = c(10, 15), |
|
95 |
#' text = c("Quadrant 1", "Quadrant 2", "Quadrant 3", "Quadrant 4"), |
|
96 |
#' caption = paste( |
|
97 |
#' "Maximum values are those maximum values that occur", |
|
98 |
#' "post-baseline (no time constraints and not necessarily concurrent events)." |
|
99 |
#' ), |
|
100 |
#' title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase", |
|
101 |
#' xlab = "Maximum Alanine Aminotransferase (/ULN)", |
|
102 |
#' ylab = "Maximum Total Bilirubin (/ULN)" |
|
103 |
#' ) |
|
104 |
g_hy_law <- function(id, |
|
105 |
term, |
|
106 |
aval, |
|
107 |
arm, |
|
108 |
term_selected, |
|
109 |
anrhi, |
|
110 |
folds = c(3, 2), |
|
111 |
text = c("Normal Range", "Hyperbilirubinemia", "Possible Hy's Law Range", "Temple's Corollary"), |
|
112 |
caption = paste( |
|
113 |
"Maximum values are those maximum values that occur post-baseline", |
|
114 |
"(no time constraints and not necessarily concurrent events)." |
|
115 |
), |
|
116 |
title = "Max. Total Bilirubin vs. Max. Alanine Aminotransferase", |
|
117 |
xlab = "Maximum Alanine Aminotransferase (/ULN)", |
|
118 |
ylab = "Maximum Total Bilirubin (/ULN)") { |
|
119 | ! |
checkmate::assert_character(term_selected, len = 2, any.missing = FALSE) |
120 | ! |
checkmate::assert_numeric(folds, len = 2, any.missing = FALSE) |
121 | ! |
checkmate::assert_character(text, len = 4, any.missing = FALSE) |
122 | ! |
checkmate::assert_string(title) |
123 | ! |
checkmate::assert_string(caption) |
124 | ! |
checkmate::assert_string(xlab) |
125 | ! |
checkmate::assert_string(ylab) |
126 | ||
127 | ! |
anl <- data.frame(id, term, aval, arm, anrhi) |
128 | ||
129 | ! |
anl <- anl %>% |
130 | ! |
dplyr::filter(term %in% term_selected) %>% |
131 | ! |
dplyr::group_by(id, term) %>% |
132 | ! |
dplyr::mutate(MAX = max(aval)) %>% |
133 | ! |
dplyr::slice(1) %>% |
134 | ! |
dplyr::mutate(ULN = .data$MAX / anrhi) %>% |
135 | ! |
tidyr::pivot_wider(id_cols = c(id, arm), names_from = term, values_from = "ULN") |
136 | ||
137 | ! |
p <- ggplot(data = anl) + |
138 | ! |
scale_x_continuous( |
139 | ! |
name = xlab, |
140 | ! |
breaks = log10(c(seq(0.1, 1, 0.1), seq(2, 10, 1), seq(20, 100, 10))), |
141 | ! |
limits = c(-1, 2), |
142 | ! |
labels = c(0.1, rep(" ", 8), 1, rep(" ", 8), 10, rep(" ", 8), 100), |
143 | ! |
expand = c(0.01, 0.01) |
144 |
) + |
|
145 | ! |
scale_y_continuous( |
146 | ! |
name = ylab, |
147 | ! |
breaks = log10(c(seq(0.1, 1, 0.1), seq(2, 10, 1), seq(20, 100, 10))), |
148 | ! |
limits = c(-1, 2), |
149 | ! |
labels = c(0.1, rep(" ", 8), 1, rep(" ", 8), 10, rep(" ", 8), 100), |
150 | ! |
expand = c(0.01, 0.01) |
151 |
) + |
|
152 | ! |
labs(title = title, caption = caption) + |
153 | ! |
theme_bw(base_size = 14) + |
154 | ! |
theme( |
155 | ! |
plot.title = element_text(hjust = 0.5), |
156 | ! |
plot.title.position = "plot", |
157 | ! |
plot.caption = element_text(hjust = 0), |
158 | ! |
plot.caption.position = "plot", |
159 | ! |
legend.title = element_blank(), |
160 | ! |
panel.grid = element_blank() |
161 |
) + |
|
162 | ! |
geom_segment( |
163 | ! |
aes(x = log10(folds[1]), y = log10(0), xend = log10(folds[1]), yend = log10(75)), |
164 | ! |
size = 0.25, |
165 | ! |
color = "grey" |
166 |
) + |
|
167 | ! |
geom_segment( |
168 | ! |
aes(x = log10(0), y = log10(folds[2]), xend = log10(65), yend = log10(folds[2])), |
169 | ! |
size = 0.25, |
170 | ! |
color = "grey" |
171 |
) + |
|
172 | ! |
geom_segment( |
173 | ! |
aes(x = log10(1), y = log10(0), xend = log10(1), yend = log10(1)), |
174 | ! |
size = 0.25, |
175 | ! |
color = "black" |
176 |
) + |
|
177 | ! |
geom_segment( |
178 | ! |
aes(x = log10(0), y = log10(1), xend = log10(1), yend = log10(1)), |
179 | ! |
size = 0.25, |
180 | ! |
color = "black" |
181 |
) + |
|
182 | ! |
annotate("text", label = paste0(folds[1], "XULN"), x = log10(folds[1]), y = log10(90)) + |
183 | ! |
annotate("text", label = paste0(folds[2], "XULN"), x = log10(85), y = log10(folds[2])) + |
184 | ! |
annotate("text", label = text[1], x = log10(0.2), y = log10(0.12)) + |
185 | ! |
annotate("text", label = text[2], x = log10(0.2), y = log10(80)) + |
186 | ! |
annotate("text", label = text[3], x = log10(40), y = log10(80)) + |
187 | ! |
annotate("text", label = text[4], x = log10(40), y = log10(0.12)) + |
188 | ! |
geom_point(aes( |
189 | ! |
x = log10(.data[[term_selected[1]]]), |
190 | ! |
y = log10(.data[[term_selected[2]]]), |
191 | ! |
shape = arm, |
192 | ! |
color = arm |
193 |
)) + |
|
194 | ! |
scale_shape_manual(values = c(1:n_distinct(arm))) |
195 | ||
196 | ! |
g <- ggplotGrob(p) |
197 | ! |
grid::grid.newpage() |
198 | ! |
grid::grid.draw(g) |
199 | ! |
invisible(g) |
200 |
} |
1 |
#' Patient Domain Profile |
|
2 |
#' |
|
3 |
#' Patient domain profile provides information for a specific subject that participated in the study. |
|
4 |
#' The plot includes relevant data for one subject in a user specified domain, including |
|
5 |
#' adverse events (\code{ADAE}), response (\code{ADRS}), concomitant medications |
|
6 |
#' (\code{ADCM}), exposure (\code{ADEX}), and laboratory (\code{ADLB}). |
|
7 |
#' |
|
8 |
#' @param domain string of domain name to be shown as y-axis label, default is `NULL` |
|
9 |
#' (no y-axis label shown) |
|
10 |
#' @param var_names character vector to identify each lane |
|
11 |
#' @param marker_pos Depending on the domain, this can be |
|
12 |
#' \itemize{ |
|
13 |
#' \item marker position numeric vector for domains \code{ADEX}, \code{ADLB}, and \code{ADRS} |
|
14 |
#' \item numeric data frame with two columns, start and end time marker position, |
|
15 |
#' for domains \code{ADAE} and \code{ADCM} |
|
16 |
#' } |
|
17 |
#' @param arrow_end numeric value indicates the end of arrow when arrows are requested |
|
18 |
#' @param xtick_at numeric vector with the locations of the x-axis tick marks |
|
19 |
#' @param line_col_list a list may contain \cr |
|
20 |
#' \itemize{ |
|
21 |
#' \item \code{line_col}: factor vector to specify color for segments , default is `NULL` |
|
22 |
#' (no line color is specified)\cr |
|
23 |
#' \item \code{line_col_opt} aesthetic values to map color values (named vector to map color values to each name). |
|
24 |
#' If not `NULL`, please make sure this contains all possible values for \code{line_col} values, |
|
25 |
#' otherwise color will be assigned by \code{\link[grDevices]{hcl.colors}} |
|
26 |
#' \item \code{line_col_legend}: a string to be displayed as line color legend title when \code{line_col} is specified, |
|
27 |
#' default is `NULL` (no legend title is displayed) |
|
28 |
#' } |
|
29 |
#' @param line_width numeric value for segment width, default is \code{line_width = 1} |
|
30 |
#' @param arrow_size numeric value for arrow size, default is \code{arrow_size = 0.1} |
|
31 |
#' @param no_enddate_extention numeric value for extending the arrow when end date is missing for \code{ADAE} |
|
32 |
#' or \code{ADCM} domain. Default is \code{no_enddate_extention = 0}. |
|
33 |
#' @param marker_col_list a list may contain \cr |
|
34 |
#' \itemize{ |
|
35 |
#' \item \code{marker_col} a factor vector to specify color for markers, |
|
36 |
#' default is `NULL` (no color markers is specified) |
|
37 |
#' \item \code{marker_col_opt} aesthetic values to map color values (named vector to map color values to each name) |
|
38 |
#' If not `NULL`, please make sure this contains all possible values for \code{marker_col} values, |
|
39 |
#' otherwise color will be assigned by \code{\link[grDevices]{hcl.colors}} |
|
40 |
#' \item \code{marker_col_legend} a string to be displayed as marker color legend title, default is `NULL` |
|
41 |
#' (no legend title is displayed) |
|
42 |
#' } |
|
43 |
#' @param marker_shape_list a list may contain \cr |
|
44 |
#' \itemize{ |
|
45 |
#' \item \code{marker_shape} factor vector to specify shape for markers, |
|
46 |
#' default is `NULL` (no shape marker is specified) |
|
47 |
#' \item \code{marker_shape_opt} aesthetic values to map shape values (named vector to map shape values to each name). |
|
48 |
#' If not `NULL`, please make sure this contains all possible values for \code{marker_shape} values, |
|
49 |
#' otherwise shape will be assigned by \code{ggplot} default |
|
50 |
#' \item \code{marker_shape_legend} string to be displayed as marker shape legend title, default is `NULL` |
|
51 |
#' (no legend title is displayed) |
|
52 |
#' } |
|
53 |
#' @param show_days_label boolean value for showing y-axis label, default is \code{TRUE} |
|
54 |
#' @param xlim numeric vector for x-axis limit, default is |
|
55 |
#' \code{xlim = c(-28, max(marker_pos) + 5)} |
|
56 |
#' @param xlab string to be shown as x-axis label, default is \code{"Study Day"} |
|
57 |
#' @param show_title boolean value for showing title of the plot, default is \code{TRUE} |
|
58 |
#' @param title string to be shown as title of the plot, default is `NULL` (no plot title is displayed) |
|
59 |
#' |
|
60 |
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com} |
|
61 |
#' @author Tina Cho (chot) \email{tina.cho@roche.com} |
|
62 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
63 |
#' @template author_qit3 |
|
64 |
#' |
|
65 |
#' @return plot object |
|
66 |
#' |
|
67 |
#' @export |
|
68 |
#' |
|
69 |
#' @examples |
|
70 |
#' library(dplyr) |
|
71 |
#' |
|
72 |
#' # ADSL |
|
73 |
#' ADSL <- osprey::rADSL %>% |
|
74 |
#' filter(USUBJID == rADSL$USUBJID[1]) %>% |
|
75 |
#' mutate( |
|
76 |
#' TRTSDT = as.Date(TRTSDTM), |
|
77 |
#' max_date = max(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE), |
|
78 |
#' max_day = as.numeric(as.Date(max_date) - as.Date(TRTSDT)) + 1 |
|
79 |
#' ) %>% |
|
80 |
#' select(USUBJID, STUDYID, TRTSDT, max_day) |
|
81 |
#' |
|
82 |
#' |
|
83 |
#' |
|
84 |
#' # Example 1 Exposure "ADEX" |
|
85 |
#' ADEX <- osprey::rADEX %>% |
|
86 |
#' select(USUBJID, STUDYID, ASTDTM, PARCAT2, AVAL, AVALU, PARAMCD) |
|
87 |
#' ADEX <- left_join(ADSL, ADEX, by = c("USUBJID", "STUDYID")) |
|
88 |
#' ADEX <- ADEX %>% |
|
89 |
#' filter(PARAMCD == "DOSE") %>% |
|
90 |
#' arrange(PARCAT2, PARAMCD) %>% |
|
91 |
#' mutate(diff = c(0, diff(AVAL, lag = 1))) %>% |
|
92 |
#' mutate( |
|
93 |
#' Modification = case_when( |
|
94 |
#' diff < 0 ~ "Decrease", |
|
95 |
#' diff > 0 ~ "Increase", |
|
96 |
#' diff == 0 ~ "None" |
|
97 |
#' ) |
|
98 |
#' ) %>% |
|
99 |
#' mutate( |
|
100 |
#' ASTDT_dur = as.numeric( |
|
101 |
#' as.Date( |
|
102 |
#' substr(as.character(ASTDTM), 1, 10) |
|
103 |
#' ) - as.Date(TRTSDT) + 1 |
|
104 |
#' ) |
|
105 |
#' ) |
|
106 |
#' |
|
107 |
#' p1 <- patient_domain_profile( |
|
108 |
#' domain = "Exposure (ADEX)", |
|
109 |
#' var_names = ADEX$PARCAT2, |
|
110 |
#' marker_pos = ADEX$ASTDT_dur, |
|
111 |
#' arrow_end = ADSL$max_day, |
|
112 |
#' xtick_at = waiver(), |
|
113 |
#' line_col_list = NULL, |
|
114 |
#' line_width = 1, |
|
115 |
#' arrow_size = 0.1, |
|
116 |
#' no_enddate_extention = 0, |
|
117 |
#' marker_col_list = list( |
|
118 |
#' marker_col = factor(ADEX$Modification), |
|
119 |
#' marker_col_opt = c("Increase" = "red", "Decrease" = "green", "None" = "blue"), |
|
120 |
#' marker_col_legend = NULL |
|
121 |
#' ), |
|
122 |
#' marker_shape_list = list( |
|
123 |
#' marker_shape = factor(ADEX$Modification), |
|
124 |
#' marker_shape_opt = c("Increase" = 24, "Decrease" = 25, "None" = 23), |
|
125 |
#' marker_shape_legend = "Dose Modification" |
|
126 |
#' ), |
|
127 |
#' show_days_label = TRUE, |
|
128 |
#' xlim = c(-28, ADSL$max_day), |
|
129 |
#' xlab = "Study Day", |
|
130 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
131 |
#' ) |
|
132 |
#' p1 |
|
133 |
#' |
|
134 |
#' # Example 2 Adverse Event "ADAE" |
|
135 |
#' # Note that ASTDY is represented by a circle and AENDY is represented by a square. |
|
136 |
#' # If AENDY and ASTDY occur on the same day only AENDY will be shown. |
|
137 |
#' |
|
138 |
#' # Adverse Event ADAE |
|
139 |
#' ADAE <- osprey::rADAE %>% |
|
140 |
#' select(USUBJID, STUDYID, AESOC, AEDECOD, AESER, AETOXGR, AEREL, ASTDY, AENDY) |
|
141 |
#' ADAE <- left_join(ADSL, ADAE, by = c("USUBJID", "STUDYID")) |
|
142 |
#' |
|
143 |
#' p2 <- patient_domain_profile( |
|
144 |
#' domain = "Adverse Event (ADAE)", |
|
145 |
#' var_names = ADAE$AEDECOD, |
|
146 |
#' marker_pos = ADAE[, c("ASTDY", "AENDY")], |
|
147 |
#' arrow_end = ADSL$max_day, |
|
148 |
#' xtick_at = waiver(), |
|
149 |
#' line_col_list = list( |
|
150 |
#' line_col = ADAE$AESER, |
|
151 |
#' line_col_legend = "Serious", |
|
152 |
#' line_col_opt = c("blue", "green") |
|
153 |
#' ), |
|
154 |
#' line_width = 1, |
|
155 |
#' arrow_size = 0.1, |
|
156 |
#' no_enddate_extention = 0, |
|
157 |
#' marker_col_list = list( |
|
158 |
#' marker_col = factor(ADAE$AETOXGR), |
|
159 |
#' marker_col_opt = c("3" = "yellow", "4" = "red"), |
|
160 |
#' marker_col_legend = NULL |
|
161 |
#' ), |
|
162 |
#' marker_shape_list = list( |
|
163 |
#' marker_shape = NULL, |
|
164 |
#' marker_shape_opt = NULL, |
|
165 |
#' marker_shape_legend = "Grade" |
|
166 |
#' ), |
|
167 |
#' show_days_label = TRUE, |
|
168 |
#' xlim = c(-28, ADSL$max_day), |
|
169 |
#' xlab = "Study Day", |
|
170 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
171 |
#' ) |
|
172 |
#' p2 |
|
173 |
#' |
|
174 |
#' # Example 3 Tumor Response "ADRS" |
|
175 |
#' ADRS <- osprey::rADRS %>% |
|
176 |
#' select(USUBJID, STUDYID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADTM) |
|
177 |
#' ADRS <- left_join(ADSL, ADRS, by = c("USUBJID", "STUDYID")) |
|
178 |
#' p3 <- patient_domain_profile( |
|
179 |
#' domain = "Tumor Response (ADRS)", |
|
180 |
#' var_names = ADRS$PARAMCD, |
|
181 |
#' marker_pos = ADRS$ADY, |
|
182 |
#' arrow_end = ADSL$max_day, |
|
183 |
#' xtick_at = waiver(), |
|
184 |
#' line_col_list = NULL, |
|
185 |
#' line_width = 1, |
|
186 |
#' arrow_size = 0.1, |
|
187 |
#' no_enddate_extention = 0, |
|
188 |
#' marker_col_list = list( |
|
189 |
#' marker_col = factor(ADRS$AVALC), |
|
190 |
#' marker_col_opt = c( |
|
191 |
#' "CR" = "green", "PR" = "blue", |
|
192 |
#' "SD" = "yellow", "PD" = "red", "NE" = "pink", |
|
193 |
#' "Y" = "lightblue", "N" = "darkred" |
|
194 |
#' ), |
|
195 |
#' marker_col_legend = NULL |
|
196 |
#' ), |
|
197 |
#' marker_shape_list = list( |
|
198 |
#' marker_shape = factor(ADRS$AVALC), |
|
199 |
#' marker_shape_opt = c( |
|
200 |
#' "CR" = 21, "PR" = 24, |
|
201 |
#' "SD" = 23, "PD" = 22, "NE" = 14, |
|
202 |
#' "Y" = 11, "N" = 8 |
|
203 |
#' ), |
|
204 |
#' marker_shape_legend = "Response" |
|
205 |
#' ), |
|
206 |
#' show_days_label = TRUE, |
|
207 |
#' xlim = c(-28, ADSL$max_day), |
|
208 |
#' xlab = "Study Day", |
|
209 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
210 |
#' ) |
|
211 |
#' p3 |
|
212 |
#' |
|
213 |
#' # Example 4 Concomitant Med "ADCM" |
|
214 |
#' ADCM <- osprey::rADCM %>% |
|
215 |
#' select(USUBJID, STUDYID, ASTDTM, AENDTM, CMDECOD, ASTDY, AENDY) |
|
216 |
#' ADCM <- left_join(ADSL, ADCM, by = c("USUBJID", "STUDYID")) |
|
217 |
#' p4 <- patient_domain_profile( |
|
218 |
#' domain = "Concomitant Med (ADCM)", |
|
219 |
#' var_names = ADCM$CMDECOD, |
|
220 |
#' marker_pos = ADCM[, c("ASTDY", "AENDY")], |
|
221 |
#' arrow_end = ADSL$max_day, |
|
222 |
#' xtick_at = waiver(), |
|
223 |
#' line_col_list = list(line_col_opt = "orange"), |
|
224 |
#' line_width = 1, |
|
225 |
#' arrow_size = 0.1, |
|
226 |
#' no_enddate_extention = 50, |
|
227 |
#' marker_col_list = list(marker_col_opt = "orange"), |
|
228 |
#' marker_shape_list = NULL, |
|
229 |
#' show_days_label = TRUE, |
|
230 |
#' xlim = c(-28, ADSL$max_day), |
|
231 |
#' xlab = "Study Day", |
|
232 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
233 |
#' ) |
|
234 |
#' p4 |
|
235 |
#' |
|
236 |
#' # Example 5 Laboratory "ADLB" |
|
237 |
#' ADLB <- osprey::rADLB %>% |
|
238 |
#' select( |
|
239 |
#' USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, |
|
240 |
#' ADTM, ADY, ATPTN, AVISITN, LBTESTCD, ANRIND |
|
241 |
#' ) |
|
242 |
#' ADLB <- left_join(ADSL, ADLB, by = c("USUBJID", "STUDYID")) |
|
243 |
#' |
|
244 |
#' ADLB <- ADLB %>% |
|
245 |
#' group_by(USUBJID) %>% |
|
246 |
#' mutate(ANRIND = factor(ANRIND, levels = c("LOW", "NORMAL", "HIGH"))) |
|
247 |
#' |
|
248 |
#' p5 <- patient_domain_profile( |
|
249 |
#' domain = "Laboratory (ADLB)", |
|
250 |
#' var_names = ADLB$LBTESTCD, |
|
251 |
#' marker_pos = ADLB$ADY, |
|
252 |
#' arrow_end = ADSL$max_day, |
|
253 |
#' xtick_at = waiver(), |
|
254 |
#' line_col_list = NULL, |
|
255 |
#' line_width = 1, |
|
256 |
#' arrow_size = 0.1, |
|
257 |
#' no_enddate_extention = 0, |
|
258 |
#' marker_col_list = list( |
|
259 |
#' marker_col = factor(ADLB$ANRIND), |
|
260 |
#' marker_col_opt = c( |
|
261 |
#' "HIGH" = "red", "LOW" = "blue", |
|
262 |
#' "NORMAL" = "green", "NA" = "green" |
|
263 |
#' ) |
|
264 |
#' ), |
|
265 |
#' marker_shape_list = list( |
|
266 |
#' marker_shape = factor(ADLB$ANRIND), |
|
267 |
#' marker_shape_opt = c( |
|
268 |
#' "HIGH" = 24, "LOW" = 25, |
|
269 |
#' "NORMAL" = 23, "NA" = 23 |
|
270 |
#' ), |
|
271 |
#' marker_shape_legend = "Labs Abnormality" |
|
272 |
#' ), |
|
273 |
#' show_days_label = TRUE, |
|
274 |
#' xlim = c(-30, ADSL$max_day), |
|
275 |
#' xlab = "Study Day", |
|
276 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
277 |
#' ) |
|
278 |
#' p5 |
|
279 |
patient_domain_profile <- function(domain = NULL, |
|
280 |
var_names, |
|
281 |
marker_pos, |
|
282 |
arrow_end, |
|
283 |
xtick_at = waiver(), |
|
284 |
line_col_list = NULL, |
|
285 |
line_width = 1, |
|
286 |
arrow_size = 0.1, |
|
287 |
no_enddate_extention = 0, |
|
288 |
marker_col_list = NULL, |
|
289 |
marker_shape_list = NULL, |
|
290 |
show_days_label = TRUE, |
|
291 |
xlim = c(-28, max(marker_pos) + 5), |
|
292 |
xlab = NULL, |
|
293 |
show_title = TRUE, |
|
294 |
title = NULL) { |
|
295 | ! |
line_col <- line_col_list[["line_col"]] |
296 | ! |
line_col_opt <- line_col_list[["line_col_opt"]] |
297 | ! |
line_col_legend <- line_col_list[["line_col_legend"]] |
298 | ||
299 | ! |
marker_col <- marker_col_list[["marker_col"]] |
300 | ! |
marker_col_opt <- marker_col_list[["marker_col_opt"]] |
301 | ! |
marker_col_legend <- marker_col_list[["marker_col_legend"]] |
302 | ||
303 | ! |
marker_shape <- marker_shape_list[["marker_shape"]] |
304 | ! |
marker_shape_opt <- marker_shape_list[["marker_shape_opt"]] |
305 | ! |
marker_shape_legend <- marker_shape_list[["marker_shape_legend"]] |
306 | ||
307 |
# check user input |
|
308 | ! |
stopifnot( |
309 | ! |
"invalid arguments: check that the length of input arguments are identical" = |
310 | ! |
length(unique(nrow(data.frame(var_names)), nrow(data.frame(marker_pos)), nrow(data.frame(arrow_end)))) == 1 |
311 |
) |
|
312 | ! |
stopifnot( |
313 | ! |
"invalid argument: check that marker_pos is either a vector or a data frame with two columns" = |
314 | ! |
ncol(data.frame(marker_pos)) <= 2 |
315 |
) |
|
316 | ! |
stopifnot( |
317 | ! |
"invalid arguments: check that the length of line_col is equal as other inputs" = |
318 | ! |
is.null(line_col) || length(line_col) == length(var_names) |
319 |
) |
|
320 | ! |
stopifnot( |
321 | ! |
"invalid arguments: check that the length of marker_col is equal as other inputs" = |
322 | ! |
is.null(marker_col) || length(marker_col) == length(var_names) |
323 |
) |
|
324 | ! |
stopifnot( |
325 | ! |
"invalid arguments: check that the length of marker_shape is equal as other inputs" = |
326 | ! |
is.null(marker_shape) || length(marker_shape) == length(var_names) |
327 |
) |
|
328 | ! |
checkmate::assert_numeric(xlim, len = 2) |
329 | ||
330 | ! |
marker_data <- data.frame( |
331 | ! |
var_names, |
332 | ! |
marker_pos = if (is.null(marker_pos)) to_n("x", length(var_names)) else marker_pos, |
333 | ! |
marker_shape = if (is.null(marker_shape)) to_n("x", length(var_names)) else marker_shape, |
334 | ! |
marker_col = if (is.null(marker_col)) to_n("x", length(var_names)) else marker_col |
335 |
) |
|
336 | ||
337 |
# plot lines |
|
338 | ! |
if (length(dim(marker_pos)) == 2) { |
339 | ! |
line_data <- data.frame( |
340 | ! |
var_names, |
341 | ! |
line_col = if (is.null(line_col)) to_n("x", length(var_names)) else line_col, |
342 | ! |
line_start = unname(dplyr::pull(marker_pos, 1)), |
343 | ! |
line_end = unname(dplyr::pull(marker_pos, 2)), |
344 | ! |
line_min = rep(xlim[1], length(var_names)), |
345 | ! |
line_max = rep(arrow_end + no_enddate_extention, length(var_names)) |
346 |
) |
|
347 | ! |
names(line_data) <- c("var_names", "line_col", "line_start", "line_end", "line_min", "line_max") |
348 | ||
349 | ! |
p <- ggplot() + |
350 | ! |
geom_segment( |
351 | ! |
data = line_data[!is.na(line_data$line_end), ], |
352 | ! |
aes( |
353 | ! |
x = var_names, |
354 | ! |
y = line_start, |
355 | ! |
xend = var_names, |
356 | ! |
yend = line_end, |
357 | ! |
color = line_col |
358 |
), |
|
359 | ! |
lineend = "round", linejoin = "round", |
360 | ! |
size = line_width, arrow = NULL, show.legend = NA, |
361 | ! |
na.rm = TRUE |
362 |
) + |
|
363 | ! |
scale_y_continuous(limits = xlim, breaks = xtick_at, expand = c(0, 0)) + |
364 | ! |
coord_flip(xlim = c(1, length(unique(var_names)))) + |
365 | ! |
geom_segment( |
366 | ! |
data = line_data[is.na(line_data$line_end) == TRUE, ], |
367 | ! |
aes( |
368 | ! |
x = var_names, |
369 | ! |
y = pmax(line_start, line_min, na.rm = TRUE), |
370 | ! |
xend = var_names, |
371 | ! |
yend = line_max, |
372 | ! |
color = line_col |
373 |
), |
|
374 | ! |
lineend = "round", linejoin = "round", |
375 | ! |
size = line_width, show.legend = FALSE, |
376 | ! |
arrow = arrow(length = grid::unit(arrow_size, "inches")), |
377 | ! |
na.rm = TRUE |
378 |
) |
|
379 | ||
380 | ! |
if (is.null(line_col_opt)) { |
381 | ! |
line_col_opt <- if (!is.null(getOption("ggplot2.discrete.colour"))) { |
382 | ! |
getOption("ggplot2.discrete.colour") |
383 |
} else { |
|
384 | ! |
grDevices::hcl.colors(length(levels(line_data$line_col))) |
385 |
} |
|
386 |
} |
|
387 | ||
388 | ! |
p <- p + |
389 | ! |
scale_color_manual( |
390 | ! |
breaks = line_data$line_col, |
391 | ! |
values = line_col_opt, |
392 | ! |
limits = levels(line_data$line_col) |
393 |
) |
|
394 | ||
395 | ! |
if (!is.null(line_col)) { |
396 | ! |
p <- p + guides(color = guide_legend(line_col_legend, order = 1)) |
397 |
} else { |
|
398 | ! |
p <- p + guides(color = "none") |
399 |
} |
|
400 | ||
401 |
# plot markers |
|
402 | ! |
p <- p + |
403 | ! |
geom_point( |
404 | ! |
data = marker_data, |
405 | ! |
aes(x = var_names, y = marker_data[, 2], fill = factor(marker_col)), |
406 | ! |
shape = 21, |
407 | ! |
size = 5, |
408 | ! |
na.rm = TRUE |
409 |
) + |
|
410 | ! |
geom_point( |
411 | ! |
data = marker_data, |
412 | ! |
aes(x = var_names, y = marker_data[, 3], fill = factor(marker_col)), |
413 | ! |
shape = 22, |
414 | ! |
size = 3, |
415 | ! |
na.rm = TRUE |
416 |
) |
|
417 | ||
418 | ! |
if (is.null(marker_col_opt)) { |
419 | ! |
marker_col_opt <- if (!is.null(getOption("ggplot2.discrete.colour"))) { |
420 | ! |
getOption("ggplot2.discrete.colour") |
421 |
} else { |
|
422 | ! |
grDevices::hcl.colors(length(levels(marker_data$marker_col))) |
423 |
} |
|
424 |
} |
|
425 | ! |
p <- p + |
426 | ! |
scale_fill_manual( |
427 | ! |
breaks = marker_data$marker_col, |
428 | ! |
values = marker_col_opt |
429 |
) |
|
430 | ||
431 | ||
432 | ! |
p <- p + theme_bw() + |
433 | ! |
theme( |
434 | ! |
panel.background = element_blank(), |
435 | ! |
panel.grid = element_blank(), |
436 | ! |
axis.line = element_line(colour = "black") |
437 |
) + |
|
438 | ! |
ylab(xlab) + xlab(domain) |
439 | ||
440 | ! |
if (!is.null(marker_col)) { |
441 | ! |
p <- p + guides(fill = guide_legend(marker_col_legend, order = 2)) |
442 |
} else { |
|
443 | ! |
p <- p + guides(fill = "none") |
444 |
} |
|
445 | ||
446 | ! |
p <- p + guides(shape = guide_legend("Shape", order = 3)) |
447 | ||
448 | ! |
p <- p + scale_shape_manual(values = c(21, 22)) + |
449 | ! |
guides(shape = guide_legend(title = "Shape", override.aes = list(label = c("Start", "End")), order = 3)) |
450 | ||
451 | ! |
if (!is.null(marker_shape)) { |
452 | ! |
p <- p + guides(shape = guide_legend(marker_shape_legend, order = 3)) |
453 |
} else { |
|
454 | ! |
p <- p + guides(shape = "none") |
455 |
} |
|
456 |
} else { |
|
457 | ! |
p <- ggplot() + |
458 | ! |
geom_point( |
459 | ! |
data = marker_data, |
460 | ! |
aes( |
461 | ! |
x = var_names, |
462 | ! |
y = marker_pos, |
463 | ! |
shape = marker_shape, |
464 | ! |
fill = marker_col |
465 |
), |
|
466 | ! |
size = 3, na.rm = TRUE |
467 |
) + |
|
468 | ! |
scale_y_continuous(limits = xlim, breaks = xtick_at, expand = c(0, 0)) + |
469 | ! |
coord_flip(xlim = c(1, length(unique(var_names)))) + |
470 | ! |
theme_bw() + |
471 | ! |
theme( |
472 | ! |
panel.background = element_blank(), |
473 | ! |
panel.grid = element_blank(), |
474 | ! |
axis.line = element_line(colour = "black") |
475 |
) + |
|
476 | ! |
ylab(xlab) + |
477 | ! |
xlab(domain) |
478 | ||
479 | ! |
if (is.null(marker_col_legend)) { |
480 | ! |
if (length(setdiff(marker_col, marker_shape)) == 0) { |
481 | ! |
marker_col_legend <- marker_shape_legend |
482 |
} |
|
483 |
} |
|
484 | ||
485 | ! |
if (is.null(marker_shape_legend)) { |
486 | ! |
if (length(setdiff(marker_col, marker_shape)) == 0) { |
487 | ! |
marker_shape_legend <- marker_col_legend |
488 |
} |
|
489 |
} |
|
490 | ||
491 | ! |
if (is.null(marker_col_opt)) { |
492 | ! |
if (!is.null(getOption("ggplot2.discrete.colour"))) { |
493 | ! |
marker_col_opt <- getOption("ggplot2.discrete.colour") |
494 |
} else { |
|
495 | ! |
marker_col_opt <- grDevices::hcl.colors(length(levels(marker_data$marker_col))) |
496 |
} |
|
497 |
} |
|
498 | ! |
p <- p + |
499 | ! |
scale_fill_manual( |
500 | ! |
name = marker_col_legend, |
501 | ! |
breaks = marker_data$marker_col, |
502 | ! |
values = marker_col_opt |
503 |
) |
|
504 | ||
505 | ! |
if (is.null(marker_shape_opt)) marker_shape_opt <- 1:25 |
506 | ! |
p <- p + scale_shape_manual( |
507 | ! |
name = marker_shape_legend, |
508 | ! |
breaks = marker_data$marker_shape, |
509 | ! |
values = marker_shape_opt |
510 |
) |
|
511 |
} |
|
512 | ||
513 |
# plot title and labels |
|
514 | ! |
if (show_title) { |
515 | ! |
p <- p + |
516 | ! |
labs(title = title) + |
517 | ! |
theme(plot.title = element_text(face = "bold")) |
518 |
} |
|
519 | ||
520 |
# Plot y axis label |
|
521 | ! |
if (show_days_label == FALSE) { |
522 | ! |
p <- p + theme_bw() + |
523 | ! |
theme( |
524 | ! |
panel.background = element_blank(), |
525 | ! |
panel.grid = element_blank(), |
526 | ! |
axis.line = element_line(colour = "black"), |
527 | ! |
axis.text.x = element_blank(), |
528 | ! |
axis.title.x = element_blank(), |
529 | ! |
axis.title.y = element_text(size = rel(0.8)), |
530 | ! |
legend.title = element_text(size = 10), |
531 | ! |
legend.spacing.y = grid::unit(0, "cm"), |
532 | ! |
legend.key.height = grid::unit(1, "line"), |
533 | ! |
legend.margin = margin(t = 0, b = 0, r = 0.5, l = 0, unit = "cm"), |
534 | ! |
plot.margin = margin(t = 0, b = 0, r = 0.5, l = 0.5, unit = "cm") |
535 |
) |
|
536 |
} else { |
|
537 | ! |
p <- p + theme_bw() + |
538 | ! |
theme( |
539 | ! |
panel.background = element_blank(), |
540 | ! |
panel.grid = element_blank(), |
541 | ! |
axis.line = element_line(colour = "black"), |
542 | ! |
legend.title = element_text(size = 10), |
543 | ! |
legend.spacing.y = grid::unit(0, "cm"), |
544 | ! |
legend.key.height = grid::unit(1, "line"), |
545 | ! |
legend.margin = margin(t = 0, b = 0, r = 0.5, l = 0, unit = "cm"), |
546 | ! |
plot.margin = margin(t = 0, b = 0, l = 0.5, r = 0.5, unit = "cm") |
547 |
) |
|
548 |
} |
|
549 | ||
550 | ! |
p |
551 |
} |
|
552 | ||
553 |
#' Patient Profile Plot |
|
554 |
#' |
|
555 |
#' Patient profile plot provides detailed information for a specific subject participating in the study. |
|
556 |
#' The plot includes relevant data for one subject that can help correlate adverse events, response, |
|
557 |
#' concomitant medications, exposure, and laboratory. The plotting of patient profile is modularized, with |
|
558 |
#' each domain plot generated by function \code{\link{patient_domain_profile}}. This \code{\link{g_patient_profile}} |
|
559 |
#' function assembles all requested domain plots into one patient profile. |
|
560 |
#' \code{ADSL}, \code{ADEX}, \code{ADAE}, \code{ADRS}, \code{ADCM} and \code{ADLB} data must be provided. |
|
561 |
#' The plot output will not include domains with data unspecified |
|
562 |
#' |
|
563 |
#' @param ex list may contain |
|
564 |
#' \itemize{ |
|
565 |
#' \item \code{data} dataframe for \code{ADEX} domain dataset |
|
566 |
#' \item \code{var} vector to identify each lane of \code{ADEX} domain plot |
|
567 |
#' } |
|
568 |
#' @param ae list may contain |
|
569 |
#' \itemize{ |
|
570 |
#' \item \code{data} dataframe for \code{ADAE} domain dataset |
|
571 |
#' \item \code{var} vector to identify each lane of \code{ADAE} plot |
|
572 |
#' \item \code{line_col} factor vector to specify color for segments of \code{ADAE} plot |
|
573 |
#' \item \code{line_col_legend} string to be displayed as line color legend title of \code{ADAE} plot |
|
574 |
#' \item \code{line_col_opt} aesthetic values to map line color values of \code{ADAE} plot |
|
575 |
#' (named vector to map color values to each name). |
|
576 |
#' If not `NULL`, please make sure this contains all possible values for \code{line_col} values, |
|
577 |
#' otherwise color will be assigned by \code{ggplot} default, please note that `NULL` needs to be |
|
578 |
#' specified |
|
579 |
#' } |
|
580 |
#' @param rs list may contain |
|
581 |
#' \itemize{ |
|
582 |
#' \item \code{data} dataframe for \code{ADRS} domain dataset |
|
583 |
#' \item \code{var} vector to identify each lane of \code{ADRS} domain plot |
|
584 |
#' } |
|
585 |
#' @param cm list may contain |
|
586 |
#' \itemize{ |
|
587 |
#' \item \code{data} dataframe for \code{ADCM} domain dataset |
|
588 |
#' \item \code{var} vector to identify each lane of \code{ADCM} domain plot |
|
589 |
#' } |
|
590 |
#' @param lb list may contain |
|
591 |
#' \itemize{ |
|
592 |
#' \item \code{data} dataframe for \code{ADLB} domain dataset |
|
593 |
#' \item \code{var} vector to identify each lane of \code{ADLB} domain plot |
|
594 |
#' } |
|
595 |
#' @param arrow_end_day numeric value indicates the end of arrow when arrows are requested |
|
596 |
#' @param xlim numeric vector for x-axis limit that will be shared by all domain plots, default is |
|
597 |
#' \code{xlim = c(-28, 365)} |
|
598 |
#' @param xlab string to be shown as x-axis label, default is \code{"Study Day"} |
|
599 |
#' @param title string to be shown as title of the plot, default is \code{"Patient Profile"} |
|
600 |
#' |
|
601 |
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com} |
|
602 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
603 |
#' @template author_qit3 |
|
604 |
#' |
|
605 |
#' @return plot object |
|
606 |
#' |
|
607 |
#' @export |
|
608 |
#' |
|
609 |
#' @seealso \code{\link{patient_domain_profile}} |
|
610 |
#' |
|
611 |
#' @examples |
|
612 |
#' library(dplyr) |
|
613 |
#' library(nestcolor) |
|
614 |
#' # ADSL |
|
615 |
#' ADSL <- osprey::rADSL %>% |
|
616 |
#' filter(USUBJID == rADSL$USUBJID[1]) %>% |
|
617 |
#' mutate( |
|
618 |
#' TRTSDT = as.Date(TRTSDTM), |
|
619 |
#' max_date = max(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE), |
|
620 |
#' max_day = as.numeric(as.Date(max_date) - as.Date(TRTSDT)) + 1 |
|
621 |
#' ) %>% |
|
622 |
#' select(USUBJID, STUDYID, TRTSDT, max_day) |
|
623 |
#' |
|
624 |
#' |
|
625 |
#' # ADEX |
|
626 |
#' ADEX <- osprey::rADEX %>% |
|
627 |
#' select(USUBJID, STUDYID, ASTDTM, PARCAT2, AVAL, AVALU, PARAMCD) |
|
628 |
#' ADEX <- left_join(ADSL, ADEX, by = c("USUBJID", "STUDYID")) |
|
629 |
#' |
|
630 |
#' ADEX <- ADEX %>% |
|
631 |
#' filter(PARAMCD == "DOSE") %>% |
|
632 |
#' arrange(PARCAT2, PARAMCD) %>% |
|
633 |
#' mutate(diff = c(0, diff(AVAL, lag = 1))) %>% |
|
634 |
#' mutate(Modification = case_when( |
|
635 |
#' diff < 0 ~ "Decrease", |
|
636 |
#' diff > 0 ~ "Increase", |
|
637 |
#' diff == 0 ~ "None" |
|
638 |
#' )) %>% |
|
639 |
#' mutate(ASTDT_dur = as.numeric( |
|
640 |
#' as.Date(substr(as.character(ASTDTM), 1, 10)) - |
|
641 |
#' as.Date(TRTSDT) + 1 |
|
642 |
#' )) |
|
643 |
#' |
|
644 |
#' # ADAE |
|
645 |
#' ADAE <- osprey::rADAE %>% |
|
646 |
#' select(USUBJID, STUDYID, AESOC, AEDECOD, AESER, AETOXGR, AEREL, ASTDY, AENDY) |
|
647 |
#' ADAE <- left_join(ADSL, ADAE, by = c("USUBJID", "STUDYID")) |
|
648 |
#' |
|
649 |
#' # ADRS |
|
650 |
#' ADRS <- osprey::rADRS %>% |
|
651 |
#' select(USUBJID, STUDYID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADTM) |
|
652 |
#' ADRS <- left_join(ADSL, ADRS, by = c("USUBJID", "STUDYID")) |
|
653 |
#' |
|
654 |
#' # ADCM |
|
655 |
#' ADCM <- osprey::rADCM %>% |
|
656 |
#' select(USUBJID, STUDYID, ASTDTM, AENDTM, CMDECOD, ASTDY, AENDY) |
|
657 |
#' ADCM <- left_join(ADSL, ADCM, by = c("USUBJID", "STUDYID")) |
|
658 |
#' |
|
659 |
#' # ADLB |
|
660 |
#' ADLB <- osprey::rADLB %>% |
|
661 |
#' select( |
|
662 |
#' USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, ADTM, |
|
663 |
#' ADY, ATPTN, AVISITN, LBTESTCD, ANRIND |
|
664 |
#' ) |
|
665 |
#' ADLB <- left_join(ADSL, ADLB, by = c("USUBJID", "STUDYID")) |
|
666 |
#' |
|
667 |
#' ADLB <- ADLB %>% |
|
668 |
#' group_by(USUBJID) %>% |
|
669 |
#' mutate(ANRIND = factor(ANRIND, levels = c("LOW", "NORMAL", "HIGH"))) |
|
670 |
#' |
|
671 |
#' # Example Patient Profile plot 5 domains |
|
672 |
#' g_patient_profile( |
|
673 |
#' ex = list( |
|
674 |
#' data = ADEX, |
|
675 |
#' var = ADEX$PARCAT2 |
|
676 |
#' ), |
|
677 |
#' ae = list( |
|
678 |
#' data = ADAE, |
|
679 |
#' var = ADAE$AEDECOD, |
|
680 |
#' line_col = factor(ADAE$AESER), |
|
681 |
#' line_col_legend = "Serious", |
|
682 |
#' line_col_opt = c("Y" = "red", "N" = "blue") |
|
683 |
#' ), |
|
684 |
#' rs = list( |
|
685 |
#' data = ADRS, |
|
686 |
#' var = ADRS$PARAMCD |
|
687 |
#' ), |
|
688 |
#' cm = list( |
|
689 |
#' data = ADCM, |
|
690 |
#' var = ADCM$CMDECOD |
|
691 |
#' ), |
|
692 |
#' lb = list( |
|
693 |
#' data = ADLB, |
|
694 |
#' var = ADLB$LBTESTCD |
|
695 |
#' ), |
|
696 |
#' arrow_end_day = ADSL$max_day, |
|
697 |
#' xlim = c(-28, ADSL$max_day), |
|
698 |
#' xlab = "Study Day", |
|
699 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
700 |
#' ) |
|
701 |
#' |
|
702 |
#' # Example Patient Profile plot without ADCM and ADLB |
|
703 |
#' g_patient_profile( |
|
704 |
#' ex = list( |
|
705 |
#' data = ADEX, |
|
706 |
#' var = ADEX$PARCAT2 |
|
707 |
#' ), |
|
708 |
#' ae = list( |
|
709 |
#' data = ADAE, |
|
710 |
#' var = ADAE$AEDECOD, |
|
711 |
#' line_col = factor(ADAE$AESER), |
|
712 |
#' line_col_legend = "Serious", |
|
713 |
#' line_col_opt = c("Y" = "red", "N" = "blue") |
|
714 |
#' ), |
|
715 |
#' rs = list( |
|
716 |
#' data = ADRS, |
|
717 |
#' var = ADRS$PARAMCD |
|
718 |
#' ), |
|
719 |
#' arrow_end_day = ADSL$max_day, |
|
720 |
#' xlim = c(-28, ADSL$max_day), |
|
721 |
#' xlab = "Study Day", |
|
722 |
#' title = paste("Patient Profile: ", ADSL$USUBJID) |
|
723 |
#' ) |
|
724 |
g_patient_profile <- function(ex = NULL, |
|
725 |
ae = NULL, |
|
726 |
rs = NULL, |
|
727 |
cm = NULL, |
|
728 |
lb = NULL, |
|
729 |
arrow_end_day, |
|
730 |
xlim = c(-28, 365), |
|
731 |
xlab = "Study Day", |
|
732 |
title = "Patient Profile") { |
|
733 | ! |
domains <- list(ex = ex, ae = ae, rs = rs, cm = cm, lb = lb) |
734 | ! |
select <- mapply(domain_check, domains, names(domains)) |
735 | ! |
names(select) <- names(domains) |
736 | ||
737 | ! |
show_days_label <- c(FALSE, FALSE, FALSE, FALSE, FALSE) |
738 | ! |
show_days_label[max(which(select == TRUE))] <- TRUE |
739 | ||
740 | ! |
show_title <- c(FALSE, FALSE, FALSE, FALSE, FALSE) |
741 | ! |
show_title[min(which(select == TRUE))] <- TRUE |
742 | ||
743 | ! |
if (!is.null(getOption("ggplot2.discrete.colour"))) { |
744 | ! |
cols <- getOption("ggplot2.discrete.colour") |
745 |
} else { |
|
746 | ! |
cols <- NULL |
747 |
} |
|
748 | ||
749 |
# Domain "ADEX" |
|
750 | ! |
if (select["ex"]) { |
751 | ! |
p1 <- patient_domain_profile( |
752 | ! |
domain = "Exposure (ADEX)", |
753 | ! |
var_names = ex$var, |
754 | ! |
marker_pos = ex$data$ASTDT_dur, |
755 | ! |
arrow_end = arrow_end_day, |
756 | ! |
xtick_at = waiver(), |
757 | ! |
line_col_list = NULL, |
758 | ! |
line_width = 1, |
759 | ! |
arrow_size = 0.1, |
760 | ! |
no_enddate_extention = 0, |
761 | ! |
marker_col_list = list( |
762 | ! |
marker_col = factor(ex$data$Modification), |
763 | ! |
marker_col_opt = if (!is.null(cols)) cols else c("Increase" = "red", "Decrease" = "green", "None" = "blue") |
764 |
), |
|
765 | ! |
marker_shape_list = list( |
766 | ! |
marker_shape = factor(ex$data$Modification), |
767 | ! |
marker_shape_opt = c("Increase" = 24, "Decrease" = 25, "None" = 23), |
768 | ! |
marker_shape_legend = "Dose Modification" |
769 |
), |
|
770 | ! |
show_days_label = show_days_label[1], |
771 | ! |
xlim = xlim, |
772 | ! |
xlab = xlab, |
773 | ! |
show_title = show_title[1], |
774 | ! |
title = title |
775 |
) |
|
776 |
} else { |
|
777 | ! |
p1 <- NULL |
778 |
} |
|
779 |
# Domain "ADAE" |
|
780 | ! |
if (select["ae"]) { |
781 | ! |
p2 <- patient_domain_profile( |
782 | ! |
domain = "Adverse Event (ADAE)", |
783 | ! |
var_names = ae$var, |
784 | ! |
marker_pos = ae$data[, c("ASTDY", "AENDY")], |
785 | ! |
arrow_end = arrow_end_day, |
786 | ! |
xtick_at = waiver(), |
787 | ! |
line_col_list = list( |
788 | ! |
line_col = ae$line_col, |
789 | ! |
line_col_legend = ae$line_col_legend, |
790 | ! |
line_col_opt = ae$line_col_opt |
791 |
), |
|
792 | ! |
line_width = 1, |
793 | ! |
arrow_size = 0.1, |
794 | ! |
no_enddate_extention = 0.1, |
795 | ! |
marker_col_list = list( |
796 | ! |
marker_col = factor(ae$data$AETOXGR), |
797 | ! |
marker_col_opt = if (!is.null(cols)) { |
798 | ! |
cols |
799 |
} else { |
|
800 | ! |
c( |
801 | ! |
"1" = "green", "2" = "blue", "3" = "yellow", "4" = "orange", "5" = "red" |
802 |
) |
|
803 |
}, |
|
804 | ! |
marker_col_legend = "Grade" |
805 |
), |
|
806 | ! |
marker_shape_list = NULL, |
807 | ! |
show_days_label = show_days_label[2], |
808 | ! |
xlim = xlim, |
809 | ! |
xlab = xlab, |
810 | ! |
show_title = show_title[2], |
811 | ! |
title = title |
812 |
) |
|
813 |
} else { |
|
814 | ! |
p2 <- NULL |
815 |
} |
|
816 | ||
817 | ||
818 |
# Domain "ADRS" |
|
819 | ! |
if (select["rs"]) { |
820 | ! |
p3 <- patient_domain_profile( |
821 | ! |
domain = "Response (ADRS)", |
822 | ! |
var_names = rs$var, |
823 | ! |
marker_pos = rs$data$ADY, |
824 | ! |
arrow_end = arrow_end_day, |
825 | ! |
xtick_at = waiver(), |
826 | ! |
line_col_list = NULL, |
827 | ! |
line_width = 1, |
828 | ! |
arrow_size = 0.1, |
829 | ! |
no_enddate_extention = 0, |
830 | ! |
marker_col_list = list( |
831 | ! |
marker_col = factor(rs$data$AVALC), |
832 | ! |
marker_col_opt = if (!is.null(cols)) { |
833 | ! |
cols |
834 |
} else { |
|
835 | ! |
c( |
836 | ! |
"CR" = "green", "PR" = "blue", "SD" = "yellow", "PD" = "red", |
837 | ! |
"NE" = "pink", "Y" = "lightblue", "N" = "darkred" |
838 |
) |
|
839 |
} |
|
840 |
), |
|
841 | ! |
marker_shape_list = list( |
842 | ! |
marker_shape = factor(rs$data$AVALC), |
843 | ! |
marker_shape_opt = c("CR" = 21, "PR" = 24, "SD" = 23, "PD" = 22, "NE" = 14, "Y" = 11, "N" = 8), |
844 | ! |
marker_shape_legend = "Response" |
845 |
), |
|
846 | ! |
show_days_label = show_days_label[3], |
847 | ! |
xlim = xlim, |
848 | ! |
xlab = xlab, |
849 | ! |
show_title = show_title[3], |
850 | ! |
title = title |
851 |
) |
|
852 |
} else { |
|
853 | ! |
p3 <- NULL |
854 |
} |
|
855 | ||
856 | ||
857 |
# Domain "ADCM" |
|
858 | ! |
if (select["cm"]) { |
859 | ! |
p4 <- patient_domain_profile( |
860 | ! |
domain = "Conmed (ADCM)", |
861 | ! |
var_names = cm$var, |
862 | ! |
marker_pos = cm$data[, c("ASTDY", "AENDY")], |
863 | ! |
arrow_end = arrow_end_day, |
864 | ! |
xtick_at = waiver(), |
865 | ! |
line_col_list = list(line_col_opt = if (!is.null(cols)) cols else "orange"), |
866 | ! |
line_width = 1, |
867 | ! |
arrow_size = 0.1, |
868 | ! |
no_enddate_extention = 0.1, |
869 | ! |
marker_col_list = list(marker_col_opt = if (!is.null(cols)) cols else "orange"), |
870 | ! |
marker_shape_list = NULL, |
871 | ! |
show_days_label = show_days_label[4], |
872 | ! |
xlim = xlim, |
873 | ! |
xlab = xlab, |
874 | ! |
show_title = show_title[4], |
875 | ! |
title = title |
876 |
) |
|
877 |
} else { |
|
878 | ! |
p4 <- NULL |
879 |
} |
|
880 | ||
881 |
# Domain "ADLB" |
|
882 | ! |
if (select["lb"]) { |
883 | ! |
p5 <- patient_domain_profile( |
884 | ! |
domain = "Laboratory (ADLB)", |
885 | ! |
var_names = lb$var, |
886 | ! |
marker_pos = lb$data$ADY, |
887 | ! |
arrow_end = arrow_end_day, |
888 | ! |
xtick_at = waiver(), |
889 | ! |
line_col_list = NULL, |
890 | ! |
line_width = 1, |
891 | ! |
arrow_size = 0.1, |
892 | ! |
no_enddate_extention = 0, |
893 | ! |
marker_col_list = list( |
894 | ! |
marker_col = factor(lb$data$ANRIND), |
895 | ! |
marker_col_opt = if (!is.null(cols)) cols else c("HIGH" = "red", "LOW" = "blue", "NORMAL" = "green") |
896 |
), |
|
897 | ! |
marker_shape_list = list( |
898 | ! |
marker_shape = factor(lb$data$ANRIND), |
899 | ! |
marker_shape_opt = c("HIGH" = 24, "LOW" = 25, "NORMAL" = 23), |
900 | ! |
marker_shape_legend = "Labs Abnormality" |
901 |
), |
|
902 | ! |
show_days_label = show_days_label[5], |
903 | ! |
xlim = xlim, |
904 | ! |
xlab = xlab, |
905 | ! |
show_title = show_title[5], |
906 | ! |
title = title |
907 |
) |
|
908 |
} else { |
|
909 | ! |
p5 <- NULL |
910 |
} |
|
911 | ||
912 |
# Assemble domain plots into patient profile plot |
|
913 | ! |
plot_list <- list(p1, p2, p3, p4, p5) |
914 | ||
915 | ! |
plot_list <- plot_list[select] |
916 |
# distribute space by number of levels in each domain |
|
917 | ! |
var_list <- list(ex$var, ae$var, rs$var, cm$var, lb$var) |
918 | ! |
var_list <- var_list %>% |
919 | ! |
lapply(unique) %>% |
920 | ! |
lapply(length) %>% |
921 | ! |
unlist() %>% |
922 | ! |
cbind(.data, select) %>% |
923 | ! |
as.data.frame() %>% |
924 |
# keep the selected domains |
|
925 | ! |
dplyr::filter(select == TRUE) %>% |
926 | ! |
dplyr::mutate(nline_dat = ifelse(. <= 10 & . > 0, 10, .)) %>% |
927 |
# relative height |
|
928 | ! |
dplyr::mutate(sbplt_ht = unlist(nline_dat) / sum(unlist(nline_dat))) |
929 | ||
930 | ! |
cowplot::plot_grid( |
931 | ! |
plotlist = plot_list, |
932 | ! |
nrow = nrow(var_list), |
933 | ! |
align = "v", |
934 | ! |
axis = "lr", |
935 | ! |
rel_heights = var_list$sbplt_ht |
936 |
) |
|
937 |
} |
|
938 | ||
939 |
#' a helper function for g_patient_profile to check whether the domain has data available |
|
940 |
#' @param domain domain input from g_patient_profile |
|
941 |
#' @param name domain names |
|
942 |
#' @keywords internal |
|
943 |
domain_check <- function(domain, name) { |
|
944 | ! |
if (is.null(domain)) { |
945 | ! |
select <- FALSE |
946 |
} else { |
|
947 | ! |
select <- TRUE |
948 | ! |
if (dim(domain$data)[1] == 0 || is.null(domain$data)) { |
949 | ! |
warning(paste("No", name, "data for this subject")) |
950 | ! |
select <- FALSE |
951 |
} |
|
952 |
} |
|
953 | ! |
return(select) |
954 |
} |
1 |
#' Heatmap by Grade |
|
2 |
#' |
|
3 |
#' This function plots heatmap |
|
4 |
#' |
|
5 |
#' @param id_var (`character`)\cr name of the column that contains the unique subject identifier shared by all data |
|
6 |
#' Usually it is \code{"USUBJID"}. |
|
7 |
#' @param exp_data (`data.frame`)\cr exposure data. Usually it is \code{ADEX}. |
|
8 |
#' @param visit_var (`character`)\cr name of the column that contains the analysis visit. Usually it is \code{"AVISIT"} |
|
9 |
#' @param ongo_var (`character`)\cr name of the column in \code{exp_data} that contains the logical variable |
|
10 |
#' indicating whether the treatment is still ongoing. |
|
11 |
#' Usually it can be derived from \code{EOSSTT} |
|
12 |
#' @param anno_data (`data.frame`)\cr annotation data that contains subject level characteristics. |
|
13 |
#' Usually it is \code{ADSL} |
|
14 |
#' @param anno_var (`character`) a vector of columns name(s) to include for the annotation |
|
15 |
#' @param heat_data (`data.frame`)\cr data frame that contains the information needed for the text over heatmap |
|
16 |
#' Usually it is \code{ADCM}. |
|
17 |
#' @param heat_color_var (`character`)\cr name of the column that contains the heat grade |
|
18 |
#' @param heat_color_opt optional, (`character`)\cr a named vector that maps the names to heat colors |
|
19 |
#' @param conmed_data optional, (`data.frame`)\cr concomitant medicine data. Usually it is \code{ADCM} |
|
20 |
#' default is `NULL` (no `conmed` plotted) |
|
21 |
#' @param conmed_var optional, (`character`)\cr concomitant medicine variable name. Must be a column name in |
|
22 |
#' `conmed_data` when `conmed_data` is provided. default is `NULL` (no `conmed` plotted) |
|
23 |
#' @param conmed_color_opt optional, (`character`)\cr vector of color name(s) to `conmed_data` |
|
24 |
#' @param xlab optional, (`character`)\cr string to be shown as x-axis label, default is \code{"Visit"} |
|
25 |
#' @param title (`character`)\cr string to be shown as title of the plot. |
|
26 |
#' default is `NULL` (no plot title is displayed) |
|
27 |
#' |
|
28 |
#' @export |
|
29 |
#' |
|
30 |
#' @author Nina Qi (qit3) \email{qit3@gene.com} |
|
31 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
32 |
#' |
|
33 |
#' @examples |
|
34 |
#' library(dplyr) |
|
35 |
#' |
|
36 |
#' ADSL <- osprey::rADSL %>% slice(1:30) |
|
37 |
#' ADEX <- osprey::rADEX %>% filter(USUBJID %in% ADSL$USUBJID) |
|
38 |
#' ADAE <- osprey::rADAE %>% filter(USUBJID %in% ADSL$USUBJID) |
|
39 |
#' ADCM <- osprey::rADCM %>% filter(USUBJID %in% ADSL$USUBJID) |
|
40 |
#' # function to derive AVISIT from ADEX |
|
41 |
#' add_visit <- function(data_need_visit) { |
|
42 |
#' visit_dates <- ADEX %>% |
|
43 |
#' filter(PARAMCD == "DOSE") %>% |
|
44 |
#' distinct(USUBJID, AVISIT, ASTDTM) %>% |
|
45 |
#' group_by(USUBJID) %>% |
|
46 |
#' arrange(ASTDTM) %>% |
|
47 |
#' mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>% |
|
48 |
#' rename(this_vis = ASTDTM) |
|
49 |
#' data_visit <- data_need_visit %>% |
|
50 |
#' select(USUBJID, ASTDTM) %>% |
|
51 |
#' left_join(visit_dates, by = "USUBJID") %>% |
|
52 |
#' filter(ASTDTM > this_vis & (ASTDTM < next_vis | is_last == TRUE)) %>% |
|
53 |
#' left_join(data_need_visit) |
|
54 |
#' return(data_visit) |
|
55 |
#' } |
|
56 |
#' # add AVISIT in ADAE and ADCM |
|
57 |
#' ADAE <- add_visit(ADAE) |
|
58 |
#' ADCM <- add_visit(ADCM) |
|
59 |
#' exp_data <- ADEX %>% |
|
60 |
#' filter(PARCAT1 == "INDIVIDUAL") %>% |
|
61 |
#' group_by(USUBJID) %>% |
|
62 |
#' # create a shorter subject identifier |
|
63 |
#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>% |
|
64 |
#' mutate(ongo_var = (EOSSTT == "ONGOING")) %>% |
|
65 |
#' ungroup() |
|
66 |
#' anno_data <- ADSL %>% |
|
67 |
#' select(SEX, COUNTRY, USUBJID) %>% |
|
68 |
#' group_by(USUBJID) %>% |
|
69 |
#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>% |
|
70 |
#' ungroup() %>% |
|
71 |
#' select(-USUBJID) |
|
72 |
#' heat_data <- ADAE %>% |
|
73 |
#' select(USUBJID, AVISIT, AETOXGR) %>% |
|
74 |
#' group_by(USUBJID) %>% |
|
75 |
#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) %>% |
|
76 |
#' ungroup() %>% |
|
77 |
#' select(-USUBJID) |
|
78 |
#' heat_color_opt <- c( |
|
79 |
#' "No Event" = "gray90", |
|
80 |
#' "1" = "lightsteelblue1", |
|
81 |
#' "2" = "steelblue1", |
|
82 |
#' "3" = "steelblue4", |
|
83 |
#' "4" = "maroon", |
|
84 |
#' "5" = "brown4" |
|
85 |
#' ) |
|
86 |
#' cmdecod_label <- attr(ADCM[["CMDECOD"]], "label") |
|
87 |
#' ADCM <- ADCM %>% |
|
88 |
#' filter( |
|
89 |
#' CMDECOD == "medname A_1/3" | CMDECOD == "medname A_2/3" | CMDECOD == "medname A_3/3" |
|
90 |
#' ) %>% |
|
91 |
#' mutate(CMDECOD = factor(CMDECOD, levels = unique(CMDECOD))) |
|
92 |
#' attr(ADCM[["CMDECOD"]], "label") <- cmdecod_label |
|
93 |
#' conmed_data <- ADCM %>% |
|
94 |
#' group_by(USUBJID) %>% |
|
95 |
#' mutate(SUBJ = utils::tail(strsplit(USUBJID, "-")[[1]], n = 1)) |
|
96 |
#' # example plotting conmed |
|
97 |
#' g_heat_bygrade( |
|
98 |
#' id_var = "SUBJ", |
|
99 |
#' exp_data, |
|
100 |
#' visit_var = "AVISIT", |
|
101 |
#' ongo_var = "ongo_var", |
|
102 |
#' anno_data, |
|
103 |
#' anno_var = c("SEX", "COUNTRY"), |
|
104 |
#' heat_data, |
|
105 |
#' heat_color_var = "AETOXGR", |
|
106 |
#' heat_color_opt, |
|
107 |
#' conmed_data, |
|
108 |
#' conmed_var = "CMDECOD", |
|
109 |
#' conmed_color_opt = c("green", "green3", "green4") |
|
110 |
#' ) |
|
111 |
#' # example not plotting conmed |
|
112 |
#' g_heat_bygrade( |
|
113 |
#' id_var = "SUBJ", |
|
114 |
#' exp_data, |
|
115 |
#' visit_var = "AVISIT", |
|
116 |
#' ongo_var = "ongo_var", |
|
117 |
#' anno_data, |
|
118 |
#' anno_var = c("SEX", "COUNTRY"), |
|
119 |
#' heat_data, |
|
120 |
#' heat_color_var = "AETOXGR", |
|
121 |
#' heat_color_opt |
|
122 |
#' ) |
|
123 |
#' |
|
124 |
g_heat_bygrade <- function(id_var, |
|
125 |
exp_data, |
|
126 |
visit_var, |
|
127 |
ongo_var, |
|
128 |
anno_data, |
|
129 |
anno_var, |
|
130 |
heat_data, |
|
131 |
heat_color_var, |
|
132 |
heat_color_opt = NULL, |
|
133 |
conmed_data = NULL, |
|
134 |
conmed_var = NULL, |
|
135 |
conmed_color_opt = NULL, |
|
136 |
xlab = "Visit", |
|
137 |
title = NULL) { |
|
138 |
# check if all PARCAT1 in exp_data is "individual" |
|
139 | ! |
checkmate::assert_string(id_var) |
140 | ! |
checkmate::assert_data_frame(exp_data) |
141 | ! |
stopifnot( |
142 | ! |
"invalid argument: please only include 'INDIVIDUAL' record in exp_data" = !is.na(exp_data[[visit_var]]) |
143 |
) |
|
144 | ! |
checkmate::assert_string(visit_var) |
145 | ! |
checkmate::assert_string(ongo_var) |
146 | ! |
checkmate::assert( |
147 | ! |
combine = "and", |
148 | ! |
checkmate::check_choice(ongo_var, names(exp_data)), |
149 | ! |
checkmate::check_logical(exp_data[[ongo_var]]) |
150 |
) |
|
151 | ! |
checkmate::assert_data_frame(anno_data) |
152 | ! |
stopifnot( |
153 | ! |
"invalid argument: anno_data can only contain 3 or less columns including subject ID" = length(anno_var) <= 2 |
154 |
) |
|
155 | ! |
checkmate::assert_data_frame(heat_data) |
156 | ! |
checkmate::assert_choice(heat_color_var, names(heat_data)) |
157 | ! |
stopifnot( |
158 | ! |
"invalid argument: need to provide conmed_data and conmed_var" = |
159 | ! |
any(is.null(conmed_data), is.null(conmed_data) == is.null(conmed_var)) |
160 |
) |
|
161 | ! |
checkmate::assert_choice(conmed_var, names(conmed_data), null.ok = TRUE) |
162 | ! |
stopifnot( |
163 | ! |
"invalid argument: please only include no more than three conmeds for plotting" = |
164 | ! |
is.null(conmed_var) || length(levels(conmed_data[[conmed_var]])) <= 3 |
165 |
) |
|
166 | ! |
stopifnot( |
167 | ! |
"invalid argument: please specify conmed_color_opt for all unique conmed_var" = |
168 | ! |
is.null(conmed_data) || is.null(conmed_color_opt) || |
169 | ! |
length(conmed_color_opt) == length(unique(conmed_data[[conmed_var]])) |
170 |
) |
|
171 | ||
172 | ! |
if (!((is.null(conmed_data) || id_var %in% names(conmed_data)) && |
173 | ! |
id_var %in% names(exp_data) && |
174 | ! |
id_var %in% names(anno_data) && |
175 | ! |
id_var %in% names(heat_data))) { |
176 | ! |
stop( |
177 | ! |
paste( |
178 | ! |
"exp_data, anno_data, heat_data, and conmed_data (if plotting conmed) must include a column named", |
179 | ! |
id_var, |
180 | ! |
sep = " " |
181 |
) |
|
182 |
) |
|
183 |
} |
|
184 | ! |
if (!((is.null(conmed_data) || visit_var %in% names(conmed_data)) && |
185 | ! |
visit_var %in% names(exp_data) && |
186 | ! |
visit_var %in% names(heat_data))) { |
187 | ! |
stop( |
188 | ! |
paste( |
189 | ! |
"exp_data, heat_data, and conmed_data (if plotting conmed) must include a column named", |
190 | ! |
visit_var, |
191 | ! |
sep = " " |
192 |
) |
|
193 |
) |
|
194 |
} |
|
195 | ||
196 | ! |
anl_data <- exp_data %>% |
197 | ! |
select(!!id_var, !!sym(visit_var)) %>% |
198 | ! |
left_join(heat_data, by = c(id_var, visit_var)) %>% |
199 | ! |
distinct() %>% |
200 | ! |
mutate(heat_color_num = tidyr::replace_na(as.numeric(.data[[heat_color_var]]), 0)) %>% |
201 | ! |
group_by(!!sym(id_var), !!sym(visit_var)) %>% |
202 | ! |
arrange(!!sym(visit_var)) %>% |
203 | ! |
mutate(heat_color_max = factor(max(.data$heat_color_num), levels = 0:5)) %>% |
204 | ! |
select(-(!!heat_color_var), -"heat_color_num") %>% # nolint |
205 | ! |
distinct() %>% |
206 | ! |
left_join(anno_data, by = id_var) |
207 | ||
208 |
# dose reduction data |
|
209 | ! |
ex_red <- exp_data %>% |
210 | ! |
filter(.data$PARAMCD == "DOSE") %>% |
211 | ! |
group_by(!!sym(id_var)) %>% |
212 | ! |
arrange(.data$ASTDTM) %>% |
213 | ! |
mutate( |
214 | ! |
RANK = order(.data$ASTDTM), |
215 | ! |
LASTDOSE = lag(.data$AVAL), |
216 | ! |
DOSERED = ifelse(.data$RANK != 1 & .data$AVAL < .data$LASTDOSE, TRUE, FALSE) |
217 |
) %>% |
|
218 | ! |
select(!!sym(id_var), !!sym(visit_var), "RANK", "AVAL", "LASTDOSE", "DOSERED") %>% |
219 | ! |
filter(.data$DOSERED == TRUE) |
220 |
# does ongoing data |
|
221 | ! |
exp_lst <- exp_data %>% |
222 | ! |
filter(.data$PARAMCD == "DOSE") %>% |
223 | ! |
filter(!!sym(ongo_var) == TRUE) %>% |
224 | ! |
group_by(!!sym(id_var)) %>% |
225 | ! |
arrange(!!sym(visit_var)) %>% |
226 | ! |
slice_tail() %>% |
227 | ! |
select(!!sym(id_var), !!sym(visit_var)) |
228 | ! |
visit_levels <- unique(anl_data[[visit_var]]) |
229 | ! |
if (!is.null(conmed_data) && !is.null(conmed_var)) { |
230 | ! |
conmed_data <- conmed_data %>% |
231 | ! |
left_join(anl_data, by = c(id_var, visit_var)) %>% |
232 | ! |
ungroup() %>% |
233 | ! |
mutate( |
234 | ! |
conmed_num = as.numeric(.data[[conmed_var]]), |
235 | ! |
conmed_num_m = stats::median(unique(.data$conmed_num), na.rm = TRUE) |
236 |
) %>% |
|
237 | ! |
mutate( |
238 | ! |
distance = (ifelse( |
239 | ! |
.data$conmed_num <= .data$conmed_num_m, |
240 | ! |
.data$conmed_num - 1, |
241 | ! |
.data$conmed_num + 1 |
242 | ! |
) - .data$conmed_num_m) / 5, |
243 | ! |
conmed_x = as.numeric(!!sym(visit_var)) + .data$distance |
244 |
) |
|
245 |
} |
|
246 | ! |
subj_levels <- unique(anl_data[[id_var]]) |
247 | ! |
levels(anl_data$heat_color_max)[levels(anl_data$heat_color_max) == "0"] <- "No Event" |
248 | ! |
p <- ggplot( |
249 | ! |
data = anl_data, |
250 | ! |
aes(x = !!sym(visit_var), y = factor(!!sym(id_var), levels = c(rev(subj_levels), ""))) |
251 |
) + |
|
252 | ! |
geom_tile(aes(fill = .data$heat_color_max)) + |
253 | ! |
scale_y_discrete(drop = FALSE) + |
254 | ! |
scale_fill_discrete( |
255 | ! |
name = "Highest grade of\nindividual events", |
256 | ! |
type = if (!is.null(heat_color_opt)) { |
257 | ! |
heat_color_opt |
258 |
} else { |
|
259 | ! |
if (!is.null(getOption("ggplot2.discrete.colour"))) { |
260 | ! |
rev(grDevices::hcl.colors(6, palette = "peach")) |
261 |
} else { |
|
262 | ! |
rev(grDevices::terrain.colors(6)) |
263 |
} |
|
264 |
} |
|
265 |
) + |
|
266 |
# plot dose reduction |
|
267 | ! |
geom_segment( |
268 | ! |
data = ex_red, |
269 | ! |
aes( |
270 | ! |
y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) + 0.3, |
271 | ! |
x = as.numeric(factor(!!sym(visit_var), levels = visit_levels)), |
272 | ! |
yend = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) - 0.3, |
273 | ! |
xend = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) |
274 |
), |
|
275 | ! |
arrow = arrow(length = grid::unit(0.1, "cm")), |
276 | ! |
size = .5, |
277 | ! |
color = "black" |
278 |
) + |
|
279 |
# plot ongoing |
|
280 | ! |
geom_segment( |
281 | ! |
data = exp_lst, |
282 | ! |
aes( |
283 | ! |
x = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) + 0.5, |
284 | ! |
xend = as.numeric(factor(!!sym(visit_var), levels = visit_levels)) + 0.65, |
285 | ! |
y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))), |
286 | ! |
yend = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))) |
287 |
), |
|
288 | ! |
arrow = arrow(length = grid::unit(0.1, "cm")), |
289 | ! |
size = .5, |
290 | ! |
color = "black" |
291 |
) |
|
292 | ! |
if (!is.null(conmed_data) && !is.null(conmed_var)) { |
293 | ! |
p <- p + |
294 | ! |
geom_point( |
295 | ! |
data = conmed_data, |
296 | ! |
aes( |
297 | ! |
x = .data$conmed_x, |
298 | ! |
y = as.numeric(factor(!!sym(id_var), levels = rev(subj_levels))), |
299 | ! |
shape = .data[[conmed_var]], |
300 | ! |
color = .data[[conmed_var]] |
301 |
), |
|
302 | ! |
size = 2 |
303 |
) + |
|
304 | ! |
scale_colour_manual( |
305 | ! |
name = attr(conmed_data[[conmed_var]], "label"), |
306 | ! |
values = if (!is.null(conmed_color_opt)) { |
307 | ! |
conmed_color_opt |
308 |
} else { |
|
309 | ! |
if (!is.null(getOption("ggplot2.discrete.colour"))) { |
310 | ! |
getOption("ggplot2.discrete.colour")[-2] |
311 |
} else { |
|
312 | ! |
rep("black", 5) |
313 |
} |
|
314 |
} |
|
315 |
) + |
|
316 | ! |
scale_shape_manual( |
317 | ! |
name = attr(conmed_data[[conmed_var]], "label"), |
318 | ! |
values = c(15:17) |
319 |
) |
|
320 |
} |
|
321 | ||
322 | ! |
p <- p + |
323 | ! |
theme_bw() + |
324 | ! |
theme( |
325 | ! |
panel.background = element_blank(), |
326 | ! |
panel.grid = element_blank(), |
327 | ! |
axis.line = element_line(colour = "black"), |
328 | ! |
axis.text.x = element_text(angle = 90), |
329 | ! |
axis.text.y = element_blank(), |
330 | ! |
axis.title.y = element_blank() |
331 |
) + |
|
332 | ! |
labs(x = xlab, y = "ylab") |
333 |
# plot title and labels |
|
334 | ! |
if (!is.null(title)) { |
335 | ! |
p <- p + |
336 | ! |
labs(title = title) + |
337 | ! |
theme(plot.title = element_text(face = "bold")) |
338 |
} |
|
339 | ||
340 |
# plot left legend |
|
341 | ! |
t <- anl_data %>% |
342 | ! |
as.data.frame() %>% |
343 | ! |
select((!!anno_var), (!!id_var)) %>% |
344 | ! |
distinct() |
345 | ! |
my_theme <- gridExtra::ttheme_default( |
346 | ! |
core = list( |
347 | ! |
bg_params = list(fill = NA, col = NA), |
348 | ! |
fg_params = list(cex = 0.8) |
349 |
), |
|
350 | ! |
colhead = list( |
351 | ! |
bg_params = list(fill = NA, col = NA), |
352 | ! |
fg_params = list(cex = 0.8) |
353 |
) |
|
354 |
) |
|
355 | ! |
tb <- gridExtra::tableGrob(t, rows = NULL, theme = my_theme) |
356 | ! |
tb$heights <- grid::unit(rep(1 / nrow(tb), nrow(tb)), "null") |
357 | ||
358 |
# grab plot and table as one plot |
|
359 | ! |
g0 <- ggplotGrob(p) |
360 | ! |
g1 <- gtable::gtable_add_cols(g0, sum(tb$widths), 0) |
361 | ! |
g <- gtable::gtable_add_grob(g1, tb, t = g1$layout[g1$layout$name == "panel", 1], l = 1) |
362 | ||
363 | ! |
grid::grid.newpage() |
364 | ! |
grid::grid.draw(g) |
365 | ! |
invisible(g) |
366 |
} |
1 |
#' Spider Plot |
|
2 |
#' |
|
3 |
#' Spider plot is often used in Early Development (ED) and displays individual |
|
4 |
#' patient plot of an endpoint over time by group. |
|
5 |
#' |
|
6 |
#' |
|
7 |
#' @param marker_x vector of x values (must be in sorted order) |
|
8 |
#' @param marker_id vector to group the points together (default |
|
9 |
#' should be `USUBJID`) |
|
10 |
#' @param marker_y vector of y values |
|
11 |
#' @param line_colby vector defines by what variable plot is color coded, |
|
12 |
#' default here is `NULL` |
|
13 |
#' @param line_color_opt vector defines line color, default here is `NULL` |
|
14 |
#' @param marker_size size of markers in plot, default here is `NULL` |
|
15 |
#' @param marker_shape vector defines by what variable points are shape coded, |
|
16 |
#' , default here is `NULL` |
|
17 |
#' @param marker_shape_opt vector defines marker shape code, default here is `NULL` |
|
18 |
#' @param datalabel_txt list defines text (at last time point) and flag for an arrow annotation: |
|
19 |
#' - (per defined variable) elements must be labeled `txt_ann`/`mrkr_all`/`mrkr_ann`. |
|
20 |
#' - `txt_ann` text annotation next to final data point (for text annotation) |
|
21 |
#' - `mrkr_all` vector of ID's (for annotation marker) |
|
22 |
#' - `mrkr_ann` vector of ID's (subset of `mrkr_all`) where arrow is desired to |
|
23 |
#' indicate any study interim points. Default here is `NULL`. |
|
24 |
#' @param facet_rows dataframe defines what variable is used to split the |
|
25 |
#' plot into rows, default here is `NULL`. |
|
26 |
#' @param facet_columns dataframe defines what variable is used to split the |
|
27 |
#' plot into columns, default here is `NULL`. |
|
28 |
#' @param vref_line value defines vertical line overlay |
|
29 |
#' (can be a vector), default here is `NULL`. |
|
30 |
#' @param href_line value defines horizontal line overlay |
|
31 |
#' (can be a vector), default here is `NULL`. |
|
32 |
#' @param x_label string of text for x axis label, default is time. |
|
33 |
#' @param y_label string of text for y axis label, default is % change. |
|
34 |
#' @param show_legend boolean of whether marker legend is included, default here is `FALSE`. |
|
35 |
#' |
|
36 |
#' @return `ggplot` object |
|
37 |
#' |
|
38 |
#' @details there is no equivalent STREAM output |
|
39 |
#' |
|
40 |
#' @export |
|
41 |
#' |
|
42 |
#' @template author_zhanc107 |
|
43 |
#' |
|
44 |
#' @examples |
|
45 |
#' # simple example |
|
46 |
#' library(dplyr) |
|
47 |
#' library(nestcolor) |
|
48 |
#' |
|
49 |
#' ADTR <- osprey::rADTR %>% select(STUDYID, USUBJID, ADY, AVISIT, CHG, PCHG, PARAMCD) |
|
50 |
#' ADSL <- osprey::rADSL %>% select(STUDYID, USUBJID, RACE, SEX, ARM) |
|
51 |
#' ANL <- left_join(ADTR, ADSL, by = c("STUDYID", "USUBJID")) |
|
52 |
#' ANL <- ANL %>% |
|
53 |
#' dplyr::filter(PARAMCD == "SLDINV" & AVISIT != "POST-BASELINE MINIMUM") %>% |
|
54 |
#' dplyr::filter(RACE %in% c("WHITE", "ASIAN")) %>% |
|
55 |
#' group_by(USUBJID) %>% |
|
56 |
#' dplyr::arrange(ADY) %>% |
|
57 |
#' dplyr::mutate( |
|
58 |
#' CHG = ifelse(AVISIT == "Screening", 0, CHG), |
|
59 |
#' PCHG = ifelse(AVISIT == "Screening", 0, PCHG) |
|
60 |
#' ) |
|
61 |
#' ANL$USUBJID <- substr(ANL$USUBJID, 14, 18) |
|
62 |
#' |
|
63 |
#' # Plot 1 - default color and shape mapping |
|
64 |
#' g_spiderplot( |
|
65 |
#' marker_x = ANL$ADY, |
|
66 |
#' marker_id = ANL$USUBJID, |
|
67 |
#' marker_y = ANL$PCHG, |
|
68 |
#' line_colby = ANL$USUBJID, |
|
69 |
#' marker_shape = ANL$USUBJID, |
|
70 |
#' # marker_size = 5, |
|
71 |
#' datalabel_txt = list(txt_ann = ANL$USUBJID), |
|
72 |
#' # facet_rows = data.frame(sex = ANL$SEX), |
|
73 |
#' # facet_columns = data.frame(arm = ANL$ARM), |
|
74 |
#' vref_line = c(42, 86), |
|
75 |
#' href_line = c(-20, 20), |
|
76 |
#' x_label = "Time (Days)", |
|
77 |
#' y_label = "Change (%) from Baseline", |
|
78 |
#' show_legend = TRUE |
|
79 |
#' ) |
|
80 |
#' |
|
81 |
#' # Plot 2 - with line color mapping |
|
82 |
#' g_spiderplot( |
|
83 |
#' marker_x = ANL$AVISIT, |
|
84 |
#' marker_id = ANL$USUBJID, |
|
85 |
#' marker_y = ANL$CHG, |
|
86 |
#' line_colby = ANL$RACE, |
|
87 |
#' line_color_opt = c("WHITE" = "red", "ASIAN" = "blue"), |
|
88 |
#' marker_shape = ANL$USUBJID, |
|
89 |
#' x_label = "Visit", |
|
90 |
#' y_label = "Change from Baseline", |
|
91 |
#' show_legend = TRUE |
|
92 |
#' ) |
|
93 |
g_spiderplot <- function(marker_x, |
|
94 |
marker_id, |
|
95 |
marker_y, |
|
96 |
line_colby = NULL, |
|
97 |
line_color_opt = NULL, |
|
98 |
marker_shape = NULL, |
|
99 |
marker_shape_opt = NULL, |
|
100 |
marker_size = 3, |
|
101 |
datalabel_txt = NULL, # USUBJID default |
|
102 |
facet_rows = NULL, |
|
103 |
facet_columns = NULL, |
|
104 |
vref_line = NULL, |
|
105 |
href_line = NULL, |
|
106 |
x_label = "Time (Days)", |
|
107 |
y_label = "Change (%) from Baseline", |
|
108 |
show_legend = FALSE) { |
|
109 | ! |
check_input_length <- c(nrow(data.frame(marker_x)), nrow(data.frame(marker_id)), nrow(data.frame(marker_y))) |
110 | ||
111 | ! |
if (length(unique(check_input_length)) > 1) { |
112 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
113 |
} |
|
114 | ! |
if (any(check_input_length == 0)) { |
115 | ! |
stop("invalid arguments: check that inputs are not null") |
116 |
} |
|
117 | ||
118 |
# set up data------- |
|
119 | ! |
dat <- data.frame(x = marker_x, y = marker_y, group = marker_id) |
120 | ||
121 | ! |
if (!is.null(marker_shape)) { |
122 | ! |
if (length(unique(c(nrow(data.frame(marker_shape)), check_input_length))) != 1) { |
123 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
124 |
} |
|
125 | ! |
dat$sh <- marker_shape |
126 |
} |
|
127 | ! |
if (!is.null(facet_rows)) { |
128 | ! |
if (length(unique(c(nrow(facet_rows), check_input_length))) != 1) { |
129 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
130 |
} |
|
131 | ! |
dat$f_rows <- interaction(facet_rows) |
132 |
} |
|
133 | ! |
if (!is.null(facet_columns)) { |
134 | ! |
if (length(unique(c(nrow(facet_columns), check_input_length))) != 1) { |
135 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
136 |
} |
|
137 | ! |
dat$f_columns <- interaction(facet_columns) |
138 |
} |
|
139 | ! |
if (!is.null(line_colby)) { |
140 | ! |
if (length(unique(c(nrow(data.frame(line_colby)), check_input_length))) != 1) { |
141 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
142 |
} |
|
143 | ! |
dat$l_col <- line_colby |
144 |
} |
|
145 | ! |
if (!is.null(datalabel_txt$txt_ann)) { |
146 | ! |
dat$lbl_all <- datalabel_txt$txt_ann |
147 | ||
148 | ! |
dat <- dat %>% |
149 | ! |
group_by(.data$lbl_all) %>% |
150 | ! |
dplyr::mutate(lab = ifelse(.data$x == last(.data$x), as.character(.data$lbl_all), " ")) |
151 |
} |
|
152 | ! |
if (!is.null(datalabel_txt$mrkr_all) && !is.null(datalabel_txt$mrkr_ann)) { |
153 | ! |
if (length(unique(c(nrow(datalabel_txt$mrkr_all), check_input_length))) != 1) { |
154 | ! |
stop("invalid arguments: check that the length of input arguments are identical") |
155 |
} |
|
156 | ! |
dat$id <- datalabel_txt$mrkr_all |
157 |
} |
|
158 | ||
159 | ! |
dat <- dat %>% as.data.frame() |
160 | ||
161 |
# plot spider plot----------------- this section can be condensed later |
|
162 | ! |
pl <- ggplot(data = dat, aes_string(x = "x", y = "y", group = "group")) + |
163 | ! |
xlab(x_label) + |
164 | ! |
ylab(y_label) + |
165 | ! |
theme(legend.position = "top", legend.title = element_blank()) |
166 | ||
167 | ! |
pl <- pl + geom_hline(yintercept = 0, linetype = "solid", color = "gray", size = 1) |
168 | ||
169 | ||
170 | ! |
pl <- pl + |
171 | ! |
geom_line( |
172 | ! |
mapping = if (!is.null(line_colby)) { |
173 | ! |
aes_string(color = "l_col") |
174 |
} else { |
|
175 | ! |
NULL |
176 |
}, |
|
177 | ! |
size = 1, |
178 | ! |
alpha = 0.5, |
179 | ! |
show.legend = show_legend |
180 |
) |
|
181 | ||
182 |
# marker shape------------ this section can be condensed later |
|
183 | ! |
if (!is.null(marker_shape)) { |
184 | ! |
pl <- pl + |
185 | ! |
geom_point(mapping = if (!is.null(line_colby)) { |
186 | ! |
aes_string(shape = "sh", color = "l_col") |
187 |
} else { |
|
188 | ! |
aes_string(shape = "sh") |
189 | ! |
}, size = marker_size, show.legend = show_legend) |
190 | ! |
} else if (is.null(marker_shape)) { |
191 | ! |
pl <- pl + |
192 | ! |
geom_point(mapping = if (!is.null(line_colby)) { |
193 | ! |
aes_string(color = "l_col") |
194 |
} else { |
|
195 | ! |
NULL |
196 | ! |
}, size = 3, show.legend = show_legend) |
197 |
} |
|
198 | ||
199 |
# label at last data point--------- |
|
200 | ! |
if (!is.null(datalabel_txt)) { |
201 | ! |
if (!is.null(datalabel_txt$txt_ann) && is.null(datalabel_txt$mrkr_all) && is.null(datalabel_txt$mrkr_ann)) { |
202 | ! |
pl <- pl + |
203 | ! |
geom_text( |
204 | ! |
data = dat, |
205 | ! |
aes_string(x = "x", y = "y", label = "lab"), hjust = -0.3, |
206 | ! |
size = 4, |
207 | ! |
show.legend = FALSE |
208 |
) |
|
209 | ! |
} else if (is.null(datalabel_txt$txt_ann) && |
210 | ! |
!is.null(datalabel_txt$mrkr_all) && |
211 | ! |
!is.null(datalabel_txt$mrkr_ann)) { |
212 | ! |
dat_arrow <- dat %>% |
213 | ! |
dplyr::filter(id %in% datalabel_txt$mrkr_ann) %>% |
214 | ! |
group_by(.data$id) %>% |
215 | ! |
dplyr::filter(.data$x == last(.data$x)) |
216 | ! |
pl <- pl + |
217 | ! |
geom_segment( |
218 | ! |
data = dat_arrow, |
219 | ! |
mapping = aes_string(x = "x", y = "y", xend = "x", yend = "y"), |
220 | ! |
arrow = arrow(length = grid::unit(0.15, "inches"), ends = "first", type = "closed"), |
221 | ! |
size = 0.4, |
222 | ! |
color = "black", |
223 | ! |
show.legend = FALSE |
224 |
) |
|
225 | ! |
} else if (!is.null(datalabel_txt$txt_ann) && |
226 | ! |
!is.null(datalabel_txt$mrkr_all) && |
227 | ! |
!is.null(datalabel_txt$mrkr_ann)) { |
228 | ! |
pl <- pl + |
229 | ! |
geom_text( |
230 | ! |
data = dat, |
231 | ! |
aes_string(x = "x", y = "y", label = "lab"), |
232 | ! |
hjust = -0.45, |
233 | ! |
size = 4, |
234 | ! |
show.legend = FALSE |
235 |
) |
|
236 | ||
237 | ! |
dat_arrow <- dat %>% |
238 | ! |
dplyr::filter(id %in% datalabel_txt$mrkr_ann) %>% |
239 | ! |
group_by(.data$id) %>% |
240 | ! |
dplyr::filter(.data$x == last(.data$x)) |
241 | ||
242 | ! |
pl <- pl + |
243 | ! |
geom_segment( |
244 | ! |
data = dat_arrow, |
245 | ! |
mapping = aes_string(x = "x", y = "y", xend = "x", yend = "y"), |
246 | ! |
arrow = arrow(length = grid::unit(0.15, "inches"), ends = "first", type = "closed"), |
247 | ! |
size = 0.4, |
248 | ! |
color = "black", |
249 | ! |
show.legend = FALSE |
250 |
) |
|
251 |
} |
|
252 |
} |
|
253 | ||
254 |
# vertical and horizontal reference lines |
|
255 | ! |
if (!is.null(href_line)) { |
256 | ! |
pl <- pl + geom_hline(yintercept = href_line, linetype = "dotted", color = "black") |
257 |
} |
|
258 | ||
259 | ! |
if (!is.null(vref_line)) { |
260 | ! |
for (i in seq_along(vref_line)) { |
261 | ! |
pl <- pl + |
262 | ! |
annotate("segment", |
263 | ! |
x = vref_line[i], |
264 | ! |
y = -Inf, |
265 | ! |
xend = vref_line[i], |
266 | ! |
yend = Inf, |
267 | ! |
linetype = "dotted", |
268 | ! |
color = "black" |
269 |
) |
|
270 |
} |
|
271 |
} |
|
272 | ||
273 |
# facets--------------- |
|
274 | ! |
if (is.null(facet_rows) && is.null(facet_columns)) { |
275 | ! |
pl |
276 | ! |
} else if (is.null(facet_rows) && !is.null(facet_columns)) { |
277 | ! |
pl <- pl + facet_grid(. ~ f_columns) |
278 | ! |
} else if (is.null(facet_columns) && !is.null(facet_rows)) { |
279 | ! |
pl <- pl + facet_grid(f_rows ~ .) |
280 |
} else { |
|
281 | ! |
pl <- pl + facet_grid(f_rows ~ f_columns) |
282 |
} |
|
283 | ||
284 |
# simple function to call a vector of color values |
|
285 | ! |
call_color <- function(len) { |
286 | ! |
dat_col <- data.frame(color_opt = grDevices::colors()) |
287 | ! |
dat_col <- dat_col %>% |
288 | ! |
dplyr::filter(!grepl("white", .data$color_opt)) %>% |
289 | ! |
droplevels() |
290 | ||
291 | ! |
return(dat_col[1:len, 1]) |
292 |
} |
|
293 | ||
294 |
# remove marker from color legend |
|
295 | ! |
if (!is.null(line_colby)) { |
296 | ! |
if (!is.null(line_color_opt)) { |
297 | ! |
pl <- pl + scale_color_manual( |
298 | ! |
name = "Color", |
299 | ! |
breaks = dat$l_col, |
300 | ! |
values = line_color_opt |
301 |
) |
|
302 |
} |
|
303 |
} |
|
304 | ||
305 | ! |
if (!is.null(marker_shape) && is.null(marker_shape_opt)) { |
306 | ! |
symbol_val <- c(15:18, 1:14) |
307 | ! |
len <- length(unique(dat$sh)) |
308 | ! |
symbol_val <- rep(symbol_val, ceiling(len / 26)) |
309 | ||
310 | ! |
pl <- pl + scale_shape_manual( |
311 | ! |
values = symbol_val[1:len] |
312 |
) |
|
313 |
} |
|
314 | ||
315 | ! |
if (!is.null(marker_shape_opt)) { |
316 | ! |
pl <- pl + scale_shape_manual( |
317 | ! |
name = "Shape", |
318 | ! |
breaks = dat$sh, |
319 | ! |
values = marker_shape_opt |
320 |
) |
|
321 |
} |
|
322 | ||
323 |
# modify background color |
|
324 | ! |
pl <- pl + annotate("segment", x = -Inf, xend = Inf, y = -Inf, yend = -Inf) + |
325 | ! |
annotate("segment", x = -Inf, xend = -Inf, y = -Inf, yend = Inf) + |
326 | ! |
theme_bw() + |
327 | ! |
theme( |
328 | ! |
strip.background = element_rect(linetype = "blank", fill = "white"), |
329 | ! |
text = element_text(size = 16), |
330 | ! |
axis.text = element_text(color = "black"), |
331 | ! |
legend.text = element_text(size = 7), |
332 | ! |
legend.title = element_text(size = 7) |
333 |
) + |
|
334 | ! |
labs(shape = "Shape", color = "Color") # + |
335 | ||
336 | ! |
if (is.numeric(marker_x)) { |
337 | ! |
pl <- pl + xlim(min(marker_x), max(marker_x) * 1.3) |
338 |
} else { |
|
339 | ! |
pl <- pl + |
340 | ! |
scale_x_discrete(expand = c(0.3, 0)) + |
341 | ! |
theme(axis.text.x = element_text(angle = 90)) |
342 |
} |
|
343 | ||
344 | ! |
grid::grid.draw(pl) |
345 | ! |
invisible(pl) |
346 |
} |
1 |
#' Simple spider plot |
|
2 |
#' |
|
3 |
#' Description of this plot |
|
4 |
#' |
|
5 |
#' @param anl The analysis data frame |
|
6 |
#' @param byvar Analysis dataset |
|
7 |
#' @param days Variable with time in days |
|
8 |
#' @param mes_value Variable with measurement |
|
9 |
#' @param group_col Variable to color the individual lines and id in plot |
|
10 |
#' @param baseday Numeric Value, points with only smaller values will be cut out |
|
11 |
#' |
|
12 |
#' |
|
13 |
#' @return `ggplot` object |
|
14 |
#' |
|
15 |
#' @export |
|
16 |
#' |
|
17 |
#' @author Mika Maekinen |
|
18 |
#' |
|
19 |
#' @examples |
|
20 |
#' library(dplyr) |
|
21 |
#' library(nestcolor) |
|
22 |
#' |
|
23 |
#' ADSL <- osprey::rADSL[1:15, ] |
|
24 |
#' ADTR <- osprey::rADTR |
|
25 |
#' ANL <- left_join(ADSL, ADTR) |
|
26 |
#' |
|
27 |
#' ANL %>% |
|
28 |
#' dplyr::filter(ANL01FL == "Y" & PARAMCD == "SLDINV") %>% |
|
29 |
#' spiderplot_simple(group_col = "SEX", days = "ADY", mes_value = "AVAL") |
|
30 |
spiderplot_simple <- function(anl, |
|
31 |
byvar = "USUBJID", |
|
32 |
days = "TRTDURD", |
|
33 |
mes_value = "PARAM", |
|
34 |
group_col = "USUBJID", |
|
35 |
baseday = 0) { |
|
36 |
### remove patients without post baseline measurement |
|
37 | ! |
anl <- anl %>% |
38 | ! |
group_by(!!byvar) %>% |
39 | ! |
dplyr::mutate(morebase = ifelse(max(!!days, na.rm = TRUE) > baseday, TRUE, FALSE)) %>% |
40 | ! |
dplyr::filter(.data$morebase == TRUE) %>% |
41 | ! |
ungroup() |
42 |
### find the last measurement |
|
43 | ! |
last_obs <- anl %>% |
44 | ! |
group_by(!!as.symbol(byvar)) %>% |
45 | ! |
slice(which.max(!!as.symbol(days))) |
46 | ||
47 |
# plotr |
|
48 | ! |
ggplot( |
49 | ! |
data = anl, |
50 | ! |
mapping = aes_string(x = days, y = mes_value, group = byvar, colour = group_col), |
51 | ! |
size = 2, |
52 | ! |
alpha = 1 |
53 |
) + |
|
54 | ! |
geom_point(size = 3) + |
55 | ! |
geom_line(size = 2, alpha = 0.7) + |
56 | ! |
geom_text(aes_string(x = days, y = mes_value, label = byvar), data = last_obs, hjust = 0) + |
57 | ! |
geom_hline(aes(yintercept = 0), linetype = "dotted", color = "black") + |
58 | ! |
xlab("Time (Days)") + |
59 | ! |
ylab("Change(%) from Baseline") |
60 |
} |