1 |
#' Scatter Plot Teal Module For Biomarker Analysis |
|
2 |
#' |
|
3 |
#' @description Scatter Plot Teal Module For Biomarker Analysis |
|
4 |
#' |
|
5 |
#' @inheritParams teal.widgets::standard_layout |
|
6 |
#' @param label menu item label of the module in the teal app. |
|
7 |
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured |
|
8 |
#' laboratory data frame \code{ADLB}. |
|
9 |
#' @param param_var name of variable containing biomarker codes e.g. \code{PARAMCD}. |
|
10 |
#' @param xaxis_param biomarker selected for `x-axis`. |
|
11 |
#' @param yaxis_param biomarker selected for `y-axis`. |
|
12 |
#' @param xaxis_var name of variable containing biomarker results displayed on x-axis e.g. \code{BASE}. |
|
13 |
#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. \code{AVAL}. |
|
14 |
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option |
|
15 |
#' for variable names representing treatment group e.g. `ARM`. |
|
16 |
#' @param color_manual vector of colors applied to treatment values. |
|
17 |
#' @param shape_manual vector of symbols applied to `LOQ` values. |
|
18 |
#' @param facet_ncol numeric value indicating number of facets per row. |
|
19 |
#' @param trt_facet facet by treatment group \code{trt_group}. |
|
20 |
#' @param visit_facet visit facet toggle. |
|
21 |
#' @param reg_line include regression line and annotations for slope and coefficient in visualization. Use with facet |
|
22 |
#' TRUE. |
|
23 |
#' @param loq_legend `loq` legend toggle. |
|
24 |
#' @param rotate_xlab 45 degree rotation of `x-axis` values. |
|
25 |
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines. |
|
26 |
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}. |
|
27 |
#' naming the color for the arbitrary horizontal lines. |
|
28 |
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}. |
|
29 |
#' naming the label for the arbitrary horizontal lines. |
|
30 |
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines. |
|
31 |
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines. |
|
32 |
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear |
|
33 |
#' @param vline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines. |
|
34 |
#' @param vline_arb_color a character vector of at most length of \code{vline_arb}. |
|
35 |
#' naming the color for the arbitrary horizontal lines. |
|
36 |
#' @param vline_arb_label a character vector of at most length of \code{vline_arb}. |
|
37 |
#' naming the label for the arbitrary horizontal lines. |
|
38 |
#' @param vline_vars a character vector to name the columns that will define additional vertical lines. |
|
39 |
#' @param vline_vars_colors a character vector naming the colors for the additional vertical lines. |
|
40 |
#' @param vline_vars_labels a character vector naming the labels for the additional vertical lines that will appear |
|
41 |
#' @param plot_height controls plot height. |
|
42 |
#' @param plot_width optional, controls plot width. |
|
43 |
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend. |
|
44 |
#' @param dot_size plot dot size. |
|
45 |
#' @param reg_text_size font size control for regression line annotations. |
|
46 |
#' |
|
47 |
#' @export |
|
48 |
#' |
|
49 |
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com |
|
50 |
#' @author Balazs Toth (tothb2) toth.balazs@gene.com |
|
51 |
#' |
|
52 |
#' @examples |
|
53 |
#' # Example using ADaM structure analysis dataset. |
|
54 |
#' data <- teal_data() |
|
55 |
#' data <- within(data, { |
|
56 |
#' library(dplyr) |
|
57 |
#' library(stringr) |
|
58 |
#' |
|
59 |
#' # use non-exported function from goshawk |
|
60 |
#' h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk") |
|
61 |
#' |
|
62 |
#' # original ARM value = dose value |
|
63 |
#' arm_mapping <- list( |
|
64 |
#' "A: Drug X" = "150mg QD", |
|
65 |
#' "B: Placebo" = "Placebo", |
|
66 |
#' "C: Combination" = "Combination" |
|
67 |
#' ) |
|
68 |
#' color_manual <- c("150mg QD" = "#000000", "Placebo" = "#3498DB", "Combination" = "#E74C3C") |
|
69 |
#' # assign LOQ flag symbols: circles for "N" and triangles for "Y", squares for "NA" |
|
70 |
#' shape_manual <- c("N" = 1, "Y" = 2, "NA" = 0) |
|
71 |
#' |
|
72 |
#' set.seed(1) |
|
73 |
#' ADSL <- rADSL |
|
74 |
#' ADLB <- rADLB |
|
75 |
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) |
|
76 |
#' ADLB <- ADLB %>% |
|
77 |
#' mutate(AVISITCD = case_when( |
|
78 |
#' AVISIT == "SCREENING" ~ "SCR", |
|
79 |
#' AVISIT == "BASELINE" ~ "BL", |
|
80 |
#' grepl("WEEK", AVISIT) ~ |
|
81 |
#' paste( |
|
82 |
#' "W", |
|
83 |
#' trimws( |
|
84 |
#' substr( |
|
85 |
#' AVISIT, |
|
86 |
#' start = 6, |
|
87 |
#' stop = str_locate(AVISIT, "DAY") - 1 |
|
88 |
#' ) |
|
89 |
#' ) |
|
90 |
#' ), |
|
91 |
#' TRUE ~ NA_character_ |
|
92 |
#' )) %>% |
|
93 |
#' mutate(AVISITCDN = case_when( |
|
94 |
#' AVISITCD == "SCR" ~ -2, |
|
95 |
#' AVISITCD == "BL" ~ 0, |
|
96 |
#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), |
|
97 |
#' TRUE ~ NA_real_ |
|
98 |
#' )) %>% |
|
99 |
#' # use ARMCD values to order treatment in visualization legend |
|
100 |
#' mutate(TRTORD = ifelse(grepl("C", ARMCD), 1, |
|
101 |
#' ifelse(grepl("B", ARMCD), 2, |
|
102 |
#' ifelse(grepl("A", ARMCD), 3, NA) |
|
103 |
#' ) |
|
104 |
#' )) %>% |
|
105 |
#' mutate(ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))])) %>% |
|
106 |
#' mutate(ARM = factor(ARM) %>% |
|
107 |
#' reorder(TRTORD)) %>% |
|
108 |
#' mutate( |
|
109 |
#' ANRHI = case_when( |
|
110 |
#' PARAMCD == "ALT" ~ 60, |
|
111 |
#' PARAMCD == "CRP" ~ 70, |
|
112 |
#' PARAMCD == "IGA" ~ 80, |
|
113 |
#' TRUE ~ NA_real_ |
|
114 |
#' ), |
|
115 |
#' ANRLO = case_when( |
|
116 |
#' PARAMCD == "ALT" ~ 20, |
|
117 |
#' PARAMCD == "CRP" ~ 30, |
|
118 |
#' PARAMCD == "IGA" ~ 40, |
|
119 |
#' TRUE ~ NA_real_ |
|
120 |
#' ) |
|
121 |
#' ) %>% |
|
122 |
#' rowwise() %>% |
|
123 |
#' group_by(PARAMCD) %>% |
|
124 |
#' mutate(LBSTRESC = ifelse( |
|
125 |
#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), |
|
126 |
#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC |
|
127 |
#' )) %>% |
|
128 |
#' mutate(LBSTRESC = ifelse( |
|
129 |
#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), |
|
130 |
#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC |
|
131 |
#' )) %>% |
|
132 |
#' ungroup() |
|
133 |
#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] |
|
134 |
#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" |
|
135 |
#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" |
|
136 |
#' |
|
137 |
#' # add LLOQ and ULOQ variables |
|
138 |
#' ADLB_LOQS <- h_identify_loq_values(ADLB, "LOQFL") |
|
139 |
#' ADLB <- left_join(ADLB, ADLB_LOQS, by = "PARAM") |
|
140 |
#' }) |
|
141 |
#' |
|
142 |
#' datanames <- c("ADSL", "ADLB") |
|
143 |
#' datanames(data) <- datanames |
|
144 |
#' |
|
145 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
146 |
#' |
|
147 |
#' app <- init( |
|
148 |
#' data = data, |
|
149 |
#' modules = modules( |
|
150 |
#' tm_g_gh_correlationplot( |
|
151 |
#' label = "Correlation Plot", |
|
152 |
#' dataname = "ADLB", |
|
153 |
#' param_var = "PARAMCD", |
|
154 |
#' xaxis_param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), |
|
155 |
#' yaxis_param = choices_selected(c("ALT", "CRP", "IGA"), "CRP"), |
|
156 |
#' xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "BASE"), |
|
157 |
#' yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"), |
|
158 |
#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
159 |
#' color_manual = c( |
|
160 |
#' "Drug X 100mg" = "#000000", |
|
161 |
#' "Placebo" = "#3498DB", |
|
162 |
#' "Combination 100mg" = "#E74C3C" |
|
163 |
#' ), |
|
164 |
#' shape_manual = c("N" = 1, "Y" = 2, "NA" = 0), |
|
165 |
#' plot_height = c(500, 200, 2000), |
|
166 |
#' facet_ncol = 2, |
|
167 |
#' visit_facet = TRUE, |
|
168 |
#' reg_line = FALSE, |
|
169 |
#' loq_legend = TRUE, |
|
170 |
#' font_size = c(12, 8, 20), |
|
171 |
#' dot_size = c(1, 1, 12), |
|
172 |
#' reg_text_size = c(3, 3, 10), |
|
173 |
#' hline_arb = c(40, 50), |
|
174 |
#' hline_arb_label = "arb hori label", |
|
175 |
#' hline_arb_color = c("red", "blue"), |
|
176 |
#' hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"), |
|
177 |
#' hline_vars_colors = c("green", "blue", "purple", "cyan"), |
|
178 |
#' hline_vars_labels = c("ANRHI Label", "ANRLO Label", "ULOQN Label", "LLOQN Label"), |
|
179 |
#' vline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"), |
|
180 |
#' vline_vars_colors = c("yellow", "orange", "brown", "gold"), |
|
181 |
#' vline_vars_labels = c("ANRHI Label", "ANRLO Label", "ULOQN Label", "LLOQN Label"), |
|
182 |
#' vline_arb = c(50, 70), |
|
183 |
#' vline_arb_label = "arb vert A", |
|
184 |
#' vline_arb_color = c("green", "orange") |
|
185 |
#' ) |
|
186 |
#' ) |
|
187 |
#' ) |
|
188 |
#' if (interactive()) { |
|
189 |
#' shinyApp(app$ui, app$server) |
|
190 |
#' } |
|
191 |
#' |
|
192 |
tm_g_gh_correlationplot <- function(label, |
|
193 |
dataname, |
|
194 |
param_var = "PARAMCD", |
|
195 |
xaxis_param = "ALT", |
|
196 |
xaxis_var = "BASE", |
|
197 |
yaxis_param = "CRP", |
|
198 |
yaxis_var = "AVAL", |
|
199 |
trt_group, |
|
200 |
color_manual = NULL, |
|
201 |
shape_manual = NULL, |
|
202 |
facet_ncol = 2, |
|
203 |
visit_facet = TRUE, |
|
204 |
trt_facet = FALSE, |
|
205 |
reg_line = FALSE, |
|
206 |
loq_legend = TRUE, |
|
207 |
rotate_xlab = FALSE, |
|
208 |
hline_arb = numeric(0), |
|
209 |
hline_arb_color = "red", |
|
210 |
hline_arb_label = "Horizontal line", |
|
211 |
hline_vars = character(0), |
|
212 |
hline_vars_colors = "green", |
|
213 |
hline_vars_labels = hline_vars, |
|
214 |
vline_arb = numeric(0), |
|
215 |
vline_arb_color = "red", |
|
216 |
vline_arb_label = "Vertical line", |
|
217 |
vline_vars = character(0), |
|
218 |
vline_vars_colors = "green", |
|
219 |
vline_vars_labels = vline_vars, |
|
220 |
plot_height = c(500, 200, 2000), |
|
221 |
plot_width = NULL, |
|
222 |
font_size = c(12, 8, 20), |
|
223 |
dot_size = c(1, 1, 12), |
|
224 |
reg_text_size = c(3, 3, 10), |
|
225 |
pre_output = NULL, |
|
226 |
post_output = NULL) { |
|
227 | ! |
message("Initializing tm_g_gh_correlationplot") |
228 | ! |
checkmate::assert_class(xaxis_param, "choices_selected") |
229 | ! |
checkmate::assert_class(yaxis_param, "choices_selected") |
230 | ! |
checkmate::assert_class(xaxis_var, "choices_selected") |
231 | ! |
checkmate::assert_class(yaxis_var, "choices_selected") |
232 | ! |
checkmate::assert_class(trt_group, "choices_selected") |
233 | ! |
checkmate::assert_flag(trt_facet) |
234 | ! |
validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label) |
235 | ! |
validate_line_arb_arg(vline_arb, vline_arb_color, vline_arb_label) |
236 | ! |
validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels) |
237 | ! |
validate_line_vars_arg(vline_vars, vline_vars_colors, vline_vars_labels) |
238 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
239 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
240 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
241 | ! |
checkmate::assert_numeric( |
242 | ! |
plot_width[1], |
243 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
244 |
) |
|
245 | ! |
checkmate::assert_numeric(font_size, len = 3) |
246 | ! |
checkmate::assert_numeric(dot_size, len = 3) |
247 | ! |
checkmate::assert_numeric(reg_text_size, len = 3) |
248 | ||
249 | ! |
args <- as.list(environment()) |
250 | ||
251 | ! |
module( |
252 | ! |
label = label, |
253 | ! |
datanames = dataname, |
254 | ! |
server = srv_g_correlationplot, |
255 | ! |
server_args = list( |
256 | ! |
dataname = dataname, |
257 | ! |
param_var = param_var, |
258 | ! |
trt_group = trt_group, |
259 | ! |
trt_facet = trt_facet, |
260 | ! |
color_manual = color_manual, |
261 | ! |
shape_manual = shape_manual, |
262 | ! |
plot_height = plot_height, |
263 | ! |
plot_width = plot_width, |
264 | ! |
hline_vars_colors = hline_vars_colors, |
265 | ! |
hline_vars_labels = hline_vars_labels, |
266 | ! |
vline_vars_colors = vline_vars_colors, |
267 | ! |
vline_vars_labels = vline_vars_labels, |
268 | ! |
module_args = args |
269 |
), |
|
270 | ! |
ui = ui_g_correlationplot, |
271 | ! |
ui_args = args |
272 |
) |
|
273 |
} |
|
274 | ||
275 |
ui_g_correlationplot <- function(id, ...) { |
|
276 | ! |
ns <- NS(id) |
277 | ! |
a <- list(...) |
278 | ||
279 | ! |
teal.widgets::standard_layout( |
280 | ! |
output = templ_ui_output_datatable(ns), |
281 | ! |
encoding = tags$div( |
282 |
### Reporter |
|
283 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
284 |
### |
|
285 | ! |
templ_ui_dataname(a$dataname), |
286 | ! |
teal.widgets::optionalSelectInput( |
287 | ! |
ns("trt_group"), |
288 | ! |
label = "Select Treatment Variable", |
289 | ! |
choices = get_choices(a$trt_group$choices), |
290 | ! |
selected = a$trt_group$selected, |
291 | ! |
multiple = FALSE |
292 |
), |
|
293 | ! |
uiOutput(ns("axis_selections")), |
294 | ! |
templ_ui_constraint(ns, "X-Axis Data Constraint"), # required by constr_anl_q |
295 | ! |
if (length(a$hline_vars) > 0) { |
296 | ! |
teal.widgets::optionalSelectInput( |
297 | ! |
ns("hline_vars"), |
298 | ! |
label = "Add Horizontal Range Line(s):", |
299 | ! |
choices = a$hline_vars, |
300 | ! |
selected = NULL, |
301 | ! |
multiple = TRUE |
302 |
) |
|
303 |
}, |
|
304 | ! |
ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color), |
305 | ! |
if (length(a$vline_vars) > 0) { |
306 | ! |
teal.widgets::optionalSelectInput( |
307 | ! |
ns("vline_vars"), |
308 | ! |
label = "Add Vertical Range Line(s):", |
309 | ! |
choices = a$vline_vars, |
310 | ! |
selected = NULL, |
311 | ! |
multiple = TRUE |
312 |
) |
|
313 |
}, |
|
314 | ! |
ui_arbitrary_lines( |
315 | ! |
id = ns("vline_arb"), |
316 | ! |
a$vline_arb, |
317 | ! |
a$vline_arb_label, |
318 | ! |
a$vline_arb_color, |
319 | ! |
title = "Arbitrary Vertical Lines:" |
320 |
), |
|
321 | ! |
teal.widgets::panel_group( |
322 | ! |
teal.widgets::panel_item( |
323 | ! |
title = "Plot Aesthetic Settings", |
324 | ! |
toggle_slider_ui( |
325 | ! |
ns("xrange_scale"), |
326 | ! |
label = "X-Axis Range Zoom", |
327 | ! |
min = -1000000, max = 1000000, value = c(-1000000, 1000000) |
328 |
), |
|
329 | ! |
toggle_slider_ui( |
330 | ! |
ns("yrange_scale"), |
331 | ! |
label = "Y-Axis Range Zoom", |
332 | ! |
min = -1000000, max = 1000000, value = c(-1000000, 1000000) |
333 |
), |
|
334 | ! |
numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), |
335 | ! |
checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet), |
336 | ! |
checkboxInput(ns("visit_facet"), "Visit Faceting", a$visit_facet), |
337 | ! |
checkboxInput(ns("reg_line"), "Regression Line", a$reg_line), |
338 | ! |
checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend), |
339 | ! |
checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab) |
340 |
), |
|
341 | ! |
teal.widgets::panel_item( |
342 | ! |
title = "Plot settings", |
343 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE), |
344 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE), |
345 | ! |
teal.widgets::optionalSliderInputValMinMax( |
346 | ! |
ns("reg_text_size"), |
347 | ! |
"Regression Annotations Size", |
348 | ! |
a$reg_text_size, |
349 | ! |
ticks = FALSE |
350 |
) |
|
351 |
) |
|
352 |
) |
|
353 |
), |
|
354 | ! |
forms = tagList( |
355 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
356 |
), |
|
357 | ! |
pre_output = a$pre_output, |
358 | ! |
post_output = a$post_output |
359 |
) |
|
360 |
} |
|
361 | ||
362 |
srv_g_correlationplot <- function(id, |
|
363 |
data, |
|
364 |
reporter, |
|
365 |
filter_panel_api, |
|
366 |
dataname, |
|
367 |
param_var, |
|
368 |
trt_group, |
|
369 |
trt_facet, |
|
370 |
color_manual, |
|
371 |
shape_manual, |
|
372 |
plot_height, |
|
373 |
plot_width, |
|
374 |
hline_vars_colors, |
|
375 |
hline_vars_labels, |
|
376 |
vline_vars_colors, |
|
377 |
vline_vars_labels, |
|
378 |
module_args) { |
|
379 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
380 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
381 | ! |
checkmate::assert_class(data, "reactive") |
382 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
383 | ||
384 | ! |
moduleServer(id, function(input, output, session) { |
385 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
386 | ! |
output$axis_selections <- renderUI({ |
387 | ! |
env <- shiny::isolate(as.list(data()@env)) |
388 | ! |
resolved_x_param <- teal.transform::resolve_delayed(module_args$xaxis_param, env) |
389 | ! |
resolved_x_var <- teal.transform::resolve_delayed(module_args$xaxis_var, env) |
390 | ! |
resolved_y_param <- teal.transform::resolve_delayed(module_args$yaxis_param, env) |
391 | ! |
resolved_y_var <- teal.transform::resolve_delayed(module_args$yaxis_var, env) |
392 | ! |
templ_ui_params_vars( |
393 | ! |
session$ns, |
394 | ! |
xparam_choices = resolved_x_param$choices, |
395 | ! |
xparam_selected = resolved_x_param$selected, |
396 | ! |
xchoices = resolved_x_var$choices, |
397 | ! |
xselected = resolved_x_var$selected, |
398 | ! |
yparam_choices = resolved_y_param$choices, |
399 | ! |
yparam_selected = resolved_y_param$selected, |
400 | ! |
ychoices = resolved_y_var$choices, |
401 | ! |
yselected = resolved_y_var$selected |
402 |
) |
|
403 |
}) |
|
404 | ||
405 | ! |
iv_r <- reactive({ |
406 | ! |
iv <- shinyvalidate::InputValidator$new() |
407 | ||
408 | ! |
iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select an X-Axis biomarker")) |
409 | ! |
iv$add_rule("yaxis_param", shinyvalidate::sv_required("Please select a Y-Axis biomarker")) |
410 | ! |
iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable")) |
411 | ! |
iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable")) |
412 | ! |
iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable")) |
413 | ! |
iv$add_rule("facet_ncol", plots_per_row_validate_rules()) |
414 | ||
415 | ! |
iv$add_validator(anl_constraint_output()$iv_r()) |
416 | ! |
iv$add_validator(horizontal_line()$iv_r()) |
417 | ! |
iv$add_validator(vertical_line()$iv_r()) |
418 | ! |
iv$enable() |
419 | ! |
iv |
420 |
}) |
|
421 | ||
422 | ||
423 | ||
424 |
# filter selected biomarkers |
|
425 | ! |
anl_param <- reactive({ |
426 | ! |
dataset_var <- dataname |
427 | ! |
ANL <- data()[[dataname]] # nolint |
428 | ! |
validate_has_data(ANL, 1) |
429 | ||
430 | ! |
if (length(input$hline_vars) > 0) { |
431 | ! |
validate( |
432 | ! |
need( |
433 | ! |
all(input$hline_vars %in% names(ANL)), |
434 | ! |
"One or more selected horizontal line variable(s) is/are not names to any column in the data" |
435 |
), |
|
436 | ! |
need( |
437 | ! |
all(input$vline_vars %in% names(ANL)), |
438 | ! |
"One or more selected vertical line variable(s) is/are not names to any column in the data" |
439 |
) |
|
440 |
) |
|
441 |
} |
|
442 | ||
443 | ! |
validate_has_variable(ANL, param_var) |
444 | ||
445 | ! |
validate_in( |
446 | ! |
input$xaxis_param, unique(ANL[[param_var]]), |
447 | ! |
sprintf("X-Axis Biomarker %s is not available in data %s", input$xaxis_param, dataname) |
448 |
) |
|
449 | ||
450 | ! |
validate_in( |
451 | ! |
input$yaxis_param, unique(ANL[[param_var]]), |
452 | ! |
sprintf("Y-Axis Biomarker %s is not available in data %s", input$yaxis_param, dataname) |
453 |
) |
|
454 | ||
455 | ! |
validate_has_variable( |
456 | ! |
ANL, |
457 | ! |
"AVISITCD", |
458 | ! |
sprintf("Variable AVISITCD is not available in data %s", dataname) |
459 |
) |
|
460 | ||
461 | ! |
validate_has_variable( |
462 | ! |
ANL, |
463 | ! |
"BASE", |
464 | ! |
sprintf("Variable BASE is not available in data %s", dataname) |
465 |
) |
|
466 | ||
467 | ! |
validate_has_variable( |
468 | ! |
ANL, |
469 | ! |
"BASE2", |
470 | ! |
sprintf("Variable BASE2 is not available in data %s", dataname) |
471 |
) |
|
472 | ||
473 | ! |
validate_has_variable( |
474 | ! |
ANL, |
475 | ! |
"LOQFL", |
476 | ! |
sprintf("Variable LOQFL is not available in data %s", dataname) |
477 |
) |
|
478 | ||
479 | ! |
validate_has_variable( |
480 | ! |
ANL, |
481 | ! |
"PARAM", |
482 | ! |
sprintf("Variable PARAM is not available in data %s", dataname) |
483 |
) |
|
484 | ||
485 | ! |
validate_has_variable( |
486 | ! |
ANL, |
487 | ! |
"LBSTRESC", |
488 | ! |
sprintf("Variable LBSTRESC is not available in data %s", dataname) |
489 |
) |
|
490 | ||
491 | ! |
validate_has_variable( |
492 | ! |
ANL, |
493 | ! |
input$trt_group, |
494 | ! |
sprintf("Variable %s is not available in data %s", input$trt_group, dataname) |
495 |
) |
|
496 | ||
497 | ! |
validate_has_variable( |
498 | ! |
ANL, |
499 | ! |
"USUBJID", |
500 | ! |
sprintf("Variable USUBJID is not available in data %s", dataname) |
501 |
) |
|
502 | ||
503 | ! |
validate_has_variable( |
504 | ! |
ANL, |
505 | ! |
input$xaxis_var, |
506 | ! |
sprintf("Variable %s is not available in data %s", input$xaxis_var, dataname) |
507 |
) |
|
508 | ||
509 | ! |
validate_has_variable( |
510 | ! |
ANL, |
511 | ! |
input$yaxis_var, |
512 | ! |
sprintf("Variable %s is not available in data %s", input$yaxis_var, dataname) |
513 |
) |
|
514 | ||
515 |
# analysis |
|
516 | ! |
private_qenv <- data() %>% |
517 | ! |
teal.code::eval_code( |
518 | ! |
code = bquote({ |
519 | ! |
ANL <- .(as.name(dataset_var)) %>% # nolint |
520 | ! |
dplyr::filter(.data[[.(param_var)]] %in% union(.(input$xaxis_param), .(input$yaxis_param))) %>% |
521 | ! |
dplyr::select( |
522 | ! |
.(c( |
523 | ! |
"USUBJID", input$trt_group, "AVISITCD", param_var, "PARAM", input$xaxis_var, input$yaxis_var, |
524 | ! |
"LOQFL", "LBSTRESC", unique(c(input$hline_vars, input$vline_vars)) |
525 |
)) |
|
526 |
) |
|
527 |
}) |
|
528 |
) |
|
529 | ! |
validate_has_data(private_qenv[["ANL"]], 1) |
530 | ! |
return(list(ANL = ANL, qenv = private_qenv)) |
531 |
}) |
|
532 | ||
533 |
# constraints |
|
534 | ! |
observe({ |
535 | ! |
req(input$xaxis_param) |
536 | ||
537 | ! |
constraint_var <- input$constraint_var |
538 | ! |
req(constraint_var) |
539 | ||
540 |
# note that filtered is false thus we cannot use anl_param()$ANL |
|
541 | ! |
ANL <- data()[[dataname]] # nolint |
542 | ! |
validate_has_data(ANL, 1) |
543 | ||
544 | ! |
validate_has_variable(ANL, param_var) |
545 | ! |
validate_has_variable(ANL, "AVISITCD") |
546 | ! |
validate_has_variable(ANL, "BASE") |
547 | ! |
validate_has_variable(ANL, "BASE2") |
548 | ||
549 | ! |
ANL <- ANL %>% dplyr::filter(.data[[param_var]] == input$xaxis_param) # nolint |
550 | ||
551 | ! |
visit_freq <- unique(ANL$AVISITCD) |
552 | ||
553 |
# get min max values |
|
554 | ! |
if ((constraint_var == "BASE2" && any(grepl("SCR", visit_freq))) || |
555 | ! |
(constraint_var == "BASE" && any(grepl("BL", visit_freq)))) { # nolint |
556 | ! |
val <- stats::na.omit(switch(constraint_var, |
557 | ! |
"BASE" = ANL$BASE[ANL$AVISITCD == "BL"], |
558 | ! |
"BASE2" = ANL$BASE2[ANL$AVISITCD == "SCR"], |
559 | ! |
stop(paste(constraint_var, "not allowed")) |
560 |
)) |
|
561 | ||
562 | ! |
if (length(val) == 0 || all(is.na(val))) { |
563 | ! |
shinyjs::show("all_na") |
564 | ! |
shinyjs::hide("constraint_range") |
565 | ! |
args <- list( |
566 | ! |
min = list(label = "Min", min = 0, max = 0, value = 0), |
567 | ! |
max = list(label = "Max", min = 0, max = 0, value = 0) |
568 |
) |
|
569 | ! |
update_min_max(session, args) |
570 |
} else { |
|
571 | ! |
rng <- range(val, na.rm = TRUE) |
572 | ||
573 | ! |
minmax <- c(floor(rng[1] * 1000) / 1000, ceiling(rng[2] * 1000) / 1000) |
574 | ||
575 | ! |
label_min <- sprintf("Min (%s)", minmax[1]) |
576 | ! |
label_max <- sprintf("Max (%s)", minmax[2]) |
577 | ||
578 | ! |
args <- list( |
579 | ! |
min = list(label = label_min, min = minmax[1], max = minmax[2], value = minmax[1]), |
580 | ! |
max = list(label = label_max, min = minmax[1], max = minmax[2], value = minmax[2]) |
581 |
) |
|
582 | ||
583 | ! |
update_min_max(session, args) |
584 | ! |
shinyjs::show("constraint_range") # update before show |
585 | ! |
shinyjs::hide("all_na") |
586 |
} |
|
587 | ! |
} else if (constraint_var == "NONE") { |
588 | ! |
shinyjs::hide("constraint_range") # hide before update |
589 | ! |
shinyjs::hide("all_na") |
590 | ||
591 |
# force update (and thus refresh) on different constraint_var -> pass unique value for each constraint_var name |
|
592 | ! |
args <- list( |
593 | ! |
min = list(label = "Min", min = 0, max = 0, value = 0), |
594 | ! |
max = list(label = "Max", min = 0, max = 0, value = 0) |
595 |
) |
|
596 | ||
597 | ! |
update_min_max(session, args) |
598 |
} else { |
|
599 | ! |
stop("invalid contraint_var", constraint_var) |
600 |
} |
|
601 |
}) |
|
602 | ||
603 | ! |
anl_constraint_output <- create_anl_constraint_reactive(anl_param, input, param_id = "xaxis_param", min_rows = 1) |
604 | ! |
anl_constraint <- anl_constraint_output()$value |
605 | ||
606 |
# update sliders for axes taking constraints into account |
|
607 | ! |
xrange_slider <- toggle_slider_server("xrange_scale") |
608 | ! |
yrange_slider <- toggle_slider_server("yrange_scale") |
609 | ! |
keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_constraint) |
610 | ! |
keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "yaxis_param", anl_constraint) |
611 | ! |
keep_data_const_opts_updated(session, input, anl_constraint, "xaxis_param") |
612 | ||
613 |
# selector names after transposition |
|
614 | ! |
xvar <- reactive(paste0(input$xaxis_var, "_", input$xaxis_param)) |
615 | ! |
yvar <- reactive(paste0(input$yaxis_var, "_", input$yaxis_param)) |
616 | ! |
xloqfl <- reactive(paste0("LOQFL_", input$xaxis_param)) |
617 | ! |
yloqfl <- reactive(paste0("LOQFL_", input$yaxis_param)) |
618 | ||
619 |
# transpose data to plot |
|
620 | ! |
plot_data_transpose <- reactive({ |
621 | ! |
teal::validate_inputs(iv_r()) |
622 | ||
623 | ! |
req(anl_constraint()) |
624 | ! |
ANL <- anl_constraint()$ANL # nolint |
625 | ! |
trt_group <- input$trt_group |
626 | ||
627 | ! |
qenv <- anl_constraint()$qenv %>% teal.code::eval_code( |
628 | ! |
code = bquote({ |
629 | ! |
ANL_x <- ANL %>% # nolint |
630 | ! |
dplyr::filter(.data[[.(param_var)]] == .(input$xaxis_param) & !is.na(.data[[.(input$xaxis_var)]])) |
631 |
}) |
|
632 |
) |
|
633 | ||
634 | ! |
if (input$xaxis_var == "BASE") { |
635 | ! |
qenv <- qenv %>% within({ |
636 | ! |
ANL_x <- ANL_x |> # nolint |
637 | ! |
dplyr::group_by(.data[["USUBJID"]]) %>% |
638 | ! |
dplyr::mutate(LOQFL = .data[["LOQFL"]][.data[["AVISITCD"]] == "BL"]) %>% |
639 | ! |
dplyr::ungroup() |
640 |
}) |
|
641 | ! |
} else if (input$xaxis_var != "AVAL") { |
642 | ! |
qenv <- qenv %>% within({ |
643 | ! |
ANL_x <- ANL_x |> # nolint |
644 | ! |
dplyr::mutate(LOQFL = "N") |
645 |
}) |
|
646 |
} |
|
647 | ||
648 | ! |
qenv <- qenv %>% teal.code::eval_code( |
649 | ! |
code = bquote({ |
650 | ! |
ANL_y <- ANL %>% # nolint |
651 | ! |
dplyr::filter(.data[[.(param_var)]] == .(input$yaxis_param) & !is.na(.data[[.(input$yaxis_var)]])) |
652 |
}) |
|
653 |
) |
|
654 | ||
655 | ! |
if (input$yaxis_var == "BASE") { |
656 | ! |
qenv <- qenv %>% within({ |
657 | ! |
ANL_y <- ANL_y |> # nolint |
658 | ! |
dplyr::group_by(.data[["USUBJID"]]) %>% |
659 | ! |
dplyr::mutate(LOQFL = .data[["LOQFL"]][.data[["AVISITCD"]] == "BL"]) %>% |
660 | ! |
dplyr::ungroup() |
661 |
}) |
|
662 | ! |
} else if (input$yaxis_var != "AVAL") { |
663 | ! |
qenv <- qenv %>% within({ |
664 | ! |
ANL_y <- ANL_y |> # nolint |
665 | ! |
dplyr::mutate(LOQFL = "N") |
666 |
}) |
|
667 |
} |
|
668 | ||
669 | ! |
qenv <- qenv %>% teal.code::eval_code( |
670 | ! |
code = bquote({ |
671 | ! |
ANL_TRANSPOSED <- dplyr::full_join( # nolint |
672 | ! |
ANL_x, ANL_y, |
673 | ! |
by = c("USUBJID", "AVISITCD", .(trt_group)), |
674 | ! |
suffix = .(sprintf("_%s", c(input$xaxis_param, input$yaxis_param))) |
675 |
) |
|
676 | ! |
ANL_TRANSPOSED <- ANL_TRANSPOSED %>% # nolint |
677 | ! |
dplyr::mutate( |
678 | ! |
LOQFL_COMB = case_when( |
679 | ! |
.data[[.(xloqfl())]] == "Y" | .data[[.(yloqfl())]] == "Y" ~ "Y", |
680 | ! |
.data[[.(xloqfl())]] == "N" | .data[[.(yloqfl())]] == "N" ~ "N", |
681 | ! |
TRUE ~ "NA" |
682 |
) |
|
683 |
) |
|
684 |
}) |
|
685 |
) |
|
686 | ||
687 | ! |
validate(need(nrow(qenv[["ANL_TRANSPOSED"]]) > 0, "Plot Data No Observations Left")) |
688 | ! |
validate_has_variable(data = qenv[["ANL_TRANSPOSED"]], varname = c(xvar(), yvar(), xloqfl(), yloqfl())) |
689 | ||
690 | ! |
qenv <- teal.code::eval_code( |
691 | ! |
object = qenv, |
692 | ! |
code = |
693 | ! |
bquote(attr(ANL_TRANSPOSED[[.(trt_group)]], "label") <- attr(ANL[[.(trt_group)]], "label")) # nolint |
694 |
) |
|
695 | ! |
return(list(ANL_TRANSPOSED = qenv[["ANL_TRANSPOSED"]], qenv = qenv)) |
696 |
}) |
|
697 | ||
698 | ! |
plot_labels <- reactive({ |
699 | ! |
req(anl_constraint()) |
700 | ! |
ANL <- anl_constraint()$qenv[["ANL"]] # nolint |
701 | ||
702 | ! |
xparam <- ANL$PARAM[ANL[[param_var]] == input$xaxis_param][1] |
703 | ! |
yparam <- ANL$PARAM[ANL[[param_var]] == input$yaxis_param][1] |
704 | ||
705 |
# setup the x-axis label. Combine the biomarker and the units (if available) |
|
706 | ! |
if (is.null(ANL$AVALU) || all(ANL[["AVALU"]] == "")) { |
707 | ! |
title_text <- paste(xparam, "and", yparam, "@ Visits") |
708 | ! |
xaxis_lab <- paste(xparam, input$xaxis_var, "Values") |
709 | ! |
yaxis_lab <- paste(yparam, input$yaxis_var, "Values") |
710 |
} else { |
|
711 | ! |
xunit <- ANL$AVALU[ANL[[param_var]] == input$xaxis_param][1] |
712 | ! |
yunit <- ANL$AVALU[ANL[[param_var]] == input$yaxis_param][1] |
713 | ||
714 | ! |
title_text <- paste0(xparam, " (", xunit, ") and ", yparam, " (", yunit, ") @ Visits") |
715 | ! |
xaxis_lab <- paste0(xparam, " (", xunit, ") ", input$xaxis_var, " Values") |
716 | ! |
yaxis_lab <- paste0(yparam, " (", yunit, ") ", input$yaxis_var, " Values") |
717 |
} |
|
718 | ||
719 | ! |
list(title_text = title_text, xaxis_lab = xaxis_lab, yaxis_lab = yaxis_lab) |
720 |
}) |
|
721 | ||
722 | ! |
horizontal_line <- srv_arbitrary_lines("hline_arb") |
723 | ! |
vertical_line <- srv_arbitrary_lines("vline_arb") |
724 | ||
725 |
# plot |
|
726 | ! |
plot_q <- reactive({ |
727 | ! |
req(plot_data_transpose()) |
728 |
# nolint start |
|
729 | ! |
xaxis_param <- input$xaxis_param |
730 | ! |
xaxis_var <- input$xaxis_var |
731 | ! |
yaxis_param <- input$yaxis_param |
732 | ! |
yaxis_var <- input$yaxis_var |
733 | ! |
xlim <- xrange_slider$state()$value |
734 | ! |
ylim <- yrange_slider$state()$value |
735 | ! |
font_size <- input$font_size |
736 | ! |
dot_size <- input$dot_size |
737 | ! |
reg_text_size <- input$reg_text_size |
738 | ! |
hline_arb <- horizontal_line()$line_arb |
739 | ! |
hline_arb_label <- horizontal_line()$line_arb_label |
740 | ! |
hline_arb_color <- horizontal_line()$line_arb_color |
741 | ! |
hline_vars <- if (length(input$hline_vars) == 0) { |
742 | ! |
NULL |
743 |
} else { |
|
744 | ! |
paste0(input$hline_vars, "_", yaxis_param) |
745 |
} |
|
746 | ! |
vline_arb <- vertical_line()$line_arb |
747 | ! |
vline_arb_label <- vertical_line()$line_arb_label |
748 | ! |
vline_arb_color <- vertical_line()$line_arb_color |
749 | ! |
vline_vars <- if (length(input$vline_vars) == 0) { |
750 | ! |
NULL |
751 |
} else { |
|
752 | ! |
paste0(input$vline_vars, "_", xaxis_param) |
753 |
} |
|
754 | ! |
facet_ncol <- input$facet_ncol |
755 | ! |
validate(need( |
756 | ! |
is.na(facet_ncol) || (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0), |
757 | ! |
"Number of plots per row must be a positive integer" |
758 |
)) |
|
759 | ! |
visit_facet <- input$visit_facet |
760 | ! |
facet <- input$trt_facet |
761 | ! |
reg_line <- input$reg_line |
762 | ! |
loq_legend <- input$loq_legend |
763 | ! |
rotate_xlab <- input$rotate_xlab |
764 |
# nolint end |
|
765 | ! |
title_text <- plot_labels()$title_text |
766 | ! |
xaxis_lab <- plot_labels()$xaxis_lab |
767 | ! |
yaxis_lab <- plot_labels()$yaxis_lab |
768 | ! |
validate(need(input$trt_group, "Please select a treatment variable")) |
769 | ! |
trt_group <- input$trt_group |
770 | ||
771 | ! |
teal.code::eval_code( |
772 | ! |
object = plot_data_transpose()$qenv, |
773 | ! |
code = bquote({ |
774 |
# re-establish treatment variable label |
|
775 | ! |
p <- goshawk::g_correlationplot( |
776 | ! |
data = ANL_TRANSPOSED, |
777 | ! |
param_var = .(param_var), |
778 | ! |
xaxis_param = .(xaxis_param), |
779 | ! |
xaxis_var = .(xaxis_var), |
780 | ! |
xvar = .(xvar()), |
781 | ! |
yaxis_param = .(yaxis_param), |
782 | ! |
yaxis_var = .(yaxis_var), |
783 | ! |
yvar = .(yvar()), |
784 | ! |
trt_group = .(trt_group), |
785 | ! |
xlim = .(xlim), |
786 | ! |
ylim = .(ylim), |
787 | ! |
title_text = .(title_text), |
788 | ! |
xaxis_lab = .(xaxis_lab), |
789 | ! |
yaxis_lab = .(yaxis_lab), |
790 | ! |
color_manual = .(color_manual), |
791 | ! |
shape_manual = .(shape_manual), |
792 | ! |
facet_ncol = .(facet_ncol), |
793 | ! |
visit_facet = .(visit_facet), |
794 | ! |
facet = .(facet), |
795 | ! |
facet_var = .(trt_group), |
796 | ! |
reg_line = .(reg_line), |
797 | ! |
font_size = .(font_size), |
798 | ! |
dot_size = .(dot_size), |
799 | ! |
reg_text_size = .(reg_text_size), |
800 | ! |
loq_legend = .(loq_legend), |
801 | ! |
rotate_xlab = .(rotate_xlab), |
802 | ! |
hline_arb = .(hline_arb), |
803 | ! |
hline_arb_label = .(hline_arb_label), |
804 | ! |
hline_arb_color = .(hline_arb_color), |
805 | ! |
hline_vars = .(hline_vars), |
806 | ! |
hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]), |
807 | ! |
hline_vars_labels = .(paste(hline_vars_labels[seq_along(hline_vars)], "-", yaxis_param)), |
808 | ! |
vline_arb = .(vline_arb), |
809 | ! |
vline_arb_label = .(vline_arb_label), |
810 | ! |
vline_arb_color = .(vline_arb_color), |
811 | ! |
vline_vars = .(vline_vars), |
812 | ! |
vline_vars_colors = .(vline_vars_colors[seq_along(vline_vars)]), |
813 | ! |
vline_vars_labels = .(paste(vline_vars_labels[seq_along(vline_vars)], "-", xaxis_param)) |
814 |
) |
|
815 | ! |
print(p) |
816 |
}) |
|
817 |
) |
|
818 |
}) |
|
819 | ||
820 | ! |
plot_r <- reactive(plot_q()[["p"]]) |
821 | ||
822 | ! |
plot_data <- teal.widgets::plot_with_settings_srv( |
823 | ! |
id = "plot", |
824 | ! |
plot_r = plot_r, |
825 | ! |
height = plot_height, |
826 | ! |
width = plot_width, |
827 | ! |
brushing = TRUE |
828 |
) |
|
829 | ||
830 | ||
831 |
### REPORTER |
|
832 | ! |
if (with_reporter) { |
833 | ! |
card_fun <- function(comment, label) { |
834 | ! |
constraint_description <- paste( |
835 | ! |
"\nTreatment Variable Faceting:", |
836 | ! |
input$trt_facet, |
837 | ! |
"\nRegression Line:", |
838 | ! |
input$reg_line |
839 |
) |
|
840 | ! |
card <- report_card_template_goshawk( |
841 | ! |
title = "Correlation Plot", |
842 | ! |
label = label, |
843 | ! |
with_filter = with_filter, |
844 | ! |
filter_panel_api = filter_panel_api, |
845 | ! |
constraint_list = list( |
846 | ! |
constraint_var = input$constraint_var, |
847 | ! |
constraint_range_min = input$constraint_range_min, |
848 | ! |
constraint_range_max = input$constraint_range_max |
849 |
), |
|
850 | ! |
constraint_description = constraint_description, |
851 | ! |
style = "verbatim" |
852 |
) |
|
853 | ! |
card$append_text("Plot", "header3") |
854 | ! |
card$append_plot(plot_r(), dim = plot_data$dim()) |
855 | ! |
if (!comment == "") { |
856 | ! |
card$append_text("Comment", "header3") |
857 | ! |
card$append_text(comment) |
858 |
} |
|
859 | ! |
card$append_src(teal.code::get_code(plot_q())) |
860 | ! |
card |
861 |
} |
|
862 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
863 |
} |
|
864 |
### |
|
865 | ||
866 |
# highlight plot area |
|
867 | ! |
output$brush_data <- DT::renderDataTable({ |
868 | ! |
req(iv_r()$is_valid()) |
869 | ! |
plot_brush <- plot_data$brush() |
870 | ||
871 | ! |
ANL_TRANSPOSED <- isolate(plot_data_transpose()$ANL_TRANSPOSED) # nolint |
872 | ||
873 | ! |
df <- teal.widgets::clean_brushedPoints( |
874 | ! |
dplyr::select( |
875 | ! |
ANL_TRANSPOSED, "USUBJID", dplyr::all_of(input$trt_group), "AVISITCD", |
876 | ! |
dplyr::all_of(c(xvar(), yvar())), "LOQFL_COMB" |
877 |
), |
|
878 | ! |
plot_brush |
879 |
) |
|
880 | ||
881 | ! |
numeric_cols <- names(dplyr::select_if(df, is.numeric)) |
882 | ||
883 | ! |
DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>% |
884 | ! |
DT::formatRound(numeric_cols, 4) |
885 |
}) |
|
886 | ||
887 | ! |
teal.widgets::verbatim_popup_srv( |
888 | ! |
id = "rcode", |
889 | ! |
verbatim_content = reactive(teal.code::get_code(plot_q())), |
890 | ! |
title = "Show R Code for Correlation Plot" |
891 |
) |
|
892 |
}) |
|
893 |
} |
1 |
#' Line plot |
|
2 |
#' |
|
3 |
#' This teal module renders the UI and calls the function that creates a line plot. |
|
4 |
#' |
|
5 |
#' @inheritParams teal.widgets::standard_layout |
|
6 |
#' @param label menu item label of the module in the teal app. |
|
7 |
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured |
|
8 |
#' laboratory data frame `ADLB`. |
|
9 |
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`. |
|
10 |
#' @param param biomarker selected. |
|
11 |
#' @param param_var_label single name of variable in analysis data that includes parameter labels. |
|
12 |
#' @param xaxis_var single name of variable in analysis data that is used as x-axis in the plot for the |
|
13 |
#' respective `goshawk` function. |
|
14 |
#' @param xvar_level vector that can be used to define the factor level of `xvar`. Only use it when |
|
15 |
#' `xvar` is character or factor. |
|
16 |
#' @param filter_var data constraint variable. |
|
17 |
#' @param filter_var_choices data constraint variable choices. |
|
18 |
#' @param yaxis_var single name of variable in analysis data that is used as summary variable in the |
|
19 |
#' respective `goshawk` function. |
|
20 |
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option |
|
21 |
#' for variable names representing treatment group e.g. `ARM`. |
|
22 |
#' @param trt_group_level vector that can be used to define factor level of `trt_group`. |
|
23 |
#' @param shape_choices Vector or \code{choices_selected} object with names of `ADSL` variables which |
|
24 |
#' can be used to change shape |
|
25 |
#' @param color_manual string vector representing customized colors |
|
26 |
#' @param stat string of statistics |
|
27 |
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines. |
|
28 |
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}. |
|
29 |
#' naming the color for the arbitrary horizontal lines. |
|
30 |
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}. |
|
31 |
#' naming the label for the arbitrary horizontal lines. |
|
32 |
#' @param xtick numeric vector to define the tick values of x-axis when x variable is numeric. |
|
33 |
#' Default value is waive(). |
|
34 |
#' @param xlabel vector with same length of `xtick` to define the label of x-axis tick values. |
|
35 |
#' Default value is waive(). |
|
36 |
#' @param rotate_xlab `logical(1)` value indicating whether to rotate `x-axis` labels. |
|
37 |
#' @param plot_height controls plot height. |
|
38 |
#' @param plot_width optional, controls plot width. |
|
39 |
#' @param plot_font_size control font size for title, `x-axis`, `y-axis` and legend font. |
|
40 |
#' @param dodge controls the position dodge of error bar |
|
41 |
#' @param count_threshold minimum count of observations (as listed in the output table) to plot |
|
42 |
#' nodes on the graph |
|
43 |
#' @param table_font_size controls the font size of values in the table |
|
44 |
#' @param dot_size plot dot size. |
|
45 |
#' @param plot_relative_height_value numeric value between 500 and 5000 for controlling the starting value |
|
46 |
#' of the relative plot height slider |
|
47 |
#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com |
|
48 |
#' @author Balazs Toth (tothb2) toth.balazs@gene.com |
|
49 |
#' |
|
50 |
#' @return \code{shiny} object |
|
51 |
#' |
|
52 |
#' @export |
|
53 |
#' |
|
54 |
#' @examples |
|
55 |
#' # Example using ADaM structure analysis dataset. |
|
56 |
#' data <- teal_data() |
|
57 |
#' data <- within(data, { |
|
58 |
#' library(dplyr) |
|
59 |
#' library(stringr) |
|
60 |
#' library(nestcolor) |
|
61 |
#' |
|
62 |
#' # original ARM value = dose value |
|
63 |
#' arm_mapping <- list( |
|
64 |
#' "A: Drug X" = "150mg QD", |
|
65 |
#' "B: Placebo" = "Placebo", |
|
66 |
#' "C: Combination" = "Combination" |
|
67 |
#' ) |
|
68 |
#' |
|
69 |
#' ADSL <- rADSL |
|
70 |
#' ADLB <- rADLB |
|
71 |
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) |
|
72 |
#' ADLB <- ADLB %>% |
|
73 |
#' mutate( |
|
74 |
#' AVISITCD = case_when( |
|
75 |
#' AVISIT == "SCREENING" ~ "SCR", |
|
76 |
#' AVISIT == "BASELINE" ~ "BL", |
|
77 |
#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")), |
|
78 |
#' TRUE ~ as.character(NA) |
|
79 |
#' ), |
|
80 |
#' AVISITCDN = case_when( |
|
81 |
#' AVISITCD == "SCR" ~ -2, |
|
82 |
#' AVISITCD == "BL" ~ 0, |
|
83 |
#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), |
|
84 |
#' TRUE ~ as.numeric(NA) |
|
85 |
#' ), |
|
86 |
#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN), |
|
87 |
#' TRTORD = case_when( |
|
88 |
#' ARMCD == "ARM C" ~ 1, |
|
89 |
#' ARMCD == "ARM B" ~ 2, |
|
90 |
#' ARMCD == "ARM A" ~ 3 |
|
91 |
#' ), |
|
92 |
#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]), |
|
93 |
#' ARM = factor(ARM) %>% reorder(TRTORD), |
|
94 |
#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]), |
|
95 |
#' ACTARM = factor(ACTARM) %>% reorder(TRTORD) |
|
96 |
#' ) |
|
97 |
#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] |
|
98 |
#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]] |
|
99 |
#' }) |
|
100 |
#' |
|
101 |
#' datanames <- c("ADSL", "ADLB") |
|
102 |
#' datanames(data) <- datanames |
|
103 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
104 |
#' |
|
105 |
#' app <- init( |
|
106 |
#' data = data, |
|
107 |
#' modules = modules( |
|
108 |
#' tm_g_gh_lineplot( |
|
109 |
#' label = "Line Plot", |
|
110 |
#' dataname = "ADLB", |
|
111 |
#' param_var = "PARAMCD", |
|
112 |
#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), |
|
113 |
#' shape_choices = c("SEX", "RACE"), |
|
114 |
#' xaxis_var = choices_selected("AVISITCD", "AVISITCD"), |
|
115 |
#' yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"), |
|
116 |
#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
117 |
#' hline_arb = c(20.5, 19.5), |
|
118 |
#' hline_arb_color = c("red", "green"), |
|
119 |
#' hline_arb_label = c("A", "B") |
|
120 |
#' ) |
|
121 |
#' ) |
|
122 |
#' ) |
|
123 |
#' if (interactive()) { |
|
124 |
#' shinyApp(app$ui, app$server) |
|
125 |
#' } |
|
126 |
#' |
|
127 |
tm_g_gh_lineplot <- function(label, |
|
128 |
dataname, |
|
129 |
param_var, |
|
130 |
param, |
|
131 |
param_var_label = "PARAM", |
|
132 |
xaxis_var, |
|
133 |
yaxis_var, |
|
134 |
xvar_level = NULL, |
|
135 |
filter_var = yaxis_var, |
|
136 |
filter_var_choices = filter_var, |
|
137 |
trt_group, |
|
138 |
trt_group_level = NULL, |
|
139 |
shape_choices = NULL, |
|
140 |
stat = "mean", |
|
141 |
hline_arb = numeric(0), |
|
142 |
hline_arb_color = "red", |
|
143 |
hline_arb_label = "Horizontal line", |
|
144 |
color_manual = c( |
|
145 |
getOption("ggplot2.discrete.colour"), |
|
146 |
c("#ff0000", "#008000", "#4ca3dd", "#8a2be2") |
|
147 |
)[1:4], |
|
148 |
xtick = ggplot2::waiver(), |
|
149 |
xlabel = xtick, |
|
150 |
rotate_xlab = FALSE, |
|
151 |
plot_height = c(600, 200, 4000), |
|
152 |
plot_width = NULL, |
|
153 |
plot_font_size = c(12, 8, 20), |
|
154 |
dodge = c(0.4, 0, 1), |
|
155 |
pre_output = NULL, |
|
156 |
post_output = NULL, |
|
157 |
count_threshold = 0, |
|
158 |
table_font_size = c(12, 4, 20), |
|
159 |
dot_size = c(2, 1, 12), |
|
160 |
plot_relative_height_value = 1000) { |
|
161 | ! |
message("Initializing tm_g_gh_lineplot") |
162 |
# Validate string inputs |
|
163 | ! |
checkmate::assert_string(label) |
164 | ! |
checkmate::assert_string(dataname) |
165 | ! |
checkmate::assert_string(param_var) |
166 | ! |
checkmate::assert_string(param_var_label) |
167 | ! |
checkmate::assert_string(stat) |
168 | ||
169 |
# Validate choices_selected class inputs |
|
170 | ! |
checkmate::assert_class(param, "choices_selected") |
171 | ! |
checkmate::assert_class(xaxis_var, "choices_selected") |
172 | ! |
checkmate::assert_class(yaxis_var, "choices_selected") |
173 | ! |
checkmate::assert_class(trt_group, "choices_selected") |
174 | ||
175 |
# Validate flag inputs |
|
176 | ! |
checkmate::assert_flag(rotate_xlab) |
177 | ||
178 |
# Validate numeric vector inputs |
|
179 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
180 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
181 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
182 | ! |
checkmate::assert_numeric( |
183 | ! |
plot_width[1], |
184 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
185 |
) |
|
186 | ! |
checkmate::assert_numeric(table_font_size, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
187 | ! |
checkmate::assert_numeric(dot_size, len = 3) |
188 | ! |
checkmate::assert_numeric( |
189 | ! |
table_font_size[1], |
190 | ! |
lower = table_font_size[2], upper = table_font_size[3], |
191 | ! |
null.ok = TRUE, .var.name = "table_font_size" |
192 |
) |
|
193 | ! |
checkmate::assert_number(plot_relative_height_value, lower = 500, upper = 5000) |
194 | ! |
checkmate::assert_number(count_threshold) |
195 | ||
196 |
# Validate color manual if provided |
|
197 | ! |
checkmate::assert_character(color_manual, null.ok = TRUE) |
198 | ! |
checkmate::assert_character(hline_arb_color) |
199 | ! |
checkmate::assert_character(hline_arb_label) |
200 | ||
201 |
# Validate line arguments |
|
202 | ! |
validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label) |
203 | ||
204 | ! |
args <- as.list(environment()) |
205 | ||
206 | ! |
module( |
207 | ! |
label = label, |
208 | ! |
server = srv_lineplot, |
209 | ! |
server_args = list( |
210 | ! |
dataname = dataname, |
211 | ! |
param_var = param_var, |
212 | ! |
trt_group = trt_group, |
213 | ! |
color_manual = color_manual, |
214 | ! |
xvar_level = xvar_level, |
215 | ! |
trt_group_level = trt_group_level, |
216 | ! |
shape_choices = shape_choices, |
217 | ! |
param_var_label = param_var_label, |
218 | ! |
xtick = xtick, |
219 | ! |
xlabel = xlabel, |
220 | ! |
plot_height = plot_height, |
221 | ! |
plot_width = plot_width, |
222 | ! |
module_args = args |
223 |
), |
|
224 | ! |
ui = ui_lineplot, |
225 | ! |
ui_args = args, |
226 | ! |
datanames = dataname |
227 |
) |
|
228 |
} |
|
229 | ||
230 |
ui_lineplot <- function(id, ...) { |
|
231 | ! |
ns <- NS(id) |
232 | ! |
a <- list(...) |
233 | ||
234 | ! |
shiny::tagList( |
235 | ! |
include_css_files("custom"), |
236 | ! |
teal.widgets::standard_layout( |
237 | ! |
output = teal.widgets::plot_with_settings_ui(id = ns("plot")), |
238 | ! |
encoding = tags$div( |
239 |
### Reporter |
|
240 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
241 |
### |
|
242 | ! |
templ_ui_dataname(a$dataname), |
243 | ! |
teal.widgets::optionalSelectInput( |
244 | ! |
ns("trt_group"), |
245 | ! |
label = "Select Treatment Variable", |
246 | ! |
choices = get_choices(a$trt_group$choices), |
247 | ! |
selected = a$trt_group$selected, |
248 | ! |
multiple = FALSE |
249 |
), |
|
250 | ! |
uiOutput(ns("axis_selections")), |
251 | ! |
uiOutput(ns("shape_ui")), |
252 | ! |
radioButtons(ns("stat"), "Select a Statistic:", c("mean", "median"), a$stat), |
253 | ! |
checkboxInput(ns("include_stat"), "Include Statistic Table", value = TRUE), |
254 | ! |
tags$div( |
255 | ! |
sliderInput( |
256 | ! |
ns("relative_height"), |
257 | ! |
tags$div( |
258 | ! |
"Relative height of plot to table(s)", |
259 | ! |
title = |
260 | ! |
paste( |
261 | ! |
"The larger the value selected the greater the size of the plot relative\nto", |
262 | ! |
"the size of the tables. Note the units of this slider are arbitrary.\nTo", |
263 | ! |
"change the total size of the plot and table(s)\nuse", |
264 | ! |
"the plot resizing controls available at the top right of the plot." |
265 |
), |
|
266 | ! |
icon("circle-info") |
267 |
), |
|
268 | ! |
min = 500, |
269 | ! |
max = 5000, |
270 | ! |
step = 50, |
271 | ! |
value = a$plot_relative_height_value, |
272 | ! |
ticks = FALSE |
273 |
), |
|
274 |
), |
|
275 | ! |
templ_ui_constraint(ns), # required by constr_anl_q |
276 | ! |
ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color), |
277 | ! |
teal.widgets::panel_group( |
278 | ! |
teal.widgets::panel_item( |
279 | ! |
title = "Plot Aesthetic Settings", |
280 | ! |
toggle_slider_ui( |
281 | ! |
ns("yrange_scale"), |
282 | ! |
label = "Y-Axis Range Zoom", |
283 | ! |
min = -1000000, |
284 | ! |
max = 1000000, |
285 | ! |
value = c(-1000000, 1000000) |
286 |
), |
|
287 | ! |
checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab), |
288 | ! |
numericInput(ns("count_threshold"), "Contributing Observations Threshold:", a$count_threshold) |
289 |
), |
|
290 | ! |
teal.widgets::panel_item( |
291 | ! |
title = "Plot settings", |
292 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("dodge"), "Error Bar Position Dodge", a$dodge, ticks = FALSE), |
293 | ! |
teal.widgets::panel_group( |
294 | ! |
teal.widgets::panel_item( |
295 | ! |
title = "Line Settings", |
296 | ! |
uiOutput(ns("lines")) |
297 |
), |
|
298 | ! |
teal.widgets::panel_item( |
299 | ! |
title = "Symbol settings", |
300 | ! |
uiOutput(ns("symbols")) |
301 |
) |
|
302 |
), |
|
303 | ! |
teal.widgets::optionalSliderInputValMinMax( |
304 | ! |
ns("plot_font_size"), |
305 | ! |
"Font Size", |
306 | ! |
a$plot_font_size, |
307 | ! |
ticks = FALSE |
308 |
), |
|
309 | ! |
teal.widgets::optionalSliderInputValMinMax( |
310 | ! |
ns("dot_size"), |
311 | ! |
"Dot Size", |
312 | ! |
a$dot_size, |
313 | ! |
ticks = FALSE |
314 |
) |
|
315 |
), |
|
316 | ! |
teal.widgets::panel_item( |
317 | ! |
title = "Table settings", |
318 | ! |
teal.widgets::optionalSliderInputValMinMax( |
319 | ! |
ns("table_font_size"), |
320 | ! |
"Table Font Size", |
321 | ! |
a$table_font_size, |
322 | ! |
ticks = FALSE |
323 |
) |
|
324 |
) |
|
325 |
) |
|
326 |
), |
|
327 | ! |
forms = tagList( |
328 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
329 |
), |
|
330 | ! |
pre_output = a$pre_output, |
331 | ! |
post_output = a$post_output |
332 |
) |
|
333 |
) |
|
334 |
} |
|
335 | ||
336 |
srv_lineplot <- function(id, |
|
337 |
data, |
|
338 |
reporter, |
|
339 |
filter_panel_api, |
|
340 |
dataname, |
|
341 |
param_var, |
|
342 |
trt_group, |
|
343 |
color_manual, |
|
344 |
xvar_level, |
|
345 |
trt_group_level, |
|
346 |
shape_choices, |
|
347 |
param_var_label, |
|
348 |
xtick, |
|
349 |
xlabel, |
|
350 |
plot_height, |
|
351 |
plot_width, |
|
352 |
module_args) { |
|
353 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
354 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
355 | ! |
checkmate::assert_class(data, "reactive") |
356 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
357 | ||
358 | ! |
moduleServer(id, function(input, output, session) { |
359 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
360 | ! |
ns <- session$ns |
361 | ||
362 | ! |
output$axis_selections <- renderUI({ |
363 | ! |
env <- shiny::isolate(as.list(data()@env)) |
364 | ! |
resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env) |
365 | ! |
resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env) |
366 | ! |
resolved_param <- teal.transform::resolve_delayed(module_args$param, env) |
367 | ! |
templ_ui_params_vars( |
368 | ! |
ns, |
369 |
# xparam and yparam are identical, so we only show the user one |
|
370 | ! |
xparam_choices = resolved_param$choices, |
371 | ! |
xparam_selected = resolved_param$selected, |
372 | ! |
xparam_label = "Select a Biomarker", |
373 | ! |
xchoices = resolved_x$choices, |
374 | ! |
xselected = resolved_x$selected, |
375 | ! |
ychoices = resolved_y$choices, |
376 | ! |
yselected = resolved_y$selected |
377 |
) |
|
378 |
}) |
|
379 | ||
380 | ! |
output$shape_ui <- renderUI({ |
381 | ! |
if (!is.null(shape_choices)) { |
382 | ! |
if (methods::is(shape_choices, "choices_selected")) { |
383 | ! |
choices <- get_choices(shape_choices$choices) |
384 | ! |
selected <- shape_choices$selected |
385 |
} else { |
|
386 | ! |
choices <- shape_choices |
387 | ! |
selected <- NULL |
388 |
} |
|
389 | ! |
teal.widgets::optionalSelectInput( |
390 | ! |
ns("shape"), |
391 | ! |
"Select Line Splitting Variable", |
392 | ! |
choices = choices, selected = selected |
393 |
) |
|
394 |
} |
|
395 |
}) |
|
396 | ||
397 | ! |
anl_q_output <- constr_anl_q( |
398 | ! |
session = session, |
399 | ! |
input = input, |
400 | ! |
data = data, |
401 | ! |
dataname = dataname, |
402 | ! |
param_id = "xaxis_param", |
403 | ! |
param_var = param_var, |
404 | ! |
trt_group = input$trt_group, |
405 | ! |
min_rows = 2 |
406 |
) |
|
407 | ||
408 | ! |
anl_q <- anl_q_output()$value |
409 | ||
410 | ! |
keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") |
411 | ||
412 | ! |
yrange_slider <- toggle_slider_server("yrange_scale") |
413 | ||
414 | ! |
horizontal_line <- srv_arbitrary_lines("hline_arb") |
415 | ||
416 | ! |
iv_r <- reactive({ |
417 | ! |
iv <- shinyvalidate::InputValidator$new() |
418 | ! |
iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker")) |
419 | ! |
iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable")) |
420 | ! |
iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable")) |
421 | ! |
iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable")) |
422 | ||
423 | ! |
iv$add_validator(horizontal_line()$iv_r()) |
424 | ! |
iv$add_validator(anl_q_output()$iv_r()) |
425 | ! |
iv$enable() |
426 | ! |
iv |
427 |
}) |
|
428 | ||
429 | ||
430 |
# update sliders for axes |
|
431 | ! |
observe({ |
432 | ! |
varname <- input[["yaxis_var"]] |
433 | ! |
validate(need(varname, "Please select variable")) |
434 | ||
435 | ! |
ANL <- anl_q()$ANL # nolint |
436 | ! |
validate_has_variable(ANL, varname, paste("variable", varname, "does not exist")) |
437 | ||
438 | ! |
shape <- if (!(is.null(input$shape) || input$shape == "None")) { |
439 | ! |
input$shape |
440 |
} else { |
|
441 | ! |
NULL |
442 |
} |
|
443 | ||
444 |
# we don't need to additionally filter for paramvar here as in keep_range_slider_updated because |
|
445 |
# xaxis_var and yaxis_var are always distinct |
|
446 | ! |
sum_data <- ANL %>% |
447 | ! |
dplyr::group_by_at(c(input$xaxis_var, input$trt_group, shape)) %>% |
448 | ! |
dplyr::summarise( |
449 | ! |
upper = if (input$stat == "mean") { |
450 | ! |
mean(!!sym(varname), na.rm = TRUE) + |
451 | ! |
1.96 * stats::sd(!!sym(varname), na.rm = TRUE) / sqrt(dplyr::n()) |
452 |
} else { |
|
453 | ! |
stats::quantile(!!sym(varname), 0.75, na.rm = TRUE) |
454 |
}, |
|
455 | ! |
lower = if (input$stat == "mean") { |
456 | ! |
mean(!!sym(varname), na.rm = TRUE) - |
457 | ! |
1.96 * stats::sd(!!sym(varname), na.rm = TRUE) / sqrt(dplyr::n()) |
458 |
} else { |
|
459 | ! |
stats::quantile(!!sym(varname), 0.25, na.rm = TRUE) |
460 |
} |
|
461 |
) |
|
462 | ||
463 | ! |
minmax <- grDevices::extendrange( |
464 | ! |
r = c( |
465 | ! |
floor(min(sum_data$lower, na.rm = TRUE) * 10) / 10, |
466 | ! |
ceiling(max(sum_data$upper, na.rm = TRUE) * 10) / 10 |
467 |
), |
|
468 | ! |
f = 0.05 |
469 |
) |
|
470 | ||
471 |
# we don't use keep_range_slider_updated because this module computes the min, max |
|
472 |
# not from the constrained ANL, but rather by first grouping and computing confidence |
|
473 |
# intervals |
|
474 | ! |
isolate(yrange_slider$update_state( |
475 | ! |
min = minmax[[1]], |
476 | ! |
max = minmax[[2]], |
477 | ! |
value = minmax |
478 |
)) |
|
479 |
}) |
|
480 | ||
481 | ! |
line_color_defaults <- color_manual |
482 | ! |
line_type_defaults <- c( |
483 | ! |
"blank", |
484 | ! |
"solid", |
485 | ! |
"dashed", |
486 | ! |
"dotted", |
487 | ! |
"dotdash", |
488 | ! |
"longdash", |
489 | ! |
"twodash", |
490 | ! |
"1F", |
491 | ! |
"F1", |
492 | ! |
"4C88C488", |
493 | ! |
"12345678" |
494 |
) |
|
495 | ||
496 | ! |
line_color_selected <- reactive({ |
497 | ! |
req(input$trt_group) |
498 | ! |
anl_arm <- as.factor(isolate(anl_q())$ANL[[input$trt_group]]) |
499 | ! |
anl_arm_nlevels <- nlevels(anl_arm) |
500 | ! |
anl_arm_levels <- levels(anl_arm) |
501 | ||
502 | ! |
stats::setNames( |
503 | ! |
vapply( |
504 | ! |
seq_len(anl_arm_nlevels), |
505 | ! |
function(idx) { |
506 | ! |
x <- input[[paste0("line_color_", idx)]] |
507 | ! |
anl_arm_level <- anl_arm_levels[[idx]] |
508 | ! |
if (length(x)) { |
509 | ! |
x |
510 | ! |
} else if (anl_arm_level %in% names(line_color_defaults)) { |
511 | ! |
line_color_defaults[[anl_arm_level]] |
512 | ! |
} else if (idx <= length(line_color_defaults)) { |
513 | ! |
line_color_defaults[[idx]] |
514 |
} else { |
|
515 | ! |
"#000000" |
516 |
} |
|
517 |
}, |
|
518 | ! |
character(1) |
519 |
), |
|
520 | ! |
anl_arm_levels |
521 |
) |
|
522 |
}) |
|
523 | ! |
line_type_selected <- reactive({ |
524 | ! |
req(input$trt_group) |
525 | ! |
anl_arm <- as.factor(isolate(anl_q())$ANL[[input$trt_group]]) |
526 | ! |
anl_arm_nlevels <- nlevels(anl_arm) |
527 | ! |
anl_arm_levels <- levels(anl_arm) |
528 | ||
529 | ! |
stats::setNames( |
530 | ! |
vapply( |
531 | ! |
seq_len(anl_arm_nlevels), |
532 | ! |
function(idx) { |
533 | ! |
x <- input[[paste0("line_type_", idx)]] |
534 | ! |
if (is.null(x)) "solid" else x |
535 |
}, |
|
536 | ! |
character(1) |
537 |
), |
|
538 | ! |
anl_arm_levels |
539 |
) |
|
540 |
}) |
|
541 | ||
542 | ! |
output$lines <- renderUI({ |
543 | ! |
req(input$trt_group) |
544 | ! |
anl_arm <- as.factor(anl_q()$ANL[[input$trt_group]]) |
545 | ! |
anl_arm_nlevels <- nlevels(anl_arm) |
546 | ! |
anl_arm_levels <- levels(anl_arm) |
547 | ||
548 | ! |
tagList( |
549 | ! |
lapply( |
550 | ! |
seq_len(anl_arm_nlevels), |
551 | ! |
function(idx) { |
552 | ! |
x <- anl_arm_levels[[idx]] |
553 | ! |
color_input <- colourpicker::colourInput( |
554 | ! |
ns(paste0("line_color_", idx)), |
555 | ! |
"Color:", |
556 | ! |
isolate(line_color_selected()[[idx]]) |
557 |
) |
|
558 | ! |
type_input <- selectInput( |
559 | ! |
ns(paste0("line_type_", idx)), |
560 | ! |
"Type:", |
561 | ! |
choices = line_type_defaults, |
562 | ! |
selected = isolate(line_type_selected()[[idx]]) |
563 |
) |
|
564 | ! |
tags$div( |
565 | ! |
tags$label("Line configuration for:", tags$code(x)), |
566 | ! |
tags$div( |
567 | ! |
class = "flex", |
568 | ! |
tags$div( |
569 | ! |
class = "flex-grow-1", |
570 | ! |
color_input |
571 |
), |
|
572 | ! |
tags$div( |
573 | ! |
class = "flex-grow-1", |
574 | ! |
type_input |
575 |
) |
|
576 |
) |
|
577 |
) |
|
578 |
} |
|
579 |
) |
|
580 |
) |
|
581 |
}) |
|
582 | ||
583 | ! |
symbol_type_start <- c( |
584 | ! |
"circle", |
585 | ! |
"square", |
586 | ! |
"diamond", |
587 | ! |
"triangle", |
588 | ! |
"circle open", |
589 | ! |
"square open", |
590 | ! |
"diamond open", |
591 | ! |
"triangle open", |
592 | ! |
"triangle down open", |
593 | ! |
"circle cross", |
594 | ! |
"square cross", |
595 | ! |
"circle plus", |
596 | ! |
"square plus", |
597 | ! |
"diamond plus", |
598 | ! |
"square triangle", |
599 | ! |
"plus", |
600 | ! |
"cross", |
601 | ! |
"asterisk" |
602 |
) |
|
603 | ! |
symbol_type_defaults <- reactiveVal(symbol_type_start) |
604 | ||
605 |
# reset shapes when different splitting variable is selected |
|
606 | ! |
observeEvent( |
607 | ! |
eventExpr = input$shape, |
608 | ! |
handlerExpr = symbol_type_defaults(symbol_type_start), |
609 | ! |
ignoreNULL = TRUE |
610 |
) |
|
611 | ||
612 | ! |
observe({ |
613 | ! |
req(input$shape) |
614 | ! |
req(anl_q()) |
615 | ! |
anl_shape <- anl_q()$ANL[[input$shape]] |
616 | ! |
anl_shape_nlevels <- nlevels(anl_shape) |
617 | ! |
symbol_type_to_set <- symbol_type_defaults()[pmin(length(symbol_type_defaults()), seq_len(anl_shape_nlevels))] |
618 | ! |
symbol_type_defaults(symbol_type_to_set) |
619 |
}) |
|
620 | ||
621 | ! |
symbol_type_selected <- reactive({ |
622 | ! |
req(anl_q()) |
623 | ! |
if (is.null(input$shape)) { |
624 | ! |
return(NULL) |
625 |
} |
|
626 | ! |
anl_shape <- isolate(anl_q()$ANL[[input$shape]]) |
627 | ! |
anl_shape_nlevels <- nlevels(anl_shape) |
628 | ! |
anl_shape_levels <- levels(anl_shape) |
629 | ||
630 | ! |
stats::setNames( |
631 | ! |
vapply( |
632 | ! |
seq_len(anl_shape_nlevels), |
633 | ! |
function(idx) { |
634 | ! |
x <- input[[paste0("symbol_type_", idx)]] |
635 | ! |
if (is.null(x)) isolate(symbol_type_defaults())[[idx]] else x |
636 |
}, |
|
637 | ! |
character(1) |
638 |
), |
|
639 | ! |
anl_shape_levels |
640 |
) |
|
641 |
}) |
|
642 | ||
643 | ! |
output$symbols <- renderUI({ |
644 | ! |
req(symbol_type_defaults()) |
645 | ! |
validate(need(input$shape, "Please select line splitting variable first.")) |
646 | ||
647 | ! |
anl_shape <- isolate(anl_q()$ANL[[input$shape]]) |
648 | ! |
validate(need(is.factor(anl_shape), "Line splitting variable must be a factor.")) |
649 | ||
650 | ! |
anl_shape_nlevels <- nlevels(anl_shape) |
651 | ! |
anl_shape_levels <- levels(anl_shape) |
652 | ! |
symbol_def <- symbol_type_defaults() |
653 | ||
654 | ! |
tagList( |
655 | ! |
lapply( |
656 | ! |
seq_len(anl_shape_nlevels), |
657 | ! |
function(idx) { |
658 | ! |
x <- anl_shape_levels[[idx]] |
659 | ! |
x_color <- symbol_def[[idx]] |
660 | ! |
selectInput( |
661 | ! |
ns(paste0("symbol_type_", idx)), |
662 | ! |
HTML(paste0("Symbol for: ", tags$code(x))), |
663 | ! |
choices = symbol_type_start, |
664 | ! |
selected = x_color |
665 |
) |
|
666 |
} |
|
667 |
) |
|
668 |
) |
|
669 |
}) |
|
670 | ||
671 | ! |
plot_q <- reactive({ |
672 | ! |
teal::validate_inputs(iv_r()) |
673 | ! |
req(anl_q(), line_color_selected(), line_type_selected()) |
674 |
# nolint start |
|
675 | ! |
ylim <- yrange_slider$state()$value |
676 | ! |
plot_font_size <- input$plot_font_size |
677 | ! |
dot_size <- input$dot_size |
678 | ! |
dodge <- input$dodge |
679 | ! |
rotate_xlab <- input$rotate_xlab |
680 | ! |
count_threshold <- `if`(is.na(as.numeric(input$count_threshold)), 0, as.numeric(input$count_threshold)) |
681 | ! |
table_font_size <- input$table_font_size |
682 | ||
683 | ! |
median <- ifelse(input$stat == "median", TRUE, FALSE) |
684 | ! |
relative_height <- input$relative_height |
685 | ! |
trt_group <- input$trt_group |
686 | ! |
color_selected <- line_color_selected() |
687 | ! |
type_selected <- line_type_selected() |
688 | ! |
symbol_selected <- symbol_type_selected() |
689 | ! |
include_stat <- input$include_stat |
690 | ||
691 | ! |
param <- input$xaxis_param |
692 | ! |
xaxis <- input$xaxis_var |
693 | ! |
yaxis <- input$yaxis_var |
694 |
# nolint end |
|
695 | ||
696 | ! |
shape <- if (!(is.null(input$shape) || input$shape == "None")) { |
697 | ! |
input$shape |
698 |
} else { |
|
699 | ! |
NULL |
700 |
} |
|
701 | ||
702 | ! |
validate( |
703 | ! |
need( |
704 | ! |
nrow(anl_q()$ANL[stats::complete.cases(anl_q()$ANL[, c(yaxis, xaxis)]), ]) >= 2, |
705 | ! |
"Number of complete rows on x and y axis variables is less than 2" |
706 |
) |
|
707 |
) |
|
708 | ||
709 | ! |
private_qenv <- anl_q()$qenv |
710 | ||
711 | ! |
if (!methods::is(xtick, "waiver") && !is.null(xtick)) { |
712 | ! |
private_qenv <- teal.code::eval_code( |
713 | ! |
object = private_qenv, |
714 | ! |
code = bquote({ |
715 | ! |
keep_index <- which(.(xtick) %in% ANL[[.(xaxis)]]) |
716 | ! |
xtick <- (.(xtick))[keep_index] # extra parentheses needed for edge case, e.g. 1:5[keep_index] |
717 | ! |
xlabel <- (.(xlabel))[keep_index] |
718 |
}) |
|
719 |
) |
|
720 | ! |
} else if (methods::is(xtick, "waiver")) { |
721 | ! |
private_qenv <- teal.code::eval_code( |
722 | ! |
object = private_qenv, |
723 | ! |
code = " |
724 | ! |
xtick <- ggplot2::waiver() |
725 | ! |
xlabel <- ggplot2::waiver() |
726 |
" |
|
727 |
) |
|
728 |
} |
|
729 | ||
730 | ! |
hline_arb <- horizontal_line()$line_arb |
731 | ! |
hline_arb_label <- horizontal_line()$line_arb_label |
732 | ! |
hline_arb_color <- horizontal_line()$line_arb_color |
733 | ||
734 | ! |
teal.code::eval_code( |
735 | ! |
object = private_qenv, |
736 | ! |
code = bquote({ |
737 | ! |
p <- goshawk::g_lineplot( |
738 | ! |
data = ANL[stats::complete.cases(ANL[, c(.(yaxis), .(xaxis))]), ], |
739 | ! |
biomarker_var = .(param_var), |
740 | ! |
biomarker_var_label = .(param_var_label), |
741 | ! |
biomarker = .(param), |
742 | ! |
value_var = .(yaxis), |
743 | ! |
ylim = .(ylim), |
744 | ! |
trt_group = .(trt_group), |
745 | ! |
trt_group_level = .(trt_group_level), |
746 | ! |
shape = .(shape), |
747 | ! |
shape_type = .(symbol_selected), |
748 | ! |
time = .(xaxis), |
749 | ! |
time_level = .(xvar_level), |
750 | ! |
color_manual = .(color_selected), |
751 | ! |
line_type = .(type_selected), |
752 | ! |
median = .(median), |
753 | ! |
hline_arb = .(hline_arb), |
754 | ! |
hline_arb_label = .(hline_arb_label), |
755 | ! |
hline_arb_color = .(hline_arb_color), |
756 | ! |
xtick = .(if (!is.null(xtick)) quote(xtick) else xtick), |
757 | ! |
xlabel = .(if (!is.null(xtick)) quote(xlabel) else xlabel), |
758 | ! |
rotate_xlab = .(rotate_xlab), |
759 | ! |
plot_height = .(relative_height), # in g_lineplot this is relative height of plot to table |
760 | ! |
plot_font_size = .(plot_font_size), |
761 | ! |
dot_size = .(dot_size), |
762 | ! |
dodge = .(dodge), |
763 | ! |
count_threshold = .(count_threshold), |
764 | ! |
table_font_size = .(table_font_size), |
765 | ! |
display_center_tbl = .(include_stat) |
766 |
) |
|
767 | ! |
print(p) |
768 |
}) |
|
769 |
) |
|
770 |
}) |
|
771 | ||
772 | ! |
plot_r <- reactive(plot_q()[["p"]]) |
773 | ||
774 | ! |
plot_data <- teal.widgets::plot_with_settings_srv( |
775 | ! |
id = "plot", |
776 | ! |
plot_r = plot_r, |
777 | ! |
height = plot_height, |
778 | ! |
width = plot_width, |
779 |
) |
|
780 | ||
781 |
### REPORTER |
|
782 | ! |
if (with_reporter) { |
783 | ! |
card_fun <- function(comment, label) { |
784 | ! |
constraint_description <- paste( |
785 | ! |
"\nSelect Line Splitting Variable:", |
786 | ! |
if (!is.null(input$shape)) input$shape else "None", |
787 | ! |
"\nContributing Observations Threshold:", |
788 | ! |
input$count_threshold |
789 |
) |
|
790 | ! |
card <- report_card_template_goshawk( |
791 | ! |
title = "Line Plot", |
792 | ! |
label = label, |
793 | ! |
with_filter = with_filter, |
794 | ! |
filter_panel_api = filter_panel_api, |
795 | ! |
constraint_list = list( |
796 | ! |
constraint_var = input$constraint_var, |
797 | ! |
constraint_range_min = input$constraint_range_min, |
798 | ! |
constraint_range_max = input$constraint_range_max |
799 |
), |
|
800 | ! |
constraint_description = constraint_description, |
801 | ! |
style = "verbatim" |
802 |
) |
|
803 | ! |
card$append_text("Plot", "header3") |
804 | ! |
card$append_plot(plot_r(), dim = plot_data$dim()) |
805 | ! |
if (!comment == "") { |
806 | ! |
card$append_text("Comment", "header3") |
807 | ! |
card$append_text(comment) |
808 |
} |
|
809 | ! |
card$append_src(teal.code::get_code(plot_q())) |
810 | ! |
card |
811 |
} |
|
812 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
813 |
} |
|
814 |
### |
|
815 | ||
816 | ! |
teal.widgets::verbatim_popup_srv( |
817 | ! |
id = "rcode", |
818 | ! |
verbatim_content = reactive(teal.code::get_code(plot_q())), |
819 | ! |
title = "Show R Code for Line Plot" |
820 |
) |
|
821 |
}) |
|
822 |
} |
1 |
#' Spaghetti Plot |
|
2 |
#' |
|
3 |
#' This teal module renders the UI and calls the function |
|
4 |
#' that creates a spaghetti plot. |
|
5 |
#' |
|
6 |
#' @param label menu item label of the module in the teal app. |
|
7 |
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. |
|
8 |
#' E.g. `ADaM` structured laboratory data frame `ADLB`. |
|
9 |
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`. |
|
10 |
#' @param param biomarker selected. |
|
11 |
#' @param param_var_label single name of variable in analysis data |
|
12 |
#' that includes parameter labels. |
|
13 |
#' @param idvar name of unique subject id variable. |
|
14 |
#' @param xaxis_var single name of variable in analysis data |
|
15 |
#' that is used as x-axis in the plot for the respective goshawk function. |
|
16 |
#' @param xaxis_var_level vector that can be used to define the factor level of `xaxis_var`. |
|
17 |
#' Only use it when `xaxis_var` is character or factor. |
|
18 |
#' @param filter_var data constraint variable. |
|
19 |
#' @param yaxis_var single name of variable in analysis data that is used as |
|
20 |
#' summary variable in the respective `goshawk` function. |
|
21 |
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option |
|
22 |
#' for variable names representing treatment group e.g. `ARM`. |
|
23 |
#' @param trt_group_level vector that can be used to define factor |
|
24 |
#' level of `trt_group`. |
|
25 |
#' @param man_color string vector representing customized colors |
|
26 |
#' @param color_comb name or hex value for combined treatment color. |
|
27 |
#' @param xtick numeric vector to define the tick values of `x-axis` |
|
28 |
#' when x variable is numeric. Default value is `waive()`. |
|
29 |
#' @param xlabel vector with same length of `xtick` to define the |
|
30 |
#' label of `x-axis` tick values. Default value is `waive()`. |
|
31 |
#' @param rotate_xlab `logical(1)` value indicating whether to rotate `x-axis` labels |
|
32 |
#' @param facet_ncol numeric value indicating number of facets per row. |
|
33 |
#' @param free_x `logical(1)` should scales be `"fixed"` (`FALSE`) of `"free"` (`TRUE`) for `x-axis` in |
|
34 |
#' \code{\link[ggplot2]{facet_wrap}} \code{scales} parameter. |
|
35 |
#' @param plot_height controls plot height. |
|
36 |
#' @param plot_width optional, controls plot width. |
|
37 |
#' @param font_size control font size for title, `x-axis`, `y-axis` and legend font. |
|
38 |
#' @param dot_size plot dot size. |
|
39 |
#' @param group_stats control group mean or median overlay. |
|
40 |
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines. |
|
41 |
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}. |
|
42 |
#' naming the color for the arbitrary horizontal lines. |
|
43 |
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}. |
|
44 |
#' naming the label for the arbitrary horizontal lines. |
|
45 |
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines. |
|
46 |
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines. |
|
47 |
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear |
|
48 |
#' in the legend. |
|
49 |
#' @inheritParams teal.widgets::standard_layout |
|
50 |
#' |
|
51 |
#' @author Wenyi Liu (luiw2) wenyi.liu@roche.com |
|
52 |
#' @author Balazs Toth (tothb2) toth.balazs@gene.com |
|
53 |
#' |
|
54 |
#' @return \code{shiny} object |
|
55 |
#' |
|
56 |
#' @export |
|
57 |
#' |
|
58 |
#' @examples |
|
59 |
#' # Example using ADaM structure analysis dataset. |
|
60 |
#' data <- teal_data() |
|
61 |
#' data <- within(data, { |
|
62 |
#' library(dplyr) |
|
63 |
#' library(stringr) |
|
64 |
#' |
|
65 |
#' # use non-exported function from goshawk |
|
66 |
#' h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk") |
|
67 |
#' |
|
68 |
#' # original ARM value = dose value |
|
69 |
#' arm_mapping <- list( |
|
70 |
#' "A: Drug X" = "150mg QD", |
|
71 |
#' "B: Placebo" = "Placebo", |
|
72 |
#' "C: Combination" = "Combination" |
|
73 |
#' ) |
|
74 |
#' set.seed(1) |
|
75 |
#' ADSL <- rADSL |
|
76 |
#' ADLB <- rADLB |
|
77 |
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) |
|
78 |
#' ADLB <- ADLB %>% |
|
79 |
#' mutate( |
|
80 |
#' AVISITCD = case_when( |
|
81 |
#' AVISIT == "SCREENING" ~ "SCR", |
|
82 |
#' AVISIT == "BASELINE" ~ "BL", |
|
83 |
#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")), |
|
84 |
#' TRUE ~ as.character(NA) |
|
85 |
#' ), |
|
86 |
#' AVISITCDN = case_when( |
|
87 |
#' AVISITCD == "SCR" ~ -2, |
|
88 |
#' AVISITCD == "BL" ~ 0, |
|
89 |
#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), |
|
90 |
#' TRUE ~ as.numeric(NA) |
|
91 |
#' ), |
|
92 |
#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN), |
|
93 |
#' TRTORD = case_when( |
|
94 |
#' ARMCD == "ARM C" ~ 1, |
|
95 |
#' ARMCD == "ARM B" ~ 2, |
|
96 |
#' ARMCD == "ARM A" ~ 3 |
|
97 |
#' ), |
|
98 |
#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]), |
|
99 |
#' ARM = factor(ARM) %>% reorder(TRTORD), |
|
100 |
#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]), |
|
101 |
#' ACTARM = factor(ACTARM) %>% reorder(TRTORD), |
|
102 |
#' ANRLO = 30, |
|
103 |
#' ANRHI = 75 |
|
104 |
#' ) %>% |
|
105 |
#' rowwise() %>% |
|
106 |
#' group_by(PARAMCD) %>% |
|
107 |
#' mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE), |
|
108 |
#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC |
|
109 |
#' )) %>% |
|
110 |
#' mutate(LBSTRESC = ifelse(USUBJID %in% sample(USUBJID, 1, replace = TRUE), |
|
111 |
#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC |
|
112 |
#' )) %>% |
|
113 |
#' ungroup() |
|
114 |
#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] |
|
115 |
#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]] |
|
116 |
#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" |
|
117 |
#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" |
|
118 |
#' |
|
119 |
#' # add LLOQ and ULOQ variables |
|
120 |
#' ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL") |
|
121 |
#' ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM") |
|
122 |
#' }) |
|
123 |
#' |
|
124 |
#' datanames <- c("ADSL", "ADLB") |
|
125 |
#' datanames(data) <- datanames |
|
126 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
127 |
#' |
|
128 |
#' app <- init( |
|
129 |
#' data = data, |
|
130 |
#' modules = modules( |
|
131 |
#' tm_g_gh_spaghettiplot( |
|
132 |
#' label = "Spaghetti Plot", |
|
133 |
#' dataname = "ADLB", |
|
134 |
#' param_var = "PARAMCD", |
|
135 |
#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), |
|
136 |
#' idvar = "USUBJID", |
|
137 |
#' xaxis_var = choices_selected(c("Analysis Visit Code" = "AVISITCD"), "AVISITCD"), |
|
138 |
#' yaxis_var = choices_selected(c("AVAL", "CHG", "PCHG"), "AVAL"), |
|
139 |
#' filter_var = choices_selected( |
|
140 |
#' c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE"), |
|
141 |
#' "NONE" |
|
142 |
#' ), |
|
143 |
#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
144 |
#' color_comb = "#39ff14", |
|
145 |
#' man_color = c( |
|
146 |
#' "Combination" = "#000000", |
|
147 |
#' "Placebo" = "#fce300", |
|
148 |
#' "150mg QD" = "#5a2f5f" |
|
149 |
#' ), |
|
150 |
#' hline_arb = c(60, 50), |
|
151 |
#' hline_arb_color = c("grey", "red"), |
|
152 |
#' hline_arb_label = c("default A", "default B"), |
|
153 |
#' hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"), |
|
154 |
#' hline_vars_colors = c("pink", "brown", "purple", "black"), |
|
155 |
#' ) |
|
156 |
#' ) |
|
157 |
#' ) |
|
158 |
#' if (interactive()) { |
|
159 |
#' shinyApp(app$ui, app$server) |
|
160 |
#' } |
|
161 |
#' |
|
162 |
tm_g_gh_spaghettiplot <- function(label, |
|
163 |
dataname, |
|
164 |
param_var, |
|
165 |
param, |
|
166 |
param_var_label = "PARAM", |
|
167 |
idvar, |
|
168 |
xaxis_var, |
|
169 |
yaxis_var, |
|
170 |
xaxis_var_level = NULL, |
|
171 |
filter_var = yaxis_var, |
|
172 |
trt_group, |
|
173 |
trt_group_level = NULL, |
|
174 |
group_stats = "NONE", |
|
175 |
man_color = NULL, |
|
176 |
color_comb = NULL, |
|
177 |
xtick = ggplot2::waiver(), |
|
178 |
xlabel = xtick, |
|
179 |
rotate_xlab = FALSE, |
|
180 |
facet_ncol = 2, |
|
181 |
free_x = FALSE, |
|
182 |
plot_height = c(600, 200, 2000), |
|
183 |
plot_width = NULL, |
|
184 |
font_size = c(12, 8, 20), |
|
185 |
dot_size = c(2, 1, 12), |
|
186 |
hline_arb = numeric(0), |
|
187 |
hline_arb_color = "red", |
|
188 |
hline_arb_label = "Horizontal line", |
|
189 |
hline_vars = character(0), |
|
190 |
hline_vars_colors = "green", |
|
191 |
hline_vars_labels = hline_vars, |
|
192 |
pre_output = NULL, |
|
193 |
post_output = NULL) { |
|
194 | ! |
message("Initializing tm_g_gh_spaghettiplot") |
195 | ||
196 |
# Validate string inputs |
|
197 | ! |
checkmate::assert_string(label) |
198 | ! |
checkmate::assert_string(dataname) |
199 | ! |
checkmate::assert_string(param_var) |
200 | ! |
checkmate::assert_string(param_var_label) |
201 | ! |
checkmate::assert_string(idvar) |
202 | ! |
checkmate::assert_string(group_stats) |
203 | ||
204 |
# Validate choices_selected class inputs |
|
205 | ! |
checkmate::assert_class(param, "choices_selected") |
206 | ! |
checkmate::assert_class(xaxis_var, "choices_selected") |
207 | ! |
checkmate::assert_class(yaxis_var, "choices_selected") |
208 | ! |
checkmate::assert_class(trt_group, "choices_selected") |
209 | ||
210 |
# Validate flag inputs |
|
211 | ! |
checkmate::assert_flag(rotate_xlab) |
212 | ! |
checkmate::assert_flag(free_x) |
213 | ||
214 |
# Validate numeric vector inputs |
|
215 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
216 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
217 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
218 | ! |
checkmate::assert_numeric( |
219 | ! |
plot_width[1], |
220 | ! |
lower = plot_width[2], upper = plot_width[3], |
221 | ! |
null.ok = TRUE, .var.name = "plot_width" |
222 |
) |
|
223 | ! |
checkmate::assert_numeric(font_size, len = 3, any.missing = FALSE, finite = TRUE) |
224 | ! |
checkmate::assert_numeric(dot_size, len = 3, any.missing = FALSE, finite = TRUE) |
225 | ||
226 |
# Validate color manual if provided |
|
227 | ! |
checkmate::assert_character(man_color, null.ok = TRUE) |
228 | ! |
checkmate::assert_character(color_comb, null.ok = TRUE) |
229 | ! |
checkmate::assert_character(hline_arb_color) |
230 | ! |
checkmate::assert_character(hline_arb_label) |
231 | ||
232 |
# Validate facet columns |
|
233 | ! |
checkmate::assert_int(facet_ncol, lower = 1) |
234 | ||
235 |
# Validate line arguments |
|
236 | ! |
validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label) |
237 | ! |
validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels) |
238 | ||
239 | ! |
args <- as.list(environment()) |
240 | ||
241 | ! |
module( |
242 | ! |
label = label, |
243 | ! |
server = srv_g_spaghettiplot, |
244 | ! |
server_args = list( |
245 | ! |
dataname = dataname, |
246 | ! |
idvar = idvar, |
247 | ! |
param_var = param_var, |
248 | ! |
trt_group = trt_group, |
249 | ! |
xaxis_var_level = xaxis_var_level, |
250 | ! |
trt_group_level = trt_group_level, |
251 | ! |
man_color = man_color, |
252 | ! |
color_comb = color_comb, |
253 | ! |
param_var_label = param_var_label, |
254 | ! |
xtick = xtick, |
255 | ! |
xlabel = xlabel, |
256 | ! |
plot_height = plot_height, |
257 | ! |
plot_width = plot_width, |
258 | ! |
hline_vars_colors = hline_vars_colors, |
259 | ! |
hline_vars_labels = hline_vars_labels, |
260 | ! |
module_args = args |
261 |
), |
|
262 | ! |
ui = g_ui_spaghettiplot, |
263 | ! |
ui_args = args, |
264 | ! |
datanames = dataname |
265 |
) |
|
266 |
} |
|
267 | ||
268 |
g_ui_spaghettiplot <- function(id, ...) { |
|
269 | ! |
ns <- NS(id) |
270 | ! |
a <- list(...) |
271 | ||
272 | ! |
shiny::tagList( |
273 | ! |
include_css_files("custom"), |
274 | ! |
teal.widgets::standard_layout( |
275 | ! |
output = templ_ui_output_datatable(ns), |
276 | ! |
encoding = tags$div( |
277 |
### Reporter |
|
278 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
279 |
### |
|
280 | ! |
templ_ui_dataname(a$dataname), |
281 | ! |
teal.widgets::optionalSelectInput( |
282 | ! |
ns("trt_group"), |
283 | ! |
label = "Select Treatment Variable", |
284 | ! |
choices = get_choices(a$trt_group$choices), |
285 | ! |
selected = a$trt_group$selected, |
286 | ! |
multiple = FALSE |
287 |
), |
|
288 | ! |
uiOutput(ns("axis_selections")), |
289 | ! |
radioButtons( |
290 | ! |
ns("group_stats"), |
291 | ! |
"Group Statistics", |
292 | ! |
c("None" = "NONE", "Mean" = "MEAN", "Median" = "MEDIAN"), |
293 | ! |
inline = TRUE |
294 |
), |
|
295 | ! |
templ_ui_constraint(ns), # required by constr_anl_q |
296 | ! |
if (length(a$hline_vars) > 0) { |
297 | ! |
teal.widgets::optionalSelectInput( |
298 | ! |
ns("hline_vars"), |
299 | ! |
label = "Add Horizontal Range Line(s):", |
300 | ! |
choices = a$hline_vars, |
301 | ! |
selected = NULL, |
302 | ! |
multiple = TRUE |
303 |
) |
|
304 |
}, |
|
305 | ! |
ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color), |
306 | ! |
teal.widgets::panel_group( |
307 | ! |
teal.widgets::panel_item( |
308 | ! |
title = "Plot Aesthetic Settings", |
309 | ! |
tags$div( |
310 | ! |
toggle_slider_ui( |
311 | ! |
ns("yrange_scale"), |
312 | ! |
label = "Y-Axis Range Zoom", |
313 | ! |
min = -1000000, |
314 | ! |
max = 1000000, |
315 | ! |
value = c(-1000000, 1000000) |
316 |
), |
|
317 | ! |
tags$div( |
318 | ! |
class = "flex flex-wrap items-center", |
319 | ! |
tags$div( |
320 | ! |
class = "mr-1", |
321 | ! |
tags$span(tags$strong("Number of Plots Per Row:")) |
322 |
), |
|
323 | ! |
tags$div( |
324 | ! |
class = "w-65px", |
325 | ! |
numericInput(ns("facet_ncol"), "", a$facet_ncol, min = 1) |
326 |
) |
|
327 |
) |
|
328 |
), |
|
329 | ! |
checkboxInput(ns("free_x"), "Free X-Axis Scales", a$free_x), |
330 | ! |
checkboxInput(ns("rotate_xlab"), "Rotate X-Axis Label", a$rotate_xlab), |
331 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE), |
332 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE), |
333 | ! |
teal.widgets::optionalSliderInputValMinMax( |
334 | ! |
ns("alpha"), |
335 | ! |
"Line Alpha", |
336 | ! |
a$alpha, |
337 | ! |
value_min_max = c(0.8, 0.0, 1.0), step = 0.1, ticks = FALSE |
338 |
) |
|
339 |
) |
|
340 |
) |
|
341 |
), |
|
342 | ! |
forms = tagList( |
343 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
344 |
), |
|
345 | ! |
pre_output = a$pre_output, |
346 | ! |
post_output = a$post_output |
347 |
) |
|
348 |
) |
|
349 |
} |
|
350 | ||
351 | ||
352 | ||
353 |
srv_g_spaghettiplot <- function(id, |
|
354 |
data, |
|
355 |
reporter, |
|
356 |
filter_panel_api, |
|
357 |
dataname, |
|
358 |
idvar, |
|
359 |
param_var, |
|
360 |
trt_group, |
|
361 |
man_color, |
|
362 |
color_comb, |
|
363 |
xaxis_var_level, |
|
364 |
trt_group_level, |
|
365 |
param_var_label, |
|
366 |
xtick, |
|
367 |
xlabel, |
|
368 |
plot_height, |
|
369 |
plot_width, |
|
370 |
hline_vars_colors, |
|
371 |
hline_vars_labels, |
|
372 |
module_args) { |
|
373 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
374 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
375 | ! |
checkmate::assert_class(data, "reactive") |
376 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
377 | ||
378 | ! |
moduleServer(id, function(input, output, session) { |
379 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
380 | ! |
output$axis_selections <- renderUI({ |
381 | ! |
env <- shiny::isolate(as.list(data()@env)) |
382 | ! |
resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env) |
383 | ! |
resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env) |
384 | ! |
resolved_param <- teal.transform::resolve_delayed(module_args$param, env) |
385 | ! |
templ_ui_params_vars( |
386 | ! |
session$ns, |
387 |
# xparam and yparam are identical, so we only show the user one |
|
388 | ! |
xparam_choices = resolved_param$choices, |
389 | ! |
xparam_selected = resolved_param$selected, |
390 | ! |
xparam_label = "Select a Biomarker", |
391 | ! |
xchoices = resolved_x$choices, |
392 | ! |
xselected = resolved_x$selected, |
393 | ! |
ychoices = resolved_y$choices, |
394 | ! |
yselected = resolved_y$selected |
395 |
) |
|
396 |
}) |
|
397 | ||
398 |
# reused in all modules |
|
399 | ! |
anl_q_output <- constr_anl_q( |
400 | ! |
session, input, data, dataname, |
401 | ! |
param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1 |
402 |
) |
|
403 | ||
404 | ! |
anl_q <- anl_q_output()$value |
405 | ||
406 |
# update sliders for axes taking constraints into account |
|
407 | ! |
yrange_slider <- toggle_slider_server("yrange_scale") |
408 | ! |
keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q) |
409 | ! |
keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") |
410 | ||
411 | ! |
horizontal_line <- srv_arbitrary_lines("hline_arb") |
412 | ||
413 | ! |
iv_r <- reactive({ |
414 | ! |
iv <- shinyvalidate::InputValidator$new() |
415 | ||
416 | ! |
iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker")) |
417 | ! |
iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable")) |
418 | ! |
iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable")) |
419 | ! |
iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable")) |
420 | ! |
iv$add_rule("facet_ncol", plots_per_row_validate_rules()) |
421 | ||
422 | ! |
iv$add_validator(horizontal_line()$iv_r()) |
423 | ! |
iv$add_validator(anl_q_output()$iv_r()) |
424 | ! |
iv$enable() |
425 | ! |
iv |
426 |
}) |
|
427 | ||
428 | ||
429 | ! |
plot_q <- reactive({ |
430 | ! |
teal::validate_inputs(iv_r()) |
431 | ! |
req(anl_q()) |
432 |
# nolint start |
|
433 | ! |
ylim <- yrange_slider$state()$value |
434 | ! |
facet_ncol <- input$facet_ncol |
435 | ! |
facet_scales <- ifelse(input$free_x, "free_x", "fixed") |
436 | ||
437 | ! |
rotate_xlab <- input$rotate_xlab |
438 | ! |
hline_arb <- horizontal_line()$line_arb |
439 | ! |
hline_arb_label <- horizontal_line()$line_arb_label |
440 | ! |
hline_arb_color <- horizontal_line()$line_arb_color |
441 | ! |
group_stats <- input$group_stats |
442 | ! |
font_size <- input$font_size |
443 | ! |
dot_size <- input$dot_size |
444 | ! |
alpha <- input$alpha |
445 | ! |
validate(need(input$trt_group, "Please select a treatment variable")) |
446 | ! |
trt_group <- input$trt_group |
447 | ||
448 |
# Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs |
|
449 | ! |
param <- input$xaxis_param |
450 | ! |
xaxis_var <- input$xaxis_var |
451 | ! |
yaxis_var <- input$yaxis_var |
452 | ! |
hline_vars <- input$hline_vars |
453 |
# nolint end |
|
454 | ||
455 | ! |
private_qenv <- anl_q()$qenv |
456 | ||
457 |
# this code is needed to make sure the waiver attribute |
|
458 |
# of ggplot2::waiver is correctly passed to goshawk's spaghettiplot |
|
459 | ! |
if (!methods::is(xtick, "waiver")) { |
460 | ! |
private_qenv <- teal.code::eval_code( |
461 | ! |
object = private_qenv, |
462 | ! |
code = bquote(xtick <- .(xtick)) |
463 |
) |
|
464 |
} else { |
|
465 | ! |
private_qenv <- teal.code::eval_code( |
466 | ! |
object = private_qenv, |
467 | ! |
code = quote(xtick <- ggplot2::waiver()) |
468 |
) |
|
469 |
} |
|
470 | ||
471 | ! |
if (!methods::is(xlabel, "waiver")) { |
472 | ! |
private_qenv <- teal.code::eval_code( |
473 | ! |
object = private_qenv, |
474 | ! |
code = bquote(xlabel <- .(xlabel)) |
475 |
) |
|
476 |
} else { |
|
477 | ! |
private_qenv <- teal.code::eval_code( |
478 | ! |
object = private_qenv, |
479 | ! |
code = quote(xlabel <- ggplot2::waiver()) |
480 |
) |
|
481 |
} |
|
482 | ||
483 | ! |
teal.code::eval_code( |
484 | ! |
object = private_qenv, |
485 | ! |
code = bquote({ |
486 | ! |
p <- goshawk::g_spaghettiplot( |
487 | ! |
data = ANL, |
488 | ! |
subj_id = .(idvar), |
489 | ! |
biomarker_var = .(param_var), |
490 | ! |
biomarker_var_label = .(param_var_label), |
491 | ! |
biomarker = .(param), |
492 | ! |
value_var = .(yaxis_var), |
493 | ! |
trt_group = .(trt_group), |
494 | ! |
trt_group_level = .(trt_group_level), |
495 | ! |
time = .(xaxis_var), |
496 | ! |
time_level = .(xaxis_var_level), |
497 | ! |
color_manual = .(man_color), |
498 | ! |
color_comb = .(color_comb), |
499 | ! |
ylim = .(ylim), |
500 | ! |
facet_ncol = .(facet_ncol), |
501 | ! |
facet_scales = .(facet_scales), |
502 | ! |
hline_arb = .(hline_arb), |
503 | ! |
hline_arb_label = .(hline_arb_label), |
504 | ! |
hline_arb_color = .(hline_arb_color), |
505 | ! |
xtick = xtick, |
506 | ! |
xlabel = xlabel, |
507 | ! |
rotate_xlab = .(rotate_xlab), |
508 | ! |
font_size = .(font_size), |
509 | ! |
dot_size = .(dot_size), |
510 | ! |
alpha = .(alpha), |
511 | ! |
group_stats = .(group_stats), |
512 | ! |
hline_vars = .(hline_vars), |
513 | ! |
hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]), |
514 | ! |
hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)]) |
515 |
) |
|
516 | ! |
print(p) |
517 |
}) |
|
518 |
) |
|
519 |
}) |
|
520 | ||
521 | ! |
plot_r <- reactive({ |
522 | ! |
plot_q()[["p"]] |
523 |
}) |
|
524 | ||
525 | ! |
plot_data <- teal.widgets::plot_with_settings_srv( |
526 | ! |
id = "plot", |
527 | ! |
plot_r = plot_r, |
528 | ! |
height = plot_height, |
529 | ! |
width = plot_width, |
530 | ! |
brushing = TRUE |
531 |
) |
|
532 | ||
533 |
### REPORTER |
|
534 | ! |
if (with_reporter) { |
535 | ! |
card_fun <- function(comment, label) { |
536 | ! |
card <- report_card_template_goshawk( |
537 | ! |
title = "Spaghetti Plot", |
538 | ! |
label = label, |
539 | ! |
with_filter = with_filter, |
540 | ! |
filter_panel_api = filter_panel_api, |
541 | ! |
constraint_list = list( |
542 | ! |
constraint_var = input$constraint_var, |
543 | ! |
constraint_range_min = input$constraint_range_min, |
544 | ! |
constraint_range_max = input$constraint_range_max |
545 |
) |
|
546 |
) |
|
547 | ! |
card$append_text("Spaghetti Plot", "header3") |
548 | ! |
card$append_plot(plot_r(), dim = plot_data$dim()) |
549 | ! |
if (!comment == "") { |
550 | ! |
card$append_text("Comment", "header3") |
551 | ! |
card$append_text(comment) |
552 |
} |
|
553 | ! |
card$append_src(teal.code::get_code(plot_q())) |
554 | ! |
card |
555 |
} |
|
556 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
557 |
} |
|
558 |
### |
|
559 | ||
560 | ! |
output$brush_data <- DT::renderDataTable({ |
561 | ! |
plot_brush <- plot_data$brush() |
562 | ||
563 | ! |
ANL <- isolate(anl_q()$ANL) # nolint |
564 | ! |
validate_has_data(ANL, 1) |
565 | ||
566 | ! |
xvar <- isolate(input$xaxis_var) |
567 | ! |
yvar <- isolate(input$yaxis_var) |
568 | ! |
trt_group <- isolate(input$trt_group) |
569 | ||
570 | ! |
req(all(c(xvar, yvar) %in% names(ANL))) |
571 | ||
572 | ! |
df <- teal.widgets::clean_brushedPoints( |
573 | ! |
dplyr::select( |
574 | ! |
ANL, "USUBJID", dplyr::all_of(trt_group), "PARAMCD", |
575 | ! |
dplyr::all_of(c(xvar, yvar)), "LOQFL" |
576 |
), |
|
577 | ! |
plot_brush |
578 |
) |
|
579 | ! |
df <- df[order(df$PARAMCD, df[[trt_group]], df$USUBJID, df[[xvar]]), ] |
580 | ! |
numeric_cols <- names(dplyr::select_if(df, is.numeric)) |
581 | ||
582 | ! |
DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>% |
583 | ! |
DT::formatRound(numeric_cols, 4) |
584 |
}) |
|
585 | ||
586 | ! |
teal.widgets::verbatim_popup_srv( |
587 | ! |
id = "rcode", |
588 | ! |
verbatim_content = reactive(teal.code::get_code(plot_q())), |
589 | ! |
title = "Show R Code for Spaghetti Plot" |
590 |
) |
|
591 |
}) |
|
592 |
} |
1 |
templ_ui_constraint <- function(ns, label = "Data Constraint") { |
|
2 | ! |
tags$div( |
3 | ! |
id = ns("constraint_var_whole"), # give an id to hide it |
4 | ! |
radioButtons(ns("constraint_var"), label, choices = "NONE"), |
5 | ! |
shinyjs::hidden(tags$div( |
6 | ! |
id = ns("constraint_range"), |
7 | ! |
tags$div( |
8 | ! |
class = "inline-block;", |
9 | ! |
numericInput(ns("constraint_range_min"), label = "Min", value = 0, min = 0, max = 0) |
10 |
), |
|
11 | ! |
tags$div( |
12 | ! |
class = "inline-block;", |
13 | ! |
numericInput(ns("constraint_range_max"), label = "Min", value = 0, min = 0, max = 0) |
14 |
) |
|
15 |
)), |
|
16 | ! |
shinyjs::hidden(tags$div( |
17 | ! |
id = ns("all_na"), |
18 | ! |
helpText("All values are missing (NA)") |
19 |
)) |
|
20 |
) |
|
21 |
} |
|
22 | ||
23 |
keep_data_const_opts_updated <- function(session, input, data, id_param_var) { |
|
24 |
# use reactiveVal so that it only updates when options actually changed and not just data |
|
25 | ! |
choices <- reactiveVal() |
26 | ! |
observeEvent(data(), { |
27 | ! |
paramname <- input[[id_param_var]] |
28 | ! |
req(length(paramname) == 1) |
29 | ||
30 | ! |
data_filtered <- data()$ANL %>% dplyr::filter(.data$PARAMCD == paramname) |
31 | ! |
choices(c("None" = "NONE", "Screening" = "BASE2", "Baseline" = "BASE")[ |
32 | ! |
c(TRUE, !all(is.na(data_filtered[["BASE2"]])), !all(is.na(data_filtered[["BASE"]]))) |
33 |
]) |
|
34 |
}) |
|
35 | ! |
observeEvent(choices(), { |
36 | ! |
updateRadioButtons(session, "constraint_var", choices = choices()) |
37 |
# hide when only one option "NONE" |
|
38 | ! |
if (length(choices()) == 1) { |
39 | ! |
shinyjs::hide("constraint_var_whole") |
40 |
} else { |
|
41 | ! |
shinyjs::show("constraint_var_whole") |
42 |
} |
|
43 |
}) |
|
44 |
} |
|
45 | ||
46 | ||
47 | ||
48 | ||
49 |
# param_id: input id that contains values of PARAMCD to filter for |
|
50 |
# param_var: currently only "PARAMCD" is supported |
|
51 |
constr_anl_q <- function(session, input, data, dataname, param_id, param_var, trt_group, min_rows) { |
|
52 | ! |
checkmate::assert_class(data, "reactive") |
53 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
54 | ! |
dataset_var <- dataname |
55 | ! |
if (!identical(param_var, "PARAMCD")) { |
56 |
# why is there a variable param_id which is provided to this function and always equal to "param"? |
|
57 | ! |
stop("param_var must be 'PARAMCD'. Otherwise, we cannot currently guarantee the correctness of the code.") |
58 |
} |
|
59 | ||
60 | ! |
anl_param <- reactive({ |
61 | ! |
param_var_value <- input[[param_id]] # value to filter PARAMCD for |
62 | ! |
validate(need(param_var_value, "Please select a biomarker")) |
63 | ! |
checkmate::assert_string(param_var_value) |
64 | ||
65 | ! |
ANL <- data()[[dataname]] # nolint |
66 | ! |
validate_has_data(ANL, min_rows) |
67 | ||
68 | ! |
validate_has_variable(ANL, param_var) |
69 | ! |
validate_has_variable(ANL, "AVISITCD") |
70 | ! |
validate_has_variable(ANL, "BASE") |
71 | ! |
validate_has_variable(ANL, "BASE2") |
72 | ! |
validate_has_variable(ANL, trt_group) |
73 | ||
74 |
# analysis |
|
75 | ! |
private_qenv <- data() %>% |
76 | ! |
teal.code::eval_code( |
77 | ! |
substitute(ANL <- dataname, list(dataname = as.name(dataname))) # nolint |
78 |
) %>% |
|
79 | ! |
teal.code::eval_code( |
80 | ! |
code = bquote({ |
81 | ! |
ANL <- .(as.name(dataset_var)) %>% # nolint |
82 | ! |
dplyr::filter(.(as.name(param_var)) == .(param_var_value)) |
83 |
}) |
|
84 |
) |
|
85 | ! |
validate_has_data(private_qenv[["ANL"]], min_rows) |
86 | ! |
list(ANL = ANL, qenv = private_qenv) |
87 |
}) |
|
88 | ||
89 | ! |
observe({ |
90 | ! |
param_var_value <- input[[param_id]] |
91 | ! |
validate(need(param_var_value, "Please select a biomarker")) |
92 | ||
93 | ! |
constraint_var <- input[["constraint_var"]] |
94 | ! |
validate(need(constraint_var, "select a constraint variable")) |
95 | ||
96 | ! |
ANL <- data()[[dataname]] # nolint |
97 | ! |
validate_has_data(ANL, min_rows) |
98 | ||
99 | ! |
validate_has_variable(ANL, param_var) |
100 | ! |
validate_has_variable(ANL, "AVISITCD") |
101 | ! |
validate_has_variable(ANL, "BASE") |
102 | ! |
validate_has_variable(ANL, "BASE2") |
103 | ||
104 | ! |
ANL <- ANL %>% dplyr::filter(!!sym(param_var) == param_var_value) # nolint |
105 | ||
106 | ! |
visit_freq <- unique(ANL$AVISITCD) |
107 | ||
108 |
# get min max values |
|
109 | ! |
if ((constraint_var == "BASE2" && any(grepl("SCR", visit_freq))) || |
110 | ! |
(constraint_var == "BASE" && any(grepl("BL", visit_freq)))) { # nolint |
111 | ! |
val <- stats::na.omit(switch(constraint_var, |
112 | ! |
"BASE" = ANL$BASE[ANL$AVISITCD == "BL"], |
113 | ! |
"BASE2" = ANL$BASE2[ANL$AVISITCD == "SCR"], |
114 | ! |
stop(paste(constraint_var, "not allowed")) |
115 |
)) |
|
116 | ||
117 | ! |
if (length(val) == 0 || all(is.na(val))) { |
118 | ! |
shinyjs::show("all_na") |
119 | ! |
shinyjs::hide("constraint_range") |
120 | ! |
args <- list( |
121 | ! |
min = list(label = "Min", min = 0, max = 0, value = 0), |
122 | ! |
max = list(label = "Max", min = 0, max = 0, value = 0) |
123 |
) |
|
124 | ! |
update_min_max(session, args) |
125 |
} else { |
|
126 | ! |
rng <- range(val, na.rm = TRUE) |
127 | ||
128 | ! |
minmax <- c(floor(rng[1] * 1000) / 1000, ceiling(rng[2] * 1000) / 1000) |
129 | ||
130 | ! |
label_min <- sprintf("Min (%s)", minmax[1]) |
131 | ! |
label_max <- sprintf("Max (%s)", minmax[2]) |
132 | ||
133 | ! |
args <- list( |
134 | ! |
min = list(label = label_min, min = minmax[1], max = minmax[2], value = minmax[1]), |
135 | ! |
max = list(label = label_max, min = minmax[1], max = minmax[2], value = minmax[2]) |
136 |
) |
|
137 | ||
138 | ! |
update_min_max(session, args) |
139 | ! |
shinyjs::show("constraint_range") # update before show |
140 | ! |
shinyjs::hide("all_na") |
141 |
} |
|
142 | ! |
} else if (constraint_var == "NONE") { |
143 | ! |
shinyjs::hide("constraint_range") # hide before update |
144 | ! |
shinyjs::hide("all_na") |
145 | ||
146 |
# force update (and thus refresh) on different constraint_var -> pass unique value for each constraint_var name |
|
147 | ! |
args <- list( |
148 | ! |
min = list(label = "Min", min = 0, max = 0, value = 0), |
149 | ! |
max = list(label = "Max", min = 0, max = 0, value = 0) |
150 |
) |
|
151 | ||
152 | ! |
update_min_max(session, args) |
153 |
} else { |
|
154 | ! |
validate(need(FALSE, "This is an invalid data contraint for the filtered data")) |
155 |
} |
|
156 |
}) |
|
157 | ||
158 | ! |
anl_constraint <- create_anl_constraint_reactive(anl_param, input, param_id = param_id, min_rows = min_rows) |
159 | ||
160 | ! |
return(anl_constraint) |
161 |
} |
|
162 | ||
163 |
# returns a reactive that applies the `x-axis data constraint` |
|
164 |
# More precisely, all patients are filtered out that do not have the range of |
|
165 |
# `param_id.constraint_var` in the specified range |
|
166 |
# constraint var means that `param_id.constraint_var` is constrained to the filtered range (or NA), |
|
167 |
# e.g. `ALT.BASE2` (i.e. `PARAMCD = ALT & range_filter_on(BASE2)`) |
|
168 |
create_anl_constraint_reactive <- function(anl_param, input, param_id, min_rows) { |
|
169 | ! |
iv_r <- reactive({ |
170 | ! |
iv <- shinyvalidate::InputValidator$new() |
171 | ! |
iv$condition(~ isTRUE(input$constraint_var != "NONE")) |
172 | ! |
iv$add_rule("constraint_range_min", shinyvalidate::sv_required("A contraint minimum value is required")) |
173 | ! |
iv$add_rule("constraint_range_max", shinyvalidate::sv_required("A contraint maximum value is required")) |
174 | ! |
iv$add_rule( |
175 | ! |
"constraint_range_min", |
176 | ! |
~ if (!is.na(input$constraint_range_max) && (.) > input$constraint_range_max) { |
177 | ! |
"constraint min needs to be less than max" |
178 |
} |
|
179 |
) |
|
180 | ! |
iv$add_rule( |
181 | ! |
"constraint_range_max", |
182 | ! |
~ if (!is.na(input$constraint_range_min) && (.) < input$constraint_range_min) { |
183 | ! |
"constraint min needs to be less than max" |
184 |
} |
|
185 |
) |
|
186 | ! |
iv |
187 |
}) |
|
188 | ||
189 | ||
190 | ! |
return_val <- reactive({ |
191 | ! |
private_qenv <- anl_param()$qenv |
192 | ||
193 |
# it is assumed that constraint_var is triggering constraint_range which then trigger this clause |
|
194 | ! |
constraint_var <- isolate(input[["constraint_var"]]) |
195 | ! |
constraint_range_min <- input[["constraint_range_min"]] |
196 | ! |
constraint_range_max <- input[["constraint_range_max"]] |
197 | ! |
param <- input[[param_id]] |
198 | ! |
req(param) |
199 | ||
200 |
# filter constraint |
|
201 | ! |
if (constraint_var != "NONE") { |
202 | ! |
private_qenv <- teal.code::eval_code( |
203 | ! |
object = private_qenv, |
204 | ! |
code = bquote({ |
205 |
# the below includes patients who have at least one non-NA BASE value |
|
206 |
# ideally, a patient should either have all NA values or none at all |
|
207 |
# this could be achieved through preprocessing; otherwise, this is easily overseen |
|
208 | ! |
filtered_usubjids <- ANL %>% # nolint |
209 | ! |
dplyr::filter( |
210 | ! |
PARAMCD == .(param), |
211 | ! |
(.(constraint_range_min) <= .data[[.(constraint_var)]]) & |
212 | ! |
(.data[[.(constraint_var)]] <= .(constraint_range_max)) |
213 |
) %>% |
|
214 | ! |
dplyr::pull(USUBJID) |
215 |
# include patients with all NA values for constraint_var |
|
216 | ! |
filtered_usubjids <- c( |
217 | ! |
filtered_usubjids, |
218 | ! |
ANL %>% |
219 | ! |
dplyr::filter(PARAMCD == .(param)) %>% |
220 | ! |
dplyr::group_by(USUBJID) %>% |
221 | ! |
dplyr::summarize(all_na = all(is.na(.data[[.(constraint_var)]]))) %>% |
222 | ! |
dplyr::filter(all_na) %>% |
223 | ! |
dplyr::pull(USUBJID) |
224 |
) |
|
225 | ! |
ANL <- ANL %>% dplyr::filter(USUBJID %in% filtered_usubjids) # nolint |
226 |
}) |
|
227 |
) |
|
228 | ! |
validate_has_data(private_qenv[["ANL"]], min_rows) |
229 |
} |
|
230 | ! |
list(ANL = private_qenv[["ANL"]], qenv = private_qenv) |
231 |
}) |
|
232 | ||
233 | ! |
reactive( |
234 | ! |
list( |
235 | ! |
value = return_val, |
236 | ! |
iv_r = iv_r |
237 |
) |
|
238 |
) |
|
239 |
} |
|
240 | ||
241 |
# for outputting the constraint in the report |
|
242 |
formatted_data_constraint <- function(constraint_var, constraint_range_min, constraint_range_max) { |
|
243 | ! |
constraint_var_label <- switch(constraint_var, |
244 | ! |
"BASE2" = "Screening", |
245 | ! |
"BASE" = "Baseline", |
246 | ! |
"None" |
247 |
) |
|
248 | ! |
msg <- paste("Data Constraint:", constraint_var_label) |
249 | ! |
if (constraint_var_label != "None") { |
250 | ! |
msg <- paste(msg, "from", constraint_range_min, "to", constraint_range_max) |
251 |
} |
|
252 | ! |
msg |
253 |
} |
|
254 | ||
255 |
update_min_max <- function(session, args) { |
|
256 | ! |
do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_min"), args$min)) |
257 | ! |
do.call("updateNumericInput", c(list(session = session, inputId = "constraint_range_max"), args$max)) |
258 |
} |
1 |
#' Box Plot |
|
2 |
#' |
|
3 |
#' This teal module renders the UI and calls the functions that create a box plot and accompanying |
|
4 |
#' summary table. |
|
5 |
#' |
|
6 |
#' @param label menu item label of the module in the teal app. |
|
7 |
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured |
|
8 |
#' laboratory data frame `ALB`. |
|
9 |
#' @param param_var name of variable containing biomarker codes e.g. `PARAMCD`. |
|
10 |
#' @param param list of biomarkers of interest. |
|
11 |
#' @param yaxis_var name of variable containing biomarker results displayed on y-axis e.g. `AVAL`. When not provided, |
|
12 |
#' it defaults to `choices_selected(c("AVAL", "CHG"), "AVAL")`. |
|
13 |
#' @param xaxis_var variable to categorize the x-axis. When not provided, it defaults to |
|
14 |
#' `choices_selected("AVISITCD", "AVISITCD")`. |
|
15 |
#' @param facet_var variable to facet the plots by. When not provided, it defaults to |
|
16 |
#' `choices_selected(c("ARM", "ACTARM"), "ARM")`. |
|
17 |
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected |
|
18 |
#' option for variable names representing treatment group e.g. `ARM`. |
|
19 |
#' @param color_manual vector of colors applied to treatment values. |
|
20 |
#' @param shape_manual vector of symbols applied to `LOQ` values. |
|
21 |
#' @param facet_ncol numeric value indicating number of facets per row. |
|
22 |
#' @param loq_legend `loq` legend toggle. |
|
23 |
#' @param rotate_xlab 45 degree rotation of `x-axis` values. |
|
24 |
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines. |
|
25 |
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}. |
|
26 |
#' naming the color for the arbitrary horizontal lines. |
|
27 |
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}. |
|
28 |
#' naming the label for the arbitrary horizontal lines. |
|
29 |
#' @param hline_vars a character vector to name the columns that will define additional horizontal lines. |
|
30 |
#' @param hline_vars_colors a character vector naming the colors for the additional horizontal lines. |
|
31 |
#' @param hline_vars_labels a character vector naming the labels for the additional horizontal lines that will appear |
|
32 |
#' in the legend. |
|
33 |
#' @param plot_height controls plot height. |
|
34 |
#' @param plot_width optional, controls plot width. |
|
35 |
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend. |
|
36 |
#' @param dot_size plot dot size. |
|
37 |
#' @param alpha numeric vector to define transparency of plotted points. |
|
38 |
#' |
|
39 |
#' @inheritParams teal.widgets::standard_layout |
|
40 |
#' |
|
41 |
#' @author Jeff Tomlinson (tomlinsj) jeffrey.tomlinson@roche.com |
|
42 |
#' @author Balazs Toth (tothb2) toth.balazs@gene.com |
|
43 |
#' |
|
44 |
#' @return an \code{\link[teal]{module}} object |
|
45 |
#' |
|
46 |
#' @export |
|
47 |
#' |
|
48 |
#' @examples |
|
49 |
#' # Example using ADaM structure analysis dataset. |
|
50 |
#' data <- teal_data() |
|
51 |
#' data <- within(data, { |
|
52 |
#' library(dplyr) |
|
53 |
#' library(nestcolor) |
|
54 |
#' library(stringr) |
|
55 |
#' |
|
56 |
#' # use non-exported function from goshawk |
|
57 |
#' h_identify_loq_values <- getFromNamespace("h_identify_loq_values", "goshawk") |
|
58 |
#' |
|
59 |
#' # original ARM value = dose value |
|
60 |
#' arm_mapping <- list( |
|
61 |
#' "A: Drug X" = "150mg QD", |
|
62 |
#' "B: Placebo" = "Placebo", |
|
63 |
#' "C: Combination" = "Combination" |
|
64 |
#' ) |
|
65 |
#' set.seed(1) |
|
66 |
#' ADSL <- rADSL |
|
67 |
#' ADLB <- rADLB |
|
68 |
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) |
|
69 |
#' ADLB <- ADLB %>% |
|
70 |
#' mutate( |
|
71 |
#' AVISITCD = case_when( |
|
72 |
#' AVISIT == "SCREENING" ~ "SCR", |
|
73 |
#' AVISIT == "BASELINE" ~ "BL", |
|
74 |
#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")), |
|
75 |
#' TRUE ~ as.character(NA) |
|
76 |
#' ), |
|
77 |
#' AVISITCDN = case_when( |
|
78 |
#' AVISITCD == "SCR" ~ -2, |
|
79 |
#' AVISITCD == "BL" ~ 0, |
|
80 |
#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), |
|
81 |
#' TRUE ~ as.numeric(NA) |
|
82 |
#' ), |
|
83 |
#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN), |
|
84 |
#' TRTORD = case_when( |
|
85 |
#' ARMCD == "ARM C" ~ 1, |
|
86 |
#' ARMCD == "ARM B" ~ 2, |
|
87 |
#' ARMCD == "ARM A" ~ 3 |
|
88 |
#' ), |
|
89 |
#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]), |
|
90 |
#' ARM = factor(ARM) %>% reorder(TRTORD), |
|
91 |
#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]), |
|
92 |
#' ACTARM = factor(ACTARM) %>% reorder(TRTORD), |
|
93 |
#' ANRLO = 50, |
|
94 |
#' ANRHI = 75 |
|
95 |
#' ) %>% |
|
96 |
#' rowwise() %>% |
|
97 |
#' group_by(PARAMCD) %>% |
|
98 |
#' mutate(LBSTRESC = ifelse( |
|
99 |
#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), |
|
100 |
#' paste("<", round(runif(1, min = 25, max = 30))), LBSTRESC |
|
101 |
#' )) %>% |
|
102 |
#' mutate(LBSTRESC = ifelse( |
|
103 |
#' USUBJID %in% sample(USUBJID, 1, replace = TRUE), |
|
104 |
#' paste(">", round(runif(1, min = 70, max = 75))), LBSTRESC |
|
105 |
#' )) %>% |
|
106 |
#' ungroup() |
|
107 |
#' |
|
108 |
#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] |
|
109 |
#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]] |
|
110 |
#' attr(ADLB[["ANRLO"]], "label") <- "Analysis Normal Range Lower Limit" |
|
111 |
#' attr(ADLB[["ANRHI"]], "label") <- "Analysis Normal Range Upper Limit" |
|
112 |
#' |
|
113 |
#' # add LLOQ and ULOQ variables |
|
114 |
#' ALB_LOQS <- h_identify_loq_values(ADLB, "LOQFL") |
|
115 |
#' ADLB <- left_join(ADLB, ALB_LOQS, by = "PARAM") |
|
116 |
#' }) |
|
117 |
#' |
|
118 |
#' datanames <- c("ADSL", "ADLB") |
|
119 |
#' datanames(data) <- datanames |
|
120 |
#' |
|
121 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
122 |
#' |
|
123 |
#' app <- init( |
|
124 |
#' data = data, |
|
125 |
#' modules = modules( |
|
126 |
#' tm_g_gh_boxplot( |
|
127 |
#' label = "Box Plot", |
|
128 |
#' dataname = "ADLB", |
|
129 |
#' param_var = "PARAMCD", |
|
130 |
#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), |
|
131 |
#' yaxis_var = choices_selected(c("AVAL", "BASE", "CHG"), "AVAL"), |
|
132 |
#' xaxis_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "STUDYID"), "ARM"), |
|
133 |
#' facet_var = choices_selected(c("ACTARM", "ARM", "AVISITCD", "SEX"), "AVISITCD"), |
|
134 |
#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
135 |
#' loq_legend = TRUE, |
|
136 |
#' rotate_xlab = FALSE, |
|
137 |
#' hline_arb = c(60, 55), |
|
138 |
#' hline_arb_color = c("grey", "red"), |
|
139 |
#' hline_arb_label = c("default_hori_A", "default_hori_B"), |
|
140 |
#' hline_vars = c("ANRHI", "ANRLO", "ULOQN", "LLOQN"), |
|
141 |
#' hline_vars_colors = c("pink", "brown", "purple", "black"), |
|
142 |
#' ) |
|
143 |
#' ) |
|
144 |
#' ) |
|
145 |
#' if (interactive()) { |
|
146 |
#' shinyApp(app$ui, app$server) |
|
147 |
#' } |
|
148 |
#' |
|
149 |
tm_g_gh_boxplot <- function(label, |
|
150 |
dataname, |
|
151 |
param_var, |
|
152 |
param, |
|
153 |
yaxis_var = teal.transform::choices_selected(c("AVAL", "CHG"), "AVAL"), |
|
154 |
xaxis_var = teal.transform::choices_selected("AVISITCD", "AVISITCD"), |
|
155 |
facet_var = teal.transform::choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
156 |
trt_group, |
|
157 |
color_manual = NULL, |
|
158 |
shape_manual = NULL, |
|
159 |
facet_ncol = NULL, |
|
160 |
loq_legend = TRUE, |
|
161 |
rotate_xlab = FALSE, |
|
162 |
hline_arb = numeric(0), |
|
163 |
hline_arb_color = "red", |
|
164 |
hline_arb_label = "Horizontal line", |
|
165 |
hline_vars = character(0), |
|
166 |
hline_vars_colors = "green", |
|
167 |
hline_vars_labels = hline_vars, |
|
168 |
plot_height = c(600, 200, 2000), |
|
169 |
plot_width = NULL, |
|
170 |
font_size = c(12, 8, 20), |
|
171 |
dot_size = c(2, 1, 12), |
|
172 |
alpha = c(0.8, 0.0, 1.0), |
|
173 |
pre_output = NULL, |
|
174 |
post_output = NULL) { |
|
175 | ! |
message("Initializing tm_g_gh_boxplot") |
176 | ! |
checkmate::assert_string(label) |
177 | ! |
checkmate::assert_string(dataname) |
178 | ! |
checkmate::assert_string(param_var) |
179 | ! |
checkmate::assert_class(param, "choices_selected") |
180 | ! |
checkmate::assert_class(yaxis_var, "choices_selected") |
181 | ! |
checkmate::assert_class(xaxis_var, "choices_selected") |
182 | ! |
checkmate::assert_class(facet_var, "choices_selected") |
183 | ! |
checkmate::assert_class(trt_group, "choices_selected") |
184 | ! |
checkmate::assert_int(facet_ncol, null.ok = TRUE) |
185 | ! |
checkmate::assert_flag(loq_legend) |
186 | ! |
checkmate::assert_flag(rotate_xlab) |
187 | ! |
checkmate::assert_numeric(font_size, len = 3) |
188 | ! |
checkmate::assert_numeric(dot_size, len = 3) |
189 | ! |
checkmate::assert_numeric(alpha, len = 3) |
190 | ! |
validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label) |
191 | ! |
validate_line_vars_arg(hline_vars, hline_vars_colors, hline_vars_labels) |
192 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
193 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
194 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
195 | ! |
checkmate::assert_numeric( |
196 | ! |
plot_width[1], |
197 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
198 |
) |
|
199 | ||
200 | ! |
args <- as.list(environment()) |
201 | ||
202 | ! |
module( |
203 | ! |
label = label, |
204 | ! |
datanames = dataname, |
205 | ! |
server = srv_g_boxplot, |
206 | ! |
server_args = list( |
207 | ! |
dataname = dataname, |
208 | ! |
param_var = param_var, |
209 | ! |
trt_group = trt_group, |
210 | ! |
facet_var = facet_var, |
211 | ! |
color_manual = color_manual, |
212 | ! |
shape_manual = shape_manual, |
213 | ! |
plot_height = plot_height, |
214 | ! |
plot_width = plot_width, |
215 | ! |
hline_vars_colors = hline_vars_colors, |
216 | ! |
hline_vars_labels = hline_vars_labels, |
217 | ! |
module_args = args |
218 |
), |
|
219 | ! |
ui = ui_g_boxplot, |
220 | ! |
ui_args = args |
221 |
) |
|
222 |
} |
|
223 | ||
224 |
ui_g_boxplot <- function(id, ...) { |
|
225 | ! |
ns <- NS(id) |
226 | ! |
a <- list(...) |
227 | ||
228 | ! |
teal.widgets::standard_layout( |
229 | ! |
output = tags$div( |
230 | ! |
fluidRow( |
231 | ! |
teal.widgets::plot_with_settings_ui(id = ns("boxplot")) |
232 |
), |
|
233 | ! |
fluidRow(column( |
234 | ! |
width = 12, |
235 | ! |
tags$br(), tags$hr(), |
236 | ! |
tags$h4("Selected Data Points"), |
237 | ! |
DT::dataTableOutput(ns("brush_data")) |
238 |
)), |
|
239 | ! |
fluidRow(column( |
240 | ! |
width = 12, |
241 | ! |
tags$br(), tags$hr(), |
242 | ! |
tags$h4("Descriptive Statistics"), |
243 | ! |
DT::dataTableOutput(ns("table_ui")) |
244 |
)) |
|
245 |
), |
|
246 | ! |
encoding = tags$div( |
247 |
### Reporter |
|
248 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
249 |
### |
|
250 | ! |
templ_ui_dataname(a$dataname), |
251 | ! |
teal.widgets::optionalSelectInput( |
252 | ! |
ns("trt_group"), |
253 | ! |
label = "Select Treatment Variable", |
254 | ! |
choices = get_choices(a$trt_group$choices), |
255 | ! |
selected = a$trt_group$selected, |
256 | ! |
multiple = FALSE |
257 |
), |
|
258 | ! |
uiOutput(ns("axis_selections")), |
259 | ! |
teal.widgets::optionalSelectInput( |
260 | ! |
ns("facet_var"), |
261 | ! |
label = "Facet by", |
262 | ! |
choices = get_choices(a$facet_var$choices), |
263 | ! |
selected = a$facet_var$selected, |
264 | ! |
multiple = FALSE |
265 |
), |
|
266 | ! |
templ_ui_constraint(ns, label = "Data Constraint"), # required by constr_anl_q |
267 | ! |
if (length(a$hline_vars) > 0) { |
268 | ! |
teal.widgets::optionalSelectInput( |
269 | ! |
ns("hline_vars"), |
270 | ! |
label = "Add Horizontal Range Line(s):", |
271 | ! |
choices = a$hline_vars, |
272 | ! |
selected = NULL, |
273 | ! |
multiple = TRUE |
274 |
) |
|
275 |
}, |
|
276 | ! |
ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color), |
277 | ! |
teal.widgets::panel_group( |
278 | ! |
teal.widgets::panel_item( |
279 | ! |
title = "Plot Aesthetic Settings", |
280 | ! |
toggle_slider_ui( |
281 | ! |
ns("yrange_scale"), |
282 | ! |
label = "Y-Axis Range Zoom", |
283 | ! |
min = -1000000, |
284 | ! |
max = 1000000, |
285 | ! |
value = c(-1000000, 1000000) |
286 |
), |
|
287 | ! |
numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), |
288 | ! |
checkboxInput(ns("loq_legend"), "Display LoQ Legend", a$loq_legend), |
289 | ! |
checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab) |
290 |
), |
|
291 | ! |
teal.widgets::panel_item( |
292 | ! |
title = "Plot settings", |
293 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE), |
294 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE), |
295 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("alpha"), "Dot Alpha", a$alpha, ticks = FALSE) |
296 |
) |
|
297 |
) |
|
298 |
), |
|
299 | ! |
forms = tagList( |
300 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
301 |
), |
|
302 | ! |
pre_output = a$pre_output, |
303 | ! |
post_output = a$post_output |
304 |
) |
|
305 |
} |
|
306 | ||
307 | ||
308 |
srv_g_boxplot <- function(id, |
|
309 |
data, |
|
310 |
reporter, |
|
311 |
filter_panel_api, |
|
312 |
dataname, |
|
313 |
param_var, |
|
314 |
trt_group, |
|
315 |
facet_var, |
|
316 |
color_manual, |
|
317 |
shape_manual, |
|
318 |
plot_height, |
|
319 |
plot_width, |
|
320 |
hline_vars_colors, |
|
321 |
hline_vars_labels, |
|
322 |
module_args) { |
|
323 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
324 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
325 | ! |
checkmate::assert_class(data, "reactive") |
326 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
327 | ||
328 | ! |
moduleServer(id, function(input, output, session) { |
329 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
330 | ! |
output$axis_selections <- renderUI({ |
331 | ! |
env <- shiny::isolate(as.list(data()@env)) |
332 | ! |
resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env) |
333 | ! |
resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env) |
334 | ! |
resolved_param <- teal.transform::resolve_delayed(module_args$param, env) |
335 | ! |
templ_ui_params_vars( |
336 | ! |
session$ns, |
337 | ! |
xparam_choices = resolved_param$choices, |
338 | ! |
xparam_selected = resolved_param$selected, |
339 | ! |
xparam_label = module_args$"Select a Biomarker", |
340 | ! |
xchoices = resolved_x$choices, |
341 | ! |
xselected = resolved_x$selected, |
342 | ! |
ychoices = resolved_y$choices, |
343 | ! |
yselected = resolved_y$selected |
344 |
) |
|
345 |
}) |
|
346 |
# reused in all modules |
|
347 | ! |
anl_q_output <- constr_anl_q( |
348 | ! |
session, input, data, dataname, |
349 | ! |
param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2 |
350 |
) |
|
351 | ||
352 | ! |
anl_q <- anl_q_output()$value |
353 | ||
354 |
# update sliders for axes taking constraints into account |
|
355 | ! |
yrange_slider <- toggle_slider_server("yrange_scale") |
356 | ! |
keep_range_slider_updated( |
357 | ! |
session, |
358 | ! |
input, |
359 | ! |
update_slider_fcn = yrange_slider$update_state, |
360 | ! |
id_var = "yaxis_var", |
361 | ! |
id_param_var = "xaxis_param", |
362 | ! |
reactive_ANL = anl_q |
363 |
) |
|
364 | ! |
keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") |
365 | ||
366 | ! |
horizontal_line <- srv_arbitrary_lines("hline_arb") |
367 | ||
368 | ! |
trt_group <- reactive({ |
369 | ! |
input$trt_group |
370 |
}) |
|
371 | ||
372 | ! |
iv_r <- reactive({ |
373 | ! |
iv <- shinyvalidate::InputValidator$new() |
374 | ||
375 | ! |
iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker")) |
376 | ! |
iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable")) |
377 | ! |
iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable")) |
378 | ! |
iv$add_rule("xaxis_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) { |
379 | ! |
sprintf("You can not choose %s as x-axis variable for treatment variable %s.", (.), trt_group()) |
380 |
}) |
|
381 | ! |
iv$add_rule("yaxis_var", shinyvalidate::sv_required("Please select a Y-Axis variable")) |
382 | ||
383 | ! |
iv$add_rule("facet_var", shinyvalidate::sv_optional()) |
384 | ! |
iv$add_rule("facet_var", ~ if ((.) %in% c("ACTARM", "ARM") && isTRUE((.) != trt_group())) { |
385 | ! |
sprintf("You can not choose %s as faceting variable for treatment variable %s.", (.), trt_group()) |
386 |
}) |
|
387 | ||
388 | ! |
iv_facet <- shinyvalidate::InputValidator$new() |
389 | ! |
iv_facet$condition(~ !is.null(input$facet_var)) |
390 | ! |
iv_facet$add_rule("facet_ncol", plots_per_row_validate_rules(required = FALSE)) |
391 | ! |
iv$add_validator(iv_facet) |
392 | ||
393 | ! |
iv$add_validator(horizontal_line()$iv_r()) |
394 | ! |
iv$add_validator(anl_q_output()$iv_r()) |
395 | ! |
iv$enable() |
396 | ! |
iv |
397 |
}) |
|
398 | ||
399 | ! |
create_plot <- reactive({ |
400 | ! |
teal::validate_inputs(iv_r()) |
401 | ||
402 | ! |
req(anl_q()) |
403 |
# nolint start |
|
404 | ! |
param <- input$xaxis_param |
405 | ! |
yaxis <- input$yaxis_var |
406 | ! |
xaxis <- input$xaxis_var |
407 | ! |
facet_var <- `if`(is.null(input$facet_var), "None", input$facet_var) |
408 | ! |
ylim <- yrange_slider$state()$value |
409 | ! |
facet_ncol <- input$facet_ncol |
410 | ||
411 | ! |
alpha <- input$alpha |
412 | ! |
font_size <- input$font_size |
413 | ! |
dot_size <- input$dot_size |
414 | ! |
loq_legend <- input$loq_legend |
415 | ! |
rotate_xlab <- input$rotate_xlab |
416 | ||
417 | ! |
hline_arb <- horizontal_line()$line_arb |
418 | ! |
hline_arb_label <- horizontal_line()$line_arb_label |
419 | ! |
hline_arb_color <- horizontal_line()$line_arb_color |
420 | ||
421 | ! |
hline_vars <- input$hline_vars |
422 | ! |
trt_group <- input$trt_group |
423 |
# nolint end |
|
424 | ||
425 | ! |
validate_has_variable( |
426 | ! |
anl_q()$ANL, |
427 | ! |
yaxis, |
428 | ! |
sprintf("Variable %s is not available in data %s", yaxis, dataname) |
429 |
) |
|
430 | ! |
validate_has_variable( |
431 | ! |
anl_q()$ANL, |
432 | ! |
xaxis, |
433 | ! |
sprintf("Variable %s is not available in data %s", xaxis, dataname) |
434 |
) |
|
435 | ||
436 | ! |
if (!facet_var == "None") { |
437 | ! |
validate_has_variable( |
438 | ! |
anl_q()$ANL, |
439 | ! |
facet_var, |
440 | ! |
sprintf("Variable %s is not available in data %s", facet_var, dataname) |
441 |
) |
|
442 |
} |
|
443 | ||
444 | ! |
anl_q()$qenv %>% teal.code::eval_code( |
445 | ! |
code = bquote({ |
446 | ! |
p <- goshawk::g_boxplot( |
447 | ! |
data = ANL, |
448 | ! |
biomarker = .(param), |
449 | ! |
xaxis_var = .(xaxis), |
450 | ! |
yaxis_var = .(yaxis), |
451 | ! |
hline_arb = .(hline_arb), |
452 | ! |
hline_arb_label = .(hline_arb_label), |
453 | ! |
hline_arb_color = .(hline_arb_color), |
454 | ! |
hline_vars = .(hline_vars), |
455 | ! |
hline_vars_colors = .(hline_vars_colors[seq_along(hline_vars)]), |
456 | ! |
hline_vars_labels = .(hline_vars_labels[seq_along(hline_vars)]), |
457 | ! |
facet_ncol = .(facet_ncol), |
458 | ! |
loq_legend = .(loq_legend), |
459 | ! |
rotate_xlab = .(rotate_xlab), |
460 | ! |
trt_group = .(trt_group), |
461 | ! |
ylim = .(ylim), |
462 | ! |
color_manual = .(color_manual), |
463 | ! |
shape_manual = .(shape_manual), |
464 | ! |
facet_var = .(facet_var), |
465 | ! |
alpha = .(alpha), |
466 | ! |
dot_size = .(dot_size), |
467 | ! |
font_size = .(font_size), |
468 | ! |
unit = .("AVALU") |
469 |
) |
|
470 |
}) |
|
471 |
) |
|
472 |
}) |
|
473 | ||
474 | ! |
create_table <- reactive({ |
475 | ! |
req(iv_r()$is_valid()) |
476 | ! |
req(anl_q()) |
477 | ! |
param <- input$xaxis_param |
478 | ! |
xaxis_var <- input$yaxis_var # nolint |
479 | ! |
font_size <- input$font_size |
480 | ! |
trt_group <- input$trt_group |
481 | ||
482 | ! |
anl_q()$qenv %>% teal.code::eval_code( |
483 | ! |
code = bquote({ |
484 | ! |
tbl <- goshawk::t_summarytable( |
485 | ! |
data = ANL, |
486 | ! |
trt_group = .(trt_group), |
487 | ! |
param_var = .(param_var), |
488 | ! |
param = .(param), |
489 | ! |
xaxis_var = .(xaxis_var), |
490 | ! |
facet_var = .(input$facet_var) |
491 |
) |
|
492 |
}) |
|
493 |
) |
|
494 |
}) |
|
495 | ||
496 | ! |
plot_r <- reactive({ |
497 | ! |
create_plot()[["p"]] |
498 |
}) |
|
499 | ||
500 | ! |
boxplot_data <- teal.widgets::plot_with_settings_srv( |
501 | ! |
id = "boxplot", |
502 | ! |
plot_r = plot_r, |
503 | ! |
height = plot_height, |
504 | ! |
width = plot_width, |
505 | ! |
brushing = TRUE |
506 |
) |
|
507 | ||
508 | ! |
output$table_ui <- DT::renderDataTable({ |
509 | ! |
req(create_table()) |
510 | ! |
tbl <- create_table()[["tbl"]] |
511 | ||
512 | ! |
numeric_cols <- setdiff(names(dplyr::select_if(tbl, is.numeric)), "n") |
513 | ||
514 | ! |
DT::datatable(tbl, rownames = FALSE, options = list(scrollX = TRUE)) %>% |
515 | ! |
DT::formatRound(numeric_cols, 4) |
516 |
}) |
|
517 | ||
518 |
### REPORTER |
|
519 | ! |
if (with_reporter) { |
520 | ! |
card_fun <- function(comment, label) { |
521 | ! |
constraint_description <- paste( |
522 | ! |
"\nFacet By:", |
523 | ! |
if (length(input$facet_var) != 0) input$facet_var else "None", |
524 | ! |
"\nSelect an X-axis Variable:", |
525 | ! |
input$xaxis_var |
526 |
) |
|
527 | ! |
card <- report_card_template_goshawk( |
528 | ! |
title = "Box Plot", |
529 | ! |
label = label, |
530 | ! |
with_filter = with_filter, |
531 | ! |
filter_panel_api = filter_panel_api, |
532 | ! |
constraint_list = list( |
533 | ! |
constraint_var = input$constraint_var, |
534 | ! |
constraint_range_min = input$constraint_range_min, |
535 | ! |
constraint_range_max = input$constraint_range_max |
536 |
), |
|
537 | ! |
constraint_description = constraint_description, |
538 | ! |
style = "verbatim" |
539 |
) |
|
540 | ! |
card$append_text("Plot", "header3") |
541 | ! |
card$append_plot(plot_r(), dim = boxplot_data$dim()) |
542 | ! |
if (!comment == "") { |
543 | ! |
card$append_text("Comment", "header3") |
544 | ! |
card$append_text(comment) |
545 |
} |
|
546 | ! |
card$append_src( |
547 | ! |
teal.code::get_code( |
548 | ! |
teal.code::join(create_plot(), create_table()) |
549 |
) |
|
550 |
) |
|
551 | ! |
card |
552 |
} |
|
553 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
554 |
} |
|
555 |
### |
|
556 | ||
557 |
# highlight plot area |
|
558 | ! |
output$brush_data <- DT::renderDataTable({ |
559 | ! |
boxplot_brush <- boxplot_data$brush() |
560 | ||
561 | ! |
ANL <- isolate(anl_q()$ANL) %>% droplevels() # nolint |
562 | ! |
validate_has_data(ANL, 2) |
563 | ||
564 | ! |
xvar <- isolate(input$xaxis_var) |
565 | ! |
yvar <- isolate(input$yaxis_var) |
566 | ! |
facetv <- isolate(input$facet_var) |
567 | ! |
trt_group <- isolate(input$trt_group) |
568 | ||
569 | ! |
req(all(c(xvar, yvar, facetv, trt_group) %in% names(ANL))) |
570 | ||
571 | ! |
df <- teal.widgets::clean_brushedPoints( |
572 | ! |
dplyr::select( |
573 | ! |
ANL, "USUBJID", dplyr::all_of(c(trt_group, facetv)), |
574 | ! |
"AVISITCD", "PARAMCD", dplyr::all_of(c(xvar, yvar)), "LOQFL" |
575 |
), |
|
576 | ! |
boxplot_brush |
577 |
) |
|
578 | ||
579 | ! |
numeric_cols <- names(dplyr::select_if(df, is.numeric)) |
580 | ||
581 | ! |
DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>% |
582 | ! |
DT::formatRound(numeric_cols, 4) |
583 |
}) |
|
584 | ||
585 | ! |
joined_qenvs <- reactive({ |
586 | ! |
req(create_plot(), create_table()) |
587 | ! |
teal.code::join(create_plot(), create_table()) |
588 |
}) |
|
589 | ||
590 | ! |
teal.widgets::verbatim_popup_srv( |
591 | ! |
id = "rcode", |
592 | ! |
verbatim_content = reactive(teal.code::get_code(joined_qenvs())), |
593 | ! |
title = "Show R Code for Boxplot" |
594 |
) |
|
595 |
}) |
|
596 |
} |
1 |
#' Scatter Plot Teal Module For Biomarker Analysis |
|
2 |
#' |
|
3 |
#' @description |
|
4 |
#' `r lifecycle::badge("deprecated")` |
|
5 |
#' |
|
6 |
#' `tm_g_gh_scatterplot` is deprecated. Please use [tm_g_gh_correlationplot] |
|
7 |
#' instead. |
|
8 |
#' |
|
9 |
#' @inheritParams teal.widgets::standard_layout |
|
10 |
#' @param label menu item label of the module in the teal app. |
|
11 |
#' @param dataname analysis data passed to the data argument of \code{\link[teal]{init}}. E.g. `ADaM` structured |
|
12 |
#' laboratory data frame \code{ADLB}. |
|
13 |
#' @param param_var name of variable containing biomarker codes e.g. \code{PARAMCD}. |
|
14 |
#' @param param biomarker selected. |
|
15 |
#' @param xaxis_var name of variable containing biomarker results displayed on `x-axis` e.g. \code{BASE}. |
|
16 |
#' @param yaxis_var name of variable containing biomarker results displayed on `y-axis` e.g. \code{AVAL}. |
|
17 |
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option |
|
18 |
#' for variable names representing treatment group e.g. `ARM`. |
|
19 |
#' @param color_manual vector of colors applied to treatment values. |
|
20 |
#' @param shape_manual vector of symbols applied to `LOQ` values. |
|
21 |
#' @param facet_ncol numeric value indicating number of facets per row. |
|
22 |
#' @param trt_facet facet by treatment group \code{trt_group}. |
|
23 |
#' @param reg_line include regression line and annotations for slope and coefficient in visualization. Use with facet |
|
24 |
#' TRUE. |
|
25 |
#' @param rotate_xlab 45 degree rotation of `x-axis` values. |
|
26 |
#' @param hline y-axis value to position of horizontal line. |
|
27 |
#' @param vline x-axis value to position a vertical line. |
|
28 |
#' @param plot_height controls plot height. |
|
29 |
#' @param plot_width optional, controls plot width. |
|
30 |
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend. |
|
31 |
#' @param dot_size plot dot size. |
|
32 |
#' @param reg_text_size font size control for regression line annotations. |
|
33 |
#' |
|
34 |
#' |
|
35 |
#' @export |
|
36 |
#' |
|
37 |
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com |
|
38 |
#' @author Balazs Toth (tothb2) toth.balazs@gene.com |
|
39 |
#' |
|
40 |
#' @examples |
|
41 |
#' # Example using ADaM structure analysis dataset. |
|
42 |
#' data <- teal_data() |
|
43 |
#' data <- within(data, { |
|
44 |
#' library(dplyr) |
|
45 |
#' library(stringr) |
|
46 |
#' |
|
47 |
#' # original ARM value = dose value |
|
48 |
#' arm_mapping <- list( |
|
49 |
#' "A: Drug X" = "150mg QD", |
|
50 |
#' "B: Placebo" = "Placebo", |
|
51 |
#' "C: Combination" = "Combination" |
|
52 |
#' ) |
|
53 |
#' |
|
54 |
#' ADSL <- rADSL |
|
55 |
#' ADLB <- rADLB |
|
56 |
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) |
|
57 |
#' ADLB <- ADLB %>% |
|
58 |
#' mutate( |
|
59 |
#' AVISITCD = case_when( |
|
60 |
#' AVISIT == "SCREENING" ~ "SCR", |
|
61 |
#' AVISIT == "BASELINE" ~ "BL", |
|
62 |
#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")), |
|
63 |
#' TRUE ~ as.character(NA) |
|
64 |
#' ), |
|
65 |
#' AVISITCDN = case_when( |
|
66 |
#' AVISITCD == "SCR" ~ -2, |
|
67 |
#' AVISITCD == "BL" ~ 0, |
|
68 |
#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), |
|
69 |
#' TRUE ~ as.numeric(NA) |
|
70 |
#' ), |
|
71 |
#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN), |
|
72 |
#' TRTORD = case_when( |
|
73 |
#' ARMCD == "ARM C" ~ 1, |
|
74 |
#' ARMCD == "ARM B" ~ 2, |
|
75 |
#' ARMCD == "ARM A" ~ 3 |
|
76 |
#' ), |
|
77 |
#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]), |
|
78 |
#' ARM = factor(ARM) %>% reorder(TRTORD), |
|
79 |
#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]), |
|
80 |
#' ACTARM = factor(ACTARM) %>% reorder(TRTORD) |
|
81 |
#' ) |
|
82 |
#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] |
|
83 |
#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]] |
|
84 |
#' }) |
|
85 |
#' |
|
86 |
#' datanames <- c("ADSL", "ADLB") |
|
87 |
#' datanames(data) <- datanames |
|
88 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
89 |
#' |
|
90 |
#' |
|
91 |
#' app <- init( |
|
92 |
#' data = data, |
|
93 |
#' modules = modules( |
|
94 |
#' tm_g_gh_scatterplot( |
|
95 |
#' label = "Scatter Plot", |
|
96 |
#' dataname = "ADLB", |
|
97 |
#' param_var = "PARAMCD", |
|
98 |
#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), |
|
99 |
#' xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "BASE"), |
|
100 |
#' yaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"), |
|
101 |
#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
102 |
#' color_manual = c( |
|
103 |
#' "150mg QD" = "#000000", |
|
104 |
#' "Placebo" = "#3498DB", |
|
105 |
#' "Combination" = "#E74C3C" |
|
106 |
#' ), |
|
107 |
#' shape_manual = c("N" = 1, "Y" = 2, "NA" = 0), |
|
108 |
#' plot_height = c(500, 200, 2000), |
|
109 |
#' facet_ncol = 2, |
|
110 |
#' trt_facet = FALSE, |
|
111 |
#' reg_line = FALSE, |
|
112 |
#' font_size = c(12, 8, 20), |
|
113 |
#' dot_size = c(1, 1, 12), |
|
114 |
#' reg_text_size = c(3, 3, 10) |
|
115 |
#' ) |
|
116 |
#' ) |
|
117 |
#' ) |
|
118 |
#' if (interactive()) { |
|
119 |
#' shinyApp(app$ui, app$server) |
|
120 |
#' } |
|
121 |
#' |
|
122 |
tm_g_gh_scatterplot <- function(label, |
|
123 |
dataname, |
|
124 |
param_var, |
|
125 |
param, |
|
126 |
xaxis_var, |
|
127 |
yaxis_var, |
|
128 |
trt_group, |
|
129 |
color_manual = NULL, |
|
130 |
shape_manual = NULL, |
|
131 |
facet_ncol = 2, |
|
132 |
trt_facet = FALSE, |
|
133 |
reg_line = FALSE, |
|
134 |
rotate_xlab = FALSE, |
|
135 |
hline = NULL, |
|
136 |
vline = NULL, |
|
137 |
plot_height = c(500, 200, 2000), |
|
138 |
plot_width = NULL, |
|
139 |
font_size = c(12, 8, 20), |
|
140 |
dot_size = c(1, 1, 12), |
|
141 |
reg_text_size = c(3, 3, 10), |
|
142 |
pre_output = NULL, |
|
143 |
post_output = NULL) { |
|
144 | ! |
lifecycle::deprecate_soft( |
145 | ! |
when = "0.1.15", |
146 | ! |
what = "tm_g_gh_scatterplot()", |
147 | ! |
details = "You should use teal.goshawk::tm_g_gh_correlationplot instead of teal.goshawk::tm_g_gh_scatterplot" |
148 |
) |
|
149 | ||
150 | ! |
message("Initializing tm_g_gh_scatterplot") |
151 | ! |
checkmate::assert_class(param, "choices_selected") |
152 | ! |
checkmate::assert_class(xaxis_var, "choices_selected") |
153 | ! |
checkmate::assert_class(yaxis_var, "choices_selected") |
154 | ! |
checkmate::assert_class(trt_group, "choices_selected") |
155 | ! |
checkmate::assert_flag(trt_facet) |
156 | ! |
checkmate::assert_flag(reg_line) |
157 | ! |
checkmate::assert_flag(rotate_xlab) |
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], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
164 |
) |
|
165 | ||
166 | ! |
args <- as.list(environment()) |
167 | ||
168 | ! |
module( |
169 | ! |
label = label, |
170 | ! |
datanames = dataname, |
171 | ! |
server = srv_g_scatterplot, |
172 | ! |
server_args = list( |
173 | ! |
dataname = dataname, |
174 | ! |
param_var = param_var, |
175 | ! |
trt_group = trt_group, |
176 | ! |
trt_facet = trt_facet, |
177 | ! |
color_manual = color_manual, |
178 | ! |
shape_manual = shape_manual, |
179 | ! |
plot_height = plot_height, |
180 | ! |
plot_width = plot_width, |
181 | ! |
module_args = args |
182 |
), |
|
183 | ! |
ui = ui_g_scatterplot, |
184 | ! |
ui_args = args |
185 |
) |
|
186 |
} |
|
187 | ||
188 |
ui_g_scatterplot <- function(id, ...) { |
|
189 | ! |
ns <- NS(id) |
190 | ! |
a <- list(...) |
191 | ||
192 | ! |
teal.widgets::standard_layout( |
193 | ! |
output = templ_ui_output_datatable(ns), |
194 | ! |
encoding = tags$div( |
195 |
### Reporter |
|
196 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
197 |
### |
|
198 | ! |
templ_ui_dataname(a$dataname), |
199 | ! |
teal.widgets::optionalSelectInput( |
200 | ! |
ns("trt_group"), |
201 | ! |
label = "Select Treatment Variable", |
202 | ! |
choices = get_choices(a$trt_group$choices), |
203 | ! |
selected = a$trt_group$selected, |
204 | ! |
multiple = FALSE |
205 |
), |
|
206 | ! |
uiOutput(ns("axis_selections")), |
207 | ! |
templ_ui_constraint(ns), # required by constr_anl_q |
208 | ! |
teal.widgets::panel_group( |
209 | ! |
teal.widgets::panel_item( |
210 | ! |
title = "Plot Aesthetic Settings", |
211 | ! |
toggle_slider_ui(ns("xrange_scale"), |
212 | ! |
label = "X-Axis Range Zoom", |
213 | ! |
min = -1000000, |
214 | ! |
max = 1000000, |
215 | ! |
value = c(-1000000, 1000000) |
216 |
), |
|
217 | ! |
toggle_slider_ui(ns("yrange_scale"), |
218 | ! |
label = "Y-Axis Range Zoom", |
219 | ! |
min = -1000000, |
220 | ! |
max = 1000000, |
221 | ! |
value = c(-1000000, 1000000) |
222 |
), |
|
223 | ! |
numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), |
224 | ! |
checkboxInput(ns("trt_facet"), "Treatment Variable Faceting", a$trt_facet), |
225 | ! |
checkboxInput(ns("reg_line"), "Regression Line", a$reg_line), |
226 | ! |
checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab), |
227 | ! |
numericInput(ns("hline"), "Add a horizontal line:", a$hline), |
228 | ! |
numericInput(ns("vline"), "Add a vertical line:", a$vline) |
229 |
), |
|
230 | ! |
teal.widgets::panel_item( |
231 | ! |
title = "Plot settings", |
232 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE), |
233 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("dot_size"), "Dot Size", a$dot_size, ticks = FALSE), |
234 | ! |
teal.widgets::optionalSliderInputValMinMax( |
235 | ! |
ns("reg_text_size"), |
236 | ! |
"Regression Annotations Size", |
237 | ! |
a$reg_text_size, |
238 | ! |
ticks = FALSE |
239 |
) |
|
240 |
) |
|
241 |
) |
|
242 |
), |
|
243 | ! |
forms = tagList( |
244 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
245 |
), |
|
246 | ! |
pre_output = a$pre_output, |
247 | ! |
post_output = a$post_output |
248 |
) |
|
249 |
} |
|
250 | ||
251 |
srv_g_scatterplot <- function(id, |
|
252 |
data, |
|
253 |
reporter, |
|
254 |
filter_panel_api, |
|
255 |
dataname, |
|
256 |
param_var, |
|
257 |
trt_group, |
|
258 |
trt_facet, |
|
259 |
color_manual, |
|
260 |
shape_manual, |
|
261 |
plot_height, |
|
262 |
plot_width, |
|
263 |
module_args) { |
|
264 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
265 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
266 | ! |
checkmate::assert_class(data, "reactive") |
267 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
268 | ||
269 | ! |
moduleServer(id, function(input, output, session) { |
270 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
271 | ! |
output$axis_selections <- renderUI({ |
272 | ! |
env <- shiny::isolate(as.list(data()@env)) |
273 | ! |
resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env) |
274 | ! |
resolved_y <- teal.transform::resolve_delayed(module_args$yaxis_var, env) |
275 | ! |
resolved_param <- teal.transform::resolve_delayed(module_args$param, env) |
276 | ! |
templ_ui_params_vars( |
277 | ! |
session$ns, |
278 |
# xparam and yparam are identical, so we only show the user one |
|
279 | ! |
xparam_choices = resolved_param$choices, |
280 | ! |
xparam_selected = resolved_param$selected, |
281 | ! |
xparam_label = "Select a Biomarker", |
282 | ! |
xchoices = resolved_x$choices, |
283 | ! |
xselected = resolved_x$selected, |
284 | ! |
ychoices = resolved_y$choices, |
285 | ! |
yselected = resolved_y$selected |
286 |
) |
|
287 |
}) |
|
288 | ||
289 |
# reused in all modules |
|
290 | ! |
anl_q_output <- constr_anl_q( |
291 | ! |
session, input, data, dataname, |
292 | ! |
param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 1 |
293 |
) |
|
294 | ||
295 | ! |
anl_q <- anl_q_output()$value |
296 | ||
297 |
# update sliders for axes taking constraints into account |
|
298 | ! |
xrange_slider <- toggle_slider_server("xrange_scale") |
299 | ! |
yrange_slider <- toggle_slider_server("yrange_scale") |
300 | ! |
keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q) |
301 | ! |
keep_range_slider_updated(session, input, yrange_slider$update_state, "yaxis_var", "xaxis_param", anl_q) |
302 | ! |
keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") |
303 | ||
304 |
# plot |
|
305 | ! |
plot_q <- reactive({ |
306 | ! |
req(anl_q()) |
307 |
# nolint start |
|
308 | ! |
xlim <- xrange_slider$state()$value |
309 | ! |
ylim <- yrange_slider$state()$value |
310 | ! |
facet_ncol <- input$facet_ncol |
311 | ! |
validate(need( |
312 | ! |
is.na(facet_ncol) || (as.numeric(facet_ncol) > 0 && as.numeric(facet_ncol) %% 1 == 0), |
313 | ! |
"Number of plots per row must be a positive integer" |
314 |
)) |
|
315 | ! |
reg_line <- input$reg_line |
316 | ! |
font_size <- input$font_size |
317 | ! |
dot_size <- input$dot_size |
318 | ! |
reg_text_size <- input$reg_text_size |
319 | ! |
rotate_xlab <- input$rotate_xlab |
320 | ! |
hline <- input$hline |
321 | ! |
vline <- input$vline |
322 | ! |
trt_group <- input$trt_group |
323 | ! |
facet <- input$trt_facet |
324 | ! |
validate(need(trt_group, "Please select a treatment variable")) |
325 | ||
326 |
# Below inputs should trigger plot via updates of other reactive objects (i.e. anl_q()) and some inputs |
|
327 | ! |
validate(need(input$xaxis_var, "Please select an X-Axis Variable")) |
328 | ! |
validate(need(input$yaxis_var, "Please select a Y-Axis Variable")) |
329 | ! |
param <- input$xaxis_param |
330 | ! |
xaxis <- input$xaxis_var |
331 | ! |
yaxis <- input$yaxis_var |
332 | ||
333 |
# nolint end |
|
334 | ! |
teal.code::eval_code( |
335 | ! |
object = anl_q()$qenv, |
336 | ! |
code = bquote({ |
337 |
# re-establish treatment variable label |
|
338 | ! |
p <- goshawk::g_scatterplot( |
339 | ! |
data = ANL, |
340 | ! |
param_var = .(param_var), |
341 | ! |
param = .(param), |
342 | ! |
xaxis_var = .(xaxis), |
343 | ! |
yaxis_var = .(yaxis), |
344 | ! |
trt_group = .(trt_group), |
345 | ! |
xlim = .(xlim), |
346 | ! |
ylim = .(ylim), |
347 | ! |
color_manual = .(color_manual), |
348 | ! |
shape_manual = .(shape_manual), |
349 | ! |
facet_ncol = .(facet_ncol), |
350 | ! |
facet = .(facet), |
351 | ! |
facet_var = .(trt_group), |
352 | ! |
reg_line = .(reg_line), |
353 | ! |
font_size = .(font_size), |
354 | ! |
dot_size = .(dot_size), |
355 | ! |
reg_text_size = .(reg_text_size), |
356 | ! |
rotate_xlab = .(rotate_xlab), |
357 | ! |
hline = .(`if`(is.na(hline), NULL, as.numeric(hline))), |
358 | ! |
vline = .(`if`(is.na(vline), NULL, as.numeric(vline))) |
359 |
) |
|
360 | ! |
print(p) |
361 |
}) |
|
362 |
) |
|
363 |
}) |
|
364 | ||
365 | ! |
plot_r <- reactive(plot_q()[["p"]]) |
366 | ||
367 | ! |
plot_data <- teal.widgets::plot_with_settings_srv( |
368 | ! |
id = "plot", |
369 | ! |
plot_r = plot_r, |
370 | ! |
height = plot_height, |
371 | ! |
width = plot_width, |
372 | ! |
brushing = TRUE |
373 |
) |
|
374 | ||
375 |
### REPORTER |
|
376 | ! |
if (with_reporter) { |
377 | ! |
card_fun <- function(comment, label) { |
378 | ! |
constraint_description <- paste( |
379 | ! |
"\nTreatment Variable Faceting:", |
380 | ! |
input$trt_facet, |
381 | ! |
"\nRegression Line:", |
382 | ! |
input$reg_line |
383 |
) |
|
384 | ! |
card <- report_card_template_goshawk( |
385 | ! |
title = "Scatter Plot", |
386 | ! |
label = label, |
387 | ! |
with_filter = with_filter, |
388 | ! |
filter_panel_api = filter_panel_api, |
389 | ! |
constraint_list = list( |
390 | ! |
constraint_var = input$constraint_var, |
391 | ! |
constraint_range_min = input$constraint_range_min, |
392 | ! |
constraint_range_max = input$constraint_range_max |
393 |
), |
|
394 | ! |
constraint_description = constraint_description, |
395 | ! |
style = "verbatim" |
396 |
) |
|
397 | ! |
card$append_text("Scatter Plot", "header3") |
398 | ! |
card$append_plot(plot_r(), dim = plot_data$dim()) |
399 | ! |
if (!comment == "") { |
400 | ! |
card$append_text("Comment", "header3") |
401 | ! |
card$append_text(comment) |
402 |
} |
|
403 | ! |
card$append_src(teal.code::get_code(plot_q())) |
404 | ! |
card |
405 |
} |
|
406 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
407 |
} |
|
408 |
### |
|
409 | ||
410 |
# highlight plot area |
|
411 | ! |
output$brush_data <- DT::renderDataTable({ |
412 | ! |
plot_brush <- plot_data$brush() |
413 | ||
414 | ! |
ANL <- isolate(anl_q()$ANL) # nolint |
415 | ! |
validate_has_data(ANL, 1) |
416 | ||
417 | ! |
xvar <- isolate(input$xaxis_var) |
418 | ! |
yvar <- isolate(input$yaxis_var) |
419 | ! |
trt_group <- isolate(input$trt_group) |
420 | ||
421 | ! |
req(all(c(xvar, yvar) %in% names(ANL))) |
422 | ||
423 | ! |
df <- teal.widgets::clean_brushedPoints( |
424 | ! |
dplyr::select( |
425 | ! |
ANL, "USUBJID", dplyr::all_of(trt_group), "AVISITCD", "PARAMCD", |
426 | ! |
dplyr::all_of(c(xvar, yvar)), "LOQFL" |
427 |
), |
|
428 | ! |
plot_brush |
429 |
) |
|
430 | ||
431 | ! |
numeric_cols <- names(dplyr::select_if(df, is.numeric)) |
432 | ||
433 | ! |
DT::datatable(df, rownames = FALSE, options = list(scrollX = TRUE)) %>% |
434 | ! |
DT::formatRound(numeric_cols, 4) |
435 |
}) |
|
436 | ||
437 | ! |
teal.widgets::verbatim_popup_srv( |
438 | ! |
id = "rcode", |
439 | ! |
verbatim_content = reactive(teal.code::get_code(plot_q())), |
440 | ! |
title = "Show R Code for Scatterplot" |
441 |
) |
|
442 |
}) |
|
443 |
} |
1 |
#' UI with a toggleable slider to change between slider and numeric input fields |
|
2 |
#' |
|
3 |
#' This is useful when a slider should be shown, but it is sometimes hard to configure sliders, |
|
4 |
#' so one can toggle to one or two numeric input fields to set slider instead. |
|
5 |
#' Both normal sliders (for a single number in a range) and dichotomous sliders (for a range |
|
6 |
#' within the slider range) are supported. In the former case, the toggle button |
|
7 |
#' will show one numeric input field, in the latter case two. |
|
8 |
#' |
|
9 |
#' Value is not checked to be within minmax range |
|
10 |
#' |
|
11 |
#' @md |
|
12 |
#' @param id `character` module id |
|
13 |
#' @param label `label` label for input field, e.g. slider or numeric inputs |
|
14 |
#' @param min `numeric or integer` minimum value |
|
15 |
#' @param max `numeric or integer` maximum value |
|
16 |
#' @param value `numeric or integer` either of length 1 for normal slider or of |
|
17 |
#' length 2 for dichotomous slider. |
|
18 |
#' @param slider_initially `logical` whether to show slider or numeric fields |
|
19 |
#' initially |
|
20 |
#' @param step_slider `numeric or integer` step for slider |
|
21 |
#' @param step_numeric `numeric or integer` step for numeric input fields |
|
22 |
#' @param width `numeric` width of slider or of each numeric field |
|
23 |
#' @param ... additional parameters to pass to `sliderInput` |
|
24 |
#' |
|
25 |
#' @return Shiny HTML UI |
|
26 |
#' @keywords internal |
|
27 |
#' |
|
28 |
#' @examples |
|
29 |
#' value <- c(20.3, 81.5) # dichotomous slider |
|
30 |
#' # value <- c(50.1) # normal slider |
|
31 |
#' |
|
32 |
#' # use non-exported function from teal.goshawk |
|
33 |
#' toggle_slider_ui <- getFromNamespace("toggle_slider_ui", "teal.goshawk") |
|
34 |
#' |
|
35 |
#' ui <- div( |
|
36 |
#' toggle_slider_ui( |
|
37 |
#' "toggle_slider", "Select value", |
|
38 |
#' min = 0.2, max = 100.1, value = value, |
|
39 |
#' slider_initially = FALSE, step_slider = 0.1, step_numeric = 0.001 |
|
40 |
#' ), |
|
41 |
#' verbatimTextOutput("value") |
|
42 |
#' ) |
|
43 |
#' |
|
44 |
#' server <- function(input, output, session) { |
|
45 |
#' is_dichotomous_slider <- (length(value) == 2) |
|
46 |
#' range_value <- toggle_slider_server("toggle_slider", |
|
47 |
#' is_dichotomous_slider = is_dichotomous_slider |
|
48 |
#' ) |
|
49 |
#' messages <- reactiveVal() # to keep history |
|
50 |
#' observeEvent(range_value$state(), { |
|
51 |
#' list_with_names_str <- function(x) paste(names(x), x, sep = ": ", collapse = ", ") |
|
52 |
#' messages(c(messages(), list_with_names_str(range_value$state()))) |
|
53 |
#' }) |
|
54 |
#' output$value <- renderText({ |
|
55 |
#' paste(messages(), collapse = "\n") |
|
56 |
#' }) |
|
57 |
#' } |
|
58 |
#' |
|
59 |
#' if (interactive()) { |
|
60 |
#' shinyApp(ui, server) |
|
61 |
#' } |
|
62 |
toggle_slider_ui <- function(id, |
|
63 |
label, |
|
64 |
min, |
|
65 |
max, |
|
66 |
value, |
|
67 |
slider_initially = TRUE, |
|
68 |
step_slider = NULL, |
|
69 |
step_numeric = step_slider, |
|
70 |
width = NULL, |
|
71 |
...) { |
|
72 | ! |
checkmate::assert_number(min) |
73 | ! |
checkmate::assert_number(max) |
74 | ! |
checkmate::assert_flag(slider_initially) |
75 | ! |
checkmate::assert_number(step_slider, null.ok = TRUE) |
76 | ! |
checkmate::assert_number(step_numeric, null.ok = TRUE) |
77 | ! |
checkmate::assert_numeric(value, min.len = 1, max.len = 2) |
78 | ! |
if (is.null(step_numeric)) { |
79 | ! |
step_numeric <- NA # numericInput does not support NULL |
80 |
} |
|
81 | ||
82 | ! |
show_or_not <- function(show) if (show) identity else shinyjs::hidden |
83 | ! |
ns <- NS(id) |
84 | ! |
tags$div( |
85 | ! |
include_css_files("custom"), |
86 | ! |
shinyjs::useShinyjs(), |
87 | ! |
tags$div( |
88 | ! |
class = "flex justify-between mb-1", |
89 | ! |
tags$span(tags$strong(label)), |
90 | ! |
actionButton(ns("toggle"), "Toggle", class = "btn-xs") |
91 |
), |
|
92 | ! |
show_or_not(slider_initially)( |
93 | ! |
sliderInput( |
94 | ! |
ns("slider"), |
95 | ! |
label = NULL, |
96 | ! |
min = min, |
97 | ! |
max = max, |
98 | ! |
value = value, |
99 | ! |
step = step_slider, |
100 | ! |
width = width, |
101 |
... |
|
102 |
) |
|
103 |
), |
|
104 | ! |
show_or_not(!slider_initially)(tags$span( |
105 | ! |
id = ns("numeric_view"), |
106 | ! |
if (length(value) == 1) { |
107 | ! |
numericInput( |
108 | ! |
ns("value"), |
109 | ! |
label = NULL, |
110 | ! |
min = min, |
111 | ! |
max = max, |
112 | ! |
value = value[[1]], |
113 | ! |
step = step_numeric, |
114 | ! |
width = width |
115 |
) |
|
116 |
} else { |
|
117 | ! |
tags$div( |
118 | ! |
numericInput( |
119 | ! |
ns("value_low"), |
120 | ! |
"From:", |
121 | ! |
min = min, |
122 | ! |
max = max, |
123 | ! |
value = value[[1]], |
124 | ! |
step = step_numeric, |
125 | ! |
width = width |
126 |
), |
|
127 | ! |
numericInput( |
128 | ! |
ns("value_high"), |
129 | ! |
"- to:", |
130 | ! |
min = min, |
131 | ! |
max = max, |
132 | ! |
value = value[[2]], |
133 | ! |
step = step_numeric, |
134 | ! |
width = width |
135 |
) |
|
136 |
) |
|
137 |
} |
|
138 |
)) |
|
139 |
) |
|
140 |
} |
|
141 | ||
142 |
# is_dichotomous_slider `logical` whether it is a dichotomous slider or normal slider |
|
143 |
toggle_slider_server <- function(id, is_dichotomous_slider = TRUE) { |
|
144 | ! |
moduleServer(id, function(input, output, session) { |
145 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
146 | ! |
checkmate::assert_flag(is_dichotomous_slider) |
147 |
# model view controller: cur_state is the model, the sliderInput and numericInputs are two views/controllers |
|
148 |
# additionally, the module returns the cur_state, so it can be controlled from that end as well |
|
149 | ! |
cur_state <- reactiveVal(NULL) # model, can contain min, max, value etc. |
150 | ||
151 | ||
152 | ! |
iv_r <- reactive({ |
153 | ! |
iv <- shinyvalidate::InputValidator$new() |
154 | ! |
iv$condition(~ input$toggle %% 2 == 1) |
155 | ! |
iv$add_rule("value_low", shinyvalidate::sv_required("A 'from' value is required - a default is used instead")) |
156 | ! |
iv$add_rule("value_high", shinyvalidate::sv_required("A 'to' value is required - a default is used instead)")) |
157 | ! |
iv$add_rule( |
158 | ! |
"value_high", |
159 | ! |
~ if (!is.na(input$value_low) && (.) < input$value_low) { |
160 | ! |
"'From' value should be lower than 'to' value - axis has been flipped" |
161 |
} |
|
162 |
) |
|
163 | ! |
iv$add_rule( |
164 | ! |
"value_low", |
165 | ! |
~ if (!is.na(input$value_high) && (.) > input$value_high) { |
166 | ! |
"'To' value should be greater than 'from' value - axis has been flipped" |
167 |
} |
|
168 |
) |
|
169 | ! |
iv$enable() |
170 | ! |
iv |
171 |
}) |
|
172 | ||
173 | ! |
set_state <- function(new_state) { |
174 | ! |
stopifnot(all(names(new_state) %in% c("min", "max", "step", "value"))) |
175 | ! |
iv_r()$is_valid() |
176 |
# when value does not fall into min, max range, it will automatically get truncated |
|
177 | ||
178 |
# only update provided components, do not discasrd others |
|
179 | ! |
old_state <- cur_state() |
180 | ! |
new_state <- c(new_state, old_state[!names(old_state) %in% names(new_state)]) |
181 | ! |
new_state <- new_state[sort(names(new_state))] |
182 | ! |
if (!setequal(new_state, cur_state())) { |
183 | ! |
cur_state(new_state) |
184 |
} |
|
185 |
} |
|
186 | ! |
observeEvent(input$slider, { |
187 | ! |
set_state(list(value = input$slider)) |
188 |
}) |
|
189 |
# two values for range (dichotomous slider) |
|
190 | ! |
observeEvent( |
191 | ! |
eventExpr = { # nolint |
192 | ! |
input$value_low |
193 | ! |
input$value_high |
194 |
}, |
|
195 | ! |
handlerExpr = { # nolint |
196 | ! |
set_state(list(value = c(input$value_low, input$value_high))) |
197 |
} |
|
198 |
) |
|
199 |
# one value for value in range |
|
200 | ! |
observeEvent( |
201 | ! |
input$value, |
202 | ! |
handlerExpr = { # nolint |
203 | ! |
set_state(list(value = input$value)) |
204 |
} |
|
205 |
) |
|
206 | ||
207 | ! |
update_widgets <- function() { |
208 | ! |
state_slider <- cur_state() |
209 | ! |
req(length(state_slider) > 0) # update will otherwise not work |
210 | ! |
state_low <- state_slider |
211 | ! |
state_high <- state_slider |
212 | ! |
if (!is.null(state_slider$value) && (length(state_slider$value) > 1)) { |
213 | ! |
state_low$value <- state_low$value[[1]] |
214 | ! |
state_high$value <- state_high$value[[2]] |
215 |
} |
|
216 | ! |
if (input$toggle %% 2 == 0) { |
217 | ! |
do.call(updateSliderInput, c(list(session, "slider"), state_slider)) |
218 |
} else { |
|
219 | ! |
if (length(state_slider$value) > 1) { |
220 | ! |
do.call(updateNumericInput, c(list(session, "value_low"), state_low)) |
221 | ! |
do.call(updateNumericInput, c(list(session, "value_high"), state_high)) |
222 |
} else { |
|
223 | ! |
do.call(updateNumericInput, c(list(session, "value"), state_low)) |
224 |
} |
|
225 |
} |
|
226 |
} |
|
227 | ! |
observeEvent(input$toggle, { |
228 | ! |
update_widgets() |
229 | ! |
shinyjs::toggle("numeric_view") |
230 | ! |
shinyjs::toggle("slider") |
231 |
}) |
|
232 | ||
233 | ! |
update_toggle_slider <- function(value = NULL, min = NULL, max = NULL, step = NULL) { |
234 | ! |
if (!is.null(value) && is_dichotomous_slider) { |
235 | ! |
stopifnot(length(value) == 2) |
236 |
} |
|
237 | ! |
set_state(Filter(Negate(is.null), list(value = value, min = min, max = max, step = step))) |
238 | ! |
update_widgets() |
239 |
} |
|
240 | ! |
return(list( |
241 | ! |
state = cur_state, |
242 | ! |
update_state = update_toggle_slider |
243 |
)) |
|
244 |
}) |
|
245 |
} |
1 |
#' Density Distribution Plot |
|
2 |
#' |
|
3 |
#' This teal module renders the UI and calls the functions that create a density distribution plot |
|
4 |
#' and an accompanying summary table. |
|
5 |
#' |
|
6 |
#' @param label menu item label of the module in the teal app. |
|
7 |
#' @param trt_group \code{\link[teal.transform]{choices_selected}} object with available choices and pre-selected option |
|
8 |
#' for variable names representing treatment group e.g. `ARM`. |
|
9 |
#' @param color_manual vector of colors applied to treatment values. |
|
10 |
#' @param color_comb name or hex value for combined treatment color. |
|
11 |
#' @param plot_height controls plot height. |
|
12 |
#' @param plot_width optional, controls plot width. |
|
13 |
#' @param font_size font size control for title, `x-axis` label, `y-axis` label and legend. |
|
14 |
#' @param line_size plot line thickness. |
|
15 |
#' @param hline_arb numeric vector of at most 2 values identifying intercepts for arbitrary horizontal lines. |
|
16 |
#' @param hline_arb_color a character vector of at most length of \code{hline_arb}. |
|
17 |
#' naming the color for the arbitrary horizontal lines. |
|
18 |
#' @param hline_arb_label a character vector of at most length of \code{hline_arb}. |
|
19 |
#' naming the label for the arbitrary horizontal lines. |
|
20 |
#' @param facet_ncol numeric value indicating number of facets per row. |
|
21 |
#' @param comb_line display combined treatment line toggle. |
|
22 |
#' @param rotate_xlab 45 degree rotation of `x-axis` values. |
|
23 |
#' |
|
24 |
#' @inheritParams teal.widgets::standard_layout |
|
25 |
#' @inheritParams tm_g_gh_scatterplot |
|
26 |
#' |
|
27 |
#' |
|
28 |
#' @author Nick Paszty (npaszty) paszty.nicholas@gene.com |
|
29 |
#' @author Balazs Toth (tothb2) toth.balazs@gene.com |
|
30 |
#' |
|
31 |
#' @details None |
|
32 |
#' |
|
33 |
#' @export |
|
34 |
#' |
|
35 |
#' @examples |
|
36 |
#' # Example using ADaM structure analysis dataset. |
|
37 |
#' data <- teal_data() |
|
38 |
#' data <- within(data, { |
|
39 |
#' library(dplyr) |
|
40 |
#' library(stringr) |
|
41 |
#' |
|
42 |
#' # original ARM value = dose value |
|
43 |
#' arm_mapping <- list( |
|
44 |
#' "A: Drug X" = "150mg QD", |
|
45 |
#' "B: Placebo" = "Placebo", |
|
46 |
#' "C: Combination" = "Combination" |
|
47 |
#' ) |
|
48 |
#' ADSL <- rADSL |
|
49 |
#' ADLB <- rADLB |
|
50 |
#' var_labels <- lapply(ADLB, function(x) attributes(x)$label) |
|
51 |
#' ADLB <- ADLB %>% |
|
52 |
#' mutate( |
|
53 |
#' AVISITCD = case_when( |
|
54 |
#' AVISIT == "SCREENING" ~ "SCR", |
|
55 |
#' AVISIT == "BASELINE" ~ "BL", |
|
56 |
#' grepl("WEEK", AVISIT) ~ paste("W", str_extract(AVISIT, "(?<=(WEEK ))[0-9]+")), |
|
57 |
#' TRUE ~ as.character(NA) |
|
58 |
#' ), |
|
59 |
#' AVISITCDN = case_when( |
|
60 |
#' AVISITCD == "SCR" ~ -2, |
|
61 |
#' AVISITCD == "BL" ~ 0, |
|
62 |
#' grepl("W", AVISITCD) ~ as.numeric(gsub("[^0-9]*", "", AVISITCD)), |
|
63 |
#' TRUE ~ as.numeric(NA) |
|
64 |
#' ), |
|
65 |
#' AVISITCD = factor(AVISITCD) %>% reorder(AVISITCDN), |
|
66 |
#' TRTORD = case_when( |
|
67 |
#' ARMCD == "ARM C" ~ 1, |
|
68 |
#' ARMCD == "ARM B" ~ 2, |
|
69 |
#' ARMCD == "ARM A" ~ 3 |
|
70 |
#' ), |
|
71 |
#' ARM = as.character(arm_mapping[match(ARM, names(arm_mapping))]), |
|
72 |
#' ARM = factor(ARM) %>% reorder(TRTORD), |
|
73 |
#' ACTARM = as.character(arm_mapping[match(ACTARM, names(arm_mapping))]), |
|
74 |
#' ACTARM = factor(ACTARM) %>% reorder(TRTORD) |
|
75 |
#' ) |
|
76 |
#' |
|
77 |
#' attr(ADLB[["ARM"]], "label") <- var_labels[["ARM"]] |
|
78 |
#' attr(ADLB[["ACTARM"]], "label") <- var_labels[["ACTARM"]] |
|
79 |
#' }) |
|
80 |
#' |
|
81 |
#' datanames <- c("ADSL", "ADLB") |
|
82 |
#' datanames(data) <- datanames |
|
83 |
#' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
84 |
#' |
|
85 |
#' app <- init( |
|
86 |
#' data = data, |
|
87 |
#' modules = modules( |
|
88 |
#' tm_g_gh_density_distribution_plot( |
|
89 |
#' label = "Density Distribution Plot", |
|
90 |
#' dataname = "ADLB", |
|
91 |
#' param_var = "PARAMCD", |
|
92 |
#' param = choices_selected(c("ALT", "CRP", "IGA"), "ALT"), |
|
93 |
#' xaxis_var = choices_selected(c("AVAL", "BASE", "CHG", "PCHG"), "AVAL"), |
|
94 |
#' trt_group = choices_selected(c("ARM", "ACTARM"), "ARM"), |
|
95 |
#' color_manual = c( |
|
96 |
#' "150mg QD" = "#000000", |
|
97 |
#' "Placebo" = "#3498DB", |
|
98 |
#' "Combination" = "#E74C3C" |
|
99 |
#' ), |
|
100 |
#' color_comb = "#39ff14", |
|
101 |
#' comb_line = TRUE, |
|
102 |
#' plot_height = c(500, 200, 2000), |
|
103 |
#' font_size = c(12, 8, 20), |
|
104 |
#' line_size = c(1, .25, 3), |
|
105 |
#' hline_arb = c(.02, .05), |
|
106 |
#' hline_arb_color = c("red", "black"), |
|
107 |
#' hline_arb_label = c("Horizontal Line A", "Horizontal Line B") |
|
108 |
#' ) |
|
109 |
#' ) |
|
110 |
#' ) |
|
111 |
#' if (interactive()) { |
|
112 |
#' shinyApp(app$ui, app$server) |
|
113 |
#' } |
|
114 |
#' |
|
115 |
tm_g_gh_density_distribution_plot <- function(label, # nolint |
|
116 |
dataname, |
|
117 |
param_var, |
|
118 |
param, |
|
119 |
xaxis_var, |
|
120 |
trt_group, |
|
121 |
color_manual = NULL, |
|
122 |
color_comb = NULL, |
|
123 |
plot_height = c(500, 200, 2000), |
|
124 |
plot_width = NULL, |
|
125 |
font_size = c(12, 8, 20), |
|
126 |
line_size = c(1, .25, 3), |
|
127 |
hline_arb = numeric(0), |
|
128 |
hline_arb_color = "red", |
|
129 |
hline_arb_label = "Horizontal line", |
|
130 |
facet_ncol = 2L, |
|
131 |
comb_line = TRUE, |
|
132 |
rotate_xlab = FALSE, |
|
133 |
pre_output = NULL, |
|
134 |
post_output = NULL) { |
|
135 | ! |
message("Initializing tm_g_gh_density_distribution_plot") |
136 | ! |
checkmate::assert_string(label) |
137 | ! |
checkmate::assert_string(dataname) |
138 | ! |
checkmate::assert_string(param_var) |
139 | ! |
checkmate::assert_class(param, "choices_selected") |
140 | ! |
checkmate::assert_class(xaxis_var, "choices_selected") |
141 | ! |
checkmate::assert_class(trt_group, "choices_selected") |
142 | ! |
checkmate::assert_numeric(font_size, len = 3) |
143 | ! |
checkmate::assert_numeric(line_size, len = 3) |
144 | ! |
checkmate::assert_int(facet_ncol) |
145 | ! |
checkmate::assert_flag(comb_line) |
146 | ! |
checkmate::assert_flag(rotate_xlab) |
147 | ! |
validate_line_arb_arg(hline_arb, hline_arb_color, hline_arb_label) |
148 | ! |
checkmate::assert_numeric(plot_height, len = 3, any.missing = FALSE, finite = TRUE) |
149 | ! |
checkmate::assert_numeric(plot_height[1], lower = plot_height[2], upper = plot_height[3], .var.name = "plot_height") |
150 | ! |
checkmate::assert_numeric(plot_width, len = 3, any.missing = FALSE, null.ok = TRUE, finite = TRUE) |
151 | ! |
checkmate::assert_numeric( |
152 | ! |
plot_width[1], |
153 | ! |
lower = plot_width[2], upper = plot_width[3], null.ok = TRUE, .var.name = "plot_width" |
154 |
) |
|
155 | ||
156 | ! |
args <- as.list(environment()) |
157 | ||
158 | ! |
module( |
159 | ! |
label = label, |
160 | ! |
datanames = dataname, |
161 | ! |
server = srv_g_density_distribution_plot, |
162 | ! |
server_args = list( |
163 | ! |
dataname = dataname, |
164 | ! |
param_var = param_var, |
165 | ! |
param = param, |
166 | ! |
trt_group = trt_group, |
167 | ! |
color_manual = color_manual, |
168 | ! |
color_comb = color_comb, |
169 | ! |
plot_height = plot_height, |
170 | ! |
plot_width = plot_width, |
171 | ! |
module_args = args |
172 |
), |
|
173 | ! |
ui = ui_g_density_distribution_plot, |
174 | ! |
ui_args = args |
175 |
) |
|
176 |
} |
|
177 | ||
178 |
ui_g_density_distribution_plot <- function(id, ...) { |
|
179 | ! |
ns <- NS(id) |
180 | ! |
a <- list(...) |
181 | ||
182 | ! |
teal.widgets::standard_layout( |
183 | ! |
output = tags$div( |
184 | ! |
fluidRow( |
185 | ! |
teal.widgets::plot_with_settings_ui(id = ns("plot")) |
186 |
), |
|
187 | ! |
fluidRow(column( |
188 | ! |
width = 12, |
189 | ! |
tags$br(), tags$hr(), |
190 | ! |
tags$h4("Descriptive Statistics"), |
191 | ! |
DT::dataTableOutput(ns("table_ui")) |
192 |
)) |
|
193 |
), |
|
194 | ! |
encoding = tags$div( |
195 |
### Reporter |
|
196 | ! |
teal.reporter::simple_reporter_ui(ns("simple_reporter")), |
197 |
### |
|
198 | ! |
templ_ui_dataname(a$dataname), |
199 | ! |
teal.widgets::optionalSelectInput( |
200 | ! |
ns("trt_group"), |
201 | ! |
label = "Select Treatment Variable", |
202 | ! |
choices = get_choices(a$trt_group$choices), |
203 | ! |
selected = a$trt_group$selected, |
204 | ! |
multiple = FALSE |
205 |
), |
|
206 | ! |
uiOutput(ns("axis_selections")), |
207 | ! |
templ_ui_constraint(ns, label = "Data Constraint"), |
208 | ! |
ui_arbitrary_lines(id = ns("hline_arb"), a$hline_arb, a$hline_arb_label, a$hline_arb_color), |
209 | ! |
teal.widgets::panel_group( |
210 | ! |
teal.widgets::panel_item( |
211 | ! |
title = "Plot Aesthetic Settings", |
212 | ! |
toggle_slider_ui( |
213 | ! |
ns("xrange_scale"), |
214 | ! |
label = "X-Axis Range Zoom", |
215 | ! |
min = -1000000, |
216 | ! |
max = 1000000, |
217 | ! |
value = c(-1000000, 1000000) |
218 |
), |
|
219 | ! |
toggle_slider_ui( |
220 | ! |
ns("yrange_scale"), |
221 | ! |
label = "Y-Axis Range Zoom", |
222 | ! |
min = -1000000, |
223 | ! |
max = 1000000, |
224 | ! |
value = c(-1000000, 1000000) |
225 |
), |
|
226 | ! |
numericInput(ns("facet_ncol"), "Number of Plots Per Row:", a$facet_ncol, min = 1), |
227 | ! |
checkboxInput(ns("comb_line"), "Display Combined line", a$comb_line), |
228 | ! |
checkboxInput(ns("rug_plot"), "Include rug plot", value = FALSE), |
229 | ! |
checkboxInput(ns("rotate_xlab"), "Rotate X-axis Label", a$rotate_xlab) |
230 |
), |
|
231 | ! |
teal.widgets::panel_item( |
232 | ! |
title = "Plot settings", |
233 | ! |
teal.widgets::optionalSliderInputValMinMax(ns("font_size"), "Font Size", a$font_size, ticks = FALSE), |
234 | ! |
teal.widgets::optionalSliderInputValMinMax( |
235 | ! |
ns("line_size"), |
236 | ! |
"Line Size", |
237 | ! |
value_min_max = a$line_size, |
238 | ! |
step = .25, |
239 | ! |
ticks = FALSE |
240 |
) |
|
241 |
) |
|
242 |
) |
|
243 |
), |
|
244 | ! |
forms = tagList( |
245 | ! |
teal.widgets::verbatim_popup_ui(ns("rcode"), "Show R code") |
246 |
), |
|
247 | ! |
pre_output = a$pre_output, |
248 | ! |
post_output = a$post_output |
249 |
) |
|
250 |
} |
|
251 | ||
252 |
srv_g_density_distribution_plot <- function(id, # nolint |
|
253 |
data, |
|
254 |
reporter, |
|
255 |
filter_panel_api, |
|
256 |
dataname, |
|
257 |
param_var, |
|
258 |
param, |
|
259 |
trt_group, |
|
260 |
color_manual, |
|
261 |
color_comb, |
|
262 |
plot_height, |
|
263 |
plot_width, |
|
264 |
module_args) { |
|
265 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
266 | ! |
with_filter <- !missing(filter_panel_api) && inherits(filter_panel_api, "FilterPanelAPI") |
267 | ! |
checkmate::assert_class(data, "reactive") |
268 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
269 | ||
270 | ! |
moduleServer(id, function(input, output, session) { |
271 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
272 | ! |
output$axis_selections <- renderUI({ |
273 | ! |
env <- shiny::isolate(as.list(data()@env)) |
274 | ! |
resolved_x <- teal.transform::resolve_delayed(module_args$xaxis_var, env) |
275 | ! |
resolved_param <- teal.transform::resolve_delayed(module_args$param, env) |
276 | ! |
templ_ui_params_vars( |
277 | ! |
session$ns, |
278 | ! |
xparam_choices = resolved_param$choices, |
279 | ! |
xparam_selected = resolved_param$selected, |
280 | ! |
xparam_label = "Select a Biomarker", |
281 | ! |
xchoices = resolved_x$choices, |
282 | ! |
xselected = resolved_x$selected |
283 |
) |
|
284 |
}) |
|
285 | ||
286 | ! |
anl_q_output <- constr_anl_q( |
287 | ! |
session, input, data, dataname, |
288 | ! |
param_id = "xaxis_param", param_var = param_var, trt_group = input$trt_group, min_rows = 2 |
289 |
) |
|
290 | ||
291 | ! |
anl_q <- anl_q_output()$value |
292 | ||
293 |
# update sliders for axes taking constraints into account |
|
294 | ! |
xrange_slider <- toggle_slider_server("xrange_scale") |
295 | ! |
yrange_slider <- toggle_slider_server("yrange_scale") |
296 | ! |
keep_range_slider_updated(session, input, xrange_slider$update_state, "xaxis_var", "xaxis_param", anl_q) |
297 | ! |
keep_range_slider_updated( |
298 | ! |
session, |
299 | ! |
input, |
300 | ! |
yrange_slider$update_state, |
301 | ! |
"xaxis_var", |
302 | ! |
"xaxis_param", |
303 | ! |
anl_q, |
304 | ! |
is_density = TRUE |
305 |
) |
|
306 | ! |
keep_data_const_opts_updated(session, input, anl_q, "xaxis_param") |
307 | ||
308 | ! |
horizontal_line <- srv_arbitrary_lines("hline_arb") |
309 | ||
310 | ! |
iv_r <- reactive({ |
311 | ! |
iv <- shinyvalidate::InputValidator$new() |
312 | ||
313 | ! |
iv$add_rule("xaxis_param", shinyvalidate::sv_required("Please select a biomarker")) |
314 | ! |
iv$add_rule("trt_group", shinyvalidate::sv_required("Please select a treatment variable")) |
315 | ! |
iv$add_rule("xaxis_var", shinyvalidate::sv_required("Please select an X-Axis variable")) |
316 | ! |
iv$add_rule("facet_ncol", plots_per_row_validate_rules()) |
317 | ||
318 | ! |
iv$add_validator(horizontal_line()$iv_r()) |
319 | ! |
iv$add_validator(anl_q_output()$iv_r()) |
320 | ! |
iv$enable() |
321 | ! |
iv |
322 |
}) |
|
323 | ||
324 | ||
325 | ! |
create_plot <- reactive({ |
326 | ! |
teal::validate_inputs(iv_r()) |
327 | ! |
req(anl_q()) |
328 | ||
329 |
# nolint start |
|
330 | ! |
param <- input$xaxis_param |
331 | ! |
xaxis_var <- input$xaxis_var |
332 | ! |
xlim <- xrange_slider$state()$value |
333 | ! |
ylim <- yrange_slider$state()$value |
334 | ! |
font_size <- input$font_size |
335 | ! |
line_size <- input$line_size |
336 | ! |
hline_arb <- horizontal_line()$line_arb |
337 | ! |
hline_arb_label <- horizontal_line()$line_arb_label |
338 | ! |
hline_arb_color <- horizontal_line()$line_arb_color |
339 | ! |
facet_ncol <- input$facet_ncol |
340 | ||
341 | ! |
comb_line <- input$comb_line |
342 | ! |
rug_plot <- input$rug_plot |
343 | ! |
rotate_xlab <- input$rotate_xlab |
344 | ! |
trt_group <- input$trt_group |
345 |
# nolint end |
|
346 | ||
347 | ||
348 | ! |
teal.code::eval_code( |
349 | ! |
object = anl_q()$qenv, |
350 | ! |
code = bquote({ |
351 | ! |
p <- goshawk::g_density_distribution_plot( |
352 | ! |
data = ANL, |
353 | ! |
param_var = .(param_var), |
354 | ! |
param = .(param), |
355 | ! |
xaxis_var = .(xaxis_var), |
356 | ! |
trt_group = .(trt_group), |
357 | ! |
xlim = .(xlim), |
358 | ! |
ylim = .(ylim), |
359 | ! |
color_manual = .(color_manual), |
360 | ! |
color_comb = .(color_comb), |
361 | ! |
font_size = .(font_size), |
362 | ! |
line_size = .(line_size), |
363 | ! |
facet_ncol = .(facet_ncol), |
364 | ! |
comb_line = .(comb_line), |
365 | ! |
hline_arb = .(hline_arb), |
366 | ! |
hline_arb_label = .(hline_arb_label), |
367 | ! |
hline_arb_color = .(hline_arb_color), |
368 | ! |
rug_plot = .(rug_plot) |
369 |
) |
|
370 |
}) |
|
371 |
) |
|
372 |
}) |
|
373 | ||
374 | ! |
create_table <- reactive({ |
375 | ! |
req(iv_r()$is_valid()) |
376 | ! |
req(anl_q()) |
377 | ! |
param <- input$xaxis_param |
378 | ! |
xaxis_var <- input$xaxis_var |
379 | ! |
font_size <- input$font_size |
380 | ! |
trt_group <- input$trt_group |
381 | ||
382 | ! |
teal.code::eval_code( |
383 | ! |
object = anl_q()$qenv, |
384 | ! |
code = bquote( |
385 | ! |
tbl <- goshawk::t_summarytable( |
386 | ! |
data = ANL, |
387 | ! |
trt_group = .(trt_group), |
388 | ! |
param_var = .(param_var), |
389 | ! |
param = .(param), |
390 | ! |
xaxis_var = .(xaxis_var), |
391 | ! |
font_size = .(font_size) |
392 |
) |
|
393 |
) |
|
394 |
) |
|
395 |
}) |
|
396 | ||
397 | ! |
plot_r <- reactive({ |
398 | ! |
create_plot()[["p"]] |
399 |
}) |
|
400 | ||
401 | ! |
plot_data <- teal.widgets::plot_with_settings_srv( |
402 | ! |
id = "plot", |
403 | ! |
plot_r = plot_r, |
404 | ! |
height = plot_height, |
405 | ! |
width = plot_width, |
406 |
) |
|
407 | ||
408 | ! |
output$table_ui <- DT::renderDataTable({ |
409 | ! |
req(create_table()) |
410 | ! |
tbl <- create_table()[["tbl"]] |
411 | ! |
numeric_cols <- names(dplyr::select_if(tbl, is.numeric)) |
412 | ||
413 | ! |
DT::datatable(tbl, rownames = FALSE, options = list(scrollX = TRUE)) %>% |
414 | ! |
DT::formatRound(numeric_cols, 2) |
415 |
}) |
|
416 | ||
417 | ! |
joined_qenvs <- reactive({ |
418 | ! |
req(create_plot(), create_table()) |
419 | ! |
teal.code::join(create_plot(), create_table()) |
420 |
}) |
|
421 | ||
422 | ! |
teal.widgets::verbatim_popup_srv( |
423 | ! |
id = "rcode", |
424 | ! |
verbatim_content = reactive( |
425 | ! |
teal.code::get_code(joined_qenvs()) |
426 |
), |
|
427 | ! |
title = "Show R Code for Density Distribution Plot" |
428 |
) |
|
429 | ||
430 |
### REPORTER |
|
431 | ! |
if (with_reporter) { |
432 | ! |
card_fun <- function(comment, label) { |
433 | ! |
card <- report_card_template_goshawk( |
434 | ! |
title = "Density Distribution Plot", |
435 | ! |
label = label, |
436 | ! |
with_filter = with_filter, |
437 | ! |
filter_panel_api = filter_panel_api, |
438 | ! |
constraint_list = list( |
439 | ! |
constraint_var = input$constraint_var, |
440 | ! |
constraint_range_min = input$constraint_range_min, |
441 | ! |
constraint_range_max = input$constraint_range_max |
442 |
) |
|
443 |
) |
|
444 | ! |
card$append_text("Plot", "header3") |
445 | ! |
card$append_plot(plot_r(), dim = plot_data$dim()) |
446 | ! |
card$append_text("Descriptive Statistics", "header3") |
447 | ! |
card$append_table( |
448 | ! |
create_table()[["tbl"]] %>% dplyr::mutate_if(is.numeric, round, 2) |
449 |
) |
|
450 | ! |
if (!comment == "") { |
451 | ! |
card$append_text("Comment", "header3") |
452 | ! |
card$append_text(comment) |
453 |
} |
|
454 | ! |
card$append_src( |
455 | ! |
teal.code::get_code( |
456 | ! |
teal.code::join(create_plot(), create_table()) |
457 |
) |
|
458 |
) |
|
459 | ! |
card |
460 |
} |
|
461 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun) |
462 |
} |
|
463 |
### |
|
464 |
}) |
|
465 |
} |
1 |
#' UI module to arbitrary lines |
|
2 |
#' |
|
3 |
#' UI module to input either horizontal or vertical lines to a plot via comma separated values |
|
4 |
#' |
|
5 |
#' @param id (`character(1)`)\cr |
|
6 |
#' defining namespace of the `shiny` module. |
|
7 |
#' @param line_arb (`numeric`)\cr |
|
8 |
#' default values for the `textInput` defining values of arbitrary lines |
|
9 |
#' @param line_arb_color (`character`)\cr |
|
10 |
#' default values for the `textInput` defining colors of arbitrary lines |
|
11 |
#' @param line_arb_label (`character`)\cr |
|
12 |
#' default values for the `textInput` defining labels of arbitrary lines |
|
13 |
#' @param title (`character(1)`)\cr |
|
14 |
#' title of the arbitrary lines input. The default is "Arbitrary Horizontal Lines". |
|
15 |
#' @return (`shiny.tag`) an input to define values, colors and labels for arbitrary |
|
16 |
#' straight lines. |
|
17 |
#' @keywords internal |
|
18 |
ui_arbitrary_lines <- function(id, line_arb, line_arb_label, line_arb_color, title = "Arbitrary Horizontal Lines:") { |
|
19 | ! |
ns <- NS(id) |
20 | ! |
tags$div( |
21 | ! |
tags$b(title), |
22 | ! |
textInput( |
23 | ! |
ns("line_arb"), |
24 | ! |
tags$div( |
25 | ! |
class = "teal-tooltip", |
26 | ! |
tagList( |
27 | ! |
"Value:", |
28 | ! |
icon("circle-info"), |
29 | ! |
tags$span( |
30 | ! |
class = "tooltiptext", |
31 | ! |
"For multiple lines, supply a comma separated list of values." |
32 |
) |
|
33 |
) |
|
34 |
), |
|
35 | ! |
value = paste(line_arb, collapse = ", ") |
36 |
), |
|
37 | ! |
textInput(ns("line_arb_label"), label = "Label:", value = paste(line_arb_label, collapse = ", ")), |
38 | ! |
textInput(ns("line_arb_color"), label = "Color:", value = paste(line_arb_color, collapse = ", ")) |
39 |
) |
|
40 |
} |
|
41 |
#' Server module to arbitrary lines |
|
42 |
#' |
|
43 |
#' Server to validate and transform the comma separated values into vectors of values |
|
44 |
#' to be passed into goshawk functions. |
|
45 |
#' @inheritParams shiny::moduleServer |
|
46 |
#' @return (`reactive`) returning a `list` containing `line_arb`, `line_arb_color`, |
|
47 |
#' `line_arb_label` which are validated and could be passed to `goshawk` plot functions. |
|
48 |
#' @keywords internal |
|
49 |
srv_arbitrary_lines <- function(id) { |
|
50 | ! |
moduleServer(id, function(input, output, session) { |
51 | ! |
teal.logger::log_shiny_input_changes(input, namespace = "teal.goshawk") |
52 | ! |
comma_sep_to_values <- function(values, wrapper_fun = trimws) { |
53 | ! |
vals <- strsplit(values, "\\s{0,},\\s{0,}")[[1]] |
54 | ! |
suppressWarnings(wrapper_fun(vals)) |
55 |
} |
|
56 | ||
57 | ! |
iv_r <- reactive({ |
58 | ! |
iv <- shinyvalidate::InputValidator$new() |
59 | ! |
iv$add_rule("line_arb", shinyvalidate::sv_optional()) |
60 | ! |
iv$add_rule( |
61 | ! |
"line_arb", |
62 | ! |
~ if (any(is.na(comma_sep_to_values(., as.numeric)))) { |
63 | ! |
"Arbitrary lines values should be a comma separated list of numbers" |
64 |
} |
|
65 |
) |
|
66 | ||
67 | ! |
iv_color <- shinyvalidate::InputValidator$new() |
68 | ! |
iv_color$condition(~ length(line_arb()) != 0) |
69 | ||
70 | ! |
iv_color$add_rule("line_arb_color", shinyvalidate::sv_optional()) |
71 | ! |
iv_color$add_rule( |
72 | ! |
"line_arb_color", |
73 | ! |
~ if (!length(comma_sep_to_values(.)) %in% c(1, length(line_arb()))) { |
74 | ! |
sprintf( |
75 | ! |
"Line input error: number of colors should be equal to 1, the number of lines (%d) or left blank for 'red'", |
76 | ! |
length(line_arb()) |
77 |
) |
|
78 |
} |
|
79 |
) |
|
80 | ! |
iv_color$add_rule("line_arb_color", ~ if (!check_color(comma_sep_to_values(.))) { |
81 | ! |
"The line colors entered cannot be converted to colors in R, please check your spelling" |
82 |
}) |
|
83 | ! |
iv$add_validator(iv_color) |
84 | ||
85 | ||
86 | ! |
iv_label <- shinyvalidate::InputValidator$new() |
87 | ! |
iv_label$condition(~ length(line_arb()) != 0) |
88 | ||
89 | ! |
iv_label$add_rule("line_arb_label", shinyvalidate::sv_optional()) |
90 | ! |
iv_label$add_rule( |
91 | ! |
"line_arb_label", |
92 | ! |
~ if (!length(comma_sep_to_values(.)) %in% c(1, length(line_arb()))) { |
93 | ! |
sprintf( |
94 | ! |
"Line input error: number of labels should be equal to 1, the number of lines (%d) or left blank", |
95 | ! |
length(line_arb()) |
96 |
) |
|
97 |
} |
|
98 |
) |
|
99 | ! |
iv$add_validator(iv_label) |
100 | ! |
iv |
101 |
}) |
|
102 | ||
103 | ! |
line_arb <- reactive({ |
104 | ! |
req(!is.null(input$line_arb)) |
105 | ! |
comma_sep_to_values(input$line_arb, as.numeric) |
106 |
}) |
|
107 | ||
108 | ! |
line_arb_label <- reactive({ |
109 | ! |
if (length(line_arb()) == 0) { |
110 | ! |
return(character(0)) |
111 |
} |
|
112 | ! |
val <- comma_sep_to_values(input$line_arb_label) |
113 | ! |
if (length(val) == 0) { |
114 | ! |
val <- "" |
115 |
} |
|
116 | ! |
val |
117 |
}) |
|
118 | ||
119 | ! |
line_arb_color <- reactive({ |
120 | ! |
if (length(line_arb()) == 0) { |
121 | ! |
return(character(0)) |
122 |
} |
|
123 | ! |
val <- comma_sep_to_values(input$line_arb_color) |
124 | ! |
if (length(val) == 0 || all(val == "")) { |
125 | ! |
val <- "red" |
126 |
} |
|
127 | ! |
val |
128 |
}) |
|
129 | ||
130 | ! |
return( |
131 | ! |
reactive( |
132 | ! |
list( |
133 | ! |
iv_r = iv_r, |
134 | ! |
line_arb = line_arb(), |
135 | ! |
line_arb_color = line_arb_color(), |
136 | ! |
line_arb_label = line_arb_label() |
137 |
) |
|
138 |
) |
|
139 |
) |
|
140 |
}) |
|
141 |
} |
|
142 | ||
143 |
check_color <- function(col) { |
|
144 | ! |
tryCatch( |
145 | ! |
is.matrix(grDevices::col2rgb(col)), |
146 | ! |
error = function(e) FALSE |
147 |
) |
|
148 |
} |
|
149 | ||
150 |
# to check the arbitrary line arguments |
|
151 |
validate_line_arb_arg <- function(line_arb, line_arb_color, line_arb_label) { |
|
152 | ! |
checkmate::assert_numeric(line_arb) |
153 | ! |
if (length(line_arb) > 0) { |
154 | ! |
checkmate::assert( |
155 | ! |
checkmate::check_string(line_arb_color), |
156 | ! |
checkmate::check_character(line_arb_color, len = length(line_arb)) |
157 |
) |
|
158 | ! |
checkmate::assert( |
159 | ! |
checkmate::check_string(line_arb_label), |
160 | ! |
checkmate::check_character(line_arb_label, len = length(line_arb)) |
161 |
) |
|
162 |
} |
|
163 |
} |
|
164 | ||
165 |
# to check the variable line arguments |
|
166 |
validate_line_vars_arg <- function(line_vars, line_vars_colors, line_vars_labels) { |
|
167 | ! |
checkmate::assert_character(line_vars) |
168 | ! |
if (length(line_vars) > 0) { |
169 | ! |
checkmate::assert( |
170 | ! |
checkmate::check_string(line_vars_colors), |
171 | ! |
checkmate::check_character(line_vars_colors, len = length(line_vars)) |
172 |
) |
|
173 | ! |
checkmate::assert( |
174 | ! |
checkmate::check_string(line_vars_labels), |
175 | ! |
checkmate::check_character(line_vars_labels, len = length(line_vars)) |
176 |
) |
|
177 |
} |
|
178 |
} |
1 |
keep_range_slider_updated <- function(session, |
|
2 |
input, |
|
3 |
update_slider_fcn, |
|
4 |
id_var, |
|
5 |
id_param_var, |
|
6 |
reactive_ANL, # nolint |
|
7 |
is_density = FALSE) { |
|
8 | ! |
stopifnot(is.function(update_slider_fcn)) |
9 | ||
10 | ! |
observe({ |
11 | ! |
varname <- input[[id_var]] |
12 | ! |
validate(need(varname, "Please select variable")) |
13 | ! |
paramname <- input[[id_param_var]] |
14 | ! |
validate(need(paramname, "Please select variable")) |
15 | ! |
req(length(paramname) == 1) |
16 | ||
17 |
# we need id_param_var (e.g. ALT) to filter down because the y-axis may have a different |
|
18 |
# param var and the range of id_var (e.g. BASE) values may be larger due to this |
|
19 |
# therefore, we need to filter |
|
20 | ! |
ANL <- reactive_ANL()$ANL %>% dplyr::filter(.data$PARAMCD == paramname) # nolint |
21 | ! |
validate_has_variable(ANL, varname, paste("variable", varname, "does not exist")) |
22 | ||
23 | ! |
var <- stats::na.omit(ANL[[varname]]) |
24 | ! |
minmax <- if (length(var)) c(floor(min(var)), ceiling(max(var))) else c(0, 0) |
25 | ! |
step <- NULL |
26 | ||
27 | ! |
if (isTRUE(is_density)) { |
28 | ! |
minmax <- c(0, round(max(stats::density(stats::na.omit(ANL[[varname]]))$y) * 1.5, 5)) |
29 | ! |
step <- round(max(stats::density(stats::na.omit(ANL[[varname]]))$y) / 100, 5) |
30 |
} |
|
31 | ||
32 | ! |
isolate(update_slider_fcn( |
33 | ! |
min = minmax[[1]], |
34 | ! |
max = minmax[[2]], |
35 | ! |
value = minmax, |
36 | ! |
step = step |
37 |
)) |
|
38 |
}) |
|
39 |
} |
1 |
templ_ui_output_datatable <- function(ns) { |
|
2 | ! |
tags$div( |
3 | ! |
teal.widgets::plot_with_settings_ui(id = ns("plot")), |
4 | ! |
tags$br(), tags$hr(), |
5 | ! |
tags$h4("Selected Data Points"), |
6 | ! |
DT::dataTableOutput(ns("brush_data")) |
7 |
) |
|
8 |
} |
|
9 | ||
10 |
templ_ui_dataname <- function(dataname) { |
|
11 | ! |
tags$label(dataname, "Data Settings", class = "text-primary") |
12 |
} |
|
13 | ||
14 |
# UI to create params (biomarker, value of PARAMCD) and vars (column, e.g. AVAL column) select fields for x and y |
|
15 |
templ_ui_params_vars <- function(ns, |
|
16 |
# x |
|
17 |
xparam_choices = NULL, |
|
18 |
xparam_selected = NULL, |
|
19 |
xparam_label = NULL, # biomarker, e.g. ALT |
|
20 |
xchoices = NULL, |
|
21 |
xselected = NULL, |
|
22 |
xvar_label = NULL, # variable, e.g. AVAL |
|
23 |
# y |
|
24 |
yparam_choices = NULL, |
|
25 |
yparam_selected = NULL, |
|
26 |
yparam_label = NULL, # biomarker, e.g. ALT |
|
27 |
ychoices = NULL, |
|
28 |
yselected = NULL, |
|
29 |
yvar_label = NULL, # variable, e.g. AVAL |
|
30 |
multiple = FALSE) { |
|
31 | ! |
if (is.null(xparam_choices) && !is.null(xchoices) && !is.null(yparam_choices)) { |
32 |
# otherwise, xchoices will appear first without any biomarker to select and this looks odd in the UI |
|
33 | ! |
stop( |
34 | ! |
"You have to specify xparam choices rather than yparamchoices |
35 | ! |
if both xvar and yvar should be values for the same biomarker." |
36 |
) |
|
37 |
} |
|
38 | ! |
tagList( |
39 | ! |
if (!is.null(xparam_choices)) { |
40 | ! |
teal.widgets::optionalSelectInput( |
41 | ! |
ns("xaxis_param"), |
42 | ! |
`if`(is.null(xparam_label), "Select an X-Axis Biomarker", xparam_label), |
43 | ! |
xparam_choices, |
44 | ! |
`if`(is.null(xparam_selected), xparam_choices[1], xparam_selected), |
45 | ! |
multiple = FALSE |
46 |
) |
|
47 |
}, |
|
48 | ! |
if (!is.null(xchoices)) { |
49 | ! |
teal.widgets::optionalSelectInput( |
50 | ! |
ns("xaxis_var"), |
51 | ! |
`if`(is.null(xvar_label), "Select an X-Axis Variable", xvar_label), |
52 | ! |
xchoices, xselected, |
53 | ! |
multiple = multiple |
54 |
) |
|
55 |
}, |
|
56 | ! |
if (!is.null(yparam_choices)) { |
57 | ! |
teal.widgets::optionalSelectInput( |
58 | ! |
ns("yaxis_param"), |
59 | ! |
`if`(is.null(yparam_label), "Select an Y-Axis Biomarker", yparam_label), |
60 | ! |
yparam_choices, |
61 | ! |
`if`(is.null(yparam_selected), yparam_choices[1], yparam_selected), |
62 | ! |
multiple = FALSE |
63 |
) |
|
64 |
}, |
|
65 | ! |
if (!is.null(ychoices)) { |
66 | ! |
teal.widgets::optionalSelectInput( |
67 | ! |
ns("yaxis_var"), |
68 | ! |
`if`(is.null(yvar_label), "Select a Y-Axis Variable", yvar_label), |
69 | ! |
ychoices, yselected, |
70 | ! |
multiple = multiple |
71 |
) |
|
72 |
} |
|
73 |
) |
|
74 |
} |
1 |
#' Include `CSS` files from `/inst/css/` package directory to application header |
|
2 |
#' |
|
3 |
#' `system.file` should not be used to access files in other packages, it does |
|
4 |
#' not work with `devtools`. Therefore, we redefine this method in each package |
|
5 |
#' as needed. Thus, we do not export this method. |
|
6 |
#' |
|
7 |
#' @param pattern (`character`) pattern of files to be included |
|
8 |
#' |
|
9 |
#' @return HTML code that includes `CSS` files |
|
10 |
#' @keywords internal |
|
11 |
include_css_files <- function(pattern = "*") { |
|
12 | ! |
css_files <- list.files( |
13 | ! |
system.file("css", package = "teal.goshawk", mustWork = TRUE), |
14 | ! |
pattern = pattern, full.names = TRUE |
15 |
) |
|
16 | ! |
if (length(css_files) == 0) { |
17 | ! |
return(NULL) |
18 |
} |
|
19 | ! |
return(shiny::singleton(shiny::tags$head(lapply(css_files, shiny::includeCSS)))) |
20 |
} |
|
21 | ||
22 |
plots_per_row_validate_rules <- function(required = TRUE) { |
|
23 | ! |
msg <- "Number of plots per row must be a positive integer" |
24 | ! |
shinyvalidate::compose_rules( |
25 | ! |
if (required) { |
26 | ! |
shinyvalidate::sv_required(msg) |
27 |
} else { |
|
28 | ! |
shinyvalidate::sv_optional() |
29 |
}, |
|
30 | ! |
shinyvalidate::sv_integer(msg), |
31 | ! |
shinyvalidate::sv_gt(0, message_fmt = msg) |
32 |
) |
|
33 |
} |
|
34 | ||
35 |
#' Template Function for `TealReportCard` Creation and Customization in `teal.goshawk` |
|
36 |
#' |
|
37 |
#' This function generates a report card with a title, |
|
38 |
#' an optional description, and the option to append the filter state list. |
|
39 |
#' Additionally, it display selected constraint options. |
|
40 |
#' |
|
41 |
#' @inheritParams teal::report_card_template |
|
42 |
#' @param constraint_list (`list`) a list containing constraint variables, including: |
|
43 |
#' - constraint_var (`character(1)`) the constraint variable name. |
|
44 |
#' - constraint_range_min (`numeric(1)`) the minimum constraint range value. |
|
45 |
#' - constraint_range_max (`numeric(1)`) the maximum constraint range value. |
|
46 |
#' @param constraint_description (`character(1)`) description of the constraints. |
|
47 |
#' @param style (`character(1)`) style of the constraint text block. |
|
48 |
#' options: `default`, `verbatim` (default is `default`). |
|
49 |
#' |
|
50 |
#' @return (`TealReportCard`) populated with a title, description, and filter state |
|
51 |
#' |
|
52 |
#' @keywords internal |
|
53 |
report_card_template_goshawk <- function(title, |
|
54 |
label, |
|
55 |
with_filter, |
|
56 |
filter_panel_api, |
|
57 |
constraint_list, |
|
58 |
constraint_description = NULL, |
|
59 |
style = "default") { |
|
60 | ! |
checkmate::assert_subset(names(constraint_list), c("constraint_var", "constraint_range_min", "constraint_range_max")) |
61 | ! |
checkmate::assert_string(constraint_description, null.ok = TRUE) |
62 | ! |
checkmate::assert_choice(style, c("default", "verbatim")) |
63 | ||
64 | ! |
card <- teal::report_card_template( |
65 | ! |
title = title, |
66 | ! |
label = label, |
67 | ! |
with_filter = with_filter, |
68 | ! |
filter_panel_api = filter_panel_api |
69 |
) |
|
70 | ||
71 | ! |
card$append_text("Selected Options", "header3") |
72 | ! |
card$append_text( |
73 | ! |
paste( |
74 | ! |
formatted_data_constraint( |
75 | ! |
constraint_list$constraint_var, |
76 | ! |
constraint_list$constraint_range_min, |
77 | ! |
constraint_list$constraint_range_max |
78 |
), |
|
79 | ! |
constraint_description |
80 |
), |
|
81 | ! |
style = style |
82 |
) |
|
83 | ! |
card |
84 |
} |
|
85 | ||
86 |
#' Get Choices |
|
87 |
#' |
|
88 |
#' This function returns choices based on the class of the input. |
|
89 |
#' If the input is of class `delayed_data`, it returns the `subset` of the input. |
|
90 |
#' If `subset` is NULL and the input contains `var_label` and `var_choices`, |
|
91 |
#' it throws an error prompting to resolve delayed inputs. |
|
92 |
#' Otherwise, it returns the input as is. |
|
93 |
#' |
|
94 |
#' @param choices An object that contains choices. |
|
95 |
#' @return A vector of choices. |
|
96 |
#' @keywords internal |
|
97 |
get_choices <- function(choices) { |
|
98 | ! |
if (inherits(choices, "delayed_data")) { |
99 | ! |
if (is.null(choices$subset)) { |
100 | ! |
if (!is.null(choices$var_label) && !is.null(choices$var_choices)) { |
101 | ! |
stop( |
102 | ! |
"Resolve delayed inputs by evaluating the code within the provided datasets. |
103 | ! |
Check ?teal.transform::resolve_delayed for more information." |
104 |
) |
|
105 |
} else { |
|
106 | ! |
stop("Subset is NULL and necessary fields are missing.") |
107 |
} |
|
108 |
} else { |
|
109 | ! |
choices$subset |
110 |
} |
|
111 |
} else { |
|
112 | ! |
choices |
113 |
} |
|
114 |
} |
1 |
#' helper for writing arm mapping and ordering code. |
|
2 |
#' |
|
3 |
#' Provides lines of code for left hand side of arm mapping. user must provide right hand side |
|
4 |
#' |
|
5 |
#' @details SPA configure study specific pre-processing for deploying `goshawk`. writing the code for `ARM` mapping and |
|
6 |
#' ordering is tedious. this function helps to get that started by providing the left hand side of the |
|
7 |
#' mapping and ordering syntax. call the function and then copy and paste the resulting code from the console |
|
8 |
#' into the app.R file. |
|
9 |
#' |
|
10 |
#' @param df_armvar the dataframe and column name containing treatment code. e.g. `ADSL$ARMCD` |
|
11 |
#' @param code controls whether mapping or ordering code is written to console. Valid values: `"M"` and `"O"`. |
|
12 |
#' |
|
13 |
#' @export |
|
14 |
#' |
|
15 |
#' @examples |
|
16 |
#' ADSL <- rADSL |
|
17 |
#' |
|
18 |
#' # get treatment mapping code |
|
19 |
#' maptrt(df_armvar = ADSL$ARMCD, code = "M") |
|
20 |
#' |
|
21 |
#' # get treatment ordering code |
|
22 |
#' maptrt(df_armvar = ADSL$ARMCD, code = "O") |
|
23 |
maptrt <- function(df_armvar, code = c("M", "O")) { |
|
24 | ! |
code <- match.arg(code) |
25 | ||
26 |
# get arm variable |
|
27 | ! |
trtvar <- strsplit(deparse(substitute(df_armvar)), "[$]")[[1]][2] |
28 | ||
29 | ! |
dftrt <- data.frame(unique(df_armvar)) %>% |
30 | ! |
dplyr::mutate(trt_mapping = paste0("\"", unique(df_armvar), "\"", " = \"\",")) %>% |
31 | ! |
dplyr::mutate(trt_ordering = paste0(eval(trtvar), " == \"", unique(df_armvar), "\"", " ~ ,")) |
32 | ||
33 | ! |
if (toupper(code) == "M") { |
34 | ! |
print(unname(dftrt["trt_mapping"]), row.names = FALSE) |
35 | ! |
} else if (toupper(code) == "O") { |
36 | ! |
print(unname(dftrt["trt_ordering"]), row.names = FALSE) |
37 |
} |
|
38 |
} |
1 |
.onLoad <- function(libname, pkgname) { # nolint |
|
2 | ! |
teal.logger::register_logger(namespace = "teal.goshawk") |
3 | ! |
teal.logger::register_handlers("teal.goshawk") |
4 |
} |