1 |
#' Teal Module for Waterfall Plot |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' This is teal module that generates a waterfall plot for `ADaM` data |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param dataname_tr tumor burden analysis data used in teal module to plot as bar height, needs to |
|
11 |
#' be available in the list passed to the `data` argument of [teal::init()] |
|
12 |
#' @param dataname_rs response analysis data used in teal module to label response parameters, needs to |
|
13 |
#' be available in the list passed to the `data` argument of [teal::init()] |
|
14 |
#' @param bar_paramcd `choices_selected` parameter in tumor burden data that will be plotted as |
|
15 |
#' bar height |
|
16 |
#' @param bar_var `choices_selected` numeric variable from dataset to plot the bar height, e.g., `PCHG` |
|
17 |
#' @param bar_color_var `choices_selected` color by variable (subject level), `None` corresponds |
|
18 |
#' to `NULL` |
|
19 |
#' @param bar_color_opt aesthetic values to map color values (named vector to map color values to each name). |
|
20 |
#' If not `NULL`, please make sure this contains all possible values for `bar_color_var` values, |
|
21 |
#' otherwise color will be assigned by `ggplot` default, please note that `NULL` needs to be specified |
|
22 |
#' in this case |
|
23 |
#' @param sort_var `choices_selected` sort by variable (subject level), `None` corresponds |
|
24 |
#' to `NULL` |
|
25 |
#' @param add_label_var_sl `choices_selected` add label to bars (subject level), `None` |
|
26 |
#' corresponds to `NULL` |
|
27 |
#' @param add_label_paramcd_rs `choices_selected` add label to bars (response dataset), `None` |
|
28 |
#' corresponds to `NULL`. At least one of `add_label_var_sl` and `add_label_paramcd_rs` needs |
|
29 |
#' to be `NULL` |
|
30 |
#' @param anno_txt_var_sl `choices_selected` subject level variables to be displayed in the annotation |
|
31 |
#' table, default is `NULL` |
|
32 |
#' @param anno_txt_paramcd_rs `choices_selected` analysis dataset variables to be displayed in the |
|
33 |
#' annotation table, default is `NULL` |
|
34 |
#' @param facet_var `choices_selected` facet by variable (subject level), `None` corresponds to |
|
35 |
#' `NULL` |
|
36 |
#' @param ytick_at bar height axis interval, default is 20 |
|
37 |
#' @param href_line numeric vector to plot horizontal reference lines, default is `NULL` |
|
38 |
#' @param gap_point_val singular numeric value for adding bar break when some bars are significantly higher |
|
39 |
#' than others, default is `NULL` |
|
40 |
#' @param show_value boolean of whether value of bar height is shown, default is `TRUE` |
|
41 |
#' |
|
42 |
#' @inherit argument_convention return |
|
43 |
#' |
|
44 |
#' @export |
|
45 |
#' |
|
46 |
#' @template author_qit3 |
|
47 |
#' @author houx14 \email{houx14@gene.com} |
|
48 |
#' |
|
49 |
#' @examples |
|
50 |
#' data <- cdisc_data() |> |
|
51 |
#' within({ |
|
52 |
#' library(nestcolor) |
|
53 |
#' ADSL <- rADSL |
|
54 |
#' ADRS <- rADRS |
|
55 |
#' ADTR <- rADTR |
|
56 |
#' ADSL$SEX <- factor(ADSL$SEX, levels = unique(ADSL$SEX)) |
|
57 |
#' }) |
|
58 |
#' |
|
59 |
#' datanames(data) <- c("ADSL", "ADTR", "ADRS") |
|
60 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
61 |
#' |
|
62 |
#' app <- init( |
|
63 |
#' data = data, |
|
64 |
#' modules = modules( |
|
65 |
#' tm_g_waterfall( |
|
66 |
#' label = "Waterfall", |
|
67 |
#' dataname_tr = "ADTR", |
|
68 |
#' dataname_rs = "ADRS", |
|
69 |
#' bar_paramcd = choices_selected(c("SLDINV"), "SLDINV"), |
|
70 |
#' bar_var = choices_selected(c("PCHG", "AVAL"), "PCHG"), |
|
71 |
#' bar_color_var = choices_selected(c("ARMCD", "SEX"), "ARMCD"), |
|
72 |
#' bar_color_opt = NULL, |
|
73 |
#' sort_var = choices_selected(c("ARMCD", "SEX"), NULL), |
|
74 |
#' add_label_var_sl = choices_selected(c("SEX", "EOSDY"), NULL), |
|
75 |
#' add_label_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL), |
|
76 |
#' anno_txt_var_sl = choices_selected(c("SEX", "ARMCD", "BMK1", "BMK2"), NULL), |
|
77 |
#' anno_txt_paramcd_rs = choices_selected(c("BESRSPI", "OBJRSPI"), NULL), |
|
78 |
#' facet_var = choices_selected(c("SEX", "ARMCD", "STRATA1", "STRATA2"), NULL), |
|
79 |
#' href_line = "-30, 20" |
|
80 |
#' ) |
|
81 |
#' ) |
|
82 |
#' ) |
|
83 |
#' if (interactive()) { |
|
84 |
#' shinyApp(app$ui, app$server) |
|
85 |
#' } |
|
86 |
#' |
|
87 |
tm_g_waterfall <- function(label, |
|
88 |
dataname_tr = "ADTR", |
|
89 |
dataname_rs = "ADRS", |
|
90 |
bar_paramcd, |
|
91 |
bar_var, |
|
92 |
bar_color_var, |
|
93 |
bar_color_opt = NULL, |
|
94 |
sort_var, |
|
95 |
add_label_var_sl, |
|
96 |
add_label_paramcd_rs, |
|
97 |
anno_txt_var_sl, |
|
98 |
anno_txt_paramcd_rs, |
|
99 |
facet_var, |
|
100 |
ytick_at = 20, |
|
101 |
href_line = NULL, |
|
102 |
gap_point_val = NULL, |
|
103 |
show_value = TRUE, |
|
104 |
plot_height = c(1200L, 400L, 5000L), |
|
105 |
plot_width = NULL, |
|
106 |
pre_output = NULL, |
|
107 |
post_output = NULL) { |
|
108 | ! |
message("Initializing tm_g_waterfall") |
109 | ! |
checkmate::assert_string(label) |
110 | ! |
checkmate::assert_string(dataname_tr) |
111 | ! |
checkmate::assert_string(dataname_rs) |
112 | ! |
checkmate::assert_class(bar_paramcd, classes = "choices_selected") |
113 | ! |
checkmate::assert_class(bar_var, classes = "choices_selected") |
114 | ! |
checkmate::assert_class(bar_color_var, classes = "choices_selected") |
115 | ! |
checkmate::assert_class(sort_var, classes = "choices_selected") |
116 | ! |
checkmate::assert_class(anno_txt_var_sl, classes = "choices_selected") |
117 | ! |
checkmate::assert_class(anno_txt_paramcd_rs, classes = "choices_selected") |
118 | ! |
checkmate::assert_class(facet_var, classes = "choices_selected") |
119 | ! |
checkmate::assert_class(add_label_var_sl, classes = "choices_selected") |
120 | ! |
checkmate::assert_class(add_label_paramcd_rs, classes = "choices_selected") |
121 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
122 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
123 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
124 | ! |
checkmate::assert_numeric( |
125 | ! |
plot_width[1], |
126 | ! |
lower = plot_width[2], |
127 | ! |
upper = plot_width[3], |
128 | ! |
null.ok = TRUE, |
129 | ! |
.var.name = "plot_width" |
130 |
) |
|
131 | ||
132 | ! |
args <- as.list(environment()) |
133 | ||
134 | ! |
module( |
135 | ! |
label = label, |
136 | ! |
ui = ui_g_waterfall, |
137 | ! |
ui_args = args, |
138 | ! |
server = srv_g_waterfall, |
139 | ! |
server_args = list( |
140 | ! |
dataname_tr = dataname_tr, |
141 | ! |
dataname_rs = dataname_rs, |
142 | ! |
bar_paramcd = bar_paramcd, |
143 | ! |
add_label_paramcd_rs = add_label_paramcd_rs, |
144 | ! |
anno_txt_paramcd_rs = anno_txt_paramcd_rs, |
145 | ! |
label = label, |
146 | ! |
bar_color_opt = bar_color_opt, |
147 | ! |
plot_height = plot_height, |
148 | ! |
plot_width = plot_width |
149 |
), |
|
150 | ! |
datanames = "all" |
151 |
) |
|
152 |
} |
|
153 | ||
154 |
ui_g_waterfall <- function(id, ...) { |
|
155 | ! |
a <- list(...) |
156 | ! |
ns <- NS(id) |
157 | ! |
teal.widgets::standard_layout( |
158 | ! |
output = teal.widgets::white_small_well( |
159 | ! |
teal.widgets::plot_with_settings_ui(id = ns("waterfallplot")) |
160 |
), |
|
161 | ! |
encoding = tags$div( |
162 |
### Reporter |
|
163 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
164 |
### |
|
165 | ! |
tags$label("Encodings", class = "text-primary"), |
166 | ! |
helpText("Analysis Data: ", tags$code(a$dataname_tr), tags$code(a$dataname_rs)), |
167 | ! |
teal.widgets::optionalSelectInput( |
168 | ! |
ns("bar_paramcd"), |
169 | ! |
"Tumor Burden Parameter", |
170 | ! |
multiple = FALSE |
171 |
), |
|
172 | ! |
teal.widgets::optionalSelectInput( |
173 | ! |
ns("bar_var"), |
174 | ! |
"Bar Height", |
175 | ! |
choices = get_choices(a$bar_var$choices), |
176 | ! |
selected = a$bar_var$selected, |
177 | ! |
multiple = FALSE, |
178 | ! |
label_help = helpText("Tumor change variable from ", tags$code("ADTR")) |
179 |
), |
|
180 | ! |
teal.widgets::optionalSelectInput( |
181 | ! |
ns("bar_color_var"), |
182 | ! |
"Bar Color", |
183 | ! |
choices = get_choices(a$bar_color_var$choices), |
184 | ! |
selected = a$bar_color_var$selected, |
185 | ! |
multiple = FALSE |
186 |
), |
|
187 | ! |
teal.widgets::optionalSelectInput( |
188 | ! |
ns("sort_var"), |
189 | ! |
"Sort by", |
190 | ! |
choices = get_choices(a$sort_var$choices), |
191 | ! |
selected = a$sort_var$selected, |
192 | ! |
multiple = FALSE, |
193 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
194 |
), |
|
195 | ! |
teal.widgets::optionalSelectInput( |
196 | ! |
ns("add_label_var_sl"), |
197 | ! |
"Add ADSL Label to Bars", |
198 | ! |
choices = get_choices(a$add_label_var_sl$choices), |
199 | ! |
selected = a$add_label_var_sl$selected, |
200 | ! |
multiple = FALSE |
201 |
), |
|
202 | ! |
teal.widgets::optionalSelectInput( |
203 | ! |
ns("add_label_paramcd_rs"), |
204 | ! |
"Add ADRS Label to Bars", |
205 | ! |
multiple = FALSE |
206 |
), |
|
207 | ! |
teal.widgets::optionalSelectInput( |
208 | ! |
ns("anno_txt_var_sl"), |
209 | ! |
"Annotation Variables", |
210 | ! |
choices = get_choices(a$anno_txt_var_sl$choices), |
211 | ! |
selected = a$anno_txt_var_sl$selected, |
212 | ! |
multiple = TRUE, |
213 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
214 |
), |
|
215 | ! |
teal.widgets::optionalSelectInput( |
216 | ! |
ns("anno_txt_paramcd_rs"), |
217 | ! |
"Annotation Parameters", |
218 | ! |
multiple = TRUE, |
219 | ! |
label_help = helpText("from ", tags$code("ADRS")) |
220 |
), |
|
221 | ! |
teal.widgets::optionalSelectInput( |
222 | ! |
ns("facet_var"), |
223 | ! |
"Facet by", |
224 | ! |
choices = get_choices(a$facet_var$choices), |
225 | ! |
selected = NULL, |
226 | ! |
multiple = FALSE, |
227 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
228 |
), |
|
229 | ! |
checkboxInput( |
230 | ! |
ns("show_value"), |
231 | ! |
"Add Bar Height Value", |
232 | ! |
value = a$show_value |
233 |
), |
|
234 | ! |
textInput( |
235 | ! |
ns("href_line"), |
236 | ! |
label = tags$div( |
237 | ! |
"Horizontal Reference Line(s)", |
238 | ! |
tags$br(), |
239 | ! |
helpText("Enter numeric value(s) of reference lines, separated by comma (eg. -10, 20)") |
240 |
), |
|
241 | ! |
value = a$href_line |
242 |
), |
|
243 | ! |
textInput( |
244 | ! |
ns("ytick_at"), |
245 | ! |
label = tags$div( |
246 | ! |
"Y-axis Interval", |
247 | ! |
tags$br(), |
248 | ! |
helpText("Enter a numeric value of Y axis interval") |
249 |
), |
|
250 | ! |
value = a$ytick_at |
251 |
), |
|
252 | ! |
textInput( |
253 | ! |
ns("gap_point_val"), |
254 | ! |
label = tags$div( |
255 | ! |
"Break High Bars", |
256 | ! |
tags$br(), |
257 | ! |
helpText("Enter a numeric value to break very high bars") |
258 |
), |
|
259 | ! |
value = a$gap_point_val |
260 |
) |
|
261 |
), |
|
262 | ! |
forms = tagList( |
263 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
264 |
), |
|
265 | ! |
pre_output = a$pre_output, |
266 | ! |
post_output = a$post_output |
267 |
) |
|
268 |
} |
|
269 | ||
270 |
srv_g_waterfall <- function(id, |
|
271 |
data, |
|
272 |
filter_panel_api, |
|
273 |
reporter, |
|
274 |
bar_paramcd, |
|
275 |
add_label_paramcd_rs, |
|
276 |
anno_txt_paramcd_rs, |
|
277 |
dataname_tr, |
|
278 |
dataname_rs, |
|
279 |
bar_color_opt, |
|
280 |
label, |
|
281 |
plot_height, |
|
282 |
plot_width) { |
|
283 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
284 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
285 | ! |
checkmate::assert_class(data, "reactive") |
286 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
287 | ||
288 | ! |
moduleServer(id, function(input, output, session) { |
289 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
290 | ||
291 | ! |
env <- as.list(isolate(data())@env) |
292 | ! |
resolved_bar_paramcd <- teal.transform::resolve_delayed(bar_paramcd, env) |
293 | ! |
resolved_add_label_paramcd_rs <- teal.transform::resolve_delayed(add_label_paramcd_rs, env) |
294 | ! |
resolved_anno_txt_paramcd_rs <- teal.transform::resolve_delayed(anno_txt_paramcd_rs, env) |
295 | ||
296 | ! |
teal.widgets::updateOptionalSelectInput( |
297 | ! |
session = session, |
298 | ! |
inputId = "bar_paramcd", |
299 | ! |
choices = resolved_bar_paramcd$choices, |
300 | ! |
selected = resolved_bar_paramcd$selected |
301 |
) |
|
302 | ! |
teal.widgets::updateOptionalSelectInput( |
303 | ! |
session = session, |
304 | ! |
inputId = "add_label_paramcd_rs", |
305 | ! |
choices = resolved_add_label_paramcd_rs$choices, |
306 | ! |
selected = resolved_add_label_paramcd_rs$selected |
307 |
) |
|
308 | ! |
teal.widgets::updateOptionalSelectInput( |
309 | ! |
session = session, |
310 | ! |
inputId = "anno_txt_paramcd_rs", |
311 | ! |
choices = resolved_anno_txt_paramcd_rs$choices, |
312 | ! |
selected = resolved_anno_txt_paramcd_rs$selected |
313 |
) |
|
314 | ||
315 | ! |
iv <- reactive({ |
316 | ! |
adsl <- data()[["ADSL"]] |
317 | ! |
adtr <- data()[[dataname_tr]] |
318 | ! |
adrs <- data()[[dataname_rs]] |
319 | ||
320 | ! |
iv <- shinyvalidate::InputValidator$new() |
321 | ! |
iv$add_rule("bar_var", shinyvalidate::sv_required( |
322 | ! |
message = "Bar Height is required" |
323 |
)) |
|
324 | ! |
iv$add_rule("bar_paramcd", shinyvalidate::sv_required( |
325 | ! |
message = "Tumor Burden Parameter is required" |
326 |
)) |
|
327 | ! |
iv$add_rule("bar_paramcd", shinyvalidate::sv_in_set( |
328 | ! |
set = adtr$PARAMCD, |
329 | ! |
message_fmt = "All values of Tumor Burden Parameter must be elements of ADTR PARAMCD" |
330 |
)) |
|
331 | ! |
iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_optional()) |
332 | ! |
iv$add_rule("add_label_paramcd_rs", shinyvalidate::sv_in_set( |
333 | ! |
set = adrs$PARAMCD, |
334 | ! |
message_fmt = "ADRS Label must be an element of ADRS PARAMCD" |
335 |
)) |
|
336 | ! |
rule_excl <- function(value, other) { |
337 | ! |
if (length(value) > 0L && length(other) > 0L) { |
338 | ! |
"Only one \"Label to Bars\" is allowed" |
339 |
} |
|
340 |
} |
|
341 | ! |
iv$add_rule("add_label_paramcd_rs", rule_excl, other = input$add_label_var_sl) |
342 | ! |
iv$add_rule("add_label_var_sl", rule_excl, other = input$add_label_paramcd_rs) |
343 | ! |
iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_optional()) |
344 | ! |
iv$add_rule("anno_txt_paramcd_rs", shinyvalidate::sv_in_set( |
345 | ! |
set = adrs$PARAMCD, |
346 | ! |
message_fmt = "Annotation Parameters must be elements of ADRS PARAMCD" |
347 |
)) |
|
348 | ! |
iv$add_rule("href_line", shinyvalidate::sv_optional()) |
349 | ! |
iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { |
350 | ! |
"Horizontal Reference Line(s) are invalid" |
351 |
}) |
|
352 | ! |
iv$add_rule("ytick_at", shinyvalidate::sv_required( |
353 | ! |
message = "Y-axis Interval is required" |
354 |
)) |
|
355 | ! |
iv$add_rule("ytick_at", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { |
356 | ! |
"Y-axis Interval must be a single positive number" |
357 |
}) |
|
358 | ! |
iv$add_rule("gap_point_val", shinyvalidate::sv_optional()) |
359 | ! |
iv$add_rule("gap_point_val", ~ if (!checkmate::test_number(suppressWarnings(as.numeric(.)), lower = 1)) { |
360 | ! |
"Break High Bars must be a single positive number" |
361 |
}) |
|
362 | ! |
iv$enable() |
363 | ! |
iv |
364 |
}) |
|
365 | ||
366 | ! |
output_q <- reactive({ |
367 | ! |
adsl <- data()[["ADSL"]] |
368 | ! |
adtr <- data()[[dataname_tr]] |
369 | ! |
adrs <- data()[[dataname_rs]] |
370 | ||
371 |
# validate data rows |
|
372 | ! |
teal::validate_has_data(adsl, min_nrow = 2) |
373 | ! |
teal::validate_has_data(adtr, min_nrow = 2) |
374 | ! |
teal::validate_has_data(adrs, min_nrow = 2) |
375 | ||
376 | ! |
adsl_vars <- unique( |
377 | ! |
c( |
378 | ! |
"USUBJID", "STUDYID", |
379 | ! |
input$bar_color_var, input$sort_var, input$add_label_var_sl, input$anno_txt_var_sl, input$facet_var |
380 |
) |
|
381 |
) |
|
382 | ! |
adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", input$bar_var)) |
383 | ! |
adrs_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", "AVALC")) |
384 | ! |
adrs_paramcd <- unique(c(input$add_label_paramcd_rs, input$anno_txt_paramcd_rs)) |
385 | ||
386 |
# validate data input |
|
387 | ! |
teal::validate_has_variable(adsl, adsl_vars) |
388 | ! |
teal::validate_has_variable(adrs, adrs_vars) |
389 | ! |
teal::validate_has_variable(adtr, adtr_vars) |
390 | ||
391 | ! |
teal::validate_inputs(iv()) |
392 | ||
393 |
# get variables |
|
394 | ! |
bar_var <- input$bar_var |
395 | ! |
bar_paramcd <- input$bar_paramcd |
396 | ! |
add_label_var_sl <- input$add_label_var_sl |
397 | ! |
add_label_paramcd_rs <- input$add_label_paramcd_rs |
398 | ! |
anno_txt_var_sl <- input$anno_txt_var_sl |
399 | ! |
anno_txt_paramcd_rs <- input$anno_txt_paramcd_rs |
400 | ! |
ytick_at <- input$ytick_at |
401 | ! |
href_line <- input$href_line |
402 | ! |
gap_point_val <- input$gap_point_val |
403 | ! |
show_value <- input$show_value |
404 | ! |
href_line <- suppressWarnings(as_numeric_from_comma_sep_str(href_line)) |
405 | ||
406 | ! |
if (gap_point_val == "") { |
407 | ! |
gap_point_val <- NULL |
408 |
} else { |
|
409 | ! |
gap_point_val <- as.numeric(gap_point_val) |
410 |
} |
|
411 | ! |
ytick_at <- as.numeric(ytick_at) |
412 | ||
413 | ! |
bar_color_var <- if ( |
414 | ! |
!is.null(input$bar_color_var) && |
415 | ! |
input$bar_color_var != "None" && |
416 | ! |
input$bar_color_var != "" |
417 |
) { |
|
418 | ! |
input$bar_color_var |
419 |
} else { |
|
420 | ! |
NULL |
421 |
} |
|
422 | ! |
sort_var <- if (!is.null(input$sort_var) && input$sort_var != "None" && input$sort_var != "") { |
423 | ! |
input$sort_var |
424 |
} else { |
|
425 | ! |
NULL |
426 |
} |
|
427 | ! |
facet_var <- if (!is.null(input$facet_var) && input$facet_var != "None" && input$facet_var != "") { |
428 | ! |
input$facet_var |
429 |
} else { |
|
430 | ! |
NULL |
431 |
} |
|
432 | ||
433 |
# write variables to qenv |
|
434 | ! |
q1 <- teal.code::eval_code( |
435 | ! |
data(), |
436 | ! |
code = bquote({ |
437 | ! |
bar_var <- .(bar_var) |
438 | ! |
bar_color_var <- .(bar_color_var) |
439 | ! |
sort_var <- .(sort_var) |
440 | ! |
add_label_var_sl <- .(add_label_var_sl) |
441 | ! |
add_label_paramcd_rs <- .(add_label_paramcd_rs) |
442 | ! |
anno_txt_var_sl <- .(anno_txt_var_sl) |
443 | ! |
anno_txt_paramcd_rs <- .(anno_txt_paramcd_rs) |
444 | ! |
facet_var <- .(facet_var) |
445 | ! |
href_line <- .(href_line) |
446 | ! |
gap_point_val <- .(gap_point_val) |
447 | ! |
show_value <- .(show_value) |
448 |
}) |
|
449 |
) |
|
450 | ||
451 |
# data processing |
|
452 | ! |
q1 <- teal.code::eval_code( |
453 | ! |
q1, |
454 | ! |
code = bquote({ |
455 | ! |
adsl <- ADSL[, .(adsl_vars)] |
456 | ! |
adtr <- .(as.name(dataname_tr))[, .(adtr_vars)] |
457 | ! |
adrs <- .(as.name(dataname_rs))[, .(adrs_vars)] |
458 | ||
459 | ! |
bar_tr <- .(as.name(dataname_tr)) %>% |
460 | ! |
dplyr::filter(PARAMCD == .(bar_paramcd)) %>% |
461 | ! |
dplyr::select(USUBJID, .(as.name(bar_var))) %>% |
462 | ! |
dplyr::group_by(USUBJID) %>% |
463 | ! |
dplyr::slice(which.min(.(as.name(bar_var)))) |
464 | ! |
bar_data <- adsl %>% dplyr::inner_join(bar_tr, "USUBJID") |
465 |
}) |
|
466 |
) |
|
467 | ||
468 | ! |
q1 <- if (is.null(adrs_paramcd)) { |
469 | ! |
teal.code::eval_code( |
470 | ! |
q1, |
471 | ! |
code = bquote({ |
472 | ! |
anl <- bar_data |
473 | ! |
anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) |
474 |
}) |
|
475 |
) |
|
476 |
} else { |
|
477 | ! |
qq1 <- teal.code::eval_code( |
478 | ! |
q1, |
479 | ! |
code = bquote( |
480 | ! |
rs_sub <- .(as.name(dataname_rs)) %>% |
481 | ! |
dplyr::filter(PARAMCD %in% .(adrs_paramcd)) |
482 |
) |
|
483 |
) |
|
484 | ||
485 | ! |
teal::validate_one_row_per_id(qq1[["rs_sub"]], key = c("STUDYID", "USUBJID", "PARAMCD")) |
486 | ||
487 | ! |
teal.code::eval_code( |
488 | ! |
qq1, |
489 | ! |
code = bquote({ |
490 | ! |
rs_label <- rs_sub %>% |
491 | ! |
dplyr::select(USUBJID, PARAMCD, AVALC) %>% |
492 | ! |
tidyr::pivot_wider(names_from = PARAMCD, values_from = AVALC) |
493 | ! |
anl <- bar_data %>% dplyr::left_join(rs_label, by = c("USUBJID")) |
494 | ! |
anl$USUBJID <- unlist(lapply(strsplit(anl$USUBJID, "-", fixed = TRUE), tail, 1)) |
495 |
}) |
|
496 |
) |
|
497 |
} |
|
498 | ||
499 |
# write plotting code to qenv |
|
500 | ! |
anl <- q1[["anl"]] |
501 | ||
502 | ! |
q1 <- teal.code::eval_code( |
503 | ! |
q1, |
504 | ! |
code = bquote({ |
505 | ! |
plot <- osprey::g_waterfall( |
506 | ! |
bar_id = anl[["USUBJID"]], |
507 | ! |
bar_height = anl[[bar_var]], |
508 | ! |
sort_by = .(if (length(sort_var) > 0) { |
509 | ! |
quote(anl[[sort_var]]) |
510 |
} else { |
|
511 | ! |
NULL |
512 |
}), |
|
513 | ! |
col_by = .(if (length(bar_color_var) > 0) { |
514 | ! |
quote(anl[[bar_color_var]]) |
515 |
} else { |
|
516 | ! |
NULL |
517 |
}), |
|
518 | ! |
bar_color_opt = .(if (length(bar_color_var) == 0) { |
519 | ! |
NULL |
520 | ! |
} else if (length(bar_color_var) > 0 & all(unique(anl[[bar_color_var]]) %in% names(bar_color_opt))) { |
521 | ! |
bar_color_opt |
522 |
} else { |
|
523 | ! |
NULL |
524 |
}), |
|
525 | ! |
anno_txt = .(if (length(anno_txt_var_sl) == 0 & length(anno_txt_paramcd_rs) == 0) { |
526 | ! |
NULL |
527 | ! |
} else if (length(anno_txt_var_sl) >= 1 & length(anno_txt_paramcd_rs) == 0) { |
528 | ! |
quote(data.frame(anl[anno_txt_var_sl])) |
529 | ! |
} else if (length(anno_txt_paramcd_rs) >= 1 & length(anno_txt_var_sl) == 0) { |
530 | ! |
quote(data.frame(anl[anno_txt_paramcd_rs])) |
531 |
} else { |
|
532 | ! |
quote(cbind(anl[anno_txt_var_sl], anl[anno_txt_paramcd_rs])) |
533 |
}), |
|
534 | ! |
href_line = .(href_line), |
535 | ! |
facet_by = .(if (length(facet_var) > 0) { |
536 | ! |
quote(as.factor(anl[[facet_var]])) |
537 |
} else { |
|
538 | ! |
NULL |
539 |
}), |
|
540 | ! |
show_datavalue = .(show_value), |
541 | ! |
add_label = .(if (length(add_label_var_sl) > 0 & length(add_label_paramcd_rs) == 0) { |
542 | ! |
quote(anl[[add_label_var_sl]]) |
543 | ! |
} else if (length(add_label_paramcd_rs) > 0 & length(add_label_var_sl) == 0) { |
544 | ! |
quote(anl[[add_label_paramcd_rs]]) |
545 |
} else { |
|
546 | ! |
NULL |
547 |
}), |
|
548 | ! |
gap_point = .(gap_point_val), |
549 | ! |
ytick_at = .(ytick_at), |
550 | ! |
y_label = "Tumor Burden Change from Baseline", |
551 | ! |
title = "Waterfall Plot" |
552 |
) |
|
553 | ! |
plot |
554 |
}) |
|
555 |
) |
|
556 |
}) |
|
557 | ||
558 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
559 | ||
560 |
# Insert the plot into a plot_with_settings module from teal.widgets |
|
561 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
562 | ! |
id = "waterfallplot", |
563 | ! |
plot_r = plot_r, |
564 | ! |
height = plot_height, |
565 | ! |
width = plot_width |
566 |
) |
|
567 | ||
568 |
# Show R Code |
|
569 | ! |
teal.widgets::verbatim_popup_srv( |
570 | ! |
id = "rcode", |
571 | ! |
title = paste("R code for", label), |
572 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
573 |
) |
|
574 | ||
575 |
### REPORTER |
|
576 | ! |
if (with_reporter) { |
577 | ! |
card_fun <- function(comment, label) { |
578 | ! |
card <- teal::report_card_template( |
579 | ! |
title = "Waterfall Plot", |
580 | ! |
label = label, |
581 | ! |
with_filter = with_filter, |
582 | ! |
filter_panel_api = filter_panel_api |
583 |
) |
|
584 | ! |
card$append_text("Selected Options", "header3") |
585 | ! |
card$append_text(paste0("Tumor Burden Parameter: ", input$bar_paramcd, ".")) |
586 | ! |
if (!is.null(input$sort_var)) { |
587 | ! |
card$append_text(paste0("Sorted by: ", input$sort_var, ".")) |
588 |
} |
|
589 | ! |
if (!is.null(input$facet_var)) { |
590 | ! |
card$append_text(paste0("Faceted by: ", paste(input$facet_var, collapse = ", "), ".")) |
591 |
} |
|
592 | ! |
card$append_text("Plot", "header3") |
593 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
594 | ! |
if (!comment == "") { |
595 | ! |
card$append_text("Comment", "header3") |
596 | ! |
card$append_text(comment) |
597 |
} |
|
598 | ! |
card$append_src(teal.code::get_code(output_q())) |
599 | ! |
card |
600 |
} |
|
601 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
602 |
} |
|
603 |
}) |
|
604 |
} |
1 |
#' Teal Module for `Swimlane` Plot |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' This is teal module that generates a `swimlane` plot (bar plot with markers) for `ADaM` data |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param dataname analysis data used for plotting, needs to be available in the list passed to the `data` |
|
11 |
#' argument of [teal::init()]. If no markers are to be plotted in the module, `"ADSL"` should be |
|
12 |
#' the input. If markers are to be plotted, data name for the marker data should be the input |
|
13 |
#' @param bar_var [teal.transform::choices_selected] subject-level numeric variable from dataset |
|
14 |
#' to plot as the bar length |
|
15 |
#' @param bar_color_var [teal.transform::choices_selected] color by variable (subject-level) |
|
16 |
#' @param sort_var `choices_selected` sort by variable (subject-level) |
|
17 |
#' @param marker_pos_var [teal.transform::choices_selected] variable for marker position from marker data |
|
18 |
#' (Note: make sure that marker position has the same relative start day as bar length variable `bar_var` |
|
19 |
#' @param marker_shape_var [teal.transform::choices_selected] marker shape variable from marker data |
|
20 |
#' @param marker_shape_opt aesthetic values to map shape values (named vector to map shape values to each name). |
|
21 |
#' If not `NULL`, please make sure this contains all possible values for `marker_shape_var` values, |
|
22 |
#' otherwise shape will be assigned by `ggplot` default |
|
23 |
#' @param marker_color_var marker color variable from marker data |
|
24 |
#' @param marker_color_opt aesthetic values to map color values (named vector to map color values to each name). |
|
25 |
#' If not `NULL`, please make sure this contains all possible values for `marker_color_var` values, |
|
26 |
#' otherwise color will be assigned by `ggplot` default |
|
27 |
#' @param vref_line vertical reference lines |
|
28 |
#' @param anno_txt_var character vector with subject-level variable names that are selected as annotation |
|
29 |
#' @param x_label the label of the x axis |
|
30 |
#' |
|
31 |
#' @inherit argument_convention return |
|
32 |
#' |
|
33 |
#' @export |
|
34 |
#' |
|
35 |
#' @template author_qit3 |
|
36 |
#' |
|
37 |
#' @examples |
|
38 |
#' # Example using stream (ADaM) dataset |
|
39 |
#' data <- cdisc_data() |> |
|
40 |
#' within(library(dplyr)) |> |
|
41 |
#' within(library(nestcolor)) |> |
|
42 |
#' within(ADSL <- rADSL %>% |
|
43 |
#' mutate(TRTDURD = as.integer(TRTEDTM - TRTSDTM) + 1) %>% |
|
44 |
#' filter(STRATA1 == "A" & ARMCD == "ARM A")) |> |
|
45 |
#' within(ADRS <- rADRS %>% |
|
46 |
#' filter(PARAMCD == "LSTASDI" & DCSREAS == "Death") %>% |
|
47 |
#' mutate(AVALC = DCSREAS, ADY = EOSDY) %>% |
|
48 |
#' rbind(rADRS %>% filter(PARAMCD == "OVRINV" & AVALC != "NE")) %>% |
|
49 |
#' arrange(USUBJID)) |
|
50 |
#' |
|
51 |
#' datanames(data) <- c("ADSL", "ADRS") |
|
52 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
53 |
#' |
|
54 |
#' ADSL <- data[["ADSL"]] |
|
55 |
#' ADRS <- data[["ADRS"]] |
|
56 |
#' |
|
57 |
#' app <- init( |
|
58 |
#' data = data, |
|
59 |
#' modules = modules( |
|
60 |
#' tm_g_swimlane( |
|
61 |
#' label = "Swimlane Plot", |
|
62 |
#' dataname = "ADRS", |
|
63 |
#' bar_var = choices_selected( |
|
64 |
#' selected = "TRTDURD", |
|
65 |
#' choices = c("TRTDURD", "EOSDY") |
|
66 |
#' ), |
|
67 |
#' bar_color_var = choices_selected( |
|
68 |
#' selected = "EOSSTT", |
|
69 |
#' choices = c("EOSSTT", "ARM", "ARMCD", "ACTARM", "ACTARMCD", "SEX") |
|
70 |
#' ), |
|
71 |
#' sort_var = choices_selected( |
|
72 |
#' selected = "ACTARMCD", |
|
73 |
#' choices = c("USUBJID", "SITEID", "ACTARMCD", "TRTDURD") |
|
74 |
#' ), |
|
75 |
#' marker_pos_var = choices_selected( |
|
76 |
#' selected = "ADY", |
|
77 |
#' choices = c("ADY") |
|
78 |
#' ), |
|
79 |
#' marker_shape_var = choices_selected( |
|
80 |
#' selected = "AVALC", |
|
81 |
#' c("AVALC", "AVISIT") |
|
82 |
#' ), |
|
83 |
#' marker_shape_opt = c("CR" = 16, "PR" = 17, "SD" = 18, "PD" = 15, "Death" = 8), |
|
84 |
#' marker_color_var = choices_selected( |
|
85 |
#' selected = "AVALC", |
|
86 |
#' choices = c("AVALC", "AVISIT") |
|
87 |
#' ), |
|
88 |
#' marker_color_opt = c( |
|
89 |
#' "CR" = "green", "PR" = "blue", "SD" = "goldenrod", |
|
90 |
#' "PD" = "red", "Death" = "black" |
|
91 |
#' ), |
|
92 |
#' vref_line = c(30, 60), |
|
93 |
#' anno_txt_var = choices_selected( |
|
94 |
#' selected = c("ACTARM", "SEX"), |
|
95 |
#' choices = c( |
|
96 |
#' "ARM", "ARMCD", "ACTARM", "ACTARMCD", "AGEGR1", |
|
97 |
#' "SEX", "RACE", "COUNTRY", "DCSREAS", "DCSREASP" |
|
98 |
#' ) |
|
99 |
#' ) |
|
100 |
#' ) |
|
101 |
#' ) |
|
102 |
#' ) |
|
103 |
#' if (interactive()) { |
|
104 |
#' shinyApp(app$ui, app$server) |
|
105 |
#' } |
|
106 |
#' |
|
107 |
tm_g_swimlane <- function(label, |
|
108 |
dataname, |
|
109 |
bar_var, |
|
110 |
bar_color_var = NULL, |
|
111 |
sort_var = NULL, |
|
112 |
marker_pos_var = NULL, |
|
113 |
marker_shape_var = NULL, |
|
114 |
marker_shape_opt = NULL, |
|
115 |
marker_color_var = NULL, |
|
116 |
marker_color_opt = NULL, |
|
117 |
anno_txt_var = NULL, |
|
118 |
vref_line = NULL, |
|
119 |
plot_height = c(1200L, 400L, 5000L), |
|
120 |
plot_width = NULL, |
|
121 |
pre_output = NULL, |
|
122 |
post_output = NULL, |
|
123 |
x_label = "Time from First Treatment (Day)") { |
|
124 | ! |
message("Initializing tm_g_swimlane") |
125 | ! |
args <- as.list(environment()) |
126 | ||
127 | ! |
checkmate::assert_string(label) |
128 | ! |
checkmate::assert_string(dataname) |
129 | ! |
checkmate::assert_class(bar_var, classes = "choices_selected") |
130 | ! |
checkmate::assert_class(bar_color_var, classes = "choices_selected") |
131 | ! |
checkmate::assert_class(marker_pos_var, classes = "choices_selected") |
132 | ! |
checkmate::assert_class(marker_shape_var, classes = "choices_selected") |
133 | ! |
checkmate::assert_numeric(marker_shape_opt, min.len = 1, any.missing = FALSE) |
134 | ! |
checkmate::assert_class(marker_color_var, classes = "choices_selected") |
135 | ! |
checkmate::assert_character(marker_color_opt, min.len = 1, any.missing = FALSE, null.ok = TRUE) |
136 | ! |
checkmate::assert_class(anno_txt_var, classes = "choices_selected") |
137 | ! |
checkmate::assert_numeric(vref_line, min.len = 1, null.ok = TRUE, any.missing = FALSE) |
138 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
139 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
140 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
141 | ! |
checkmate::assert_numeric( |
142 | ! |
plot_width[1], |
143 | ! |
lower = plot_width[2], |
144 | ! |
upper = plot_width[3], |
145 | ! |
null.ok = TRUE, |
146 | ! |
.var.name = "plot_width" |
147 |
) |
|
148 | ! |
checkmate::assert_string(x_label) |
149 | ||
150 | ||
151 | ! |
module( |
152 | ! |
label = label, |
153 | ! |
ui = ui_g_swimlane, |
154 | ! |
ui_args = args, |
155 | ! |
server = srv_g_swimlane, |
156 | ! |
server_args = list( |
157 | ! |
dataname = dataname, |
158 | ! |
marker_pos_var = marker_pos_var, |
159 | ! |
marker_shape_var = marker_shape_var, |
160 | ! |
marker_shape_opt = marker_shape_opt, |
161 | ! |
marker_color_var = marker_color_var, |
162 | ! |
marker_color_opt = marker_color_opt, |
163 | ! |
label = label, |
164 | ! |
plot_height = plot_height, |
165 | ! |
plot_width = plot_width, |
166 | ! |
x_label = x_label |
167 |
), |
|
168 | ! |
datanames = c("ADSL", dataname) |
169 |
) |
|
170 |
} |
|
171 | ||
172 | ||
173 |
ui_g_swimlane <- function(id, ...) { |
|
174 | ! |
a <- list(...) |
175 | ! |
ns <- NS(id) |
176 | ||
177 | ! |
shiny::tagList( |
178 | ! |
include_css_files("custom"), |
179 | ! |
teal.widgets::standard_layout( |
180 | ! |
output = teal.widgets::white_small_well( |
181 | ! |
teal.widgets::plot_with_settings_ui(id = ns("swimlaneplot")) |
182 |
), |
|
183 | ! |
encoding = tags$div( |
184 |
### Reporter |
|
185 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
186 |
### |
|
187 | ! |
tags$label("Encodings", class = "text-primary"), |
188 | ! |
helpText("Analysis data:", tags$code(a$dataname)), |
189 | ! |
tags$div( |
190 | ! |
class = "pretty-left-border", |
191 | ! |
teal.widgets::optionalSelectInput( |
192 | ! |
ns("bar_var"), |
193 | ! |
"Bar Length", |
194 | ! |
choices = get_choices(a$bar_var$choices), |
195 | ! |
selected = a$bar_var$selected, |
196 | ! |
multiple = FALSE, |
197 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
198 |
), |
|
199 | ! |
teal.widgets::optionalSelectInput( |
200 | ! |
ns("bar_color_var"), |
201 | ! |
"Bar Color", |
202 | ! |
choices = get_choices(a$bar_color_var$choices), |
203 | ! |
selected = a$bar_color_var$selected, |
204 | ! |
multiple = FALSE, |
205 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
206 |
) |
|
207 |
), |
|
208 | ! |
teal.widgets::optionalSelectInput( |
209 | ! |
ns("sort_var"), |
210 | ! |
"Sort by", |
211 | ! |
choices = get_choices(a$sort_var$choices), |
212 | ! |
selected = a$sort_var$selected, |
213 | ! |
multiple = FALSE, |
214 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
215 |
), |
|
216 | ! |
tags$div( |
217 | ! |
class = "pretty-left-border", |
218 | ! |
if (a$dataname == "ADSL") { |
219 | ! |
NULL |
220 | ! |
} else if (is.null(a$marker_pos_var)) { |
221 | ! |
NULL |
222 |
} else { |
|
223 | ! |
teal.widgets::optionalSelectInput( |
224 | ! |
ns("marker_pos_var"), |
225 | ! |
"Marker Position", |
226 | ! |
choices = get_choices(a$marker_pos_var$choices), |
227 | ! |
selected = a$marker_pos_var$selected, |
228 | ! |
multiple = FALSE, |
229 | ! |
label_help = helpText("from ", tags$code(a$dataname)) |
230 |
) |
|
231 |
}, |
|
232 | ! |
uiOutput(ns("marker_shape_sel")), |
233 | ! |
uiOutput(ns("marker_color_sel")) |
234 |
), |
|
235 | ! |
teal.widgets::optionalSelectInput( |
236 | ! |
ns("anno_txt_var"), |
237 | ! |
"Annotation Variables", |
238 | ! |
choices = get_choices(a$anno_txt_var$choices), |
239 | ! |
selected = a$anno_txt_var$selected, |
240 | ! |
multiple = TRUE, |
241 | ! |
label_help = helpText("from ", tags$code("ADSL")) |
242 |
), |
|
243 | ! |
textInput( |
244 | ! |
ns("vref_line"), |
245 | ! |
label = tags$div( |
246 | ! |
"Vertical Reference Line(s)", |
247 | ! |
tags$br(), |
248 | ! |
helpText("Enter numeric value(s) of reference lines, separated by comma (eg. 100, 200)") |
249 |
), |
|
250 | ! |
value = paste(a$vref_line, collapse = ", ") |
251 |
) |
|
252 |
), |
|
253 | ! |
forms = tagList( |
254 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
255 |
), |
|
256 | ! |
pre_output = a$pre_output, |
257 | ! |
post_output = a$post_output |
258 |
) |
|
259 |
) |
|
260 |
} |
|
261 | ||
262 |
srv_g_swimlane <- function(id, |
|
263 |
data, |
|
264 |
filter_panel_api, |
|
265 |
reporter, |
|
266 |
dataname, |
|
267 |
marker_pos_var, |
|
268 |
marker_shape_var, |
|
269 |
marker_shape_opt, |
|
270 |
marker_color_var, |
|
271 |
marker_color_opt, |
|
272 |
label, |
|
273 |
plot_height, |
|
274 |
plot_width, |
|
275 |
x_label) { |
|
276 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
277 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
278 | ! |
checkmate::assert_class(data, "reactive") |
279 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
280 | ||
281 | ! |
moduleServer(id, function(input, output, session) { |
282 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
283 | ! |
iv <- reactive({ |
284 | ! |
iv <- shinyvalidate::InputValidator$new() |
285 | ! |
iv$add_rule("bar_var", shinyvalidate::sv_required( |
286 | ! |
message = "Bar Length is required" |
287 |
)) |
|
288 |
# If reference lines are requested |
|
289 | ! |
iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { |
290 | ! |
"Vertical Reference Line(s) are invalid" |
291 |
}) |
|
292 | ! |
iv$enable() |
293 | ! |
iv |
294 |
}) |
|
295 | ||
296 |
# if marker position is NULL, then hide options for marker shape and color |
|
297 | ! |
output$marker_shape_sel <- renderUI({ |
298 | ! |
if (dataname == "ADSL" || is.null(marker_shape_var) || is.null(input$marker_pos_var)) { |
299 | ! |
NULL |
300 |
} else { |
|
301 | ! |
ns <- session$ns |
302 | ! |
teal.widgets::optionalSelectInput( |
303 | ! |
ns("marker_shape_var"), "Marker Shape", |
304 | ! |
choices = get_choices(marker_shape_var$choices), |
305 | ! |
selected = marker_shape_var$selected, multiple = FALSE, |
306 | ! |
label_help = helpText("from ", tags$code(dataname)) |
307 |
) |
|
308 |
} |
|
309 |
}) |
|
310 | ! |
output$marker_color_sel <- renderUI({ |
311 | ! |
if (dataname == "ADSL" || is.null(marker_color_var) || is.null(input$marker_pos_var)) { |
312 | ! |
NULL |
313 |
} else { |
|
314 | ! |
ns <- session$ns |
315 | ! |
teal.widgets::optionalSelectInput( |
316 | ! |
ns("marker_color_var"), "Marker Color", |
317 | ! |
choices = get_choices(marker_color_var$choices), |
318 | ! |
selected = marker_color_var$selected, multiple = FALSE, |
319 | ! |
label_help = helpText("from ", tags$code(dataname)) |
320 |
) |
|
321 |
} |
|
322 |
}) |
|
323 | ||
324 |
# create plot |
|
325 | ! |
output_q <- reactive({ |
326 | ! |
teal::validate_inputs(iv()) |
327 | ||
328 | ! |
validate(need("ADSL" %in% teal.data::datanames(data()), "'ADSL' not included in data")) |
329 | ! |
validate(need( |
330 | ! |
(length(teal.data::datanames(data())) == 1 && dataname == "ADSL") || |
331 | ! |
(length(teal.data::datanames(data())) >= 2 && dataname != "ADSL"), paste( |
332 | ! |
"Please either add just 'ADSL' as dataname when just ADSL is available.", |
333 | ! |
"In case 2 datasets are available ADSL is not supposed to be the dataname." |
334 |
) |
|
335 |
)) |
|
336 | ||
337 | ! |
ADSL <- data()[["ADSL"]] |
338 | ||
339 | ! |
anl_vars <- unique(c( |
340 | ! |
"USUBJID", "STUDYID", |
341 | ! |
input$marker_pos_var, input$marker_shape_var, input$marker_color_var |
342 |
)) |
|
343 | ! |
adsl_vars <- unique(c( |
344 | ! |
"USUBJID", "STUDYID", |
345 | ! |
input$bar_var, input$bar_color_var, input$sort_var, input$anno_txt_var |
346 |
)) |
|
347 | ||
348 | ! |
if (dataname == "ADSL") { |
349 | ! |
teal::validate_has_data(ADSL, min_nrow = 3) |
350 | ! |
teal::validate_has_variable(ADSL, adsl_vars) |
351 |
} else { |
|
352 | ! |
anl <- data()[[dataname]] |
353 | ! |
teal::validate_has_data(anl, min_nrow = 3) |
354 | ! |
teal::validate_has_variable(anl, anl_vars) |
355 | ||
356 | ! |
validate(need( |
357 | ! |
!any(c(marker_pos_var, marker_shape_var, marker_color_var) %in% adsl_vars), |
358 | ! |
"marker-related variables need to come from marker data" |
359 |
)) |
|
360 |
} |
|
361 | ||
362 |
# VARIABLE GETTERS |
|
363 |
# lookup bar variables |
|
364 | ! |
bar_var <- input$bar_var |
365 | ! |
bar_color_var <- input$bar_color_var |
366 | ! |
sort_var <- input$sort_var |
367 | ! |
anno_txt_var <- input$anno_txt_var |
368 | ||
369 |
# Check if marker inputs can be used |
|
370 | ! |
if (dataname == "ADSL") { |
371 | ! |
marker_pos_var <- NULL |
372 | ! |
marker_shape_var <- NULL |
373 | ! |
marker_color_var <- NULL |
374 |
} else { |
|
375 | ! |
marker_pos_var <- input$marker_pos_var |
376 | ! |
marker_shape_var <- input$marker_shape_var |
377 | ! |
marker_color_var <- input$marker_color_var |
378 |
} |
|
379 | ! |
vref_line <- suppressWarnings(as_numeric_from_comma_sep_str(debounce(reactive(input$vref_line), 1500)())) |
380 | ||
381 | ! |
q1 <- data() |
382 | ||
383 | ! |
q2 <- teal.code::eval_code( |
384 | ! |
q1, |
385 | ! |
code = bquote({ |
386 | ! |
bar_var <- .(bar_var) |
387 | ! |
bar_color_var <- .(bar_color_var) |
388 | ! |
sort_var <- .(sort_var) |
389 | ! |
marker_pos_var <- .(marker_pos_var) |
390 | ! |
marker_shape_var <- .(marker_shape_var) |
391 | ! |
marker_color_var <- .(marker_color_var) |
392 | ! |
anno_txt_var <- .(anno_txt_var) |
393 |
}) |
|
394 |
) |
|
395 | ||
396 |
# WRITE DATA SELECTION TO qenv |
|
397 | ! |
q3 <- if (dataname == "ADSL") { |
398 | ! |
teal.code::eval_code( |
399 | ! |
q2, |
400 | ! |
code = bquote({ |
401 | ! |
ADSL_p <- ADSL |
402 | ! |
ADSL <- ADSL_p[, .(adsl_vars)] |
403 |
# only take last part of USUBJID |
|
404 | ! |
ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) |
405 |
}) |
|
406 |
) |
|
407 |
} else { |
|
408 | ! |
teal.code::eval_code( |
409 | ! |
q2, |
410 | ! |
code = bquote({ |
411 | ! |
ADSL_p <- ADSL |
412 | ! |
ANL_p <- .(as.name(dataname)) |
413 | ||
414 | ! |
ADSL <- ADSL_p[, .(adsl_vars)] |
415 | ! |
ANL <- merge( |
416 | ! |
x = ADSL, |
417 | ! |
y = ANL_p[, .(anl_vars)], |
418 | ! |
all.x = FALSE, all.y = FALSE, |
419 | ! |
by = c("USUBJID", "STUDYID") |
420 |
) |
|
421 |
# only take last part of USUBJID |
|
422 | ! |
ADSL$USUBJID <- unlist(lapply(strsplit(ADSL$USUBJID, "-", fixed = TRUE), tail, 1)) |
423 | ! |
ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) |
424 |
}) |
|
425 |
) |
|
426 |
} |
|
427 | ||
428 | ! |
plot_call <- if (dataname == "ADSL") { |
429 | ! |
bquote( |
430 | ! |
plot <- osprey::g_swimlane( |
431 | ! |
bar_id = ADSL[["USUBJID"]], |
432 | ! |
bar_length = ADSL[[bar_var]], |
433 | ! |
sort_by = .(if (length(sort_var) > 0) quote(ADSL[[sort_var]]) else NULL), |
434 | ! |
col_by = .(if (length(bar_color_var) > 0) quote(ADSL[[bar_color_var]]) else NULL), |
435 | ! |
marker_id = NULL, |
436 | ! |
marker_pos = NULL, |
437 | ! |
marker_shape = NULL, |
438 | ! |
marker_shape_opt = NULL, |
439 | ! |
marker_color = NULL, |
440 | ! |
marker_color_opt = NULL, |
441 | ! |
anno_txt = .(if (length(anno_txt_var) > 0) quote(ADSL[, anno_txt_var]) else NULL), |
442 | ! |
xref_line = .(vref_line), |
443 | ! |
xtick_at = waiver(), |
444 | ! |
xlab = .(x_label), |
445 | ! |
title = "Swimlane Plot" |
446 |
) |
|
447 |
) |
|
448 |
} else { |
|
449 | ! |
bquote( |
450 | ! |
plot <- osprey::g_swimlane( |
451 | ! |
bar_id = ADSL[["USUBJID"]], |
452 | ! |
bar_length = ADSL[[bar_var]], |
453 | ! |
sort_by = .(if (length(sort_var) > 0) { |
454 | ! |
quote(ADSL[[sort_var]]) |
455 |
} else { |
|
456 | ! |
NULL |
457 |
}), |
|
458 | ! |
col_by = .(if (length(bar_color_var) > 0) { |
459 | ! |
quote(ADSL[[bar_color_var]]) |
460 |
} else { |
|
461 | ! |
NULL |
462 |
}), |
|
463 | ! |
marker_id = ANL[["USUBJID"]], |
464 | ! |
marker_pos = .(if (length(marker_pos_var) > 0) { |
465 | ! |
quote(ANL[[marker_pos_var]]) |
466 |
} else { |
|
467 | ! |
NULL |
468 |
}), |
|
469 | ! |
marker_shape = .(if (length(marker_shape_var) > 0) { |
470 | ! |
quote(ANL[[marker_shape_var]]) |
471 |
} else { |
|
472 | ! |
NULL |
473 |
}), |
|
474 | ! |
marker_shape_opt = .(if (length(marker_shape_var) == 0) { |
475 | ! |
NULL |
476 | ! |
} else if (length(marker_shape_var) > 0 && all(unique(anl[[marker_shape_var]]) %in% names(marker_shape_opt))) { # nolint: line_length. |
477 | ! |
bquote(.(marker_shape_opt)) |
478 |
} else { |
|
479 | ! |
NULL |
480 |
}), |
|
481 | ! |
marker_color = .(if (length(marker_color_var) > 0) { |
482 | ! |
quote(ANL[[marker_color_var]]) |
483 |
} else { |
|
484 | ! |
NULL |
485 |
}), |
|
486 | ! |
marker_color_opt = .(if (length(marker_color_var) == 0) { |
487 | ! |
NULL |
488 | ! |
} else if (length(marker_color_var) > 0 && all(unique(anl[[marker_color_var]]) %in% names(marker_color_opt))) { # nolint: line_length. |
489 | ! |
bquote(.(marker_color_opt)) |
490 |
} else { |
|
491 | ! |
NULL |
492 |
}), |
|
493 | ! |
anno_txt = .(if (length(anno_txt_var) > 0) { |
494 | ! |
quote(ADSL[, anno_txt_var]) |
495 |
} else { |
|
496 | ! |
NULL |
497 |
}), |
|
498 | ! |
xref_line = .(vref_line), |
499 | ! |
xtick_at = waiver(), |
500 | ! |
xlab = .(x_label), |
501 | ! |
title = "Swimlane Plot" |
502 |
) |
|
503 |
) |
|
504 |
} |
|
505 | ||
506 | ! |
q4 <- teal.code::eval_code(q3, code = plot_call) |
507 | ! |
teal.code::eval_code(q4, quote(plot)) |
508 |
}) |
|
509 | ||
510 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
511 | ||
512 |
# Insert the plot into a plot_with_settings module from teal.widgets |
|
513 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
514 | ! |
id = "swimlaneplot", |
515 | ! |
plot_r = plot_r, |
516 | ! |
height = plot_height, |
517 | ! |
width = plot_width |
518 |
) |
|
519 | ||
520 | ! |
teal.widgets::verbatim_popup_srv( |
521 | ! |
id = "rcode", |
522 | ! |
title = paste("R code for", label), |
523 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
524 |
) |
|
525 | ||
526 |
### REPORTER |
|
527 | ! |
if (with_reporter) { |
528 | ! |
card_fun <- function(comment, label) { |
529 | ! |
card <- teal::report_card_template( |
530 | ! |
title = "Swimlane Plot", |
531 | ! |
label = label, |
532 | ! |
with_filter = with_filter, |
533 | ! |
filter_panel_api = filter_panel_api |
534 |
) |
|
535 | ! |
if (!is.null(input$sort_var)) { |
536 | ! |
card$append_text("Selected Options", "header3") |
537 | ! |
card$append_text(paste("Sorted by:", input$sort_var)) |
538 |
} |
|
539 | ! |
card$append_text("Plot", "header3") |
540 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
541 | ! |
if (!comment == "") { |
542 | ! |
card$append_text("Comment", "header3") |
543 | ! |
card$append_text(comment) |
544 |
} |
|
545 | ! |
card$append_src(teal.code::get_code(output_q())) |
546 | ! |
card |
547 |
} |
|
548 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
549 |
} |
|
550 |
}) |
|
551 |
} |
1 |
#' Patient Profile plot teal module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display patient profile plot as a shiny module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param patient_id (`choices_seleced`) unique subject ID variable |
|
11 |
#' @param sl_dataname (`character`) subject level dataset name, |
|
12 |
#' needs to be available in the list passed to the `data` |
|
13 |
#' argument of [teal::init()] |
|
14 |
#' @param ex_dataname,ae_dataname,rs_dataname,cm_dataname,lb_dataname |
|
15 |
#' (`character(1)`) names of exposure, adverse events, response, |
|
16 |
#' concomitant medications, and labs datasets, respectively; |
|
17 |
#' must be available in the list passed to the `data` |
|
18 |
#' argument of [teal::init()]\cr |
|
19 |
#' set to NA (default) to omit from analysis |
|
20 |
#' @param sl_start_date `choices_selected` study start date variable, usually set to |
|
21 |
#' treatment start date or randomization date |
|
22 |
#' @param ex_var `choices_selected` exposure variable to plot as each line \cr |
|
23 |
#' leave unspecified or set to `NULL` if exposure data is not available |
|
24 |
#' @param ae_var `choices_selected` adverse event variable to plot as each line \cr |
|
25 |
#' leave unspecified or set to `NULL` if adverse events data is not available |
|
26 |
#' @param ae_line_col_var `choices_selected` variable for coloring `AE` lines \cr |
|
27 |
#' leave unspecified or set to `NULL` if adverse events data is not available |
|
28 |
#' @param ae_line_col_opt aesthetic values to map color values |
|
29 |
#' (named vector to map color values to each name). |
|
30 |
#' If not `NULL`, please make sure this contains all possible |
|
31 |
#' values for `ae_line_col_var` values. \cr |
|
32 |
#' leave unspecified or set to `NULL` if adverse events data is not available |
|
33 |
#' @param rs_var `choices_selected` response variable to plot as each line \cr |
|
34 |
#' leave unspecified or set to `NULL` if response data is not available |
|
35 |
#' @param cm_var `choices_selected` concomitant medication variable |
|
36 |
#' to plot as each line \cr |
|
37 |
#' leave unspecified or set to `NULL` if concomitant medications data is not available |
|
38 |
#' @param lb_var `choices_selected` lab variable to plot as each line \cr |
|
39 |
#' leave unspecified or set to `NULL` if labs data is not available |
|
40 |
#' @param x_limit a single `character` string with two numbers |
|
41 |
#' separated by a comma indicating the x-axis limit, |
|
42 |
#' default is "-28, 365" |
|
43 |
#' |
|
44 |
#' @author Xuefeng Hou (houx14) \email{houx14@gene.com} |
|
45 |
#' @author Tina Cho (chot) \email{tina.cho@roche.com} |
|
46 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
47 |
#' @template author_qit3 |
|
48 |
#' |
|
49 |
#' @inherit argument_convention return |
|
50 |
#' |
|
51 |
#' @details |
|
52 |
#' As the patient profile module plots different domains in one plot, the study day (x-axis) |
|
53 |
#' is derived for consistency based the start date of user's choice in the app (for example, |
|
54 |
#' `ADSL.RANDDT` or `ADSL.TRTSDT`): |
|
55 |
#' - In `ADAE`, `ADEX`, and `ADCM`, it would be study day based on `ASTDT` and/or |
|
56 |
#' `AENDT` in reference to the start date |
|
57 |
#' - In `ADRS` and `ADLB`, it would be study day based on `ADT` in reference to |
|
58 |
#' the start date |
|
59 |
#' |
|
60 |
#' @export |
|
61 |
#' |
|
62 |
#' @examples |
|
63 |
#' data <- cdisc_data() |> |
|
64 |
#' within({ |
|
65 |
#' library(nestcolor) |
|
66 |
#' ADSL <- rADSL |
|
67 |
#' ADAE <- rADAE %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM)) |
|
68 |
#' ADCM <- rADCM %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM)) |
|
69 |
#' # The step below is to pre-process ADCM to legacy standard |
|
70 |
#' ADCM <- ADCM %>% |
|
71 |
#' select(-starts_with("ATC")) %>% |
|
72 |
#' unique() |
|
73 |
#' ADRS <- rADRS %>% mutate(ADT = as.Date(ADTM)) |
|
74 |
#' ADEX <- rADEX %>% mutate(ASTDT = as.Date(ASTDTM), AENDT = as.Date(AENDTM)) |
|
75 |
#' ADLB <- rADLB %>% mutate(ADT = as.Date(ADTM), LBSTRESN = as.numeric(LBSTRESC)) |
|
76 |
#' }) |
|
77 |
#' |
|
78 |
#' datanames(data) <- c("ADSL", "ADAE", "ADCM", "ADRS", "ADEX", "ADLB") |
|
79 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
80 |
#' |
|
81 |
#' ADSL <- data[["ADSL"]] |
|
82 |
#' |
|
83 |
#' app <- init( |
|
84 |
#' data = data, |
|
85 |
#' modules = modules( |
|
86 |
#' tm_g_patient_profile( |
|
87 |
#' label = "Patient Profile Plot", |
|
88 |
#' patient_id = choices_selected( |
|
89 |
#' choices = unique(ADSL$USUBJID), |
|
90 |
#' selected = unique(ADSL$USUBJID)[1] |
|
91 |
#' ), |
|
92 |
#' sl_dataname = "ADSL", |
|
93 |
#' ex_dataname = "ADEX", |
|
94 |
#' ae_dataname = "ADAE", |
|
95 |
#' rs_dataname = "ADRS", |
|
96 |
#' cm_dataname = "ADCM", |
|
97 |
#' lb_dataname = "ADLB", |
|
98 |
#' sl_start_date = choices_selected( |
|
99 |
#' selected = "TRTSDTM", |
|
100 |
#' choices = c("TRTSDTM", "RANDDT") |
|
101 |
#' ), |
|
102 |
#' ex_var = choices_selected( |
|
103 |
#' selected = "PARCAT2", |
|
104 |
#' choices = "PARCAT2" |
|
105 |
#' ), |
|
106 |
#' ae_var = choices_selected( |
|
107 |
#' selected = "AEDECOD", |
|
108 |
#' choices = c("AEDECOD", "AESOC") |
|
109 |
#' ), |
|
110 |
#' ae_line_col_var = choices_selected( |
|
111 |
#' selected = "AESER", |
|
112 |
#' choices = c("AESER", "AEREL") |
|
113 |
#' ), |
|
114 |
#' ae_line_col_opt = c("Y" = "red", "N" = "blue"), |
|
115 |
#' rs_var = choices_selected( |
|
116 |
#' selected = "PARAMCD", |
|
117 |
#' choices = "PARAMCD" |
|
118 |
#' ), |
|
119 |
#' cm_var = choices_selected( |
|
120 |
#' selected = "CMDECOD", |
|
121 |
#' choices = c("CMDECOD", "CMCAT") |
|
122 |
#' ), |
|
123 |
#' lb_var = choices_selected( |
|
124 |
#' selected = "LBTESTCD", |
|
125 |
#' choices = c("LBTESTCD", "LBCAT") |
|
126 |
#' ), |
|
127 |
#' x_limit = "-28, 750", |
|
128 |
#' plot_height = c(1200, 400, 5000) |
|
129 |
#' ) |
|
130 |
#' ) |
|
131 |
#' ) |
|
132 |
#' if (interactive()) { |
|
133 |
#' shinyApp(app$ui, app$server) |
|
134 |
#' } |
|
135 |
#' |
|
136 |
tm_g_patient_profile <- function(label = "Patient Profile Plot", |
|
137 |
patient_id, |
|
138 |
sl_dataname, |
|
139 |
ex_dataname = NA, |
|
140 |
ae_dataname = NA, |
|
141 |
rs_dataname = NA, |
|
142 |
cm_dataname = NA, |
|
143 |
lb_dataname = NA, |
|
144 |
sl_start_date, |
|
145 |
ex_var = NULL, |
|
146 |
ae_var = NULL, |
|
147 |
ae_line_col_var = NULL, |
|
148 |
ae_line_col_opt = NULL, |
|
149 |
rs_var = NULL, |
|
150 |
cm_var = NULL, |
|
151 |
lb_var = NULL, |
|
152 |
x_limit = "-28, 365", |
|
153 |
plot_height = c(1200L, 400L, 5000L), |
|
154 |
plot_width = NULL, |
|
155 |
pre_output = NULL, |
|
156 |
post_output = NULL) { |
|
157 | ! |
args <- as.list(environment()) |
158 | ! |
checkmate::assert_string(label) |
159 | ! |
checkmate::assert_string(sl_dataname) |
160 | ! |
checkmate::assert_string(ex_dataname, na.ok = TRUE) |
161 | ! |
checkmate::assert_string(ae_dataname, na.ok = TRUE) |
162 | ! |
checkmate::assert_string(rs_dataname, na.ok = TRUE) |
163 | ! |
checkmate::assert_string(cm_dataname, na.ok = TRUE) |
164 | ! |
checkmate::assert_string(lb_dataname, na.ok = TRUE) |
165 | ! |
checkmate::assert_character( |
166 | ! |
c(sl_dataname, ex_dataname, rs_dataname, cm_dataname, lb_dataname), |
167 | ! |
any.missing = TRUE, all.missing = FALSE |
168 |
) |
|
169 | ! |
checkmate::assert_class(sl_start_date, classes = "choices_selected") |
170 | ! |
checkmate::assert_class(ex_var, classes = "choices_selected", null.ok = TRUE) |
171 | ! |
checkmate::assert_class(ae_var, classes = "choices_selected", null.ok = TRUE) |
172 | ! |
checkmate::assert_class(ae_line_col_var, classes = "choices_selected", null.ok = TRUE) |
173 | ! |
checkmate::assert_class(rs_var, classes = "choices_selected", null.ok = TRUE) |
174 | ! |
checkmate::assert_class(cm_var, classes = "choices_selected", null.ok = TRUE) |
175 | ! |
checkmate::assert_class(lb_var, classes = "choices_selected", null.ok = TRUE) |
176 | ! |
checkmate::assert_string(x_limit) |
177 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
178 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
179 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
180 | ! |
checkmate::assert_numeric( |
181 | ! |
plot_width[1], |
182 | ! |
lower = plot_width[2], |
183 | ! |
upper = plot_width[3], |
184 | ! |
null.ok = TRUE, |
185 | ! |
.var.name = "plot_width" |
186 |
) |
|
187 | ||
188 | ! |
module( |
189 | ! |
label = label, |
190 | ! |
ui = ui_g_patient_profile, |
191 | ! |
ui_args = args, |
192 | ! |
server = srv_g_patient_profile, |
193 | ! |
server_args = list( |
194 | ! |
patient_id = patient_id, |
195 | ! |
sl_dataname = sl_dataname, |
196 | ! |
ex_dataname = ex_dataname, |
197 | ! |
ae_dataname = ae_dataname, |
198 | ! |
rs_dataname = rs_dataname, |
199 | ! |
cm_dataname = cm_dataname, |
200 | ! |
lb_dataname = lb_dataname, |
201 | ! |
ae_line_col_opt = ae_line_col_opt, |
202 | ! |
label = label, |
203 | ! |
plot_height = plot_height, |
204 | ! |
plot_width = plot_width |
205 |
), |
|
206 | ! |
datanames = "all" |
207 |
) |
|
208 |
} |
|
209 | ||
210 |
ui_g_patient_profile <- function(id, ...) { |
|
211 | ! |
a <- list(...) |
212 | ! |
ns <- NS(id) |
213 | ! |
checkboxes <- c(a$ex_dataname, a$ae_dataname, a$rs_dataname, a$lb_dataname, a$cm_dataname) |
214 | ||
215 | ! |
shiny::tagList( |
216 | ! |
include_css_files("custom"), |
217 | ! |
teal.widgets::standard_layout( |
218 | ! |
output = teal.widgets::white_small_well( |
219 | ! |
teal.widgets::plot_with_settings_ui(id = ns("patientprofileplot")) |
220 |
), |
|
221 | ! |
encoding = tags$div( |
222 |
### Reporter |
|
223 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
224 |
### |
|
225 | ! |
tags$label("Encodings", class = "text-primary"), |
226 | ! |
selectizeInput( |
227 | ! |
inputId = ns("patient_id"), |
228 | ! |
label = "Patient ID", |
229 | ! |
choices = NULL |
230 |
), |
|
231 | ! |
tags$div( |
232 | ! |
tagList( |
233 | ! |
helpText("Select", tags$code("ADaM"), "Domains"), |
234 | ! |
checkboxGroupInput( |
235 | ! |
inputId = ns("select_ADaM"), |
236 | ! |
label = NULL, |
237 | ! |
choices = checkboxes[!is.na(checkboxes)], |
238 | ! |
selected = checkboxes[!is.na(checkboxes)] |
239 |
) |
|
240 |
) |
|
241 |
), |
|
242 | ! |
teal.widgets::optionalSelectInput( |
243 | ! |
ns("sl_start_date"), |
244 | ! |
"Start date variable", |
245 | ! |
choices = get_choices(a$sl_start_date$choices), |
246 | ! |
selected = a$sl_start_date$selected, |
247 | ! |
multiple = FALSE, |
248 | ! |
label_help = helpText( |
249 | ! |
"from ", tags$code("ADSL") |
250 |
) |
|
251 |
), |
|
252 | ! |
conditionalPanel( |
253 | ! |
condition = sprintf("input['select_ADaM'].includes('%s')", a$ex_dataname), |
254 | ! |
ns = ns, |
255 | ! |
selectInput( |
256 | ! |
ns("ex_var"), |
257 | ! |
"Exposure variable", |
258 | ! |
choices = get_choices(a$ex_var$choices), |
259 | ! |
selected = a$ex_var$selected, |
260 | ! |
multiple = FALSE |
261 |
) |
|
262 |
), |
|
263 | ! |
conditionalPanel( |
264 | ! |
condition = sprintf("input['select_ADaM'].includes('%s')", a$ae_dataname), |
265 | ! |
ns = ns, |
266 | ! |
teal.widgets::optionalSelectInput( |
267 | ! |
ns("ae_var"), |
268 | ! |
"Adverse Event variable", |
269 | ! |
choices = get_choices(a$ae_var$choices), |
270 | ! |
selected = a$ae_var$selected, |
271 | ! |
multiple = FALSE |
272 |
), |
|
273 | ! |
teal.widgets::optionalSelectInput( |
274 | ! |
ns("ae_line_var"), |
275 | ! |
"Adverse Event line color variable", |
276 | ! |
choices = get_choices(a$ae_line_col_var$choices), |
277 | ! |
selected = a$ae_line_col_var$selected, |
278 | ! |
multiple = FALSE |
279 |
) |
|
280 |
), |
|
281 | ! |
conditionalPanel( |
282 | ! |
condition = sprintf("input['select_ADaM'].includes('%s')", a$rs_dataname), |
283 | ! |
ns = ns, |
284 | ! |
teal.widgets::optionalSelectInput( |
285 | ! |
ns("rs_var"), |
286 | ! |
"Tumor response variable", |
287 | ! |
choices = get_choices(a$rs_var$choices), |
288 | ! |
selected = a$rs_var$selected, |
289 | ! |
multiple = FALSE |
290 |
) |
|
291 |
), |
|
292 | ! |
conditionalPanel( |
293 | ! |
condition = sprintf("input['select_ADaM'].includes('%s')", a$cm_dataname), |
294 | ! |
ns = ns, |
295 | ! |
teal.widgets::optionalSelectInput( |
296 | ! |
ns("cm_var"), |
297 | ! |
"Concomitant medicine variable", |
298 | ! |
choices = get_choices(a$cm_var$choices), |
299 | ! |
selected = a$cm_var$selected, |
300 | ! |
multiple = FALSE |
301 |
) |
|
302 |
), |
|
303 | ! |
conditionalPanel( |
304 | ! |
condition = sprintf("input['select_ADaM'].includes('%s')", a$lb_dataname), |
305 | ! |
ns = ns, |
306 | ! |
teal.widgets::optionalSelectInput( |
307 | ! |
ns("lb_var"), |
308 | ! |
"Lab variable", |
309 | ! |
choices = get_choices(a$lb_var$choices), |
310 | ! |
selected = a$lb_var$selected, |
311 | ! |
multiple = FALSE |
312 |
), |
|
313 | ! |
selectInput( |
314 | ! |
ns("lb_var_show"), |
315 | ! |
"Lab values", |
316 | ! |
choices = get_choices(a$lb_var$choices), |
317 | ! |
selected = a$lb_var$selected, |
318 | ! |
multiple = TRUE |
319 |
) |
|
320 |
), |
|
321 | ! |
textInput( |
322 | ! |
ns("x_limit"), |
323 | ! |
label = tags$div( |
324 | ! |
"Study Days Range", |
325 | ! |
tags$br(), |
326 | ! |
helpText("Enter TWO numeric values of study days range, separated by comma (eg. -28, 750)") |
327 |
), |
|
328 | ! |
value = a$x_limit |
329 |
) |
|
330 |
), |
|
331 | ! |
forms = tagList( |
332 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
333 |
), |
|
334 | ! |
pre_output = a$pre_output, |
335 | ! |
post_output = a$post_output |
336 |
) |
|
337 |
) |
|
338 |
} |
|
339 | ||
340 |
srv_g_patient_profile <- function(id, |
|
341 |
data, |
|
342 |
filter_panel_api, |
|
343 |
reporter, |
|
344 |
patient_id, |
|
345 |
sl_dataname, |
|
346 |
ex_dataname, |
|
347 |
ae_dataname, |
|
348 |
rs_dataname, |
|
349 |
lb_dataname, |
|
350 |
cm_dataname, |
|
351 |
label, |
|
352 |
ae_line_col_opt, |
|
353 |
plot_height, |
|
354 |
plot_width) { |
|
355 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
356 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelApi") |
357 | ! |
checkmate::assert_class(data, "reactive") |
358 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
359 | ! |
if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data)) |
360 | ! |
if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data)) |
361 | ! |
if (!is.na(rs_dataname)) checkmate::assert_names(rs_dataname, subset.of = names(data)) |
362 | ! |
if (!is.na(lb_dataname)) checkmate::assert_names(lb_dataname, subset.of = names(data)) |
363 | ! |
if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data)) |
364 | ! |
checkboxes <- c(ex_dataname, ae_dataname, rs_dataname, lb_dataname, cm_dataname) |
365 | ! |
moduleServer(id, function(input, output, session) { |
366 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
367 | ! |
select_plot <- reactive( |
368 | ! |
vapply(checkboxes, function(x) x %in% input$select_ADaM, logical(1L)) |
369 |
) |
|
370 | ||
371 | ! |
resolved <- teal.transform::resolve_delayed(patient_id, as.list(isolate(data())@env)) |
372 | ||
373 | ! |
updateSelectizeInput( |
374 | ! |
session = session, |
375 | ! |
inputId = "patient_id", |
376 | ! |
choices = resolved$choices, |
377 | ! |
selected = resolved$selected |
378 |
) |
|
379 | ||
380 | ! |
if (!is.na(lb_dataname)) { |
381 | ! |
observeEvent(input$lb_var, ignoreNULL = TRUE, { |
382 | ! |
ADLB <- data()[[lb_dataname]] |
383 | ! |
choices <- unique(ADLB[[input$lb_var]]) |
384 | ! |
choices_selected <- if (length(choices) > 5) choices[1:5] else choices |
385 | ||
386 | ! |
updateSelectInput( |
387 | ! |
session, |
388 | ! |
"lb_var_show", |
389 | ! |
selected = choices_selected, |
390 | ! |
choices = choices |
391 |
) |
|
392 |
}) |
|
393 |
} |
|
394 | ||
395 | ! |
iv <- reactive({ |
396 | ! |
iv <- shinyvalidate::InputValidator$new() |
397 | ! |
iv$add_rule("select_ADaM", shinyvalidate::sv_required( |
398 | ! |
message = "At least one ADaM data set is required" |
399 |
)) |
|
400 | ! |
iv$add_rule("sl_start_date", shinyvalidate::sv_required( |
401 | ! |
message = "Date variable is required" |
402 |
)) |
|
403 | ! |
if (isTRUE(select_plot()[ex_dataname])) { |
404 | ! |
iv$add_rule("ex_var", shinyvalidate::sv_required( |
405 | ! |
message = "Exposure variable is required" |
406 |
)) |
|
407 |
} |
|
408 | ! |
if (isTRUE(select_plot()[ae_dataname])) { |
409 | ! |
iv$add_rule("ae_var", shinyvalidate::sv_required( |
410 | ! |
message = "Adverse Event variable is required" |
411 |
)) |
|
412 | ! |
iv$add_rule("ae_line_var", shinyvalidate::sv_optional()) |
413 | ! |
iv$add_rule("ae_line_var", ~ if (length(levels(data()[[ae_dataname]][[.]])) > length(ae_line_col_opt)) { |
414 | ! |
"Not enough colors provided for Adverse Event line color, unselect" |
415 |
}) |
|
416 |
} |
|
417 | ! |
if (isTRUE(select_plot()[rs_dataname])) { |
418 | ! |
iv$add_rule("rs_var", shinyvalidate::sv_required( |
419 | ! |
message = "Tumor response variable is required" |
420 |
)) |
|
421 |
} |
|
422 | ! |
if (isTRUE(select_plot()[cm_dataname])) { |
423 | ! |
iv$add_rule("cm_var", shinyvalidate::sv_required( |
424 | ! |
message = "Concomitant medicine variable is required" |
425 |
)) |
|
426 |
} |
|
427 | ! |
if (isTRUE(select_plot()[lb_dataname])) { |
428 | ! |
iv$add_rule("lb_var", shinyvalidate::sv_required( |
429 | ! |
message = "Lab variable is required" |
430 |
)) |
|
431 | ! |
iv$add_rule("lb_var_show", shinyvalidate::sv_required( |
432 | ! |
message = "At least one Lab value is required" |
433 |
)) |
|
434 | ! |
rule_diff <- function(value, other) { |
435 | ! |
if (isTRUE(any(value == other))) { |
436 | ! |
"Lab variable and Lab value must be different" |
437 |
} |
|
438 |
} |
|
439 | ! |
iv$add_rule("lb_var", rule_diff, other = input$lb_var_show) |
440 | ! |
iv$add_rule("lb_var_show", rule_diff, other = input$lb_var) |
441 |
} |
|
442 | ! |
iv$add_rule("x_limit", shinyvalidate::sv_required( |
443 | ! |
message = "Study Days Range is required" |
444 |
)) |
|
445 | ! |
iv$add_rule("x_limit", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { |
446 | ! |
"Study Days Range is invalid" |
447 |
}) |
|
448 | ! |
iv$add_rule("x_limit", ~ if (length(suppressWarnings(as_numeric_from_comma_sep_str(.))) != 2L) { |
449 | ! |
"Study Days Range must be two values" |
450 |
}) |
|
451 | ! |
iv$add_rule("x_limit", ~ if (!identical(order(suppressWarnings(as_numeric_from_comma_sep_str(.))), 1:2)) { |
452 | ! |
"Study Days Range mut be: first lower, then upper limit" |
453 |
}) |
|
454 | ! |
iv$enable() |
455 | ! |
iv |
456 |
}) |
|
457 | ||
458 |
# render plot |
|
459 | ! |
output_q <- shiny::debounce( |
460 | ! |
millis = 200, |
461 | ! |
r = reactive({ |
462 | ! |
teal::validate_inputs(iv()) |
463 | ||
464 |
# get inputs --- |
|
465 | ! |
patient_id <- input$patient_id |
466 | ! |
sl_start_date <- input$sl_start_date |
467 | ! |
ae_var <- input$ae_var |
468 | ! |
ae_line_col_var <- input$ae_line_var |
469 | ! |
rs_var <- input$rs_var |
470 | ! |
cm_var <- input$cm_var |
471 | ! |
ex_var <- input$ex_var |
472 | ! |
lb_var <- input$lb_var |
473 | ! |
x_limit <- input$x_limit |
474 | ! |
lb_var_show <- input$lb_var_show |
475 | ||
476 | ! |
adrs_vars <- unique(c( |
477 | ! |
"USUBJID", "STUDYID", "PARAMCD", |
478 | ! |
"PARAM", "AVALC", "AVAL", "ADY", |
479 | ! |
"ADT", rs_var |
480 |
)) |
|
481 | ! |
adae_vars <- unique(c( |
482 | ! |
"USUBJID", "STUDYID", "ASTDT", |
483 | ! |
"AENDT", "AESOC", "AEDECOD", |
484 | ! |
"AESER", "AETOXGR", "AEREL", |
485 | ! |
"ASTDY", "AENDY", |
486 | ! |
ae_var, ae_line_col_var |
487 |
)) |
|
488 | ! |
adcm_vars <- unique(c( |
489 | ! |
"USUBJID", "STUDYID", "ASTDT", |
490 | ! |
"AENDT", "ASTDT", "CMDECOD", |
491 | ! |
"ASTDY", "AENDY", "CMCAT", |
492 | ! |
cm_var |
493 |
)) |
|
494 | ! |
adex_vars <- unique(c( |
495 | ! |
"USUBJID", "STUDYID", "ASTDT", |
496 | ! |
"AENDT", "PARCAT2", "AVAL", |
497 | ! |
"AVALU", "PARAMCD", "PARCAT1", |
498 | ! |
"PARCAT2", ex_var |
499 |
)) |
|
500 | ! |
adlb_vars <- unique(c( |
501 | ! |
"USUBJID", "STUDYID", "ANRIND", "LBSEQ", |
502 | ! |
"PARAMCD", "BASETYPE", "ADT", "AVISITN", |
503 | ! |
"LBSTRESN", "LBCAT", "LBTESTCD", |
504 | ! |
lb_var |
505 |
)) |
|
506 | ||
507 |
# get ADSL dataset --- |
|
508 | ! |
ADSL <- data()[[sl_dataname]] |
509 | ||
510 | ! |
ADEX <- NULL |
511 | ! |
if (isTRUE(select_plot()[ex_dataname])) { |
512 | ! |
ADEX <- data()[[ex_dataname]] |
513 | ! |
teal::validate_has_variable(ADEX, adex_vars) |
514 |
} |
|
515 | ! |
ADAE <- NULL |
516 | ! |
if (isTRUE(select_plot()[ae_dataname])) { |
517 | ! |
ADAE <- data()[[ae_dataname]] |
518 | ! |
teal::validate_has_variable(ADAE, adae_vars) |
519 |
} |
|
520 | ! |
ADRS <- NULL |
521 | ! |
if (isTRUE(select_plot()[rs_dataname])) { |
522 | ! |
ADRS <- data()[[rs_dataname]] |
523 | ! |
teal::validate_has_variable(ADRS, adrs_vars) |
524 |
} |
|
525 | ! |
ADCM <- NULL |
526 | ! |
if (isTRUE(select_plot()[cm_dataname])) { |
527 | ! |
ADCM <- data()[[cm_dataname]] |
528 | ! |
teal::validate_has_variable(ADCM, adcm_vars) |
529 |
} |
|
530 | ! |
ADLB <- NULL |
531 | ! |
if (isTRUE(select_plot()[lb_dataname])) { |
532 | ! |
ADLB <- data()[[lb_dataname]] |
533 | ! |
teal::validate_has_variable(ADLB, adlb_vars) |
534 |
} |
|
535 | ||
536 | ! |
empty_rs <- FALSE |
537 | ! |
empty_ae <- FALSE |
538 | ! |
empty_cm <- FALSE |
539 | ! |
empty_ex <- FALSE |
540 | ! |
empty_lb <- FALSE |
541 | ||
542 | ! |
q1 <- teal.code::eval_code( |
543 | ! |
data(), |
544 | ! |
code = substitute( |
545 | ! |
expr = { |
546 | ! |
ADSL <- ADSL %>% |
547 | ! |
filter(USUBJID == patient_id) %>% |
548 | ! |
group_by(USUBJID) %>% |
549 | ! |
mutate( |
550 | ! |
max_date = pmax(as.Date(LSTALVDT), as.Date(DTHDT), na.rm = TRUE), |
551 | ! |
max_day = as.numeric(difftime(as.Date(max_date), as.Date(sl_start_date), units = "days")) + |
552 | ! |
(as.Date(max_date) >= as.Date(sl_start_date)) |
553 |
) |
|
554 |
}, |
|
555 | ! |
env = list( |
556 | ! |
ADSL = as.name(sl_dataname), |
557 | ! |
sl_start_date = as.name(sl_start_date), |
558 | ! |
patient_id = patient_id |
559 |
) |
|
560 |
) |
|
561 |
) |
|
562 | ||
563 |
# ADSL with single subject |
|
564 | ! |
validate( |
565 | ! |
need( |
566 | ! |
nrow(q1[["ADSL"]]) >= 1, |
567 | ! |
paste( |
568 | ! |
"Subject", |
569 | ! |
patient_id, |
570 | ! |
"not found in the dataset. Perhaps they have been filtered out by the filter panel?" |
571 |
) |
|
572 |
) |
|
573 |
) |
|
574 | ||
575 |
# name for ae_line_col |
|
576 | ! |
q1 <- if (!is.null(ae_line_col_var) && is.data.frame(ADAE)) { |
577 | ! |
teal.code::eval_code( |
578 | ! |
q1, |
579 | ! |
code = substitute( |
580 | ! |
expr = ae_line_col_name <- formatters::var_labels(ADAE, fill = FALSE)[ae_line_col_var], |
581 | ! |
env = list(ADAE = as.name(ae_dataname), ae_line_col_var = ae_line_col_var) |
582 |
) |
|
583 |
) |
|
584 |
} else { |
|
585 | ! |
teal.code::eval_code(q1, code = quote(ae_line_col_name <- NULL)) |
586 |
} |
|
587 | ||
588 | ! |
q1 <- if (isTRUE(select_plot()[ae_dataname])) { |
589 | ! |
if (all(ADAE$USUBJID %in% ADSL$USUBJID)) { |
590 | ! |
qq <- teal.code::eval_code( |
591 | ! |
q1, |
592 | ! |
code = substitute( |
593 | ! |
expr = { |
594 |
# ADAE |
|
595 | ! |
ADAE <- ADAE[, adae_vars] |
596 | ||
597 | ! |
ADAE <- ADSL %>% |
598 | ! |
left_join(ADAE, by = c("STUDYID", "USUBJID")) %>% |
599 | ! |
as.data.frame() %>% |
600 | ! |
filter(!is.na(ASTDT), !is.na(AENDT)) %>% |
601 | ! |
mutate( |
602 | ! |
ASTDY = as.numeric(difftime(ASTDT, as.Date(sl_start_date), units = "days")) + |
603 | ! |
(ASTDT >= as.Date(sl_start_date)), |
604 | ! |
AENDY = as.numeric(difftime(AENDT, as.Date(sl_start_date), units = "days")) + |
605 | ! |
(AENDT >= as.Date(sl_start_date)) |
606 |
) %>% |
|
607 | ! |
select(c(adae_vars, ASTDY, AENDY)) |
608 | ! |
formatters::var_labels(ADAE)[ae_line_col_var] <- |
609 | ! |
formatters::var_labels(ADAE, fill = FALSE)[ae_line_col_var] |
610 |
}, |
|
611 | ! |
env = list( |
612 | ! |
ADSL = as.name(sl_dataname), |
613 | ! |
ADAE = as.name(ae_dataname), |
614 | ! |
sl_start_date = as.name(sl_start_date), |
615 | ! |
ae_line_col_var = ae_line_col_var, |
616 | ! |
adae_vars = adae_vars |
617 |
) |
|
618 |
) |
|
619 |
) %>% |
|
620 | ! |
teal.code::eval_code( |
621 | ! |
code = substitute( |
622 | ! |
expr = ae <- list( |
623 | ! |
data = data.frame(ADAE), |
624 | ! |
var = as.vector(ADAE[, ae_var]), |
625 | ! |
line_col = line_col, |
626 | ! |
line_col_legend = line_col_legend, |
627 | ! |
line_col_opt = line_col_opt |
628 |
), |
|
629 | ! |
env = list( |
630 | ! |
ADAE = as.name(ae_dataname), |
631 | ! |
ae_var = ae_var, |
632 | ! |
line_col = if (!is.null(ae_line_col_var)) bquote(as.vector(ADAE[, .(ae_line_col_var)])) else NULL, |
633 | ! |
line_col_legend = ae_line_col_var, |
634 | ! |
line_col_opt = ae_line_col_opt |
635 |
) |
|
636 |
) |
|
637 |
) |
|
638 | ! |
ADAE <- qq[[ae_dataname]] |
639 | ! |
if (is.null(ADAE) | nrow(ADAE) == 0) { |
640 | ! |
empty_ae <- TRUE |
641 |
} |
|
642 | ! |
|
643 |
} else { |
|
644 | ! |
empty_ae <- TRUE |
645 | ! |
teal.code::eval_code(q1, code = quote(ae <- NULL)) |
646 |
} |
|
647 |
} else { |
|
648 | ! |
teal.code::eval_code(q1, code = quote(ae <- NULL)) |
649 |
} |
|
650 | ||
651 | ! |
q1 <- if (isTRUE(select_plot()[rs_dataname])) { |
652 | ! |
if (all(ADRS$USUBJID %in% ADSL$USUBJID)) { |
653 | ! |
qq <- teal.code::eval_code( |
654 | ! |
q1, |
655 | ! |
code = substitute( |
656 | ! |
expr = { |
657 | ! |
ADRS <- ADRS[, adrs_vars] |
658 | ! |
ADRS <- ADSL %>% |
659 | ! |
left_join(ADRS, by = c("STUDYID", "USUBJID")) %>% |
660 | ! |
as.data.frame() %>% |
661 | ! |
mutate( |
662 | ! |
ADY = as.numeric(difftime(ADT, as.Date(sl_start_date), units = "days")) + |
663 | ! |
(ADT >= as.Date(sl_start_date)) |
664 |
) %>% |
|
665 | ! |
select(USUBJID, PARAMCD, PARAM, AVALC, AVAL, ADY, ADT) %>% |
666 | ! |
filter(is.na(ADY) == FALSE) |
667 | ! |
rs <- list(data = data.frame(ADRS), var = as.vector(ADRS[, rs_var])) |
668 |
}, |
|
669 | ! |
env = list( |
670 | ! |
ADRS = as.name(rs_dataname), |
671 | ! |
adrs_vars = adrs_vars, |
672 | ! |
sl_start_date = as.name(sl_start_date), |
673 | ! |
rs_var = rs_var |
674 |
) |
|
675 |
) |
|
676 |
) |
|
677 | ! |
ADRS <- qq[[rs_dataname]] |
678 | ! |
if (is.null(ADRS) || nrow(ADRS) == 0) { |
679 | ! |
empty_rs <- TRUE |
680 |
} |
|
681 | ! |
|
682 |
} else { |
|
683 | ! |
empty_rs <- TRUE |
684 | ! |
teal.code::eval_code(q1, expression = quote(rs <- NULL)) |
685 |
} |
|
686 |
} else { |
|
687 | ! |
teal.code::eval_code(q1, code = quote(rs <- NULL)) |
688 |
} |
|
689 | ||
690 | ! |
q1 <- if (isTRUE(select_plot()[cm_dataname])) { |
691 | ! |
if (all(ADCM$USUBJID %in% ADSL$USUBJID)) { |
692 | ! |
qq <- teal.code::eval_code( |
693 | ! |
q1, |
694 | ! |
code = substitute( |
695 | ! |
expr = { |
696 |
# ADCM |
|
697 | ! |
ADCM <- ADCM[, adcm_vars] |
698 | ! |
ADCM <- ADSL %>% |
699 | ! |
left_join(ADCM, by = c("STUDYID", "USUBJID")) %>% |
700 | ! |
as.data.frame() %>% |
701 | ! |
filter(!is.na(ASTDT), !is.na(AENDT)) %>% |
702 | ! |
mutate( |
703 | ! |
ASTDY = as.numeric(difftime(ASTDT, as.Date(sl_start_date), units = "days")) + |
704 | ! |
(ASTDT >= as.Date(sl_start_date)), |
705 | ! |
AENDY = as.numeric(difftime(AENDT, as.Date(sl_start_date), units = "days")) + |
706 | ! |
(AENDT >= as.Date(sl_start_date)) |
707 |
) %>% |
|
708 | ! |
select(USUBJID, ASTDT, AENDT, ASTDY, AENDY, !!quo(cm_var)) |
709 | ! |
if (length(unique(ADCM$USUBJID)) > 0) { |
710 | ! |
ADCM <- ADCM[which(ADCM$AENDY >= -28 | is.na(ADCM$AENDY) == TRUE & is.na(ADCM$ASTDY) == FALSE), ] |
711 |
} |
|
712 | ! |
cm <- list(data = data.frame(ADCM), var = as.vector(ADCM[, cm_var])) |
713 |
}, |
|
714 | ! |
env = list( |
715 | ! |
ADSL = as.name(sl_dataname), |
716 | ! |
ADCM = as.name(cm_dataname), |
717 | ! |
sl_start_date = as.name(sl_start_date), |
718 | ! |
adcm_vars = adcm_vars, |
719 | ! |
cm_var = cm_var |
720 |
) |
|
721 |
) |
|
722 |
) |
|
723 | ||
724 | ! |
ADCM <- qq[[cm_dataname]] |
725 | ! |
if (is.null(ADCM) | nrow(ADCM) == 0) { |
726 | ! |
empty_cm <- TRUE |
727 |
} |
|
728 | ! |
|
729 |
} else { |
|
730 | ! |
empty_cm <- TRUE |
731 | ! |
teal.code::eval_code(q1, code = quote(cm <- NULL)) |
732 |
} |
|
733 |
} else { |
|
734 | ! |
teal.code::eval_code(q1, code = quote(cm <- NULL)) |
735 |
} |
|
736 | ||
737 | ! |
q1 <- if (isTRUE(select_plot()[ex_dataname])) { |
738 | ! |
if (all(ADEX$USUBJID %in% ADSL$USUBJID)) { |
739 | ! |
qq <- teal.code::eval_code( |
740 | ! |
q1, |
741 | ! |
code = substitute( |
742 | ! |
expr = { |
743 |
# ADEX |
|
744 | ! |
ADEX <- ADEX[, adex_vars] |
745 | ! |
ADEX <- ADSL %>% |
746 | ! |
left_join(ADEX, by = c("STUDYID", "USUBJID")) %>% |
747 | ! |
as.data.frame() %>% |
748 | ! |
filter(PARCAT1 == "INDIVIDUAL" & PARAMCD == "DOSE" & !is.na(AVAL) & !is.na(ASTDT)) %>% |
749 | ! |
select(USUBJID, ASTDT, PARCAT2, AVAL, AVALU, PARAMCD, sl_start_date) |
750 | ||
751 | ! |
ADEX <- split(ADEX, ADEX$USUBJID) %>% |
752 | ! |
lapply(function(pinfo) { |
753 | ! |
pinfo %>% |
754 | ! |
arrange(PARCAT2, PARAMCD, ASTDT) %>% |
755 | ! |
ungroup() %>% |
756 | ! |
mutate( |
757 | ! |
diff = c(0, diff(AVAL, lag = 1)), |
758 | ! |
Modification = case_when( |
759 | ! |
diff < 0 ~ "Decrease", |
760 | ! |
diff > 0 ~ "Increase", |
761 | ! |
diff == 0 ~ "None" |
762 |
), |
|
763 | ! |
ASTDT_dur = as.numeric(difftime(as.Date(ASTDT), as.Date(sl_start_date), units = "days")) + |
764 | ! |
(as.Date(ASTDT) >= as.Date(sl_start_date)) |
765 |
) |
|
766 |
}) %>% |
|
767 | ! |
Reduce(rbind, .) %>% |
768 | ! |
as.data.frame() %>% |
769 | ! |
select(-diff) |
770 | ! |
ex <- list(data = data.frame(ADEX), var = as.vector(ADEX[, ex_var])) |
771 |
}, |
|
772 | ! |
env = list( |
773 | ! |
ADSL = as.name(sl_dataname), |
774 | ! |
ADEX = as.name(ex_dataname), |
775 | ! |
adex_vars = adex_vars, |
776 | ! |
sl_start_date = as.name(sl_start_date), |
777 | ! |
ex_var = ex_var |
778 |
) |
|
779 |
) |
|
780 |
) |
|
781 | ! |
ADEX <- qq[[ex_dataname]] |
782 | ! |
if (is.null(ADEX) | nrow(ADEX) == 0) { |
783 | ! |
empty_ex <- TRUE |
784 |
} |
|
785 | ! |
|
786 |
} else { |
|
787 | ! |
empty_ex <- TRUE |
788 | ! |
teal.code::eval_code(q1, code = quote(ex <- NULL)) |
789 |
} |
|
790 |
} else { |
|
791 | ! |
teal.code::eval_code(q1, code = quote(ex <- NULL)) |
792 |
} |
|
793 | ||
794 | ! |
q1 <- if (isTRUE(select_plot()[lb_dataname])) { |
795 | ! |
if (all(ADLB$USUBJID %in% ADSL$USUBJID)) { |
796 | ! |
qq <- teal.code::eval_code( |
797 | ! |
q1, |
798 | ! |
code = substitute( |
799 | ! |
expr = { |
800 | ! |
ADLB <- ADLB[, adlb_vars] |
801 | ! |
ADLB <- ADSL %>% |
802 | ! |
left_join(ADLB, by = c("STUDYID", "USUBJID")) %>% |
803 | ! |
as.data.frame() %>% |
804 | ! |
mutate( |
805 | ! |
ANRIND = factor(ANRIND, levels = c("HIGH", "LOW", "NORMAL")) |
806 |
) %>% |
|
807 | ! |
filter(!is.na(LBSTRESN) & !is.na(ANRIND) & .data[[lb_var]] %in% lb_var_show) %>% |
808 | ! |
as.data.frame() %>% |
809 | ! |
select( |
810 | ! |
USUBJID, STUDYID, LBSEQ, PARAMCD, BASETYPE, ADT, AVISITN, sl_start_date, LBTESTCD, ANRIND, lb_var |
811 |
) %>% |
|
812 | ! |
mutate( |
813 | ! |
ADY = as.numeric(difftime(ADT, as.Date(sl_start_date), units = "days")) + |
814 | ! |
(ADT >= as.Date(sl_start_date)) |
815 |
) |
|
816 | ! |
lb <- list(data = data.frame(ADLB), var = as.vector(ADLB[, lb_var])) |
817 |
}, |
|
818 | ! |
env = list( |
819 | ! |
ADLB = as.name(lb_dataname), |
820 | ! |
ADSL = as.name(sl_dataname), |
821 | ! |
adlb_vars = adlb_vars, |
822 | ! |
sl_start_date = as.name(sl_start_date), |
823 | ! |
lb_var = lb_var, |
824 | ! |
lb_var_show = lb_var_show |
825 |
) |
|
826 |
) |
|
827 |
) |
|
828 | ||
829 | ! |
ADLB <- qq[[lb_dataname]] |
830 | ! |
if (is.null(ADLB) | nrow(ADLB) == 0) { |
831 | ! |
empty_lb <- TRUE |
832 |
} |
|
833 | ! |
|
834 |
} else { |
|
835 | ! |
empty_lb <- TRUE |
836 | ! |
teal.code::eval_code(q1, code = quote(lb <- NULL)) |
837 |
} |
|
838 |
} else { |
|
839 | ! |
teal.code::eval_code(q1, code = quote(lb <- NULL)) |
840 |
} |
|
841 | ||
842 |
# Check the subject has information in at least one selected domain |
|
843 | ! |
empty_data_check <- structure( |
844 | ! |
c(empty_ex, empty_ae, empty_rs, empty_lb, empty_cm), |
845 | ! |
names = checkboxes |
846 |
) |
|
847 | ||
848 | ! |
validate(need( |
849 | ! |
any(!empty_data_check & select_plot()), |
850 | ! |
"The subject does not have information in any selected domain." |
851 |
)) |
|
852 | ||
853 |
# Check the subject has information in all the selected domains |
|
854 | ! |
if (any(empty_data_check & select_plot())) { |
855 | ! |
showNotification( |
856 | ! |
paste0( |
857 | ! |
"This subject does not have information in the ", |
858 | ! |
paste(checkboxes[empty_data_check & select_plot()], collapse = ", "), |
859 | ! |
" domain." |
860 |
), |
|
861 | ! |
duration = 8, |
862 | ! |
type = "warning" |
863 |
) |
|
864 |
} |
|
865 | ||
866 |
# Convert x_limit to numeric vector |
|
867 | ! |
if (!is.null(x_limit) || x_limit != "") { |
868 | ! |
q1 <- teal.code::eval_code( |
869 | ! |
q1, |
870 | ! |
code = bquote(x_limit <- as.numeric(unlist(strsplit(.(x_limit), ",")))) |
871 |
) |
|
872 | ! |
x_limit <- q1[["x_limit"]] |
873 |
} |
|
874 | ||
875 | ! |
q1 <- teal.code::eval_code( |
876 | ! |
q1, |
877 | ! |
code = substitute( |
878 | ! |
expr = { |
879 | ! |
plot <- osprey::g_patient_profile( |
880 | ! |
ex = ex, |
881 | ! |
ae = ae, |
882 | ! |
rs = rs, |
883 | ! |
cm = cm, |
884 | ! |
lb = lb, |
885 | ! |
arrow_end_day = ADSL[["max_day"]], |
886 | ! |
xlim = x_limit, |
887 | ! |
xlab = "Study Day", |
888 | ! |
title = paste("Patient Profile: ", patient_id) |
889 |
) |
|
890 | ! |
plot |
891 |
}, |
|
892 | ! |
env = list( |
893 | ! |
patient_id = patient_id, |
894 | ! |
ADSL = as.name(sl_dataname) |
895 |
) |
|
896 |
) |
|
897 |
) |
|
898 |
}) |
|
899 |
) |
|
900 | ||
901 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
902 | ||
903 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
904 | ! |
id = "patientprofileplot", |
905 | ! |
plot_r = plot_r, |
906 | ! |
height = plot_height, |
907 | ! |
width = plot_width |
908 |
) |
|
909 | ||
910 | ! |
teal.widgets::verbatim_popup_srv( |
911 | ! |
id = "rcode", |
912 | ! |
title = paste("R code for", label), |
913 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
914 |
) |
|
915 | ||
916 |
### REPORTER |
|
917 | ! |
if (with_reporter) { |
918 | ! |
card_fun <- function(comment, label) { |
919 | ! |
card <- teal::report_card_template( |
920 | ! |
title = "Patient Profile", |
921 | ! |
label = label, |
922 | ! |
with_filter = with_filter, |
923 | ! |
filter_panel_api = filter_panel_api |
924 |
) |
|
925 | ! |
card$append_text("Plot", "header3") |
926 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
927 | ! |
if (!comment == "") { |
928 | ! |
card$append_text("Comment", "header3") |
929 | ! |
card$append_text(comment) |
930 |
} |
|
931 | ! |
card$append_src(teal.code::get_code(output_q())) |
932 | ! |
card |
933 |
} |
|
934 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
935 |
} |
|
936 |
}) |
|
937 |
} |
1 |
#' Events by Term Plot Teal Module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display Events by Term plot as a shiny module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param term_var [teal.transform::choices_selected] object with all available choices |
|
11 |
#' and pre-selected option names that can be used to specify the term for events |
|
12 |
#' |
|
13 |
#' @inherit argument_convention return |
|
14 |
#' |
|
15 |
#' @export |
|
16 |
#' |
|
17 |
#' @author Liming Li (lil128) \email{liming.li@roche.com} |
|
18 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
19 |
#' |
|
20 |
#' @examples |
|
21 |
#' data <- cdisc_data() |> |
|
22 |
#' within({ |
|
23 |
#' library(nestcolor) |
|
24 |
#' ADSL <- rADSL |
|
25 |
#' ADAE <- rADAE |
|
26 |
#' }) |
|
27 |
#' |
|
28 |
#' datanames(data) <- c("ADSL", "ADAE") |
|
29 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
30 |
#' |
|
31 |
#' app <- init( |
|
32 |
#' data = data, |
|
33 |
#' modules = modules( |
|
34 |
#' tm_g_events_term_id( |
|
35 |
#' label = "Common AE", |
|
36 |
#' dataname = "ADAE", |
|
37 |
#' term_var = choices_selected( |
|
38 |
#' selected = "AEDECOD", |
|
39 |
#' choices = c( |
|
40 |
#' "AEDECOD", "AETERM", |
|
41 |
#' "AEHLT", "AELLT", "AEBODSYS" |
|
42 |
#' ) |
|
43 |
#' ), |
|
44 |
#' arm_var = choices_selected( |
|
45 |
#' selected = "ACTARMCD", |
|
46 |
#' choices = c("ACTARM", "ACTARMCD") |
|
47 |
#' ), |
|
48 |
#' plot_height = c(600, 200, 2000) |
|
49 |
#' ) |
|
50 |
#' ) |
|
51 |
#' ) |
|
52 |
#' if (interactive()) { |
|
53 |
#' shinyApp(app$ui, app$server) |
|
54 |
#' } |
|
55 |
#' |
|
56 |
tm_g_events_term_id <- function(label, |
|
57 |
dataname, |
|
58 |
term_var, |
|
59 |
arm_var, |
|
60 |
fontsize = c(5, 3, 7), |
|
61 |
plot_height = c(600L, 200L, 2000L), |
|
62 |
plot_width = NULL) { |
|
63 | ! |
message("Initializing tm_g_events_term_id") |
64 | ! |
checkmate::assert_string(label) |
65 | ! |
checkmate::assert_class(term_var, classes = "choices_selected") |
66 | ! |
checkmate::assert_class(arm_var, classes = "choices_selected") |
67 | ! |
checkmate::assert( |
68 | ! |
checkmate::check_number(fontsize, finite = TRUE), |
69 | ! |
checkmate::assert( |
70 | ! |
combine = "and", |
71 | ! |
.var.name = "fontsize", |
72 | ! |
checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE), |
73 | ! |
checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3]) |
74 |
) |
|
75 |
) |
|
76 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
77 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
78 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
79 | ! |
checkmate::assert_numeric( |
80 | ! |
plot_width[1], |
81 | ! |
lower = plot_width[2], |
82 | ! |
upper = plot_width[3], |
83 | ! |
null.ok = TRUE, |
84 | ! |
.var.name = "plot_width" |
85 |
) |
|
86 | ||
87 | ! |
args <- as.list(environment()) |
88 | ||
89 | ! |
module( |
90 | ! |
label = label, |
91 | ! |
server = srv_g_events_term_id, |
92 | ! |
server_args = list(label = label, dataname = dataname, plot_height = plot_height, plot_width = plot_width), |
93 | ! |
ui = ui_g_events_term_id, |
94 | ! |
ui_args = args, |
95 | ! |
datanames = c("ADSL", dataname) |
96 |
) |
|
97 |
} |
|
98 | ||
99 |
ui_g_events_term_id <- function(id, ...) { |
|
100 | ! |
ns <- NS(id) |
101 | ! |
args <- list(...) |
102 | ! |
teal.widgets::standard_layout( |
103 | ! |
output = teal.widgets::white_small_well( |
104 | ! |
plot_decorate_output(id = ns(NULL)) |
105 |
), |
|
106 | ! |
encoding = tags$div( |
107 |
### Reporter |
|
108 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
109 |
### |
|
110 | ! |
teal.widgets::optionalSelectInput( |
111 | ! |
ns("term"), |
112 | ! |
"Term Variable", |
113 | ! |
choices = get_choices(args$term_var$choices), |
114 | ! |
selected = args$term_var$selected |
115 |
), |
|
116 | ! |
teal.widgets::optionalSelectInput( |
117 | ! |
ns("arm_var"), |
118 | ! |
"Arm Variable", |
119 | ! |
choices = get_choices(args$arm_var$choices), |
120 | ! |
selected = args$arm_var$selected |
121 |
), |
|
122 | ! |
selectInput( |
123 | ! |
ns("arm_ref"), |
124 | ! |
"Control", |
125 | ! |
choices = get_choices(args$arm_var$choices), |
126 | ! |
selected = args$arm_var$selected |
127 |
), |
|
128 | ! |
selectInput( |
129 | ! |
ns("arm_trt"), |
130 | ! |
"Treatment", |
131 | ! |
choices = get_choices(args$arm_var$choices), |
132 | ! |
selected = args$arm_var$selected |
133 |
), |
|
134 | ! |
teal.widgets::optionalSelectInput( |
135 | ! |
ns("sort"), |
136 | ! |
"Sort By", |
137 | ! |
choices = c( |
138 | ! |
"Term" = "term", |
139 | ! |
"Risk Difference" = "riskdiff", |
140 | ! |
"Mean Risk" = "meanrisk" |
141 |
), |
|
142 | ! |
selected = NULL |
143 |
), |
|
144 | ! |
teal.widgets::panel_item( |
145 | ! |
"Confidence interval settings", |
146 | ! |
teal.widgets::optionalSelectInput( |
147 | ! |
ns("diff_ci_method"), |
148 | ! |
"Method for Difference of Proportions CI", |
149 | ! |
choices = ci_choices, |
150 | ! |
selected = ci_choices[1] |
151 |
), |
|
152 | ! |
teal.widgets::optionalSliderInput( |
153 | ! |
ns("conf_level"), |
154 | ! |
"Confidence Level", |
155 | ! |
min = 0.5, |
156 | ! |
max = 1, |
157 | ! |
value = 0.95 |
158 |
) |
|
159 |
), |
|
160 | ! |
teal.widgets::panel_item( |
161 | ! |
"Additional plot settings", |
162 | ! |
teal.widgets::optionalSelectInput( |
163 | ! |
ns("axis"), |
164 | ! |
"Axis Side", |
165 | ! |
choices = c("Left" = "left", "Right" = "right"), |
166 | ! |
selected = "left" |
167 |
), |
|
168 | ! |
sliderInput( |
169 | ! |
ns("raterange"), |
170 | ! |
"Overall Rate Range", |
171 | ! |
min = 0, |
172 | ! |
max = 1, |
173 | ! |
value = c(0.1, 1), |
174 | ! |
step = 0.01 |
175 |
), |
|
176 | ! |
sliderInput( |
177 | ! |
ns("diffrange"), |
178 | ! |
"Rate Difference Range", |
179 | ! |
min = -1, |
180 | ! |
max = 1, |
181 | ! |
value = c(-0.5, 0.5), |
182 | ! |
step = 0.01 |
183 |
), |
|
184 | ! |
checkboxInput(ns("reverse"), |
185 | ! |
"Reverse Order", |
186 | ! |
value = FALSE |
187 |
) |
|
188 |
), |
|
189 | ! |
ui_g_decorate( |
190 | ! |
ns(NULL), |
191 | ! |
fontsize = args$fontsize, |
192 | ! |
titles = "Common AE Table", |
193 | ! |
footnotes = "" |
194 |
) |
|
195 |
), |
|
196 | ! |
forms = tagList( |
197 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
198 |
) |
|
199 |
) |
|
200 |
} |
|
201 | ||
202 |
srv_g_events_term_id <- function(id, |
|
203 |
data, |
|
204 |
filter_panel_api, |
|
205 |
reporter, |
|
206 |
dataname, |
|
207 |
label, |
|
208 |
plot_height, |
|
209 |
plot_width) { |
|
210 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
211 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
212 | ! |
checkmate::assert_class(data, "reactive") |
213 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
214 | ||
215 | ! |
moduleServer(id, function(input, output, session) { |
216 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
217 | ! |
iv <- reactive({ |
218 | ! |
iv <- shinyvalidate::InputValidator$new() |
219 | ! |
iv$add_rule("term", shinyvalidate::sv_required( |
220 | ! |
message = "Term Variable is required" |
221 |
)) |
|
222 | ! |
iv$add_rule("arm_var", shinyvalidate::sv_required( |
223 | ! |
message = "Arm Variable is required" |
224 |
)) |
|
225 | ! |
rule_diff <- function(value, other) { |
226 | ! |
if (isTRUE(value == other)) "Control and Treatment must be different" |
227 |
} |
|
228 | ! |
iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) |
229 | ! |
iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) |
230 | ! |
iv$enable() |
231 | ! |
iv |
232 |
}) |
|
233 | ||
234 | ! |
decorate_output <- srv_g_decorate( |
235 | ! |
id = NULL, plt = plot_r, plot_height = plot_height, plot_width = plot_width |
236 |
) |
|
237 | ! |
font_size <- decorate_output$font_size |
238 | ! |
pws <- decorate_output$pws |
239 | ||
240 | ! |
observeEvent(list(input$diff_ci_method, input$conf_level), { |
241 | ! |
req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) |
242 | ! |
diff_ci_method <- input$diff_ci_method |
243 | ! |
conf_level <- input$conf_level |
244 | ! |
updateTextAreaInput( |
245 | ! |
session, |
246 | ! |
"foot", |
247 | ! |
value = sprintf( |
248 | ! |
"Note: %d%% CI is calculated using %s", |
249 | ! |
round(conf_level * 100), |
250 | ! |
name_ci(diff_ci_method) |
251 |
) |
|
252 |
) |
|
253 |
}) |
|
254 | ||
255 | ||
256 | ! |
observeEvent(input$sort, |
257 |
{ |
|
258 | ! |
sort <- if (is.null(input$sort)) " " else input$sort |
259 | ! |
updateTextInput( |
260 | ! |
session, |
261 | ! |
"title", |
262 | ! |
value = sprintf( |
263 | ! |
"Common AE Table %s", |
264 | ! |
c( |
265 | ! |
"term" = "Sorted by Term", |
266 | ! |
"riskdiff" = "Sorted by Risk Difference", |
267 | ! |
"meanrisk" = "Sorted by Mean Risk", |
268 |
" " = "" |
|
269 | ! |
)[sort] |
270 |
) |
|
271 |
) |
|
272 |
}, |
|
273 | ! |
ignoreNULL = FALSE |
274 |
) |
|
275 | ||
276 | ! |
observeEvent(input$arm_var, |
277 |
{ |
|
278 | ! |
arm_var <- input$arm_var |
279 | ! |
ANL <- data()[[dataname]] |
280 | ||
281 | ! |
choices <- levels(ANL[[arm_var]]) |
282 | ||
283 | ! |
if (length(choices) == 1) { |
284 | ! |
trt_index <- 1 |
285 |
} else { |
|
286 | ! |
trt_index <- 2 |
287 |
} |
|
288 | ||
289 | ! |
updateSelectInput( |
290 | ! |
session, |
291 | ! |
"arm_ref", |
292 | ! |
selected = choices[1], |
293 | ! |
choices = choices |
294 |
) |
|
295 | ! |
updateSelectInput( |
296 | ! |
session, |
297 | ! |
"arm_trt", |
298 | ! |
selected = choices[trt_index], |
299 | ! |
choices = choices |
300 |
) |
|
301 |
}, |
|
302 | ! |
ignoreNULL = TRUE |
303 |
) |
|
304 | ||
305 | ! |
output_q <- reactive({ |
306 | ! |
ANL <- data()[[dataname]] |
307 | ||
308 | ! |
teal::validate_inputs(iv()) |
309 | ||
310 | ! |
shiny::validate( |
311 | ! |
shiny::need(is.factor(ANL[[input$arm_var]]), "Arm Var must be a factor variable. Contact developer."), |
312 | ! |
shiny::need( |
313 | ! |
input$arm_trt %in% ANL[[req(input$arm_var)]] && input$arm_ref %in% ANL[[req(input$arm_var)]], |
314 | ! |
"Cannot generate plot. The dataset does not contain subjects from both the control and treatment arms." |
315 |
) |
|
316 |
) |
|
317 | ||
318 | ! |
adsl_vars <- unique(c("USUBJID", "STUDYID", input$arm_var)) |
319 | ! |
anl_vars <- c("USUBJID", "STUDYID", input$term) |
320 | ||
321 | ! |
q1 <- teal.code::eval_code( |
322 | ! |
data(), |
323 | ! |
code = bquote( |
324 | ! |
ANL <- merge( |
325 | ! |
x = ADSL[, .(adsl_vars), drop = FALSE], |
326 | ! |
y = .(as.name(dataname))[, .(anl_vars), drop = FALSE], |
327 | ! |
all.x = FALSE, |
328 | ! |
all.y = FALSE, |
329 | ! |
by = c("USUBJID", "STUDYID") |
330 |
) |
|
331 |
) |
|
332 |
) |
|
333 | ||
334 | ! |
teal::validate_has_data(q1[["ANL"]], |
335 | ! |
min_nrow = 10, |
336 | ! |
msg = "Analysis data set must have at least 10 data points" |
337 |
) |
|
338 | ||
339 | ! |
q2 <- teal.code::eval_code( |
340 | ! |
q1, |
341 | ! |
code = bquote( |
342 | ! |
plot <- osprey::g_events_term_id( |
343 | ! |
term = ANL[[.(input$term)]], |
344 | ! |
id = ANL$USUBJID, |
345 | ! |
arm = ANL[[.(input$arm_var)]], |
346 | ! |
arm_N = table(ADSL[[.(input$arm_var)]]), |
347 | ! |
ref = .(input$arm_ref), |
348 | ! |
trt = .(input$arm_trt), |
349 | ! |
sort_by = .(input$sort), |
350 | ! |
rate_range = .(input$raterange), |
351 | ! |
diff_range = .(input$diffrange), |
352 | ! |
reversed = .(input$reverse), |
353 | ! |
conf_level = .(input$conf_level), |
354 | ! |
diff_ci_method = .(input$diff_ci_method), |
355 | ! |
axis_side = .(input$axis), |
356 | ! |
fontsize = .(font_size()), |
357 | ! |
draw = TRUE |
358 |
) |
|
359 |
) |
|
360 |
) |
|
361 | ||
362 | ! |
teal.code::eval_code(q2, quote(plot)) |
363 |
}) |
|
364 | ||
365 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
366 | ||
367 | ! |
teal.widgets::verbatim_popup_srv( |
368 | ! |
id = "rcode", |
369 | ! |
title = paste("R code for", label), |
370 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
371 |
) |
|
372 | ||
373 |
### REPORTER |
|
374 | ! |
if (with_reporter) { |
375 | ! |
card_fun <- function(comment, label) { |
376 | ! |
card <- teal::report_card_template( |
377 | ! |
title = "Events by Term", |
378 | ! |
label = label, |
379 | ! |
with_filter = with_filter, |
380 | ! |
filter_panel_api = filter_panel_api |
381 |
) |
|
382 | ! |
card$append_text("Plot", "header3") |
383 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
384 | ! |
if (!comment == "") { |
385 | ! |
card$append_text("Comment", "header3") |
386 | ! |
card$append_text(comment) |
387 |
} |
|
388 | ! |
card$append_src(teal.code::get_code(output_q())) |
389 | ! |
card |
390 |
} |
|
391 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
392 |
} |
|
393 |
}) |
|
394 |
} |
1 |
#' Teal module for the `AE` overview |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display the `AE` overview plot as a shiny module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param flag_var_anl ([`teal.transform::choices_selected`]) |
|
11 |
#' `choices_selected` object with variables used to count adverse event |
|
12 |
#' sub-groups (e.g. Serious events, Related events, etc.) |
|
13 |
#' |
|
14 |
#' @inherit argument_convention return |
|
15 |
#' |
|
16 |
#' @export |
|
17 |
#' |
|
18 |
#' @examples |
|
19 |
#' data <- cdisc_data() |> |
|
20 |
#' within({ |
|
21 |
#' library(nestcolor) |
|
22 |
#' ADSL <- rADSL |
|
23 |
#' ADAE <- rADAE |
|
24 |
#' add_event_flags <- function(dat) { |
|
25 |
#' dat <- dat |> |
|
26 |
#' mutate( |
|
27 |
#' TMPFL_SER = AESER == "Y", |
|
28 |
#' TMPFL_REL = AEREL == "Y", |
|
29 |
#' TMPFL_GR5 = AETOXGR == "5", |
|
30 |
#' AEREL1 = (AEREL == "Y" & ACTARM == "A: Drug X"), |
|
31 |
#' AEREL2 = (AEREL == "Y" & ACTARM == "B: Placebo") |
|
32 |
#' ) |
|
33 |
#' labels <- c( |
|
34 |
#' "Serious AE", "Related AE", "Grade 5 AE", |
|
35 |
#' "AE related to A: Drug X", "AE related to B: Placebo" |
|
36 |
#' ) |
|
37 |
#' cols <- c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2") |
|
38 |
#' for (i in seq_along(labels)) { |
|
39 |
#' attr(dat[[cols[i]]], "label") <- labels[i] |
|
40 |
#' } |
|
41 |
#' dat |
|
42 |
#' } |
|
43 |
#' ADAE <- add_event_flags(ADAE) |
|
44 |
#' }) |
|
45 |
#' |
|
46 |
#' datanames(data) <- c("ADSL", "ADAE") |
|
47 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
48 |
#' |
|
49 |
#' ADAE <- data[["ADAE"]] |
|
50 |
#' |
|
51 |
#' app <- init( |
|
52 |
#' data = data, |
|
53 |
#' modules = modules( |
|
54 |
#' tm_g_ae_oview( |
|
55 |
#' label = "AE Overview", |
|
56 |
#' dataname = "ADAE", |
|
57 |
#' arm_var = choices_selected( |
|
58 |
#' selected = "ACTARM", |
|
59 |
#' choices = c("ACTARM", "ACTARMCD") |
|
60 |
#' ), |
|
61 |
#' flag_var_anl = choices_selected( |
|
62 |
#' selected = "AEREL1", |
|
63 |
#' choices = variable_choices( |
|
64 |
#' ADAE, |
|
65 |
#' c("TMPFL_SER", "TMPFL_REL", "TMPFL_GR5", "AEREL1", "AEREL2") |
|
66 |
#' ), |
|
67 |
#' ), |
|
68 |
#' plot_height = c(600, 200, 2000) |
|
69 |
#' ) |
|
70 |
#' ) |
|
71 |
#' ) |
|
72 |
#' if (interactive()) { |
|
73 |
#' shinyApp(app$ui, app$server) |
|
74 |
#' } |
|
75 |
#' |
|
76 |
tm_g_ae_oview <- function(label, |
|
77 |
dataname, |
|
78 |
arm_var, |
|
79 |
flag_var_anl, |
|
80 |
fontsize = c(5, 3, 7), |
|
81 |
plot_height = c(600L, 200L, 2000L), |
|
82 |
plot_width = NULL) { |
|
83 | ! |
message("Initializing tm_g_ae_oview") |
84 | ! |
checkmate::assert_class(arm_var, classes = "choices_selected") |
85 | ! |
checkmate::assert_class(flag_var_anl, classes = "choices_selected") |
86 | ! |
checkmate::assert( |
87 | ! |
checkmate::check_number(fontsize, finite = TRUE), |
88 | ! |
checkmate::assert( |
89 | ! |
combine = "and", |
90 | ! |
.var.name = "fontsize", |
91 | ! |
checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE), |
92 | ! |
checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3]) |
93 |
) |
|
94 |
) |
|
95 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
96 | ! |
checkmate::assert_numeric(plot_height[1], |
97 | ! |
lower = plot_height[2], upper = plot_height[3], |
98 | ! |
.var.name = "plot_height" |
99 |
) |
|
100 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
101 | ! |
checkmate::assert_numeric( |
102 | ! |
plot_width[1], |
103 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
104 |
) |
|
105 | ||
106 | ! |
args <- as.list(environment()) |
107 | ||
108 | ! |
module( |
109 | ! |
label = label, |
110 | ! |
server = srv_g_ae_oview, |
111 | ! |
server_args = list( |
112 | ! |
label = label, |
113 | ! |
dataname = dataname, |
114 | ! |
plot_height = plot_height, |
115 | ! |
plot_width = plot_width |
116 |
), |
|
117 | ! |
ui = ui_g_ae_oview, |
118 | ! |
ui_args = args, |
119 | ! |
datanames = c("ADSL", dataname) |
120 |
) |
|
121 |
} |
|
122 | ||
123 |
ui_g_ae_oview <- function(id, ...) { |
|
124 | ! |
ns <- NS(id) |
125 | ! |
args <- list(...) |
126 | ! |
teal.widgets::standard_layout( |
127 | ! |
output = teal.widgets::white_small_well( |
128 | ! |
plot_decorate_output(id = ns(NULL)) |
129 |
), |
|
130 | ! |
encoding = tags$div( |
131 |
### Reporter |
|
132 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
133 |
### |
|
134 | ! |
teal.widgets::optionalSelectInput( |
135 | ! |
ns("arm_var"), |
136 | ! |
"Arm Variable", |
137 | ! |
choices = get_choices(args$arm_var$choices), |
138 | ! |
selected = args$arm_var$selected, |
139 | ! |
multiple = FALSE |
140 |
), |
|
141 | ! |
selectInput( |
142 | ! |
ns("arm_ref"), |
143 | ! |
"Control", |
144 | ! |
choices = get_choices(args$arm_var$choices), |
145 | ! |
selected = args$arm_var$selected |
146 |
), |
|
147 | ! |
selectInput( |
148 | ! |
ns("arm_trt"), |
149 | ! |
"Treatment", |
150 | ! |
choices = get_choices(args$arm_var$choices), |
151 | ! |
selected = args$arm_var$selected |
152 |
), |
|
153 | ! |
selectInput( |
154 | ! |
ns("flag_var_anl"), |
155 | ! |
"Flags", |
156 | ! |
choices = get_choices(args$flag_var_anl$choices), |
157 | ! |
selected = args$flag_var_anl$selected, |
158 | ! |
multiple = TRUE |
159 |
), |
|
160 | ! |
teal.widgets::panel_item( |
161 | ! |
"Confidence interval settings", |
162 | ! |
teal.widgets::optionalSelectInput( |
163 | ! |
ns("diff_ci_method"), |
164 | ! |
"Method for Difference of Proportions CI", |
165 | ! |
choices = ci_choices, |
166 | ! |
selected = ci_choices[1], |
167 | ! |
multiple = FALSE |
168 |
), |
|
169 | ! |
teal.widgets::optionalSliderInput( |
170 | ! |
ns("conf_level"), |
171 | ! |
"Confidence Level", |
172 | ! |
min = 0.5, |
173 | ! |
max = 1, |
174 | ! |
value = 0.95 |
175 |
) |
|
176 |
), |
|
177 | ! |
teal.widgets::optionalSelectInput( |
178 | ! |
ns("axis"), |
179 | ! |
"Axis Side", |
180 | ! |
choices = c("Left" = "left", "Right" = "right"), |
181 | ! |
selected = "left", |
182 | ! |
multiple = FALSE |
183 |
), |
|
184 | ! |
ui_g_decorate( |
185 | ! |
ns(NULL), |
186 | ! |
fontsize = args$fontsize, |
187 | ! |
titles = "AE Overview", |
188 | ! |
footnotes = "" |
189 |
) |
|
190 |
), |
|
191 | ! |
forms = tagList( |
192 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
193 |
) |
|
194 |
) |
|
195 |
} |
|
196 | ||
197 |
srv_g_ae_oview <- function(id, |
|
198 |
data, |
|
199 |
filter_panel_api, |
|
200 |
reporter, |
|
201 |
dataname, |
|
202 |
label, |
|
203 |
plot_height, |
|
204 |
plot_width) { |
|
205 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
206 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
207 | ! |
checkmate::assert_class(data, "reactive") |
208 | ! |
checkmate::assert_class(isolate(data()), "teal_data") |
209 | ||
210 | ! |
moduleServer(id, function(input, output, session) { |
211 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
212 | ! |
iv <- reactive({ |
213 | ! |
ANL <- data()[[dataname]] |
214 | ||
215 | ! |
iv <- shinyvalidate::InputValidator$new() |
216 | ! |
iv$add_rule("arm_var", shinyvalidate::sv_required( |
217 | ! |
message = "Arm Variable is required" |
218 |
)) |
|
219 | ! |
iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { |
220 | ! |
"Arm Var must be a factor variable" |
221 |
}) |
|
222 | ! |
iv$add_rule("arm_var", ~ if (nlevels(ANL[[.]]) < 2L) { |
223 | ! |
"Selected Arm Var must have at least two levels" |
224 |
}) |
|
225 | ! |
iv$add_rule("flag_var_anl", shinyvalidate::sv_required( |
226 | ! |
message = "At least one Flag is required" |
227 |
)) |
|
228 | ! |
rule_diff <- function(value, other) { |
229 | ! |
if (isTRUE(value == other)) "Control and Treatment must be different" |
230 |
} |
|
231 | ! |
iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) |
232 | ! |
iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) |
233 | ! |
iv$enable() |
234 | ! |
iv |
235 |
}) |
|
236 | ||
237 | ! |
decorate_output <- srv_g_decorate( |
238 | ! |
id = NULL, plt = plot_r, |
239 | ! |
plot_height = plot_height, plot_width = plot_width |
240 |
) |
|
241 | ! |
font_size <- decorate_output$font_size |
242 | ! |
pws <- decorate_output$pws |
243 | ||
244 | ! |
observeEvent(list(input$diff_ci_method, input$conf_level), { |
245 | ! |
req(!is.null(input$diff_ci_method) && !is.null(input$conf_level)) |
246 | ! |
diff_ci_method <- input$diff_ci_method |
247 | ! |
conf_level <- input$conf_level |
248 | ! |
updateTextAreaInput(session, |
249 | ! |
"foot", |
250 | ! |
value = sprintf( |
251 | ! |
"Note: %d%% CI is calculated using %s", |
252 | ! |
round(conf_level * 100), |
253 | ! |
name_ci(diff_ci_method) |
254 |
) |
|
255 |
) |
|
256 |
}) |
|
257 | ||
258 | ! |
observeEvent(input$arm_var, ignoreNULL = TRUE, { |
259 | ! |
ANL <- data()[[dataname]] |
260 | ! |
arm_var <- input$arm_var |
261 | ! |
arm_val <- ANL[[arm_var]] |
262 | ! |
choices <- levels(arm_val) |
263 | ||
264 | ! |
if (length(choices) == 1) { |
265 | ! |
trt_index <- 1 |
266 |
} else { |
|
267 | ! |
trt_index <- 2 |
268 |
} |
|
269 | ||
270 | ! |
updateSelectInput( |
271 | ! |
session, |
272 | ! |
"arm_ref", |
273 | ! |
selected = choices[1], |
274 | ! |
choices = choices |
275 |
) |
|
276 | ! |
updateSelectInput( |
277 | ! |
session, |
278 | ! |
"arm_trt", |
279 | ! |
selected = choices[trt_index], |
280 | ! |
choices = choices |
281 |
) |
|
282 |
}) |
|
283 | ||
284 | ! |
output_q <- shiny::debounce( |
285 | ! |
millis = 200, |
286 | ! |
r = reactive({ |
287 | ! |
ANL <- data()[[dataname]] |
288 | ||
289 | ! |
teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) |
290 | ||
291 | ! |
teal::validate_inputs(iv()) |
292 | ||
293 | ! |
validate(need( |
294 | ! |
input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]], |
295 | ! |
"Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" |
296 |
)) |
|
297 | ||
298 | ! |
q1 <- teal.code::eval_code( |
299 | ! |
data(), |
300 | ! |
code = as.expression(c( |
301 | ! |
bquote(anl_labels <- formatters::var_labels(.(as.name(dataname)), fill = FALSE)), |
302 | ! |
bquote( |
303 | ! |
flags <- .(as.name(dataname)) %>% |
304 | ! |
select(all_of(.(input$flag_var_anl))) %>% |
305 | ! |
rename_at(vars(.(input$flag_var_anl)), function(x) paste0(x, ": ", anl_labels[x])) |
306 |
) |
|
307 |
)) |
|
308 |
) |
|
309 | ||
310 | ! |
teal.code::eval_code( |
311 | ! |
q1, |
312 | ! |
code = as.expression(c( |
313 | ! |
bquote( |
314 | ! |
plot <- osprey::g_events_term_id( |
315 | ! |
term = flags, |
316 | ! |
id = .(as.name(dataname))[["USUBJID"]], |
317 | ! |
arm = .(as.name(dataname))[[.(input$arm_var)]], |
318 | ! |
arm_N = table(ADSL[[.(input$arm_var)]]), |
319 | ! |
ref = .(input$arm_ref), |
320 | ! |
trt = .(input$arm_trt), |
321 | ! |
diff_ci_method = .(input$diff_ci_method), |
322 | ! |
conf_level = .(input$conf_level), |
323 | ! |
axis_side = .(input$axis), |
324 | ! |
fontsize = .(font_size()), |
325 | ! |
draw = TRUE |
326 |
) |
|
327 |
), |
|
328 | ! |
quote(plot) |
329 |
)) |
|
330 |
) |
|
331 |
}) |
|
332 |
) |
|
333 | ||
334 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
335 | ||
336 | ! |
teal.widgets::verbatim_popup_srv( |
337 | ! |
id = "rcode", |
338 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())), |
339 | ! |
title = paste("R code for", label) |
340 |
) |
|
341 |
### REPORTER |
|
342 | ! |
if (with_reporter) { |
343 | ! |
card_fun <- function(comment, label) { |
344 | ! |
card <- teal::report_card_template( |
345 | ! |
title = "AE Overview", |
346 | ! |
label = label, |
347 | ! |
with_filter = with_filter, |
348 | ! |
filter_panel_api = filter_panel_api |
349 |
) |
|
350 | ! |
card$append_text("Plot", "header3") |
351 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
352 | ! |
if (!comment == "") { |
353 | ! |
card$append_text("Comment", "header3") |
354 | ! |
card$append_text(comment) |
355 |
} |
|
356 | ! |
card$append_src(teal.code::get_code(output_q())) |
357 | ! |
card |
358 |
} |
|
359 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
360 |
} |
|
361 |
}) |
|
362 |
} |
1 |
#' Teal module for the heatmap by grade |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display the heatmap by grade as a shiny module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param sl_dataname (`character`) subject level dataset name, |
|
11 |
#' needs to be available in the list passed to the `data` |
|
12 |
#' argument of [teal::init()] |
|
13 |
#' @param ex_dataname (`character`) exposures dataset name, |
|
14 |
#' needs to be available in the list passed to the `data` |
|
15 |
#' argument of [teal::init()] \cr |
|
16 |
#' @param ae_dataname (`character`) adverse events dataset name, |
|
17 |
#' needs to be available in the list passed to the `data` |
|
18 |
#' argument of [teal::init()] \cr |
|
19 |
#' @param cm_dataname (`character`) concomitant medications dataset name, |
|
20 |
#' needs to be available in the list passed to the `data` |
|
21 |
#' argument of [teal::init()] \cr |
|
22 |
#' specify to `NA` if no concomitant medications data is available |
|
23 |
#' @param id_var (`choices_seleced`) unique subject ID variable |
|
24 |
#' @param visit_var (`choices_seleced`) analysis visit variable |
|
25 |
#' @param ongo_var (`choices_seleced`) study ongoing status variable. |
|
26 |
#' This variable is a derived logical variable. Usually it can be derived from `EOSSTT`. |
|
27 |
#' @param anno_var (`choices_seleced`) annotation variable |
|
28 |
#' @param heat_var (`choices_seleced`) heatmap variable |
|
29 |
#' @param conmed_var (`choices_seleced`) concomitant medications variable, |
|
30 |
#' specify to `NA` if no concomitant medications data is available |
|
31 |
#' |
|
32 |
#' @inherit argument_convention return |
|
33 |
#' |
|
34 |
#' @export |
|
35 |
#' |
|
36 |
#' @examples |
|
37 |
#' data <- cdisc_data() |> |
|
38 |
#' within({ |
|
39 |
#' library(dplyr) |
|
40 |
#' library(nestcolor) |
|
41 |
#' ADSL <- rADSL %>% slice(1:30) |
|
42 |
#' ADEX <- rADEX %>% filter(USUBJID %in% ADSL$USUBJID) |
|
43 |
#' ADAE <- rADAE %>% filter(USUBJID %in% ADSL$USUBJID) |
|
44 |
#' ADCM <- rADCM %>% filter(USUBJID %in% ADSL$USUBJID) |
|
45 |
#' # This preprocess is only to force legacy standard on ADCM |
|
46 |
#' ADCM <- ADCM %>% |
|
47 |
#' select(-starts_with("ATC")) %>% |
|
48 |
#' unique() |
|
49 |
#' # function to derive AVISIT from ADEX |
|
50 |
#' add_visit <- function(data_need_visit) { |
|
51 |
#' visit_dates <- ADEX %>% |
|
52 |
#' filter(PARAMCD == "DOSE") %>% |
|
53 |
#' distinct(USUBJID, AVISIT, ASTDTM) %>% |
|
54 |
#' group_by(USUBJID) %>% |
|
55 |
#' arrange(ASTDTM) %>% |
|
56 |
#' mutate(next_vis = lead(ASTDTM), is_last = ifelse(is.na(next_vis), TRUE, FALSE)) %>% |
|
57 |
#' rename(this_vis = ASTDTM) |
|
58 |
#' data_visit <- data_need_visit %>% |
|
59 |
#' select(USUBJID, ASTDTM) %>% |
|
60 |
#' left_join(visit_dates, by = "USUBJID") %>% |
|
61 |
#' filter(ASTDTM > this_vis & (ASTDTM < next_vis | is_last == TRUE)) %>% |
|
62 |
#' left_join(data_need_visit) %>% |
|
63 |
#' distinct() |
|
64 |
#' return(data_visit) |
|
65 |
#' } |
|
66 |
#' # derive AVISIT for ADAE and ADCM |
|
67 |
#' ADAE <- add_visit(ADAE) |
|
68 |
#' ADCM <- add_visit(ADCM) |
|
69 |
#' # derive ongoing status variable for ADEX |
|
70 |
#' ADEX <- ADEX %>% |
|
71 |
#' filter(PARCAT1 == "INDIVIDUAL") %>% |
|
72 |
#' mutate(ongo_status = (EOSSTT == "ONGOING")) |
|
73 |
#' }) |
|
74 |
#' |
|
75 |
#' datanames(data) <- c("ADSL", "ADEX", "ADAE", "ADCM") |
|
76 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
77 |
#' |
|
78 |
#' ADCM <- data[["ADCM"]] |
|
79 |
#' |
|
80 |
#' app <- init( |
|
81 |
#' data = data, |
|
82 |
#' modules = modules( |
|
83 |
#' tm_g_heat_bygrade( |
|
84 |
#' label = "Heatmap by grade", |
|
85 |
#' sl_dataname = "ADSL", |
|
86 |
#' ex_dataname = "ADEX", |
|
87 |
#' ae_dataname = "ADAE", |
|
88 |
#' cm_dataname = "ADCM", |
|
89 |
#' id_var = choices_selected( |
|
90 |
#' selected = "USUBJID", |
|
91 |
#' choices = c("USUBJID", "SUBJID") |
|
92 |
#' ), |
|
93 |
#' visit_var = choices_selected( |
|
94 |
#' selected = "AVISIT", |
|
95 |
#' choices = c("AVISIT") |
|
96 |
#' ), |
|
97 |
#' ongo_var = choices_selected( |
|
98 |
#' selected = "ongo_status", |
|
99 |
#' choices = c("ongo_status") |
|
100 |
#' ), |
|
101 |
#' anno_var = choices_selected( |
|
102 |
#' selected = c("SEX", "COUNTRY"), |
|
103 |
#' choices = c("SEX", "COUNTRY", "USUBJID") |
|
104 |
#' ), |
|
105 |
#' heat_var = choices_selected( |
|
106 |
#' selected = "AETOXGR", |
|
107 |
#' choices = c("AETOXGR") |
|
108 |
#' ), |
|
109 |
#' conmed_var = choices_selected( |
|
110 |
#' selected = "CMDECOD", |
|
111 |
#' choices = c("CMDECOD") |
|
112 |
#' ), |
|
113 |
#' plot_height = c(600, 200, 2000) |
|
114 |
#' ) |
|
115 |
#' ) |
|
116 |
#' ) |
|
117 |
#' if (interactive()) { |
|
118 |
#' shinyApp(app$ui, app$server) |
|
119 |
#' } |
|
120 |
#' |
|
121 |
tm_g_heat_bygrade <- function(label, |
|
122 |
sl_dataname, |
|
123 |
ex_dataname, |
|
124 |
ae_dataname, |
|
125 |
cm_dataname = NA, |
|
126 |
id_var, |
|
127 |
visit_var, |
|
128 |
ongo_var, |
|
129 |
anno_var, |
|
130 |
heat_var, |
|
131 |
conmed_var = NULL, |
|
132 |
fontsize = c(5, 3, 7), |
|
133 |
plot_height = c(600L, 200L, 2000L), |
|
134 |
plot_width = NULL) { |
|
135 | ! |
message("Initializing tm_g_heat_bygrade") |
136 | ! |
args <- as.list(environment()) |
137 | ||
138 | ! |
checkmate::assert_string(label) |
139 | ! |
checkmate::assert_string(sl_dataname) |
140 | ! |
checkmate::assert_string(ex_dataname) |
141 | ! |
checkmate::assert_string(ae_dataname) |
142 | ! |
checkmate::assert_string(cm_dataname, na.ok = TRUE) |
143 | ! |
checkmate::assert_class(id_var, classes = "choices_selected") |
144 | ! |
checkmate::assert_class(visit_var, classes = "choices_selected") |
145 | ! |
checkmate::assert_class(ongo_var, classes = "choices_selected") |
146 | ! |
checkmate::assert_class(anno_var, classes = "choices_selected") |
147 | ! |
checkmate::assert_class(heat_var, classes = "choices_selected") |
148 | ! |
checkmate::assert_class(conmed_var, classes = "choices_selected", null.ok = TRUE) |
149 | ! |
checkmate::assert( |
150 | ! |
checkmate::check_number(fontsize, finite = TRUE), |
151 | ! |
checkmate::assert( |
152 | ! |
combine = "and", |
153 | ! |
.var.name = "fontsize", |
154 | ! |
checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE), |
155 | ! |
checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3]) |
156 |
) |
|
157 |
) |
|
158 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
159 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
160 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
161 | ! |
checkmate::assert_numeric( |
162 | ! |
plot_width[1], |
163 | ! |
lower = plot_width[2], |
164 | ! |
upper = plot_width[3], |
165 | ! |
null.ok = TRUE, |
166 | ! |
.var.name = "plot_width" |
167 |
) |
|
168 | ||
169 | ! |
module( |
170 | ! |
label = label, |
171 | ! |
server = srv_g_heatmap_bygrade, |
172 | ! |
server_args = list( |
173 | ! |
label = label, |
174 | ! |
sl_dataname = sl_dataname, |
175 | ! |
ex_dataname = ex_dataname, |
176 | ! |
ae_dataname = ae_dataname, |
177 | ! |
cm_dataname = cm_dataname, |
178 | ! |
plot_height = plot_height, |
179 | ! |
plot_width = plot_width |
180 |
), |
|
181 | ! |
ui = ui_g_heatmap_bygrade, |
182 | ! |
ui_args = args, |
183 | ! |
datanames = "all" |
184 |
) |
|
185 |
} |
|
186 | ||
187 |
ui_g_heatmap_bygrade <- function(id, ...) { |
|
188 | ! |
ns <- NS(id) |
189 | ! |
args <- list(...) |
190 | ||
191 | ! |
shiny::tagList( |
192 | ! |
include_css_files("custom"), |
193 | ! |
teal.widgets::standard_layout( |
194 | ! |
output = teal.widgets::white_small_well( |
195 | ! |
plot_decorate_output(id = ns(NULL)) |
196 |
), |
|
197 | ! |
encoding = tags$div( |
198 |
### Reporter |
|
199 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
200 |
### |
|
201 | ! |
teal.widgets::optionalSelectInput( |
202 | ! |
ns("id_var"), |
203 | ! |
"ID Variable", |
204 | ! |
choices = get_choices(args$id_var$choices), |
205 | ! |
selected = args$id_var$selected, |
206 | ! |
multiple = FALSE |
207 |
), |
|
208 | ! |
teal.widgets::optionalSelectInput( |
209 | ! |
ns("visit_var"), |
210 | ! |
"Visit Variable", |
211 | ! |
choices = get_choices(args$visit_var$choices), |
212 | ! |
selected = args$visit_var$selected, |
213 | ! |
multiple = FALSE |
214 |
), |
|
215 | ! |
teal.widgets::optionalSelectInput( |
216 | ! |
ns("ongo_var"), |
217 | ! |
"Study Ongoing Status Variable", |
218 | ! |
choices = get_choices(args$ongo_var$choices), |
219 | ! |
selected = args$ongo_var$selected, |
220 | ! |
multiple = FALSE |
221 |
), |
|
222 | ! |
teal.widgets::optionalSelectInput( |
223 | ! |
ns("anno_var"), |
224 | ! |
"Annotation Variables", |
225 | ! |
choices = get_choices(args$anno_var$choices), |
226 | ! |
selected = args$anno_var$selected, |
227 | ! |
multiple = TRUE |
228 |
), |
|
229 | ! |
teal.widgets::optionalSelectInput( |
230 | ! |
ns("heat_var"), |
231 | ! |
"Heat Variable", |
232 | ! |
choices = get_choices(args$heat_var$choices), |
233 | ! |
selected = args$heat_var$selected, |
234 | ! |
multiple = FALSE |
235 |
), |
|
236 | ! |
helpText("Plot conmed"), |
237 | ! |
tags$div( |
238 | ! |
class = "pretty-left-border", |
239 | ! |
if (!is.na(args$cm_dataname)) { |
240 | ! |
checkboxInput( |
241 | ! |
ns("plot_cm"), |
242 | ! |
"Yes", |
243 | ! |
value = !is.na(args$cm_dataname) |
244 |
) |
|
245 |
} |
|
246 |
), |
|
247 | ! |
conditionalPanel( |
248 | ! |
paste0("input['", ns("plot_cm"), "']"), |
249 | ! |
teal.widgets::optionalSelectInput( |
250 | ! |
ns("conmed_var"), |
251 | ! |
"Conmed Variable", |
252 | ! |
choices = get_choices(args$conmed_var$choices), |
253 | ! |
selected = args$conmed_var$selected, |
254 | ! |
multiple = FALSE |
255 |
), |
|
256 | ! |
selectInput( |
257 | ! |
ns("conmed_level"), |
258 | ! |
"Conmed Levels", |
259 | ! |
choices = get_choices(args$conmed_var$choices), |
260 | ! |
selected = args$conmed_var$selected, |
261 | ! |
multiple = TRUE |
262 |
) |
|
263 |
), |
|
264 | ! |
ui_g_decorate( |
265 | ! |
ns(NULL), |
266 | ! |
fontsize = args$fontsize, |
267 | ! |
titles = "Heatmap by Grade", |
268 | ! |
footnotes = "" |
269 |
) |
|
270 |
), |
|
271 | ! |
forms = tagList( |
272 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
273 |
) |
|
274 |
) |
|
275 |
) |
|
276 |
} |
|
277 | ||
278 |
srv_g_heatmap_bygrade <- function(id, |
|
279 |
data, |
|
280 |
filter_panel_api, |
|
281 |
reporter, |
|
282 |
sl_dataname, |
|
283 |
ex_dataname, |
|
284 |
ae_dataname, |
|
285 |
cm_dataname, |
|
286 |
label, |
|
287 |
plot_height, |
|
288 |
plot_width) { |
|
289 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
290 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
291 | ! |
checkmate::assert_class(data, "reactive") |
292 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
293 | ! |
if (!is.na(sl_dataname)) checkmate::assert_names(sl_dataname, subset.of = names(data)) |
294 | ! |
if (!is.na(ex_dataname)) checkmate::assert_names(ex_dataname, subset.of = names(data)) |
295 | ! |
if (!is.na(ae_dataname)) checkmate::assert_names(ae_dataname, subset.of = names(data)) |
296 | ! |
if (!is.na(cm_dataname)) checkmate::assert_names(cm_dataname, subset.of = names(data)) |
297 | ||
298 | ! |
moduleServer(id, function(input, output, session) { |
299 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
300 | ! |
iv <- reactive({ |
301 | ! |
ADSL <- data()[[sl_dataname]] |
302 | ! |
ADEX <- data()[[ex_dataname]] |
303 | ! |
ADAE <- data()[[ae_dataname]] |
304 | ! |
if (isTRUE(input$plot_cm)) { |
305 | ! |
ADCM <- data()[[cm_dataname]] |
306 |
} |
|
307 | ||
308 | ! |
iv <- shinyvalidate::InputValidator$new() |
309 | ! |
iv$add_rule("id_var", shinyvalidate::sv_required( |
310 | ! |
message = "ID Variable is required" |
311 |
)) |
|
312 | ! |
iv$add_rule("visit_var", shinyvalidate::sv_required( |
313 | ! |
message = "Visit Variable is required" |
314 |
)) |
|
315 | ! |
iv$add_rule("ongo_var", shinyvalidate::sv_required( |
316 | ! |
message = "Study Ongoing Status Variable is required" |
317 |
)) |
|
318 | ! |
iv$add_rule("ongo_var", shinyvalidate::sv_in_set( |
319 | ! |
set = names(ADEX), |
320 | ! |
message_fmt = sprintf("Study Ongoing Status must be a variable in %s", ex_dataname) |
321 |
)) |
|
322 | ! |
iv$add_rule("ongo_var", ~ if (!is.logical(ADEX[[req(.)]])) { |
323 | ! |
"Study Ongoing Status must be a logical variable" |
324 |
}) |
|
325 | ! |
iv$add_rule("anno_var", shinyvalidate::sv_required( |
326 | ! |
message = "Annotation Variables is required" |
327 |
)) |
|
328 | ! |
iv$add_rule("anno_var", ~ if (length(.) > 2L) { |
329 | ! |
"No more than two Annotation Variables are allowed" |
330 |
}) |
|
331 | ! |
iv$add_rule("anno_var", shinyvalidate::sv_in_set( |
332 | ! |
set = names(ADSL), |
333 | ! |
message_fmt = sprintf("Study Ongoing Status must be a variable in %s", sl_dataname) |
334 |
)) |
|
335 | ! |
iv$add_rule("anno_var", ~ if (isTRUE(input$id_var %in% .)) { |
336 | ! |
sprintf("Deselect %s in Annotation Variables", input$id_var) |
337 |
}) |
|
338 | ! |
iv$add_rule("heat_var", shinyvalidate::sv_required( |
339 | ! |
message = "Heat Variable is required" |
340 |
)) |
|
341 | ! |
iv$enable() |
342 | ! |
iv |
343 |
}) |
|
344 | ! |
iv_cm <- reactive({ |
345 | ! |
ADSL <- data()[[sl_dataname]] |
346 | ! |
ADEX <- data()[[ex_dataname]] |
347 | ! |
ADAE <- data()[[ae_dataname]] |
348 | ! |
if (isTRUE(input$plot_cm)) { |
349 | ! |
ADCM <- data()[[cm_dataname]] |
350 |
} |
|
351 | ||
352 | ! |
iv_cm <- shinyvalidate::InputValidator$new() |
353 | ! |
iv_cm$condition(~ isTRUE(input$plot_cm)) |
354 | ! |
iv_cm$add_rule("conmed_var", shinyvalidate::sv_required( |
355 | ! |
message = "Conmed Variable is required" |
356 |
)) |
|
357 | ! |
iv_cm$add_rule("conmed_var", shinyvalidate::sv_in_set( |
358 | ! |
set = names(ADCM), |
359 | ! |
message_fmt = sprintf("Conmed Variable must be a variable in %s", cm_dataname) |
360 |
)) |
|
361 | ! |
iv_cm$add_rule("conmed_var", ~ if (!is.factor(ADCM[[.]])) { |
362 | ! |
"Study Ongoing Status must be a factor variable" |
363 |
}) |
|
364 | ! |
iv_cm$add_rule("conmed_level", shinyvalidate::sv_required( |
365 | ! |
"Select Conmed Levels" |
366 |
)) |
|
367 | ! |
iv_cm$add_rule("conmed_level", ~ if (length(.) > 3L) { |
368 | ! |
"No more than three Conmed Levels are allowed" |
369 |
}) |
|
370 | ! |
iv_cm$enable() |
371 | ! |
iv_cm |
372 |
}) |
|
373 | ||
374 | ! |
decorate_output <- srv_g_decorate( |
375 | ! |
id = NULL, |
376 | ! |
plt = plot_r, |
377 | ! |
plot_height = plot_height, |
378 | ! |
plot_width = plot_width |
379 |
) |
|
380 | ! |
font_size <- decorate_output$font_size |
381 | ! |
pws <- decorate_output$pws |
382 | ||
383 | ! |
if (!is.na(cm_dataname)) { |
384 | ! |
observeEvent(input$conmed_var, { |
385 | ! |
ADCM <- data()[[cm_dataname]] |
386 | ! |
choices <- levels(ADCM[[input$conmed_var]]) |
387 | ||
388 | ! |
updateSelectInput( |
389 | ! |
session, |
390 | ! |
"conmed_level", |
391 | ! |
selected = choices[1:3], |
392 | ! |
choices = choices |
393 |
) |
|
394 |
}) |
|
395 |
} |
|
396 | ||
397 | ! |
output_q <- shiny::debounce( |
398 | ! |
millis = 200, |
399 | ! |
r = reactive({ |
400 | ! |
ADSL <- data()[[sl_dataname]] |
401 | ! |
ADEX <- data()[[ex_dataname]] |
402 | ! |
ADAE <- data()[[ae_dataname]] |
403 | ! |
ADCM <- data()[[cm_dataname]] |
404 | ||
405 | ! |
teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s contains no data", sl_dataname)) |
406 | ! |
teal::validate_inputs(iv(), iv_cm()) |
407 | ! |
if (isTRUE(input$plot_cm)) { |
408 | ! |
shiny::validate(shiny::need(all(input$conmed_level %in% ADCM[[input$conmed_var]]), "Updating Conmed Levels")) |
409 |
} |
|
410 | ||
411 | ! |
qenv <- data() |
412 | ||
413 | ! |
if (isTRUE(input$plot_cm)) { |
414 | ! |
ADCM <- qenv[[cm_dataname]] |
415 | ! |
qenv <- teal.code::eval_code( |
416 | ! |
qenv, |
417 | ! |
code = substitute( |
418 | ! |
expr = { |
419 | ! |
conmed_data <- ADCM %>% |
420 | ! |
filter(conmed_var_name %in% conmed_level) |
421 | ! |
conmed_data[[conmed_var]] <- |
422 | ! |
factor(conmed_data[[conmed_var]], levels = unique(conmed_data[[conmed_var]])) |
423 | ! |
formatters::var_labels(conmed_data)[conmed_var] <- |
424 | ! |
formatters::var_labels(ADCM, fill = FALSE)[conmed_var] |
425 |
}, |
|
426 | ! |
env = list( |
427 | ! |
ADCM = as.name(cm_dataname), |
428 | ! |
conmed_var = input$conmed_var, |
429 | ! |
conmed_var_name = as.name(input$conmed_var), |
430 | ! |
conmed_level = input$conmed_level |
431 |
) |
|
432 |
) |
|
433 |
) |
|
434 |
} |
|
435 | ||
436 | ! |
qenv <- teal.code::eval_code( |
437 | ! |
qenv, |
438 | ! |
code = bquote( |
439 | ! |
plot <- osprey::g_heat_bygrade( |
440 | ! |
id_var = .(input$id_var), |
441 | ! |
exp_data = .(as.name(ex_dataname)) %>% filter(PARCAT1 == "INDIVIDUAL"), |
442 | ! |
visit_var = .(input$visit_var), |
443 | ! |
ongo_var = .(input$ongo_var), |
444 | ! |
anno_data = .(as.name(sl_dataname))[c(.(input$anno_var), .(input$id_var))], |
445 | ! |
anno_var = .(input$anno_var), |
446 | ! |
heat_data = .(as.name(ae_dataname)) %>% |
447 | ! |
select(.(as.name(input$id_var)), .(as.name(input$visit_var)), .(as.name(input$heat_var))), |
448 | ! |
heat_color_var = .(input$heat_var), |
449 | ! |
conmed_data = .(if (isTRUE(input$plot_cm)) as.name("conmed_data")), |
450 | ! |
conmed_var = .(if (isTRUE(input$plot_cm)) input$conmed_var), |
451 |
) |
|
452 |
) |
|
453 |
) |
|
454 | ! |
teal.code::eval_code(qenv, quote(plot)) |
455 |
}) |
|
456 |
) |
|
457 | ||
458 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
459 | ||
460 | ! |
teal.widgets::verbatim_popup_srv( |
461 | ! |
id = "rcode", |
462 | ! |
title = paste("R code for", label), |
463 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
464 |
) |
|
465 | ||
466 |
### REPORTER |
|
467 | ! |
if (with_reporter) { |
468 | ! |
card_fun <- function(comment, label) { |
469 | ! |
card <- teal::report_card_template( |
470 | ! |
title = "Heatmap by Grade", |
471 | ! |
label = label, |
472 | ! |
with_filter = with_filter, |
473 | ! |
filter_panel_api = filter_panel_api |
474 |
) |
|
475 | ! |
card$append_text("Plot", "header3") |
476 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
477 | ! |
if (!comment == "") { |
478 | ! |
card$append_text("Comment", "header3") |
479 | ! |
card$append_text(comment) |
480 |
} |
|
481 | ! |
card$append_src(teal.code::get_code(output_q())) |
482 | ! |
card |
483 |
} |
|
484 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
485 |
} |
|
486 |
}) |
|
487 |
} |
1 |
#' teal module for the `AE` by subgroups |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display the `AE` by subgroups plot as a teal module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param group_var (`choices_selected`) subgroups variables. See [teal.transform::choices_selected()] for details. |
|
11 |
#' |
|
12 |
#' @author Liming Li (Lil128) \email{liming.li@roche.com} |
|
13 |
#' @author Molly He (hey59) \email{hey59@gene.com} |
|
14 |
#' |
|
15 |
#' @inherit argument_convention return |
|
16 |
#' |
|
17 |
#' @export |
|
18 |
#' |
|
19 |
#' @examples |
|
20 |
#' # Example using stream (ADaM) dataset |
|
21 |
#' data <- cdisc_data() |> |
|
22 |
#' within({ |
|
23 |
#' ADSL <- rADSL |
|
24 |
#' ADAE <- rADAE |
|
25 |
#' }) |
|
26 |
#' |
|
27 |
#' datanames(data) <- c("ADSL", "ADAE") |
|
28 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
29 |
#' |
|
30 |
#' app <- init( |
|
31 |
#' data = data, |
|
32 |
#' modules = modules( |
|
33 |
#' tm_g_ae_sub( |
|
34 |
#' label = "AE by Subgroup", |
|
35 |
#' dataname = "ADAE", |
|
36 |
#' arm_var = choices_selected( |
|
37 |
#' selected = "ACTARMCD", |
|
38 |
#' choices = c("ACTARM", "ACTARMCD") |
|
39 |
#' ), |
|
40 |
#' group_var = choices_selected( |
|
41 |
#' selected = c("SEX", "REGION1", "RACE"), |
|
42 |
#' choices = c("SEX", "REGION1", "RACE") |
|
43 |
#' ), |
|
44 |
#' plot_height = c(600, 200, 2000) |
|
45 |
#' ) |
|
46 |
#' ) |
|
47 |
#' ) |
|
48 |
#' if (interactive()) { |
|
49 |
#' shinyApp(app$ui, app$server) |
|
50 |
#' } |
|
51 |
#' |
|
52 |
tm_g_ae_sub <- function(label, |
|
53 |
dataname, |
|
54 |
arm_var, |
|
55 |
group_var, |
|
56 |
plot_height = c(600L, 200L, 2000L), |
|
57 |
plot_width = NULL, |
|
58 |
fontsize = c(5, 3, 7)) { |
|
59 | ! |
message("Initializing tm_g_ae_sub") |
60 | ! |
checkmate::assert_class(arm_var, classes = "choices_selected") |
61 | ! |
checkmate::assert_class(group_var, classes = "choices_selected") |
62 | ! |
checkmate::assert( |
63 | ! |
checkmate::check_number(fontsize, finite = TRUE), |
64 | ! |
checkmate::assert( |
65 | ! |
combine = "and", |
66 | ! |
.var.name = "fontsize", |
67 | ! |
checkmate::check_numeric(fontsize, len = 3, any.missing = FALSE, finite = TRUE), |
68 | ! |
checkmate::check_numeric(fontsize[1], lower = fontsize[2], upper = fontsize[3]) |
69 |
) |
|
70 |
) |
|
71 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
72 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
73 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
74 | ! |
checkmate::assert_numeric( |
75 | ! |
plot_width[1], |
76 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
77 |
) |
|
78 | ||
79 | ! |
module( |
80 | ! |
label = label, |
81 | ! |
server = srv_g_ae_sub, |
82 | ! |
server_args = list( |
83 | ! |
label = label, |
84 | ! |
dataname = dataname, |
85 | ! |
plot_height = plot_height, |
86 | ! |
plot_width = plot_width |
87 |
), |
|
88 | ! |
ui = ui_g_ae_sub, |
89 | ! |
ui_args = list( |
90 | ! |
arm_var = arm_var, |
91 | ! |
group_var = group_var, |
92 | ! |
fontsize = fontsize |
93 |
), |
|
94 | ! |
datanames = c("ADSL", dataname) |
95 |
) |
|
96 |
} |
|
97 | ||
98 |
ui_g_ae_sub <- function(id, ...) { |
|
99 | ! |
ns <- NS(id) |
100 | ! |
args <- list(...) |
101 | ! |
teal.widgets::standard_layout( |
102 | ! |
output = teal.widgets::white_small_well( |
103 | ! |
plot_decorate_output(id = ns(NULL)) |
104 |
), |
|
105 | ! |
encoding = tags$div( |
106 |
### Reporter |
|
107 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
108 |
### |
|
109 | ! |
tags$label("Encodings", class = "text-primary"), |
110 | ! |
helpText("Analysis data:", tags$code("ADAE")), |
111 | ! |
teal.widgets::optionalSelectInput( |
112 | ! |
ns("arm_var"), |
113 | ! |
"Arm Variable", |
114 | ! |
choices = get_choices(args$arm_var$choices), |
115 | ! |
selected = args$arm_var$selected |
116 |
), |
|
117 | ! |
selectInput( |
118 | ! |
ns("arm_trt"), |
119 | ! |
"Treatment", |
120 | ! |
choices = get_choices(args$arm_var$choices), |
121 | ! |
selected = args$arm_var$selected |
122 |
), |
|
123 | ! |
selectInput( |
124 | ! |
ns("arm_ref"), |
125 | ! |
"Control", |
126 | ! |
choices = get_choices(args$arm_var$choices), |
127 | ! |
selected = args$arm_var$selected |
128 |
), |
|
129 | ! |
checkboxInput( |
130 | ! |
ns("arm_n"), |
131 | ! |
"Show N in each arm", |
132 | ! |
value = args$arm_n |
133 |
), |
|
134 | ! |
teal.widgets::optionalSelectInput( |
135 | ! |
ns("groups"), |
136 | ! |
"Group Variable", |
137 | ! |
choices = get_choices(args$group_var$choices), |
138 | ! |
selected = args$group_var$selected, |
139 | ! |
multiple = TRUE |
140 |
), |
|
141 | ! |
teal.widgets::panel_item( |
142 | ! |
"Change group labels", |
143 | ! |
uiOutput(ns("grouplabel_output")) |
144 |
), |
|
145 | ! |
teal.widgets::panel_item( |
146 | ! |
"Additional plot settings", |
147 | ! |
teal.widgets::optionalSelectInput( |
148 | ! |
ns("ci"), |
149 | ! |
"CI method", |
150 | ! |
choices = ci_choices, |
151 | ! |
selected = ci_choices[1] |
152 |
), |
|
153 | ! |
teal.widgets::optionalSliderInput( |
154 | ! |
ns("conf_level"), |
155 | ! |
"Significant Level", |
156 | ! |
min = 0.5, |
157 | ! |
max = 1, |
158 | ! |
value = 0.95 |
159 |
), |
|
160 | ! |
ui_g_decorate( |
161 | ! |
ns(NULL), |
162 | ! |
fontsize = args$fontsize, |
163 | ! |
titles = "AE Table with Subgroups", |
164 | ! |
footnotes = "" |
165 |
) |
|
166 |
) |
|
167 |
), |
|
168 | ! |
forms = tagList( |
169 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
170 |
) |
|
171 |
) |
|
172 |
} |
|
173 | ||
174 |
srv_g_ae_sub <- function(id, |
|
175 |
data, |
|
176 |
filter_panel_api, |
|
177 |
reporter, |
|
178 |
dataname, |
|
179 |
label, |
|
180 |
plot_height, |
|
181 |
plot_width) { |
|
182 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
183 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
184 | ! |
checkmate::assert_class(data, "reactive") |
185 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
186 | ||
187 | ! |
moduleServer(id, function(input, output, session) { |
188 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
189 | ! |
iv <- reactive({ |
190 | ! |
ANL <- data()[[dataname]] |
191 | ! |
ADSL <- data()[["ADSL"]] |
192 | ||
193 | ! |
iv <- shinyvalidate::InputValidator$new() |
194 | ! |
iv$add_rule("arm_var", shinyvalidate::sv_required( |
195 | ! |
message = "Arm Variable is required" |
196 |
)) |
|
197 | ! |
iv$add_rule("arm_var", ~ if (!is.factor(ANL[[.]])) { |
198 | ! |
"Arm Var must be a factor variable, contact developer" |
199 |
}) |
|
200 | ! |
rule_diff <- function(value, other) { |
201 | ! |
if (isTRUE(value == other)) "Control and Treatment must be different" |
202 |
} |
|
203 | ! |
iv$add_rule("arm_trt", rule_diff, other = input$arm_ref) |
204 | ! |
iv$add_rule("arm_ref", rule_diff, other = input$arm_trt) |
205 | ! |
iv$add_rule("groups", shinyvalidate::sv_in_set( |
206 | ! |
names(ANL), |
207 | ! |
message_fmt = sprintf("Groups must be a variable in %s", dataname) |
208 |
)) |
|
209 | ! |
iv$add_rule("groups", shinyvalidate::sv_in_set( |
210 | ! |
names(ADSL), |
211 | ! |
message_fmt = "Groups must be a variable in ADSL" |
212 |
)) |
|
213 | ! |
iv$enable() |
214 | ! |
iv |
215 |
}) |
|
216 | ||
217 | ! |
decorate_output <- srv_g_decorate( |
218 | ! |
id = NULL, |
219 | ! |
plt = plot_r, |
220 | ! |
plot_height = plot_height, |
221 | ! |
plot_width = plot_width |
222 |
) |
|
223 | ! |
font_size <- decorate_output$font_size |
224 | ! |
pws <- decorate_output$pws |
225 | ||
226 | ! |
observeEvent(input$arm_var, ignoreNULL = TRUE, { |
227 | ! |
arm_var <- input$arm_var |
228 | ! |
ANL <- data()[[dataname]] |
229 | ||
230 | ! |
anl_val <- ANL[[arm_var]] |
231 | ! |
choices <- levels(anl_val) |
232 | ||
233 | ! |
if (length(choices) == 1) { |
234 | ! |
ref_index <- 1 |
235 |
} else { |
|
236 | ! |
ref_index <- 2 |
237 |
} |
|
238 | ||
239 | ! |
updateSelectInput( |
240 | ! |
session, |
241 | ! |
"arm_trt", |
242 | ! |
selected = choices[1], |
243 | ! |
choices = choices |
244 |
) |
|
245 | ! |
updateSelectInput( |
246 | ! |
session, |
247 | ! |
"arm_ref", |
248 | ! |
selected = choices[ref_index], |
249 | ! |
choices = choices |
250 |
) |
|
251 |
}) |
|
252 | ||
253 | ! |
observeEvent(list(input$ci, input$conf_level, input$arm_trt, input$arm_ref), { |
254 | ! |
diff_ci_method <- input$ci |
255 | ! |
conf_level <- input$conf_level |
256 | ! |
trt <- input$arm_trt |
257 | ! |
ref <- input$arm_ref |
258 | ! |
updateTextAreaInput( |
259 | ! |
session, |
260 | ! |
"foot", |
261 | ! |
value = sprintf( |
262 | ! |
"Note: %d%% CI is calculated using %s\nTRT: %s; CONT: %s", |
263 | ! |
round(conf_level * 100), |
264 | ! |
name_ci(diff_ci_method), |
265 | ! |
trt, |
266 | ! |
ref |
267 |
) |
|
268 |
) |
|
269 |
}) |
|
270 | ||
271 | ! |
observeEvent(input$groups, { |
272 | ! |
ANL <- data()[[dataname]] |
273 | ! |
output$grouplabel_output <- renderUI({ |
274 | ! |
grps <- input$groups |
275 | ! |
lo <- lapply(seq_along(grps), function(index) { |
276 | ! |
grp <- grps[index] |
277 | ! |
choices <- levels(ANL[[grp]]) |
278 | ! |
sel <- teal.widgets::optionalSelectInput( |
279 | ! |
session$ns(sprintf("groups__%s", index)), |
280 | ! |
grp, |
281 | ! |
choices, |
282 | ! |
multiple = TRUE, |
283 | ! |
selected = choices |
284 |
) |
|
285 | ! |
textname <- sprintf("text_%s_out", index) |
286 | ! |
txt <- uiOutput(session$ns(textname)) |
287 | ! |
observeEvent( |
288 | ! |
eventExpr = input[[sprintf("groups__%s", index)]], |
289 | ! |
handlerExpr = { |
290 | ! |
output[[textname]] <- renderUI({ |
291 | ! |
if (!is.null(input[[sprintf("groups__%s", index)]])) { |
292 | ! |
l <- input[[sprintf("groups__%s", index)]] |
293 | ! |
l2 <- lapply(seq_along(l), function(i) { |
294 | ! |
nm <- sprintf("groups__%s__level__%s", index, i) |
295 | ! |
label <- sprintf("Label for %s, Level %s", grp, l[i]) |
296 | ! |
textInput(session$ns(nm), label, l[i]) |
297 |
}) |
|
298 | ! |
tagList(textInput( |
299 | ! |
session$ns( |
300 | ! |
sprintf("groups__%s__level__%s", index, "all") |
301 |
), |
|
302 | ! |
sprintf("Label for %s", grp), grp |
303 | ! |
), l2) |
304 |
} |
|
305 |
}) |
|
306 |
} |
|
307 |
) |
|
308 | ! |
tagList(sel, txt) |
309 |
}) |
|
310 | ! |
ret <- tagList(lo) |
311 | ! |
ret |
312 |
}) |
|
313 |
}) |
|
314 | ||
315 | ! |
output_q <- shiny::debounce( |
316 | ! |
millis = 200, |
317 | ! |
r = reactive({ |
318 | ! |
ANL <- data()[[dataname]] |
319 | ! |
ADSL <- data()[["ADSL"]] |
320 | ||
321 | ! |
teal::validate_has_data(ANL, min_nrow = 10, msg = sprintf("%s has not enough data", dataname)) |
322 | ||
323 | ! |
teal::validate_inputs(iv()) |
324 | ||
325 | ! |
validate(need( |
326 | ! |
input$arm_trt %in% ANL[[input$arm_var]] && input$arm_ref %in% ANL[[input$arm_var]], |
327 | ! |
"Treatment or Control not found in Arm Variable. Perhaps they have been filtered out?" |
328 |
)) |
|
329 | ||
330 | ! |
group_labels <- lapply(seq_along(input$groups), function(x) { |
331 | ! |
items <- input[[sprintf("groups__%s", x)]] |
332 | ! |
if (length(items) > 0) { |
333 | ! |
l <- lapply(seq_along(items), function(y) { |
334 | ! |
input[[sprintf("groups__%s__level__%s", x, y)]] |
335 |
}) |
|
336 | ! |
names(l) <- items |
337 | ! |
l[["Total"]] <- input[[sprintf("groups__%s__level__%s", x, "all")]] |
338 | ! |
l |
339 |
} |
|
340 |
}) |
|
341 | ||
342 | ! |
group_labels_call <- if (length(unlist(group_labels)) == 0) { |
343 | ! |
quote(group_labels <- NULL) |
344 |
} else { |
|
345 | ! |
bquote(group_labels <- setNames(.(group_labels), .(input$groups))) |
346 |
} |
|
347 | ||
348 | ! |
teal.code::eval_code(data(), code = group_labels_call) %>% |
349 | ! |
teal.code::eval_code(code = "") %>% |
350 | ! |
teal.code::eval_code( |
351 | ! |
code = as.expression(c( |
352 | ! |
bquote( |
353 | ! |
plot <- osprey::g_ae_sub( |
354 | ! |
id = .(as.name(dataname))$USUBJID, |
355 | ! |
arm = as.factor(.(as.name(dataname))[[.(input$arm_var)]]), |
356 | ! |
arm_sl = as.character(ADSL[[.(input$arm_var)]]), |
357 | ! |
trt = .(input$arm_trt), |
358 | ! |
ref = .(input$arm_ref), |
359 | ! |
subgroups = .(as.name(dataname))[.(input$groups)], |
360 | ! |
subgroups_sl = ADSL[.(input$groups)], |
361 | ! |
subgroups_levels = group_labels, |
362 | ! |
conf_level = .(input$conf_level), |
363 | ! |
diff_ci_method = .(input$ci), |
364 | ! |
fontsize = .(font_size()), |
365 | ! |
arm_n = .(input$arm_n), |
366 | ! |
draw = TRUE |
367 |
) |
|
368 |
), |
|
369 | ! |
quote(plot) |
370 |
)) |
|
371 |
) |
|
372 |
}) |
|
373 |
) |
|
374 | ||
375 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
376 | ||
377 | ! |
teal.widgets::verbatim_popup_srv( |
378 | ! |
id = "rcode", |
379 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())), |
380 | ! |
title = paste("R code for", label), |
381 |
) |
|
382 | ||
383 |
### REPORTER |
|
384 | ! |
if (with_reporter) { |
385 | ! |
card_fun <- function(comment, label) { |
386 | ! |
card <- teal::report_card_template( |
387 | ! |
title = "AE Subgroups", |
388 | ! |
label = label, |
389 | ! |
with_filter = with_filter, |
390 | ! |
filter_panel_api = filter_panel_api |
391 |
) |
|
392 | ! |
card$append_text("Plot", "header3") |
393 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
394 | ! |
if (!comment == "") { |
395 | ! |
card$append_text("Comment", "header3") |
396 | ! |
card$append_text(comment) |
397 |
} |
|
398 | ! |
card$append_src(teal.code::get_code(output_q())) |
399 | ! |
card |
400 |
} |
|
401 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
402 |
} |
|
403 |
}) |
|
404 |
} |
1 |
#' Helper UI function to decorate plot output UI |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' This is used in [tm_g_ae_oview()] and [tm_g_events_term_id()]. |
|
7 |
#' |
|
8 |
#' @param id (`character`) id of this module. set to `NULL` if you want to make it identical |
|
9 |
#' to the module who called it. |
|
10 |
#' @param titles (`character`) default titles |
|
11 |
#' @param footnotes (`character`) default footnotes |
|
12 |
#' @inheritParams argument_convention |
|
13 |
#' @export |
|
14 |
ui_g_decorate <- function(id, |
|
15 |
titles = "Titles", |
|
16 |
footnotes = "footnotes", |
|
17 |
fontsize = c(5, 4, 11)) { |
|
18 | ! |
ns <- NS(id) |
19 | ! |
tagList( |
20 | ! |
teal.widgets::optionalSliderInputValMinMax( |
21 | ! |
ns("fontsize"), |
22 | ! |
"Font Size", |
23 | ! |
value_min_max = fontsize, |
24 | ! |
step = 0.1 |
25 |
), |
|
26 | ! |
textInput(ns("title"), "Title", value = titles), |
27 | ! |
textAreaInput(ns("foot"), "Footnote", value = footnotes, resize = "none") |
28 |
) |
|
29 |
} |
|
30 | ||
31 |
#' Helper server function to decorate plot output |
|
32 |
#' |
|
33 |
#' @description |
|
34 |
#' `r lifecycle::badge("stable")` |
|
35 |
#' |
|
36 |
#' This is used in [tm_g_ae_oview()] and [tm_g_events_term_id()]. |
|
37 |
#' |
|
38 |
#' @inheritParams shared_params |
|
39 |
#' @param id (`character`) id of the module |
|
40 |
#' @param plot_id (`character`) id for plot output |
|
41 |
#' @param plt (`reactive`) a reactive object of graph object |
|
42 |
#' |
|
43 |
#' @export |
|
44 |
srv_g_decorate <- function(id, |
|
45 |
plot_id = "out", |
|
46 |
plt = reactive(NULL), |
|
47 |
plot_height, |
|
48 |
plot_width) { |
|
49 | ! |
moduleServer(id, function(input, output, session) { |
50 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
51 | ! |
plot_g <- reactive({ |
52 | ! |
g <- tern::decorate_grob( |
53 | ! |
plt(), |
54 | ! |
titles = input$title, |
55 | ! |
footnotes = input$foot, |
56 | ! |
gp_titles = grid::gpar( |
57 | ! |
fontsize = input$fontsize * ggplot2::.pt, |
58 | ! |
col = "black", |
59 | ! |
fontface = "bold" |
60 |
), |
|
61 | ! |
gp_footnotes = grid::gpar(fontsize = input$fontsize * ggplot2::.pt, col = "black") |
62 |
) |
|
63 |
}) |
|
64 | ||
65 | ! |
plot_r <- function() { |
66 | ! |
grid::grid.newpage() |
67 | ! |
grid::grid.draw(plot_g()) |
68 | ! |
plot_g() |
69 |
} |
|
70 | ||
71 | ! |
class(plot_r) <- c(class(plot_r), "reactive") |
72 | ||
73 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
74 | ! |
id = plot_id, |
75 | ! |
plot_r = plot_r, |
76 | ! |
height = plot_height, |
77 | ! |
width = plot_width |
78 |
) |
|
79 | ||
80 | ! |
return( |
81 | ! |
list( |
82 | ! |
font_size = reactive(input$fontsize), |
83 | ! |
pws = pws |
84 |
) |
|
85 |
) |
|
86 |
}) |
|
87 |
} |
|
88 | ||
89 |
#' Helper function to plot decorated output UI |
|
90 |
#' |
|
91 |
#' @description |
|
92 |
#' `r lifecycle::badge("stable")` |
|
93 |
#' |
|
94 |
#' @param id (`character`) id of this element |
|
95 |
#' |
|
96 |
#' @export |
|
97 |
plot_decorate_output <- function(id) { |
|
98 | ! |
ns <- NS(id) |
99 | ! |
teal.widgets::plot_with_settings_ui(id = ns("out")) |
100 |
} |
1 |
#' Butterfly plot Teal Module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display butterfly plot as a shiny module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param filter_var (`choices_selected`) variable name of data filter, please see details regarding |
|
11 |
#' expected values, default is`NULL`.`choices` |
|
12 |
#' vector with `filter_var` choices, default is |
|
13 |
#' `NULL` |
|
14 |
#' @param right_var (`choices_selected`) dichotomization variable for right side |
|
15 |
#' @param left_var (`choices_selected`) dichotomization variable for left side |
|
16 |
#' @param category_var (`choices_selected`) category (y axis) variable |
|
17 |
#' @param color_by_var (`choices_selected`) variable defines color blocks within each bar |
|
18 |
#' @param count_by_var (`choices_selected`) variable defines how x axis is calculated |
|
19 |
#' @param facet_var (`choices_selected`) variable for row facets |
|
20 |
#' @param sort_by_var (`choices_selected`) argument for order of class and term elements in table, |
|
21 |
#' default here is "count" |
|
22 |
#' @param legend_on (`boolean`) value for whether legend is displayed |
|
23 |
#' |
|
24 |
#' @details `filter_var` option is designed to work in conjunction with |
|
25 |
#' filtering function provided by `teal` (encoding panel on the right |
|
26 |
#' hand side of the shiny app). It can be used as quick access to predefined |
|
27 |
#' subsets of the domain datasets (not subject-level dataset) to be used for |
|
28 |
#' analysis, denoted by an value of "Y". Each variable within the |
|
29 |
#' `filter_var_choices` is expected to contain values of either "Y" or |
|
30 |
#' "N". If multiple variables are selected as `filter_var`, only |
|
31 |
#' observations with "Y" value in each and every selected variables will be |
|
32 |
#' used for subsequent analysis. Flag variables (from `ADaM` datasets) can be |
|
33 |
#' used directly as filter. |
|
34 |
#' |
|
35 |
#' @inherit argument_convention return |
|
36 |
#' |
|
37 |
#' @export |
|
38 |
#' |
|
39 |
#' @template author_zhanc107 |
|
40 |
#' @template author_liaoc10 |
|
41 |
#' |
|
42 |
#' @examples |
|
43 |
#' # Example using stream (ADaM) dataset |
|
44 |
#' data <- cdisc_data() |> |
|
45 |
#' within({ |
|
46 |
#' library(dplyr) |
|
47 |
#' library(nestcolor) |
|
48 |
#' set.seed(23) |
|
49 |
#' ADSL <- rADSL |
|
50 |
#' ADAE <- rADAE |
|
51 |
#' ADSL <- mutate(ADSL, DOSE = paste(sample(1:3, n(), replace = TRUE), "UG")) |
|
52 |
#' ADAE <- mutate( |
|
53 |
#' ADAE, |
|
54 |
#' flag1 = ifelse(AETOXGR == 1, 1, 0), |
|
55 |
#' flag2 = ifelse(AETOXGR == 2, 1, 0), |
|
56 |
#' flag3 = ifelse(AETOXGR == 3, 1, 0), |
|
57 |
#' flag1_filt = rep("Y", n()) |
|
58 |
#' ) |
|
59 |
#' }) |
|
60 |
#' |
|
61 |
#' datanames(data) <- c("ADSL", "ADAE") |
|
62 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
63 |
#' |
|
64 |
#' app <- init( |
|
65 |
#' data = data, |
|
66 |
#' modules = modules( |
|
67 |
#' tm_g_butterfly( |
|
68 |
#' label = "Butterfly Plot", |
|
69 |
#' dataname = "ADAE", |
|
70 |
#' right_var = choices_selected( |
|
71 |
#' selected = "SEX", |
|
72 |
#' choices = c("SEX", "ARM", "RACE") |
|
73 |
#' ), |
|
74 |
#' left_var = choices_selected( |
|
75 |
#' selected = "RACE", |
|
76 |
#' choices = c("SEX", "ARM", "RACE") |
|
77 |
#' ), |
|
78 |
#' category_var = choices_selected( |
|
79 |
#' selected = "AEBODSYS", |
|
80 |
#' choices = c("AEDECOD", "AEBODSYS") |
|
81 |
#' ), |
|
82 |
#' color_by_var = choices_selected( |
|
83 |
#' selected = "AETOXGR", |
|
84 |
#' choices = c("AETOXGR", "None") |
|
85 |
#' ), |
|
86 |
#' count_by_var = choices_selected( |
|
87 |
#' selected = "# of patients", |
|
88 |
#' choices = c("# of patients", "# of AEs") |
|
89 |
#' ), |
|
90 |
#' facet_var = choices_selected( |
|
91 |
#' selected = NULL, |
|
92 |
#' choices = c("RACE", "SEX", "ARM") |
|
93 |
#' ), |
|
94 |
#' sort_by_var = choices_selected( |
|
95 |
#' selected = "count", |
|
96 |
#' choices = c("count", "alphabetical") |
|
97 |
#' ), |
|
98 |
#' legend_on = TRUE, |
|
99 |
#' plot_height = c(600, 200, 2000) |
|
100 |
#' ) |
|
101 |
#' ) |
|
102 |
#' ) |
|
103 |
#' if (interactive()) { |
|
104 |
#' shinyApp(app$ui, app$server) |
|
105 |
#' } |
|
106 |
#' |
|
107 |
tm_g_butterfly <- function(label, |
|
108 |
dataname, |
|
109 |
filter_var = NULL, |
|
110 |
right_var, |
|
111 |
left_var, |
|
112 |
category_var, |
|
113 |
color_by_var, |
|
114 |
count_by_var, |
|
115 |
facet_var = NULL, |
|
116 |
sort_by_var = teal.transform::choices_selected( |
|
117 |
selected = "count", choices = c("count", "alphabetical") |
|
118 |
), |
|
119 |
legend_on = TRUE, |
|
120 |
plot_height = c(600L, 200L, 2000L), |
|
121 |
plot_width = NULL, |
|
122 |
pre_output = NULL, |
|
123 |
post_output = NULL) { |
|
124 | ! |
message("Initializing tm_g_butterfly") |
125 | ! |
checkmate::assert_string(label) |
126 | ! |
checkmate::assert_string(dataname) |
127 | ! |
checkmate::assert_class(filter_var, classes = "choices_selected", null.ok = TRUE) |
128 | ! |
checkmate::assert_class(right_var, classes = "choices_selected") |
129 | ! |
checkmate::assert_class(left_var, classes = "choices_selected") |
130 | ! |
checkmate::assert_class(category_var, classes = "choices_selected") |
131 | ! |
checkmate::assert_class(color_by_var, classes = "choices_selected") |
132 | ! |
checkmate::assert_class(count_by_var, classes = "choices_selected") |
133 | ! |
checkmate::assert_class(facet_var, classes = "choices_selected", null.ok = TRUE) |
134 | ! |
checkmate::assert_class(sort_by_var, classes = "choices_selected") |
135 | ! |
checkmate::assert_flag(legend_on) |
136 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
137 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
138 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
139 | ! |
checkmate::assert_numeric( |
140 | ! |
plot_width[1], |
141 | ! |
lower = plot_width[2], |
142 | ! |
upper = plot_width[3], |
143 | ! |
null.ok = TRUE, |
144 | ! |
.var.name = "plot_width" |
145 |
) |
|
146 | ||
147 | ! |
args <- as.list(environment()) |
148 | ||
149 | ! |
module( |
150 | ! |
label = label, |
151 | ! |
datanames = c("ADSL", dataname), |
152 | ! |
server = srv_g_butterfly, |
153 | ! |
server_args = list(dataname = dataname, label = label, plot_height = plot_height, plot_width = plot_width), |
154 | ! |
ui = ui_g_butterfly, |
155 | ! |
ui_args = args |
156 |
) |
|
157 |
} |
|
158 | ||
159 |
ui_g_butterfly <- function(id, ...) { |
|
160 | ! |
ns <- NS(id) |
161 | ! |
a <- list(...) |
162 | ||
163 | ! |
teal.widgets::standard_layout( |
164 | ! |
output = teal.widgets::white_small_well( |
165 | ! |
teal.widgets::plot_with_settings_ui(id = ns("butterflyplot")) |
166 |
), |
|
167 | ! |
encoding = tags$div( |
168 |
### Reporter |
|
169 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
170 |
### |
|
171 | ! |
tags$label("Encodings", class = "text-primary"), |
172 | ! |
helpText("Dataset is:", tags$code(a$dataname)), |
173 | ! |
if (!is.null(a$filter_var)) { |
174 | ! |
teal.widgets::optionalSelectInput( |
175 | ! |
ns("filter_var"), |
176 | ! |
label = |
177 | ! |
"Preset Data Filters Observations with value of 'Y' for selected variable(s) will be used for analysis", |
178 | ! |
choices = get_choices(a$filter_var$choices), |
179 | ! |
selected = a$filter_var$selected, |
180 | ! |
multiple = TRUE |
181 |
) |
|
182 |
}, |
|
183 | ! |
teal.widgets::optionalSelectInput( |
184 | ! |
ns("right_var"), |
185 | ! |
"Right Dichotomization Variable", |
186 | ! |
get_choices(a$right_var$choices), |
187 | ! |
a$right_var$selected, |
188 | ! |
multiple = FALSE |
189 |
), |
|
190 | ! |
teal.widgets::optionalSelectInput( |
191 | ! |
ns("right_val"), |
192 | ! |
"Choose Up To 2:", |
193 | ! |
multiple = TRUE, |
194 | ! |
options = list( |
195 | ! |
`max-options` = 2L, |
196 | ! |
`max-options-text` = "no more than 2", |
197 | ! |
`actions-box` = FALSE |
198 |
) |
|
199 |
), |
|
200 | ! |
teal.widgets::optionalSelectInput( |
201 | ! |
ns("left_var"), |
202 | ! |
"Left Dichotomization Variable", |
203 | ! |
get_choices(a$left_var$choices), |
204 | ! |
a$left_var$selected, |
205 | ! |
multiple = FALSE |
206 |
), |
|
207 | ! |
teal.widgets::optionalSelectInput( |
208 | ! |
ns("left_val"), |
209 | ! |
"Choose Up To 2:", |
210 | ! |
multiple = TRUE, |
211 | ! |
options = list( |
212 | ! |
`max-options` = 2L, |
213 | ! |
`max-options-text` = "no more than 2", |
214 | ! |
`actions-box` = FALSE |
215 |
) |
|
216 |
), |
|
217 | ! |
teal.widgets::optionalSelectInput( |
218 | ! |
ns("category_var"), |
219 | ! |
"Category Variable", |
220 | ! |
get_choices(a$category_var$choices), |
221 | ! |
a$category_var$selected, |
222 | ! |
multiple = FALSE |
223 |
), |
|
224 | ! |
radioButtons( |
225 | ! |
ns("color_by_var"), |
226 | ! |
"Color Block By Variable", |
227 | ! |
get_choices(a$color_by_var$choices), |
228 | ! |
a$color_by_var$selected |
229 |
), |
|
230 | ! |
radioButtons( |
231 | ! |
ns("count_by_var"), |
232 | ! |
"Count By Variable", |
233 | ! |
get_choices(a$count_by_var$choices), |
234 | ! |
a$count_by_var$selected |
235 |
), |
|
236 | ! |
if (!is.null(a$facet_var)) { |
237 | ! |
teal.widgets::optionalSelectInput( |
238 | ! |
ns("facet_var"), |
239 | ! |
"Facet By Variable", |
240 | ! |
get_choices(a$facet_var$choices), |
241 | ! |
a$facet_var$selected, |
242 | ! |
multiple = TRUE |
243 |
) |
|
244 |
}, |
|
245 | ! |
radioButtons( |
246 | ! |
ns("sort_by_var"), |
247 | ! |
"Sort By Variable", |
248 | ! |
get_choices(a$sort_by_var$choices), |
249 | ! |
a$sort_by_var$selected |
250 |
), |
|
251 | ! |
checkboxInput( |
252 | ! |
ns("legend_on"), |
253 | ! |
"Add legend", |
254 | ! |
value = a$legend_on |
255 |
) |
|
256 |
), |
|
257 | ! |
forms = tagList( |
258 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
259 |
), |
|
260 | ! |
pre_output = a$pre_output, |
261 | ! |
post_output = a$post_output |
262 |
) |
|
263 |
} |
|
264 | ||
265 |
srv_g_butterfly <- function(id, data, filter_panel_api, reporter, dataname, label, plot_height, plot_width) { |
|
266 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
267 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
268 | ! |
checkmate::assert_class(data, "reactive") |
269 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
270 | ||
271 | ! |
moduleServer(id, function(input, output, session) { |
272 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
273 | ! |
iv <- reactive({ |
274 | ! |
ADSL <- data()[["ADSL"]] |
275 | ! |
ANL <- data()[[dataname]] |
276 | ||
277 | ! |
iv <- shinyvalidate::InputValidator$new() |
278 | ! |
iv$add_rule("category_var", shinyvalidate::sv_required( |
279 | ! |
message = "Category Variable is required" |
280 |
)) |
|
281 | ! |
iv$add_rule("right_var", shinyvalidate::sv_required( |
282 | ! |
message = "Right Dichotomization Variable is required" |
283 |
)) |
|
284 | ! |
iv$add_rule("left_var", shinyvalidate::sv_required( |
285 | ! |
message = "Left Dichotomization Variable is required" |
286 |
)) |
|
287 | ! |
iv$add_rule("right_var", ~ if (!is.factor(ANL[[.]])) { |
288 | ! |
"Right Dichotomization Variable must be a factor variable, contact developer" |
289 |
}) |
|
290 | ! |
iv$add_rule("left_var", ~ if (!is.factor(ANL[[.]])) { |
291 | ! |
"Left Dichotomization Variable must be a factor variable, contact developer" |
292 |
}) |
|
293 | ! |
iv$add_rule("right_val", shinyvalidate::sv_required( |
294 | ! |
message = "At least one value of Right Dichotomization Variable must be selected" |
295 |
)) |
|
296 | ! |
iv$add_rule("left_val", shinyvalidate::sv_required( |
297 | ! |
message = "At least one value of Left Dichotomization Variable must be selected" |
298 |
)) |
|
299 | ! |
iv$enable() |
300 | ! |
iv |
301 |
}) |
|
302 | ||
303 | ! |
options <- reactiveValues(r = NULL, l = NULL) |
304 | ! |
vars <- reactiveValues(r = NULL, l = NULL) |
305 | ||
306 |
# dynamic options for dichotomization variable |
|
307 | ! |
observeEvent(input$right_var, |
308 | ! |
handlerExpr = { |
309 | ! |
right_var <- input$right_var |
310 | ! |
right_val <- isolate(input$right_val) |
311 | ! |
current_r_var <- isolate(vars$r) |
312 | ! |
if (is.null(right_var)) { |
313 | ! |
teal.widgets::updateOptionalSelectInput( |
314 | ! |
session, |
315 | ! |
"right_val", |
316 | ! |
choices = character(0), |
317 | ! |
selected = character(0) |
318 |
) |
|
319 |
} else { |
|
320 | ! |
options$r <- if (right_var %in% names(data()[["ADSL"]])) { |
321 | ! |
levels(data()[["ADSL"]][[right_var]]) |
322 |
} else { |
|
323 | ! |
levels(data()[[dataname]][[right_var]]) |
324 |
} |
|
325 | ||
326 | ! |
selected <- if (length(right_val) > 0) { |
327 | ! |
left_over <- right_val[right_val %in% options$r] |
328 | ! |
if (length(left_over) > 0 && !is.null(current_r_var) && current_r_var == right_var) { |
329 | ! |
left_over |
330 |
} else { |
|
331 | ! |
options$r[1] |
332 |
} |
|
333 |
} else { |
|
334 | ! |
options$r[1] |
335 |
} |
|
336 | ! |
teal.widgets::updateOptionalSelectInput( |
337 | ! |
session, "right_val", |
338 | ! |
choices = as.character(options$r), selected = selected, label = "Choose Up To 2:" |
339 |
) |
|
340 |
} |
|
341 | ! |
vars$r <- right_var |
342 |
}, |
|
343 | ! |
ignoreNULL = FALSE |
344 |
) |
|
345 | ||
346 | ! |
observeEvent(input$left_var, |
347 | ! |
handlerExpr = { |
348 | ! |
left_var <- input$left_var |
349 | ! |
left_val <- isolate(input$left_val) |
350 | ! |
current_l_var <- isolate(vars$l) |
351 | ! |
if (is.null(left_var)) { |
352 | ! |
teal.widgets::updateOptionalSelectInput( |
353 | ! |
session, "left_val", |
354 | ! |
choices = character(0), selected = character(0) |
355 |
) |
|
356 |
} else { |
|
357 | ! |
options$l <- if (left_var %in% names(data()[["ADSL"]])) { |
358 | ! |
levels(data()[["ADSL"]][[left_var]]) |
359 |
} else { |
|
360 | ! |
levels(data()[[dataname]][[left_var]]) |
361 |
} |
|
362 | ||
363 | ! |
selected <- if (length(left_val) > 0) { |
364 | ! |
left_over <- left_val[left_val %in% options$l] |
365 | ! |
if (length(left_over) > 0 && !is.null(current_l_var) && current_l_var == left_var) { |
366 | ! |
left_over |
367 |
} else { |
|
368 | ! |
options$l[1] |
369 |
} |
|
370 |
} else { |
|
371 | ! |
options$l[1] |
372 |
} |
|
373 | ||
374 | ! |
teal.widgets::updateOptionalSelectInput( |
375 | ! |
session, "left_val", |
376 | ! |
choices = as.character(options$l), selected = selected, label = "Choose Up To 2:" |
377 |
) |
|
378 |
} |
|
379 | ! |
vars$l <- left_var |
380 |
}, |
|
381 | ! |
ignoreNULL = FALSE |
382 |
) |
|
383 | ||
384 | ! |
output_q <- shiny::debounce( |
385 | ! |
millis = 200, |
386 | ! |
r = reactive({ |
387 | ! |
ADSL <- data()[["ADSL"]] |
388 | ! |
ANL <- data()[[dataname]] |
389 | ||
390 | ! |
teal::validate_has_data(ADSL, min_nrow = 0, msg = sprintf("%s Data is empty", "ADSL")) |
391 | ! |
teal::validate_has_data(ANL, min_nrow = 0, msg = sprintf("%s Data is empty", dataname)) |
392 | ||
393 | ! |
teal::validate_inputs(iv()) |
394 | ||
395 | ! |
validate( |
396 | ! |
need( |
397 | ! |
all(input$right_val %in% ADSL[[input$right_var]]) && |
398 | ! |
all(input$left_val %in% ADSL[[input$left_var]]), |
399 | ! |
"No observations for selected dichotomization values (filtered out?)" |
400 |
) |
|
401 |
) |
|
402 | ||
403 | ! |
right_var <- isolate(input$right_var) |
404 | ! |
left_var <- isolate(input$left_var) |
405 | ! |
right_val <- input$right_val |
406 | ! |
left_val <- input$left_val |
407 | ! |
category_var <- input$category_var |
408 | ! |
color_by_var <- input$color_by_var |
409 | ! |
count_by_var <- input$count_by_var |
410 | ! |
legend_on <- input$legend_on |
411 | ! |
facet_var <- input$facet_var |
412 | ! |
sort_by_var <- input$sort_by_var |
413 | ! |
filter_var <- input$filter_var |
414 | ||
415 |
# if variable is not in ADSL, then take from domain VADs |
|
416 | ! |
varlist <- c(category_var, color_by_var, facet_var, filter_var, right_var, left_var) |
417 | ! |
varlist_from_adsl <- intersect(varlist, names(ADSL)) |
418 | ! |
varlist_from_anl <- intersect(varlist, setdiff(names(ANL), names(ADSL))) |
419 | ||
420 | ! |
adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) |
421 | ! |
anl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_anl)) |
422 | ||
423 | ! |
q1 <- teal.code::eval_code( |
424 | ! |
data(), |
425 | ! |
code = bquote({ |
426 | ! |
ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() |
427 | ! |
ANL <- .(as.name(dataname))[, .(anl_vars)] %>% as.data.frame() |
428 |
}) |
|
429 |
) |
|
430 | ||
431 | ! |
if (!("NULL" %in% filter_var) && !is.null(filter_var)) { |
432 | ! |
q1 <- teal.code::eval_code( |
433 | ! |
q1, |
434 | ! |
code = bquote( |
435 | ! |
ANL <- quick_filter(.(filter_var), ANL) %>% |
436 | ! |
droplevels() %>% |
437 | ! |
as.data.frame() |
438 |
) |
|
439 |
) |
|
440 |
} |
|
441 | ||
442 | ! |
q1 <- teal.code::eval_code( |
443 | ! |
q1, |
444 | ! |
code = bquote({ |
445 | ! |
ANL_f <- left_join(ADSL, ANL, by = c("USUBJID", "STUDYID")) %>% as.data.frame() |
446 | ! |
ANL_f <- na.omit(ANL_f) |
447 |
}) |
|
448 |
) |
|
449 | ||
450 | ! |
if (!is.null(right_val) && !is.null(right_val)) { |
451 | ! |
q1 <- teal.code::eval_code( |
452 | ! |
q1, |
453 | ! |
code = bquote({ |
454 | ! |
right <- ANL_f[, .(right_var)] %in% .(right_val) |
455 | ! |
right_name <- paste(.(right_val), collapse = " - ") |
456 | ! |
left <- ANL_f[, .(left_var)] %in% .(left_val) |
457 | ! |
left_name <- paste(.(left_val), collapse = " - ") |
458 |
}) |
|
459 |
) |
|
460 |
} |
|
461 | ||
462 | ! |
if (!is.null(right_val) && !is.null(left_val)) { |
463 | ! |
q1 <- teal.code::eval_code( |
464 | ! |
q1, |
465 | ! |
code = bquote( |
466 | ! |
plot <- osprey::g_butterfly( |
467 | ! |
category = ANL_f[, .(category_var)], |
468 | ! |
right_flag = right, |
469 | ! |
left_flag = left, |
470 | ! |
group_names = c(right_name, left_name), |
471 | ! |
block_count = .(count_by_var), |
472 | ! |
block_color = .(if (color_by_var != "None") { |
473 | ! |
bquote(ANL_f[, .(color_by_var)]) |
474 |
} else { |
|
475 | ! |
NULL |
476 |
}), |
|
477 | ! |
id = ANL_f$USUBJID, |
478 | ! |
facet_rows = .(if (!is.null(facet_var)) { |
479 | ! |
bquote(ANL_f[, .(facet_var)]) |
480 |
} else { |
|
481 | ! |
NULL |
482 |
}), |
|
483 | ! |
x_label = .(count_by_var), |
484 | ! |
y_label = .(category_var), |
485 | ! |
legend_label = .(color_by_var), |
486 | ! |
sort_by = .(sort_by_var), |
487 | ! |
show_legend = .(legend_on) |
488 |
) |
|
489 |
) |
|
490 |
) |
|
491 |
} |
|
492 | ||
493 | ! |
teal.code::eval_code(q1, quote(plot)) |
494 |
}) |
|
495 |
) |
|
496 | ||
497 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
498 | ||
499 |
# Insert the plot into a plot_with_settings module from teal.widgets |
|
500 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
501 | ! |
id = "butterflyplot", |
502 | ! |
plot_r = plot_r, |
503 | ! |
height = plot_height, |
504 | ! |
width = plot_width |
505 |
) |
|
506 | ||
507 | ! |
teal.widgets::verbatim_popup_srv( |
508 | ! |
id = "rcode", |
509 | ! |
title = paste("R code for", label), |
510 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
511 |
) |
|
512 | ||
513 |
### REPORTER |
|
514 | ! |
if (with_reporter) { |
515 | ! |
card_fun <- function(comment, label) { |
516 | ! |
card <- teal::report_card_template( |
517 | ! |
title = "Butterfly Plot", |
518 | ! |
label = label, |
519 | ! |
with_filter = with_filter, |
520 | ! |
filter_panel_api = filter_panel_api |
521 |
) |
|
522 | ! |
if (!is.null(input$filter_var) || !is.null(input$facet_var) || !is.null(input$sort_by_var)) { |
523 | ! |
card$append_text("Selected Options", "header3") |
524 |
} |
|
525 | ! |
if (!is.null(input$filter_var)) { |
526 | ! |
card$append_text(paste0("Preset Data Filters: ", paste(input$filter_var, collapse = ", "), ".")) |
527 |
} |
|
528 | ! |
if (!is.null(input$facet_var)) { |
529 | ! |
card$append_text(paste0("Faceted by: ", paste(input$facet_var, collapse = ", "), ".")) |
530 |
} |
|
531 | ! |
if (!is.null(input$sort_by_var)) { |
532 | ! |
card$append_text(paste0("Sorted by: ", paste(input$sort_by_var, collapse = ", "), ".")) |
533 |
} |
|
534 | ! |
card$append_text("Plot", "header3") |
535 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
536 | ! |
if (!comment == "") { |
537 | ! |
card$append_text("Comment", "header3") |
538 | ! |
card$append_text(comment) |
539 |
} |
|
540 | ! |
card$append_src(teal.code::get_code(output_q())) |
541 | ! |
card |
542 |
} |
|
543 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
544 |
} |
|
545 |
}) |
|
546 |
} |
1 |
#' Spider plot Teal Module |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("stable")` |
|
5 |
#' |
|
6 |
#' Display spider plot as a shiny module |
|
7 |
#' |
|
8 |
#' @inheritParams teal.widgets::standard_layout |
|
9 |
#' @inheritParams argument_convention |
|
10 |
#' @param x_var x-axis variables |
|
11 |
#' @param y_var y-axis variables |
|
12 |
#' @param marker_var variable dictates marker symbol |
|
13 |
#' @param line_colorby_var variable dictates line color |
|
14 |
#' @param vref_line vertical reference lines |
|
15 |
#' @param href_line horizontal reference lines |
|
16 |
#' @param anno_txt_var annotation text |
|
17 |
#' @param legend_on boolean value for whether legend is displayed |
|
18 |
#' @param xfacet_var variable for x facets |
|
19 |
#' @param yfacet_var variable for y facets |
|
20 |
#' |
|
21 |
#' @inherit argument_convention return |
|
22 |
#' @export |
|
23 |
#' |
|
24 |
#' @template author_zhanc107 |
|
25 |
#' @template author_liaoc10 |
|
26 |
#' |
|
27 |
#' @examples |
|
28 |
#' # Example using stream (ADaM) dataset |
|
29 |
#' data <- cdisc_data() |> |
|
30 |
#' within({ |
|
31 |
#' library(nestcolor) |
|
32 |
#' ADSL <- rADSL |
|
33 |
#' ADTR <- rADTR |
|
34 |
#' }) |
|
35 |
#' |
|
36 |
#' datanames(data) <- c("ADSL", "ADTR") |
|
37 |
#' join_keys(data) <- default_cdisc_join_keys[datanames(data)] |
|
38 |
#' |
|
39 |
#' app <- init( |
|
40 |
#' data = data, |
|
41 |
#' modules = modules( |
|
42 |
#' tm_g_spiderplot( |
|
43 |
#' label = "Spider plot", |
|
44 |
#' dataname = "ADTR", |
|
45 |
#' paramcd = choices_selected( |
|
46 |
#' choices = "SLDINV", |
|
47 |
#' selected = "SLDINV" |
|
48 |
#' ), |
|
49 |
#' x_var = choices_selected( |
|
50 |
#' choices = "ADY", |
|
51 |
#' selected = "ADY" |
|
52 |
#' ), |
|
53 |
#' y_var = choices_selected( |
|
54 |
#' choices = c("PCHG", "CHG", "AVAL"), |
|
55 |
#' selected = "PCHG" |
|
56 |
#' ), |
|
57 |
#' marker_var = choices_selected( |
|
58 |
#' choices = c("SEX", "RACE", "USUBJID"), |
|
59 |
#' selected = "SEX" |
|
60 |
#' ), |
|
61 |
#' line_colorby_var = choices_selected( |
|
62 |
#' choices = c("SEX", "USUBJID", "RACE"), |
|
63 |
#' selected = "SEX" |
|
64 |
#' ), |
|
65 |
#' xfacet_var = choices_selected( |
|
66 |
#' choices = c("SEX", "ARM"), |
|
67 |
#' selected = "SEX" |
|
68 |
#' ), |
|
69 |
#' yfacet_var = choices_selected( |
|
70 |
#' choices = c("SEX", "ARM"), |
|
71 |
#' selected = "ARM" |
|
72 |
#' ), |
|
73 |
#' vref_line = "10, 37", |
|
74 |
#' href_line = "-20, 0" |
|
75 |
#' ) |
|
76 |
#' ) |
|
77 |
#' ) |
|
78 |
#' if (interactive()) { |
|
79 |
#' shinyApp(app$ui, app$server) |
|
80 |
#' } |
|
81 |
#' |
|
82 |
tm_g_spiderplot <- function(label, |
|
83 |
dataname, |
|
84 |
paramcd, |
|
85 |
x_var, |
|
86 |
y_var, |
|
87 |
marker_var, |
|
88 |
line_colorby_var, |
|
89 |
xfacet_var = NULL, |
|
90 |
yfacet_var = NULL, |
|
91 |
vref_line = NULL, |
|
92 |
href_line = NULL, |
|
93 |
anno_txt_var = TRUE, |
|
94 |
legend_on = FALSE, |
|
95 |
plot_height = c(600L, 200L, 2000L), |
|
96 |
plot_width = NULL, |
|
97 |
pre_output = NULL, |
|
98 |
post_output = NULL) { |
|
99 | ! |
message("Initializing tm_g_spiderplot") |
100 | ! |
checkmate::assert_class(paramcd, classes = "choices_selected") |
101 | ! |
checkmate::assert_class(x_var, classes = "choices_selected") |
102 | ! |
checkmate::assert_class(y_var, classes = "choices_selected") |
103 | ! |
checkmate::assert_class(marker_var, classes = "choices_selected") |
104 | ! |
checkmate::assert_class(line_colorby_var, classes = "choices_selected") |
105 | ! |
checkmate::assert_class(xfacet_var, classes = "choices_selected") |
106 | ! |
checkmate::assert_class(yfacet_var, classes = "choices_selected") |
107 | ! |
checkmate::assert_string(vref_line) |
108 | ! |
checkmate::assert_string(href_line) |
109 | ! |
checkmate::assert_flag(anno_txt_var) |
110 | ! |
checkmate::assert_flag(legend_on) |
111 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
112 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
113 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
114 | ! |
checkmate::assert_numeric( |
115 | ! |
plot_width[1], |
116 | ! |
lower = plot_width[2], |
117 | ! |
upper = plot_width[3], |
118 | ! |
null.ok = TRUE, |
119 | ! |
.var.name = "plot_width" |
120 |
) |
|
121 | ||
122 | ! |
args <- as.list(environment()) |
123 | ! |
module( |
124 | ! |
label = label, |
125 | ! |
datanames = c("ADSL", dataname), |
126 | ! |
server = srv_g_spider, |
127 | ! |
server_args = list( |
128 | ! |
dataname = dataname, |
129 | ! |
paramcd = paramcd, |
130 | ! |
label = label, |
131 | ! |
plot_height = plot_height, |
132 | ! |
plot_width = plot_width |
133 |
), |
|
134 | ! |
ui = ui_g_spider, |
135 | ! |
ui_args = args |
136 |
) |
|
137 |
} |
|
138 | ||
139 |
ui_g_spider <- function(id, ...) { |
|
140 | ! |
ns <- NS(id) |
141 | ! |
a <- list(...) |
142 | ! |
shiny::tagList( |
143 | ! |
include_css_files("custom"), |
144 | ! |
teal.widgets::standard_layout( |
145 | ! |
output = teal.widgets::white_small_well( |
146 | ! |
teal.widgets::plot_with_settings_ui(id = ns("spiderplot")) |
147 |
), |
|
148 | ! |
encoding = tags$div( |
149 |
### Reporter |
|
150 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
151 |
### |
|
152 | ! |
tags$label("Encodings", class = "text-primary"), |
153 | ! |
helpText("Analysis data:", tags$code(a$dataname)), |
154 | ! |
tags$div( |
155 | ! |
class = "pretty-left-border", |
156 | ! |
teal.widgets::optionalSelectInput( |
157 | ! |
ns("paramcd"), |
158 | ! |
paste("Parameter - from", a$dataname), |
159 | ! |
multiple = FALSE |
160 |
), |
|
161 | ! |
teal.widgets::optionalSelectInput( |
162 | ! |
ns("x_var"), |
163 | ! |
"X-axis Variable", |
164 | ! |
get_choices(a$x_var$choices), |
165 | ! |
a$x_var$selected, |
166 | ! |
multiple = FALSE |
167 |
), |
|
168 | ! |
teal.widgets::optionalSelectInput( |
169 | ! |
ns("y_var"), |
170 | ! |
"Y-axis Variable", |
171 | ! |
get_choices(a$y_var$choices), |
172 | ! |
a$y_var$selected, |
173 | ! |
multiple = FALSE |
174 |
), |
|
175 | ! |
teal.widgets::optionalSelectInput( |
176 | ! |
ns("line_colorby_var"), |
177 | ! |
"Color By Variable (Line)", |
178 | ! |
get_choices(a$line_colorby_var$choices), |
179 | ! |
a$line_colorby_var$selected, |
180 | ! |
multiple = FALSE |
181 |
), |
|
182 | ! |
teal.widgets::optionalSelectInput( |
183 | ! |
ns("marker_var"), |
184 | ! |
"Marker Symbol By Variable", |
185 | ! |
get_choices(a$marker_var$choices), |
186 | ! |
a$marker_var$selected, |
187 | ! |
multiple = FALSE |
188 |
), |
|
189 | ! |
teal.widgets::optionalSelectInput( |
190 | ! |
ns("xfacet_var"), |
191 | ! |
"X-facet By Variable", |
192 | ! |
get_choices(a$xfacet_var$choices), |
193 | ! |
a$xfacet_var$selected, |
194 | ! |
multiple = TRUE |
195 |
), |
|
196 | ! |
teal.widgets::optionalSelectInput( |
197 | ! |
ns("yfacet_var"), |
198 | ! |
"Y-facet By Variable", |
199 | ! |
get_choices(a$yfacet_var$choices), |
200 | ! |
a$yfacet_var$selected, |
201 | ! |
multiple = TRUE |
202 |
) |
|
203 |
), |
|
204 | ! |
checkboxInput( |
205 | ! |
ns("anno_txt_var"), |
206 | ! |
"Add subject ID label", |
207 | ! |
value = a$anno_txt_var |
208 |
), |
|
209 | ! |
checkboxInput( |
210 | ! |
ns("legend_on"), |
211 | ! |
"Add legend", |
212 | ! |
value = a$legend_on |
213 |
), |
|
214 | ! |
textInput( |
215 | ! |
ns("vref_line"), |
216 | ! |
label = tags$div( |
217 | ! |
"Vertical Reference Line(s)", |
218 | ! |
tags$br(), |
219 | ! |
helpText("Enter numeric value(s) of vertical reference lines, separated by comma (eg. -2, 1)") |
220 |
), |
|
221 | ! |
value = a$vref_line |
222 |
), |
|
223 | ! |
textInput( |
224 | ! |
ns("href_line"), |
225 | ! |
label = tags$div( |
226 | ! |
"Hortizontal Reference Line(s)", |
227 | ! |
tags$br(), |
228 | ! |
helpText("Enter numeric value(s) of horizontal reference lines, separated by comma (eg. -2, 1)") |
229 |
), |
|
230 | ! |
value = a$href_line |
231 |
) |
|
232 |
), |
|
233 | ! |
forms = tagList( |
234 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
235 |
), |
|
236 | ! |
pre_output = a$pre_output, |
237 | ! |
post_output = a$post_output |
238 |
) |
|
239 |
) |
|
240 |
} |
|
241 | ||
242 |
srv_g_spider <- function(id, data, filter_panel_api, paramcd, reporter, dataname, label, plot_height, plot_width) { |
|
243 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
244 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
245 | ! |
checkmate::assert_class(data, "reactive") |
246 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
247 | ||
248 | ! |
moduleServer(id, function(input, output, session) { |
249 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.osprey") |
250 | ||
251 | ! |
env <- as.list(isolate(data())@env) |
252 | ! |
resolved_paramcd <- teal.transform::resolve_delayed(paramcd, env) |
253 | ||
254 | ! |
teal.widgets::updateOptionalSelectInput( |
255 | ! |
session = session, |
256 | ! |
inputId = "paramcd", |
257 | ! |
choices = resolved_paramcd$choices, |
258 | ! |
selected = resolved_paramcd$selected |
259 |
) |
|
260 | ||
261 | ! |
iv <- reactive({ |
262 | ! |
ADSL <- data()[["ADSL"]] |
263 | ! |
ADTR <- data()[[dataname]] |
264 | ||
265 | ! |
iv <- shinyvalidate::InputValidator$new() |
266 | ! |
iv$add_rule("paramcd", shinyvalidate::sv_required( |
267 | ! |
message = "Parameter is required" |
268 |
)) |
|
269 | ! |
iv$add_rule("x_var", shinyvalidate::sv_required( |
270 | ! |
message = "X Axis Variable is required" |
271 |
)) |
|
272 | ! |
iv$add_rule("y_var", shinyvalidate::sv_required( |
273 | ! |
message = "Y Axis Variable is required" |
274 |
)) |
|
275 | ! |
iv$add_rule("line_colorby_var", shinyvalidate::sv_required( |
276 | ! |
message = "Color Variable is required" |
277 |
)) |
|
278 | ! |
iv$add_rule("marker_var", shinyvalidate::sv_required( |
279 | ! |
message = "Marker Symbol Variable is required" |
280 |
)) |
|
281 | ! |
fac_dupl <- function(value, other) { |
282 | ! |
if (length(value) * length(other) > 0L && anyDuplicated(c(value, other))) { |
283 | ! |
"X- and Y-facet Variables must not overlap" |
284 |
} |
|
285 |
} |
|
286 | ! |
iv$add_rule("xfacet_var", fac_dupl, other = input$yfacet_var) |
287 | ! |
iv$add_rule("yfacet_var", fac_dupl, other = input$xfacet_var) |
288 | ! |
iv$add_rule("vref_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { |
289 | ! |
"Vertical Reference Line(s) are invalid" |
290 |
}) |
|
291 | ! |
iv$add_rule("href_line", ~ if (anyNA(suppressWarnings(as_numeric_from_comma_sep_str(.)))) { |
292 | ! |
"Horizontal Reference Line(s) are invalid" |
293 |
}) |
|
294 | ! |
iv$enable() |
295 |
}) |
|
296 | ||
297 | ! |
vals <- reactiveValues(spiderplot = NULL) |
298 | ||
299 |
# render plot |
|
300 | ! |
output_q <- reactive({ |
301 |
# get datasets --- |
|
302 | ! |
ADSL <- data()[["ADSL"]] |
303 | ! |
ADTR <- data()[[dataname]] |
304 | ||
305 | ! |
teal::validate_inputs(iv()) |
306 | ||
307 | ! |
teal::validate_has_data(ADSL, min_nrow = 1, msg = sprintf("%s data has zero rows", "ADSL")) |
308 | ! |
teal::validate_has_data(ADTR, min_nrow = 1, msg = sprintf("%s data has zero rows", dataname)) |
309 | ||
310 | ! |
paramcd <- input$paramcd |
311 | ! |
x_var <- input$x_var |
312 | ! |
y_var <- input$y_var |
313 | ! |
marker_var <- input$marker_var |
314 | ! |
line_colorby_var <- input$line_colorby_var |
315 | ! |
anno_txt_var <- input$anno_txt_var |
316 | ! |
legend_on <- input$legend_on |
317 | ! |
xfacet_var <- input$xfacet_var |
318 | ! |
yfacet_var <- input$yfacet_var |
319 | ! |
vref_line <- input$vref_line |
320 | ! |
href_line <- input$href_line |
321 | ||
322 |
# reference lines preprocessing |
|
323 | ! |
vref_line <- as_numeric_from_comma_sep_str(vref_line) |
324 | ! |
href_line <- as_numeric_from_comma_sep_str(href_line) |
325 | ||
326 |
# define variables --- |
|
327 |
# if variable is not in ADSL, then take from domain VADs |
|
328 | ! |
varlist <- c(xfacet_var, yfacet_var, marker_var, line_colorby_var) |
329 | ! |
varlist_from_adsl <- varlist[varlist %in% names(ADSL)] |
330 | ! |
varlist_from_anl <- varlist[!varlist %in% names(ADSL)] |
331 | ||
332 | ! |
adsl_vars <- unique(c("USUBJID", "STUDYID", varlist_from_adsl)) |
333 | ! |
adtr_vars <- unique(c("USUBJID", "STUDYID", "PARAMCD", x_var, y_var, varlist_from_anl)) |
334 | ||
335 |
# preprocessing of datasets to qenv --- |
|
336 | ||
337 |
# vars definition |
|
338 | ! |
adtr_vars <- adtr_vars[adtr_vars != "None"] |
339 | ! |
adtr_vars <- adtr_vars[!is.null(adtr_vars)] |
340 | ||
341 |
# merge |
|
342 | ! |
q1 <- teal.code::eval_code( |
343 | ! |
data(), |
344 | ! |
code = bquote({ |
345 | ! |
ADSL <- ADSL[, .(adsl_vars)] %>% as.data.frame() |
346 | ! |
ADTR <- .(as.name(dataname))[, .(adtr_vars)] %>% as.data.frame() |
347 | ||
348 | ! |
ANL <- merge(ADSL, ADTR, by = c("USUBJID", "STUDYID")) |
349 | ! |
ANL <- ANL %>% |
350 | ! |
group_by(USUBJID, PARAMCD) %>% |
351 | ! |
arrange(ANL[, .(x_var)]) %>% |
352 | ! |
as.data.frame() |
353 |
}) |
|
354 |
) |
|
355 | ||
356 |
# format and filter |
|
357 | ! |
q1 <- teal.code::eval_code( |
358 | ! |
q1, |
359 | ! |
code = bquote({ |
360 | ! |
ANL$USUBJID <- unlist(lapply(strsplit(ANL$USUBJID, "-", fixed = TRUE), tail, 1)) |
361 | ! |
ANL_f <- ANL %>% |
362 | ! |
filter(PARAMCD == .(paramcd)) %>% |
363 | ! |
as.data.frame() |
364 |
}) |
|
365 |
) |
|
366 | ||
367 |
# label |
|
368 | ! |
q1 <- if (anno_txt_var) { |
369 | ! |
teal.code::eval_code( |
370 | ! |
q1, |
371 | ! |
code = quote(lbl <- list(txt_ann = as.factor(ANL_f$USUBJID))) |
372 |
) |
|
373 |
} else { |
|
374 | ! |
teal.code::eval_code(q1, code = quote(lbl <- NULL)) |
375 |
} |
|
376 | ||
377 |
# plot code to qenv --- |
|
378 | ||
379 | ! |
q1 <- teal.code::eval_code( |
380 | ! |
q1, |
381 | ! |
code = bquote({ |
382 | ! |
plot <- osprey::g_spiderplot( |
383 | ! |
marker_x = ANL_f[, .(x_var)], |
384 | ! |
marker_id = ANL_f$USUBJID, |
385 | ! |
marker_y = ANL_f[, .(y_var)], |
386 | ! |
line_colby = .(if (line_colorby_var != "None") { |
387 | ! |
bquote(ANL_f[, .(line_colorby_var)]) |
388 |
} else { |
|
389 | ! |
NULL |
390 |
}), |
|
391 | ! |
marker_shape = .(if (marker_var != "None") { |
392 | ! |
bquote(ANL_f[, .(marker_var)]) |
393 |
} else { |
|
394 | ! |
NULL |
395 |
}), |
|
396 | ! |
marker_size = 4, |
397 | ! |
datalabel_txt = lbl, |
398 | ! |
facet_rows = .(if (!is.null(yfacet_var)) { |
399 | ! |
bquote(data.frame(ANL_f[, .(yfacet_var)])) |
400 |
} else { |
|
401 | ! |
NULL |
402 |
}), |
|
403 | ! |
facet_columns = .(if (!is.null(xfacet_var)) { |
404 | ! |
bquote(data.frame(ANL_f[, .(xfacet_var)])) |
405 |
} else { |
|
406 | ! |
NULL |
407 |
}), |
|
408 | ! |
vref_line = .(vref_line), |
409 | ! |
href_line = .(href_line), |
410 | ! |
x_label = if (is.null(formatters::var_labels(ADTR[.(x_var)], fill = FALSE))) { |
411 | ! |
.(x_var) |
412 |
} else { |
|
413 | ! |
formatters::var_labels(ADTR[.(x_var)], fill = FALSE) |
414 |
}, |
|
415 | ! |
y_label = if (is.null(formatters::var_labels(ADTR[.(y_var)], fill = FALSE))) { |
416 | ! |
.(y_var) |
417 |
} else { |
|
418 | ! |
formatters::var_labels(ADTR[.(y_var)], fill = FALSE) |
419 |
}, |
|
420 | ! |
show_legend = .(legend_on) |
421 |
) |
|
422 | ||
423 | ! |
plot |
424 |
}) |
|
425 |
) |
|
426 |
}) |
|
427 | ||
428 | ! |
plot_r <- reactive(output_q()[["plot"]]) |
429 | ||
430 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
431 | ! |
id = "spiderplot", |
432 | ! |
plot_r = plot_r, |
433 | ! |
height = plot_height, |
434 | ! |
width = plot_width |
435 |
) |
|
436 | ||
437 | ! |
teal.widgets::verbatim_popup_srv( |
438 | ! |
id = "rcode", |
439 | ! |
title = paste("R code for", label), |
440 | ! |
verbatim_content = reactive(teal.code::get_code(output_q())) |
441 |
) |
|
442 | ||
443 |
### REPORTER |
|
444 | ! |
if (with_reporter) { |
445 | ! |
card_fun <- function(comment, label) { |
446 | ! |
card <- teal::report_card_template( |
447 | ! |
title = "Spider Plot", |
448 | ! |
label = label, |
449 | ! |
with_filter = with_filter, |
450 | ! |
filter_panel_api = filter_panel_api |
451 |
) |
|
452 | ! |
if (!is.null(input$paramcd) || !is.null(input$xfacet_var) || !is.null(input$yfacet_var)) { |
453 | ! |
card$append_text("Selected Options", "header3") |
454 |
} |
|
455 | ! |
if (!is.null(input$paramcd)) { |
456 | ! |
card$append_text(paste0("Parameter - (from ", dataname, "): ", input$paramcd, ".")) |
457 |
} |
|
458 | ! |
if (!is.null(input$xfacet_var)) { |
459 | ! |
card$append_text(paste0("Faceted horizontally by: ", paste(input$xfacet_var, collapse = ", "), ".")) |
460 |
} |
|
461 | ! |
if (!is.null(input$yfacet_var)) { |
462 | ! |
card$append_text(paste0("Faceted vertically by: ", paste(input$yfacet_var, collapse = ", "), ".")) |
463 |
} |
|
464 | ! |
card$append_text("Plot", "header3") |
465 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
466 | ! |
if (!comment == "") { |
467 | ! |
card$append_text("Comment", "header3") |
468 | ! |
card$append_text(comment) |
469 |
} |
|
470 | ! |
card$append_src(teal.code::get_code(output_q())) |
471 | ! |
card |
472 |
} |
|
473 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
474 |
} |
|
475 |
}) |
|
476 |
} |
1 |
#' Shared Parameters |
|
2 |
#' |
|
3 |
#' @description Contains arguments that are shared between multiple functions |
|
4 |
#' in the package to avoid repetition using `inheritParams`. |
|
5 |
#' |
|
6 |
#' @param plot_height (`numeric`) optional vector of length three with `c(value, min, max)`. Specifies |
|
7 |
#' the height of the main plot. |
|
8 |
#' @param plot_width (`numeric`) optional vector of length three with `c(value, min, max)`. Specifies |
|
9 |
#' the width of the main plot and renders a slider on the plot to interactively adjust the plot width. |
|
10 |
#' @param label (`character`) module label in the teal app. Please note that this module is developed based on |
|
11 |
#' `ADaM` data structure and `ADaM` variables. |
|
12 |
#' |
|
13 |
#' @name shared_params |
|
14 |
#' @keywords internal |
|
15 |
#' |
|
16 |
NULL |
|
17 | ||
18 |
#' Utility function for quick filter |
|
19 |
#' `r lifecycle::badge("stable")` |
|
20 |
#' |
|
21 |
#' |
|
22 |
#' @param filter_opt vector of string names of flag variable to filter (keep Y rows only) |
|
23 |
#' @param ANL input dataset |
|
24 |
#' |
|
25 |
#' @return a filtered dataframe |
|
26 |
#' |
|
27 |
#' @export |
|
28 |
#' |
|
29 |
#' @template author_zhanc107 |
|
30 |
#' |
|
31 |
quick_filter <- function(filter_opt, ANL) { |
|
32 | ! |
for (i in seq_along(filter_opt)) { |
33 | ! |
ANL <- ANL[ANL[, filter_opt[i]] == "Y", ] |
34 |
} |
|
35 | ! |
return(ANL) |
36 |
} |
|
37 | ||
38 |
#' Automatically switch variable labels for standard `AE` variables in `AE` osprey functions |
|
39 |
#' `r lifecycle::badge("stable")` |
|
40 |
#' |
|
41 |
#' @param x variable key |
|
42 |
#' |
|
43 |
#' @export |
|
44 |
label_aevar <- function(x) { |
|
45 | ! |
lifecycle::deprecate_soft( |
46 | ! |
when = "0.1.15", |
47 | ! |
what = "label_aevar()", |
48 | ! |
details = "label_aevar is deprecated and will be unexported in the next release." |
49 |
) |
|
50 | ||
51 |
# Display full variable labels for standard AE variables |
|
52 | ! |
ae_varlabel <- c( |
53 | ! |
AEBODSYS = "MedDRA System Organ Class", |
54 | ! |
AESOC = "MedDRA Primary System Organ Class", |
55 | ! |
AEHLGT = "MedDRA High Level Group Term", |
56 | ! |
AEHLT = "MedDRA High Level Term", |
57 | ! |
AELLT = "MedDRA Lowest Level Term", |
58 | ! |
AEDECOD = "MedDRA Preferred Term", |
59 | ! |
AETERM = "Reported Adverse Event Term", |
60 | ! |
AEMODIFY = "Modified Reported Term", |
61 | ! |
AETOXGR = "NCI-CTCAE Grade", |
62 | ! |
AEITOXGR = "Initial Toxicity Grade" |
63 |
) |
|
64 | ||
65 | ! |
which_aevar <- match(x, names(ae_varlabel)) |
66 | ! |
out_label <- ifelse(is.na(which_aevar), x, ae_varlabel[which_aevar]) |
67 | ! |
return(out_label) |
68 |
} |
|
69 | ||
70 |
#' retrieve name of ci method |
|
71 |
#' @param x ci method to retrieve its name |
|
72 |
#' @keywords internal |
|
73 |
#' |
|
74 |
name_ci <- function(x) { |
|
75 |
names(ci_choices)[which(ci_choices == x)] |
|
76 |
} |
|
77 | ||
78 |
ci_choices <- setNames( |
|
79 |
c("wald", "waldcc", "ac", "scorecc", "score", "mn", "mee", "blj", "ha"), |
|
80 |
c( |
|
81 |
"Wald", "Corrected Wald", "Agresti-Caffo", "Newcombe", |
|
82 |
"Score", "Miettinen and Nurminen", "Mee", |
|
83 |
"Brown, Li's Jeffreys", "Hauck-Anderson" |
|
84 |
) |
|
85 |
) |
|
86 | ||
87 |
#' retrieve detailed name of ci method |
|
88 |
#' @param x ci method to retrieve its name |
|
89 |
name_ci <- function(x = ci_choices) { |
|
90 | ! |
x <- match.arg(x) |
91 | ! |
return(paste0(names(x), " (", x, ")")) |
92 |
} |
|
93 | ||
94 | ||
95 |
#' takes input_string, splits by "," and returns a numeric vector |
|
96 |
#' with NAs where the split-strings are not numeric. |
|
97 |
#' e.g. as_numeric_from_comma_separated_string("4 ,hello,5,, 3") |
|
98 |
#' is c(4, NA, 5, NA, 3). |
|
99 |
#' If input argument is NULL or just whitespace then NULL is returned |
|
100 |
#' @param input_string string to be split into numeric vector |
|
101 |
#' @keywords internal |
|
102 |
#' |
|
103 |
as_numeric_from_comma_sep_str <- function(input_string) { |
|
104 | 10x |
if (!is.null(input_string) && trimws(input_string) != "") { |
105 | 7x |
ref_line <- unlist(strsplit(trimws(input_string), ",")) |
106 | 7x |
ref_line <- as.numeric(ref_line) |
107 |
} else { |
|
108 | 3x |
ref_line <- NULL |
109 |
} |
|
110 | 10x |
return(ref_line) |
111 |
} |
|
112 | ||
113 |
#' Include `CSS` files from `/inst/css/` package directory to application header |
|
114 |
#' |
|
115 |
#' `system.file` should not be used to access files in other packages, it does |
|
116 |
#' not work with `devtools`. Therefore, we redefine this method in each package |
|
117 |
#' as needed. Thus, we do not export this method. |
|
118 |
#' |
|
119 |
#' @param pattern (`character`) pattern of files to be included |
|
120 |
#' |
|
121 |
#' @return HTML code that includes `CSS` files |
|
122 |
#' @keywords internal |
|
123 |
include_css_files <- function(pattern = "*") { |
|
124 | ! |
css_files <- list.files( |
125 | ! |
system.file("css", package = "teal.osprey", mustWork = TRUE), |
126 | ! |
pattern = pattern, full.names = TRUE |
127 |
) |
|
128 | ! |
if (length(css_files) == 0) { |
129 | ! |
return(NULL) |
130 |
} |
|
131 | ! |
return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))) |
132 |
} |
|
133 | ||
134 |
#' Get Choices |
|
135 |
#' |
|
136 |
#' This function returns choices based on the class of the input. |
|
137 |
#' If the input is of class `delayed_data`, it returns the `subset` of the input. |
|
138 |
#' If `subset` is NULL and the input contains `var_label` and `var_choices`, |
|
139 |
#' it throws an error prompting to resolve delayed inputs. |
|
140 |
#' Otherwise, it returns the input as is. |
|
141 |
#' |
|
142 |
#' @param choices An object that contains choices. |
|
143 |
#' @return A vector of choices. |
|
144 |
#' @keywords internal |
|
145 |
get_choices <- function(choices) { |
|
146 | ! |
if (inherits(choices, "delayed_data")) { |
147 | ! |
if (is.null(choices$subset)) { |
148 | ! |
if (!is.null(choices$var_label) && !is.null(choices$var_choices)) { |
149 | ! |
stop( |
150 | ! |
"Resolve delayed inputs by evaluating the code within the provided datasets. |
151 | ! |
Check ?teal.transform::resolve_delayed for more information." |
152 |
) |
|
153 |
} else { |
|
154 | ! |
stop("Subset is NULL and necessary fields are missing.") |
155 |
} |
|
156 |
} else { |
|
157 | ! |
choices$subset |
158 |
} |
|
159 |
} else { |
|
160 | ! |
choices |
161 |
} |
|
162 |
} |
1 |
.onLoad <- function(libname, pkgname) { |
|
2 | ! |
teal.logger::register_logger(namespace = "teal.osprey") |
3 | ! |
teal.logger::register_handlers("teal.osprey") |
4 |
} |