| 1 |
- #' Teal Module for PCA Analysis+ #' Teal Module for RNA-seq Barplot |
||
| 5 |
- #' This module provides an interactive principal components plot and an+ #' This module provides an interactive barplot for RNA-seq gene expression |
||
| 6 |
- #' interactive heatmap with correlation of principal components with sample+ #' analysis. |
||
| 7 |
- #' variables.+ #' |
||
| 8 |
- #'+ #' @inheritParams module_arguments |
||
| 9 |
- #' @inheritParams module_arguments+ #' |
||
| 10 |
- #'+ #' @return Shiny module to be used in the teal app. |
||
| 11 |
- #' @return Shiny module to be used in the teal app.+ #' |
||
| 19 |
- #' tm_g_pca(+ #' tm_g_barplot( |
||
| 20 |
- #' label = "PCA plot",+ #' label = "barplot", |
||
| 28 |
- tm_g_pca <- function(label,+ tm_g_barplot <- function(label, |
||
| 29 |
- mae_name,+ mae_name, |
||
| 30 |
- exclude_assays = character(),+ exclude_assays = character(), |
||
| 31 |
- pre_output = NULL,+ summary_funs = list( |
||
| 32 |
- post_output = NULL) {
+ Mean = colMeans, |
||
| 33 | -! | +
- message("Initializing tm_g_pca")
+ Median = matrixStats::colMedians, |
|
| 34 | -! | +
- assert_string(label)+ Max = matrixStats::colMaxs |
|
| 35 | -! | +
- assert_string(mae_name)+ ), |
|
| 36 | -! | +
- assert_tag(pre_output, null.ok = TRUE)+ pre_output = NULL, |
|
| 37 | -! | +
- assert_tag(post_output, null.ok = TRUE)+ post_output = NULL, |
|
| 38 |
-
+ .test = FALSE) {
|
||
| 39 | ! |
- teal::module(+ message("Initializing tm_g_barplot")
|
|
| 40 | ! |
- label = label,+ assert_string(label) |
|
| 41 | ! |
- server = srv_g_pca,+ assert_string(mae_name) |
|
| 42 | ! |
- server_args = list(+ assert_character(exclude_assays) |
|
| 43 | ! |
- mae_name = mae_name,+ assert_summary_funs(summary_funs) |
|
| 44 | ! |
- exclude_assays = exclude_assays+ assert_tag(pre_output, null.ok = TRUE) |
|
| 45 | -+ | ! |
- ),+ assert_tag(post_output, null.ok = TRUE) |
| 46 | ! |
- ui = ui_g_pca,+ assert_flag(.test) |
|
| 47 | -! | +
- ui_args = list(+ |
|
| 48 | ! |
- mae_name = mae_name,+ module( |
|
| 49 | ! |
- pre_output = pre_output,+ label = label, |
|
| 50 | ! |
- post_output = post_output+ server = srv_g_barplot, |
|
| 51 | -+ | ! |
- ),+ server_args = list( |
| 52 | ! |
- datanames = mae_name+ mae_name = mae_name, |
|
| 53 | -+ | ! |
- )+ exclude_assays = exclude_assays, |
| 54 | -+ | ! |
- }+ summary_funs = summary_funs, |
| 55 | -+ | ! |
-
+ .test = .test |
| 56 |
- #' @describeIn tm_g_pca sets up the user interface.+ ), |
||
| 57 | -+ | ! |
- #' @inheritParams module_arguments+ ui = ui_g_barplot, |
| 58 | -+ | ! |
- #' @export+ ui_args = list( |
| 59 | -+ | ! |
- ui_g_pca <- function(id,+ mae_name = mae_name, |
| 60 | -+ | ! |
- mae_name,+ summary_funs = summary_funs, |
| 61 | -+ | ! |
- pre_output,+ pre_output = pre_output, |
| 62 | -+ | ! |
- post_output) {
+ post_output = post_output, |
| 63 | -1x | +! |
- ns <- NS(id)+ .test = .test |
| 64 |
-
+ ), |
||
| 65 | -1x | +! |
- tagList(+ datanames = mae_name |
| 66 | -1x | +
- teal.widgets::standard_layout(+ ) |
|
| 67 | -1x | +
- include_css_files(pattern = "*"),+ } |
|
| 68 | -1x | +
- encoding = tags$div(+ |
|
| 69 |
- ### Reporter+ #' @describeIn tm_g_barplot sets up the user interface. |
||
| 70 | -1x | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' @inheritParams module_arguments |
|
| 71 |
- ###+ #' @export |
||
| 72 | -1x | +
- tags$label("Encodings", class = "text-primary"),
+ ui_g_barplot <- function(id, |
|
| 73 | -1x | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ mae_name, |
|
| 74 | -1x | +
- uiOutput(ns("experiment_ui")),
+ summary_funs, |
|
| 75 | -1x | +
- assaySpecInput(ns("assay")),
+ pre_output, |
|
| 76 | -1x | +
- conditionalPanel(+ post_output, |
|
| 77 | -1x | +
- condition = "input.tab_selected == 'PCA'",+ .test = FALSE) {
|
|
| 78 | 1x |
- ns = ns,+ ns <- NS(id) |
|
| 79 | 1x |
- sampleVarSpecInput(ns("color"), "Optional color variable"),
+ teal.widgets::standard_layout( |
|
| 80 | 1x |
- selectizeInput(ns("x_var"), "Select X-axis PC", choices = ""),
+ encoding = tags$div( |
|
| 81 | -1x | +
- selectizeInput(ns("y_var"), "Select Y-axis PC", choices = "")
+ ### Reporter |
|
| 82 | -+ | 1x |
- ),+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 83 | -1x | +
- teal.widgets::panel_group(+ ### |
|
| 84 | 1x |
- teal.widgets::panel_item(+ tags$label("Encodings", class = "text-primary"),
|
|
| 85 | 1x |
- input_id = "settings_item",+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|
| 86 | 1x |
- collapsed = TRUE,+ uiOutput(ns("experiment_ui")),
|
|
| 87 | 1x |
- title = "Additional Settings",+ assaySpecInput(ns("assay")),
|
|
| 88 | 1x |
- tags$label("Use only Top Variance Genes"),
+ sampleVarSpecInput(ns("facet"), "Select Facet Variable"),
|
|
| 89 | 1x |
- shinyWidgets::switchInput(ns("filter_top"), value = FALSE, size = "mini"),
+ geneSpecInput(ns("x"), summary_funs),
|
|
| 90 | 1x |
- conditionalPanel(+ sliderInput( |
|
| 91 | 1x |
- condition = "input.filter_top",+ ns("percentiles"),
|
|
| 92 | 1x |
- ns = ns,+ "Select Quantiles", |
|
| 93 | 1x |
- sliderInput(ns("n_top"), label = "Number of Top Genes", min = 10, max = 5000, value = 500)
+ min = 0, |
|
| 94 | -+ | 1x |
- ),+ max = 1, |
| 95 | 1x |
- conditionalPanel(+ value = c(0.2, 0.8) |
|
| 96 | -1x | +
- condition = "input.tab_selected == 'PCA'",+ ), |
|
| 97 | 1x |
- ns = ns,+ teal.widgets::panel_group( |
|
| 98 | 1x |
- tags$label("Show Variance %"),
+ teal.widgets::panel_item( |
|
| 99 | 1x |
- shinyWidgets::switchInput(ns("var_pct"), value = TRUE, size = "mini"),
+ input_id = "settings_item", |
|
| 100 | 1x |
- tags$label("Show Label"),
+ collapsed = TRUE, |
|
| 101 | 1x |
- shinyWidgets::switchInput(ns("label"), value = TRUE, size = "mini")
+ title = "Additional Settings", |
|
| 102 | -+ | 1x |
- ),+ sampleVarSpecInput( |
| 103 | 1x |
- conditionalPanel(+ ns("fill"),
|
|
| 104 | 1x |
- condition = "input.tab_selected == 'PC and Sample Correlation'",+ label_vars = "Optional Fill Variable" |
|
| 105 | -1x | +
- ns = ns,+ ) |
|
| 106 | -1x | +
- tags$label("Cluster columns"),
+ ) |
|
| 107 | -1x | +
- shinyWidgets::switchInput(ns("cluster_columns"), value = FALSE, size = "mini")
+ ) |
|
| 108 |
- ),+ ), |
||
| 109 | 1x |
- tags$label("View Matrix"),
+ output = div( |
|
| 110 | 1x |
- shinyWidgets::switchInput(ns("show_matrix"), value = TRUE, size = "mini")
+ if (.test) verbatimTextOutput(ns("table")) else NULL,
|
|
| 111 | -+ | 1x |
- )+ teal.widgets::plot_with_settings_ui(ns("plot"))
|
| 112 |
- )+ ), |
||
| 113 | -+ | 1x |
- ),+ pre_output = pre_output, |
| 114 | 1x |
- output = tags$div(+ post_output = post_output |
|
| 115 | -1x | +
- style = "display:flow-root",+ ) |
|
| 116 | -1x | +
- tabsetPanel(+ } |
|
| 117 | -1x | +
- id = ns("tab_selected"),
+
|
|
| 118 | -1x | +
- type = "tabs",+ #' @describeIn tm_g_barplot sets up the server with reactive graph. |
|
| 119 | -1x | +
- tabPanel(+ #' @inheritParams module_arguments |
|
| 120 | -1x | +
- "PCA",+ #' @export |
|
| 121 | -1x | +
- column(+ srv_g_barplot <- function(id, |
|
| 122 | -1x | +
- width = 12,+ data, |
|
| 123 | -1x | +
- tags$div(+ filter_panel_api, |
|
| 124 | -1x | +
- class = "my-5",+ reporter, |
|
| 125 | -1x | +
- teal.widgets::plot_with_settings_ui(ns("plot_pca"))
+ mae_name, |
|
| 126 |
- ),+ exclude_assays, |
||
| 127 | -1x | +
- DT::DTOutput(ns("table_pca"))
+ summary_funs, |
|
| 128 |
- )+ .test = FALSE) {
|
||
| 129 | -+ | ! |
- ),+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 130 | -1x | +! |
- tabPanel(+ assert_class(filter_panel_api, "FilterPanelAPI") |
| 131 | -1x | +! |
- "PC and Sample Correlation",+ checkmate::assert_class(data, "reactive") |
| 132 | -1x | +! |
- column(+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 133 | -1x | +! |
- width = 12,+ assert_flag(.test) |
| 134 | -1x | +! |
- tags$div(+ moduleServer(id, function(input, output, session) {
|
| 135 | -1x | +! |
- class = "my-5",+ output$experiment_ui <- renderUI({
|
| 136 | -1x | +! |
- teal.widgets::plot_with_settings_ui(ns("plot_cor"))
+ experimentSpecInput(session$ns("experiment"), data, mae_name)
|
| 137 |
- ),+ }) |
||
| 138 | -1x | +! |
- DT::DTOutput(ns("table_cor"))
+ experiment <- experimentSpecServer( |
| 139 | -+ | ! |
- )+ "experiment", |
| 140 | -+ | ! |
- )+ data = data, |
| 141 | -+ | ! |
- )+ filter_panel_api = filter_panel_api, |
| 142 | -+ | ! |
- ),+ mae_name = mae_name |
| 143 | -1x | +
- pre_output = pre_output,+ ) |
|
| 144 | -1x | +! |
- post_output = post_output+ assay <- assaySpecServer( |
| 145 | -+ | ! |
- )+ "assay", |
| 146 | -+ | ! |
- )+ assays = experiment$assays, |
| 147 | -+ | ! |
- }+ exclude_assays = exclude_assays |
| 148 |
-
+ ) |
||
| 149 | -+ | ! |
- #' @describeIn tm_g_pca sets up the server with reactive graph.+ multi <- multiSampleVarSpecServer( |
| 150 | -+ | ! |
- #' @inheritParams module_arguments+ c("facet", "fill"),
|
| 151 | -+ | ! |
- #' @export+ experiment_name = experiment$name, |
| 152 | -+ | ! |
- srv_g_pca <- function(id,+ original_data = experiment$data |
| 153 |
- data,+ ) |
||
| 154 | -+ | ! |
- filter_panel_api,+ x <- geneSpecServer( |
| 155 | -+ | ! |
- reporter,+ "x", |
| 156 | -+ | ! |
- mae_name,+ funs = summary_funs, |
| 157 | -+ | ! |
- exclude_assays) {
+ gene_choices = experiment$genes |
| 158 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ ) |
|
| 159 | -! | +
- assert_class(filter_panel_api, "FilterPanelAPI")+ |
|
| 160 | ! |
- checkmate::assert_class(data, "reactive")+ plot_r <- reactive({
|
|
| 161 | -! | +
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ # Resolve all reactivity. |
|
| 162 | -+ | ! |
-
+ experiment_data <- multi$experiment_data() |
| 163 | ! |
- moduleServer(id, function(input, output, session) {
+ facet_var <- multi$vars$facet() |
|
| 164 | ! |
- output$experiment_ui <- renderUI({
+ fill_var <- multi$vars$fill() |
|
| 165 | ! |
- experimentSpecInput(session$ns("experiment"), data, mae_name)
+ percentiles <- input$percentiles |
|
| 166 | -+ | ! |
- })+ assay <- assay() |
| 167 | ! |
- experiment <- experimentSpecServer(+ x <- x() |
|
| 168 | -! | +
- "experiment",+ |
|
| 169 | -! | +
- data = data,+ # Require which states need to be truthy. |
|
| 170 | ! |
- filter_panel_api = filter_panel_api,+ req( |
|
| 171 | ! |
- mae_name = mae_name+ assay, |
|
| 172 |
- )+ # Note: The following statements are important to make sure the UI inputs have been updated. |
||
| 173 | ! |
- assay <- assaySpecServer(+ isTRUE(assay %in% SummarizedExperiment::assayNames(experiment_data)), |
|
| 174 | ! |
- "assay",+ isTRUE(all(c(facet_var, fill_var) %in% names(SummarizedExperiment::colData(experiment_data)))), |
|
| 175 | ! |
- assays = experiment$assays,+ cancelOutput = FALSE |
|
| 176 | -! | +
- exclude_assays = exclude_assays+ ) |
|
| 177 |
- )+ |
||
| 178 | -! | +
- color <- sampleVarSpecServer(+ # Validate and give useful messages to the user. Note: no need to duplicate here req() from above. |
|
| 179 | ! |
- "color",+ validate(need( |
|
| 180 | ! |
- experiment_name = experiment$name,+ percentiles[1] != percentiles[2], |
|
| 181 | ! |
- original_data = experiment$data+ "please select two different quantiles - if you want only 2 groups, choose one quantile as 0 or 1" |
|
| 182 |
- )+ )) |
||
| 183 | -+ | ! |
-
+ validate_gene_spec(x, rownames(experiment_data)) |
| 184 |
- # Total number of genes at the moment.+ |
||
| 185 | ! |
- n_genes <- reactive({
+ hermes::draw_barplot( |
|
| 186 | ! |
- experiment_data <- color$experiment_data()+ object = experiment_data, |
|
| 187 | ! |
- nrow(experiment_data)+ assay_name = assay, |
|
| 188 | -+ | ! |
- })+ x_spec = x, |
| 189 | -+ | ! |
-
+ facet_var = facet_var, |
| 190 | -+ | ! |
- # When the total number changes or gene filter is activated, update slider max.+ fill_var = fill_var, |
| 191 | ! |
- observeEvent(list(n_genes(), input$filter_top), {
+ percentiles = percentiles |
|
| 192 | -! | +
- n_genes <- n_genes()+ ) |
|
| 193 | -! | +
- filter_top <- input$filter_top+ }) |
|
| 194 | -! | +
- if (filter_top) {
+
|
|
| 195 | ! |
- n_top <- input$n_top+ output$plot <- renderPlot(plot_r()) |
|
| 196 | -! | +
- updateSliderInput(+ |
|
| 197 | ! |
- session = session,+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 198 | ! |
- inputId = "n_top",+ id = "plot", |
|
| 199 | ! |
- value = min(n_top, n_genes),+ plot_r = plot_r |
|
| 200 | -! | +
- max = n_genes+ ) |
|
| 201 |
- )+ |
||
| 202 | -+ | ! |
- }+ if (.test) {
|
| 203 | -+ | ! |
- })+ table_r <- reactive({
|
| 204 | -+ | ! |
-
+ str(layer_data(plot_r())) |
| 205 |
- # When the chosen experiment or assay name changes, recompute the PC.+ }) |
||
| 206 | ! |
- pca_result <- reactive({
+ output$table <- renderPrint(table_r()) |
|
| 207 | -! | +
- experiment_data <- color$experiment_data()+ } |
|
| 208 | -! | +
- filter_top <- input$filter_top+ |
|
| 209 | -! | +
- n_top <- input$n_top+ ### REPORTER |
|
| 210 | ! |
- assay_name <- assay()+ if (with_reporter) {
|
|
| 211 | -+ | ! |
-
+ card_fun <- function(comment, label) {
|
| 212 | ! |
- validate(need(hermes::is_hermes_data(experiment_data), "please use HermesData() on input experiments"))+ card <- report_card_template( |
|
| 213 | ! |
- req(isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)))+ title = "Barplot", |
|
| 214 | ! |
- validate(need(+ label = label, |
|
| 215 | ! |
- ncol(experiment_data) > 2,+ with_filter = TRUE, |
|
| 216 | ! |
- "Sample size is too small. PCA needs more than 2 samples."+ filter_panel_api = filter_panel_api |
|
| 217 |
- ))+ ) |
||
| 218 | ! |
- validate(need(+ card$append_text("Selected Options", "header3")
|
|
| 219 | ! |
- nrow(experiment_data) > 1,+ encodings_list <- list( |
|
| 220 | ! |
- "Number of genes is too small. PCA needs more than 1 gene."+ "Experiment:", |
|
| 221 | -+ | ! |
- ))+ input$`experiment-name`, |
| 222 | -+ | ! |
-
+ "\nAssay:", |
| 223 | ! |
- hermes::calc_pca(experiment_data, assay_name, n_top = if (filter_top) n_top else NULL)+ input$`assay-name`, |
|
| 224 | -+ | ! |
- })+ "\nFacetting Variable:", |
| 225 | -+ | ! |
-
+ input$`facet-sample_var`, |
| 226 | -+ | ! |
- # When experiment or assay name changes, update choices for PCs in x_var and y_var.+ "\nGenes Selected:", |
| 227 | ! |
- observeEvent(pca_result(), {
+ paste0(x()$get_gene_labels(), collapse = ", "), |
|
| 228 | ! |
- pca_result_x <- pca_result()$x+ "\nGene Summary:", |
|
| 229 | ! |
- pc_choices <- seq_len(ncol(pca_result_x))+ input$`x-fun_name`, |
|
| 230 | -+ | ! |
-
+ "\nQuantiles:", |
| 231 | ! |
- id_names <- c("x_var", "y_var")
+ paste0(input$percentiles, collapse = ", "), |
|
| 232 | ! |
- for (i in seq_along(id_names)) {
+ "\nOptional Fill Variable:", |
|
| 233 | ! |
- updateSelectizeInput(+ input$`fill-sample_var` |
|
| 234 | -! | +
- session,+ ) |
|
| 235 | ! |
- id_names[i],+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 236 | ! |
- choices = pc_choices,+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 237 | ! |
- selected = pc_choices[i]+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 238 | -+ | ! |
- )+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
| 239 |
- }+ } else {
|
||
| 240 | -+ | ! |
- })+ paste(encodings_list, collapse = " ") |
| 241 |
-
+ } |
||
| 242 |
- # Compute correlation of PC with sample variables.+ |
||
| 243 | ! |
- cor_result <- reactive({
+ card$append_text(final_encodings, style = "verbatim") |
|
| 244 | ! |
- pca_result <- pca_result()+ card$append_text("Plot", "header3")
|
|
| 245 | ! |
- experiment_data <- color$experiment_data()+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 246 | -+ | ! |
-
+ if (!comment == "") {
|
| 247 | ! |
- hermes::correlate(pca_result, experiment_data)+ card$append_text("Comment", "header3")
|
|
| 248 | -+ | ! |
- })+ card$append_text(comment) |
| 249 |
-
+ } |
||
| 250 |
- # Compute & display PCA matrix table if show_matrix is TRUE.+ |
||
| 251 | ! |
- show_matrix_pca <- reactive({
+ card |
|
| 252 | -! | +
- if (input$show_matrix) {
+ } |
|
| 253 | ! |
- pca_result_x <- pca_result()$x+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 254 | -! | +
- pca_result_x <- round(pca_result_x, 3)+ } |
|
| 255 | -! | +
- as.data.frame(pca_result_x)+ ### |
|
| 256 |
- } else {
+ }) |
||
| 257 | -! | +
- NULL+ } |
|
| 258 |
- }+ |
||
| 259 |
- })+ #' @describeIn tm_g_barplot sample module function. |
||
| 260 |
-
+ #' @export |
||
| 261 | -! | +
- output$table_pca <- DT::renderDT({
+ #' @examples |
|
| 262 | -! | +
- show_matrix_pca <- show_matrix_pca()+ #' |
|
| 263 | -! | +
- DT::datatable(+ #' # Alternatively you can run the sample module with this function call: |
|
| 264 | -! | +
- show_matrix_pca,+ #' if (interactive()) {
|
|
| 265 | -! | +
- rownames = TRUE,+ #' sample_tm_g_barplot() |
|
| 266 | -! | +
- options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)),+ #' } |
|
| 267 | -! | +
- caption = "PCA Matrix"+ sample_tm_g_barplot <- function(.test = FALSE) {
|
|
| 268 | -+ | ! |
- )+ data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment) |
| 269 | -+ | ! |
- })+ app <- teal::init( |
| 270 | -+ | ! |
-
+ data = data, |
| 271 | -+ | ! |
- # Compute & display correlation matrix if show_matrix is TRUE+ modules = teal::modules( |
| 272 | ! |
- show_matrix_cor <- reactive({
+ tm_g_barplot( |
|
| 273 | ! |
- if (input$show_matrix) {
+ label = "barplot", |
|
| 274 | ! |
- cor_result <- cor_result()+ mae_name = "MAE", |
|
| 275 | ! |
- cor_result <- round(cor_result, 3)+ .test = .test |
|
| 276 | -! | +
- as.data.frame(cor_result)+ ) |
|
| 277 |
- } else {
+ ) |
||
| 278 | -! | +
- NULL+ ) |
|
| 279 | -+ | ! |
- }+ shinyApp(app$ui, app$server) |
| 280 |
- })- |
- ||
| 281 | -! | -
- output$table_cor <- DT::renderDT({
- |
- |
| 282 | -! | -
- show_matrix_cor <- show_matrix_cor()- |
- |
| 283 | -! | -
- DT::datatable(- |
- |
| 284 | -! | -
- show_matrix_cor,+ } |
|
| 285 | -! | +
| 1 | +
- rownames = TRUE,+ #' Data Preprocessing for `ADTTE` Module |
||
| 286 | -! | +||
| 2 | +
- options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)),+ #' |
||
| 287 | -! | +||
| 3 | +
- caption = "PC and Sample Correlation Matrix"+ #' @description `r lifecycle::badge("experimental")`
|
||
| 288 | +4 |
- )+ #' |
|
| 289 | +5 |
- })+ #' A function to help with merging of MAE to `ADTTE`. |
|
| 290 | +6 |
-
+ #' |
|
| 291 | +7 |
- # Render plot PCA output.+ #' @inheritParams function_arguments |
|
| 292 | -! | +||
| 8 | +
- plot_pca <- reactive({
+ #' |
||
| 293 | +9 |
- # Resolve all reactivity.+ #' @return A data frame containing all columns/rows from `adtte` that match |
|
| 294 | -! | +||
| 10 | +
- pca_result <- pca_result()+ #' by subject ID with the row names of the MAE and have the gene samples available |
||
| 295 | -! | +||
| 11 | +
- experiment_data <- color$experiment_data()+ #' in the given experiment. The attribute `gene_cols` contains the column names |
||
| 296 | -! | +||
| 12 | +
- x_var <- as.numeric(input$x_var)+ #' for the gene columns. |
||
| 297 | -! | +||
| 13 | +
- y_var <- as.numeric(input$y_var)+ #' |
||
| 298 | -! | +||
| 14 | +
- data <- as.data.frame(SummarizedExperiment::colData(color$experiment_data()))+ #' @note The final gene column names can start with a different string than |
||
| 299 | -! | +||
| 15 | +
- color_var <- color$sample_var()+ #' the original gene IDs (or labels), in particular white space and colons are removed. |
||
| 300 | -! | +||
| 16 | +
- assay_name <- assay()+ #' |
||
| 301 | -! | +||
| 17 | +
- var_pct <- input$var_pct+ #' @export |
||
| 302 | -! | +||
| 18 | +
- label <- input$label+ #' @examples |
||
| 303 | +19 |
-
+ #' mae <- hermes::multi_assay_experiment |
|
| 304 | +20 |
- # Require which states need to be truthy.+ #' adtte <- teal.modules.hermes::rADTTE %>% |
|
| 305 | -! | +||
| 21 | +
- req(+ #' dplyr::mutate(CNSR = as.logical(CNSR)) |
||
| 306 | -! | +||
| 22 | +
- assay_name,+ #' |
||
| 307 | +23 |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ #' new_adtte <- h_km_mae_to_adtte( |
|
| 308 | -! | +||
| 24 | +
- isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)),+ #' adtte, |
||
| 309 | -! | +||
| 25 | +
- is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))),+ #' mae, |
||
| 310 | -! | +||
| 26 | +
- cancelOutput = FALSE+ #' genes = hermes::gene_spec("GeneID:1820"),
|
||
| 311 | +27 |
- )+ #' experiment_name = "hd2" |
|
| 312 | +28 |
-
+ #' ) |
|
| 313 | +29 |
- # Validate and give useful messages to the user. Note: no need to duplicate here req() from above.+ #' new_adtte2 <- h_km_mae_to_adtte( |
|
| 314 | -! | +||
| 30 | +
- validate(need(x_var != y_var, "please select two different principal components"))+ #' adtte, |
||
| 315 | +31 |
-
+ #' mae, |
|
| 316 | -! | +||
| 32 | +
- hermes::autoplot(+ #' genes = hermes::gene_spec(c("GeneID:1820", "GeneID:94115"), fun = colMeans),
|
||
| 317 | -! | +||
| 33 | +
- object = pca_result,+ #' experiment_name = "hd2" |
||
| 318 | -! | +||
| 34 | +
- assay_name = assay_name,+ #' ) |
||
| 319 | -! | +||
| 35 | +
- x = x_var,+ #' new_adtte3 <- h_km_mae_to_adtte( |
||
| 320 | -! | +||
| 36 | +
- y = y_var,+ #' adtte, |
||
| 321 | -! | +||
| 37 | +
- data = data,+ #' mae, |
||
| 322 | -! | +||
| 38 | +
- colour = color_var,+ #' genes = hermes::gene_spec(c(A = "GeneID:1820", B = "GeneID:94115")), |
||
| 323 | -! | +||
| 39 | +
- variance_percentage = var_pct,+ #' experiment_name = "hd2" |
||
| 324 | -! | +||
| 40 | +
- label = label,+ #' ) |
||
| 325 | -! | +||
| 41 | +
- label.repel = label,+ h_km_mae_to_adtte <- function(adtte, |
||
| 326 | -! | +||
| 42 | +
- label.show.legend = FALSE+ mae, |
||
| 327 | +43 |
- )+ genes, |
|
| 328 | +44 |
- })+ experiment_name = "hd1", |
|
| 329 | -! | +||
| 45 | +
- output$plot_pca <- renderPlot(plot_pca())+ assay_name = "counts", |
||
| 330 | +46 |
-
+ usubjid_var = "USUBJID") {
|
|
| 331 | -! | +||
| 47 | +11x |
- pws_pca <- teal.widgets::plot_with_settings_srv(+ assert_class(mae, "MultiAssayExperiment") |
|
| 332 | -! | +||
| 48 | +11x |
- id = "plot_pca",+ assert_string(experiment_name) |
|
| 333 | -! | +||
| 49 | +10x |
- plot_r = plot_pca+ assert_string(usubjid_var) |
|
| 334 | -+ | ||
| 50 | +10x |
- )+ assert_names(names(adtte), must.include = usubjid_var) |
|
| 335 | +51 | ||
| 336 | +52 |
- # render correlation heatmap- |
- |
| 337 | -! | -
- plot_cor <- reactive({
+ # Check subject ID across experiment, sample map, and MAE colData. |
|
| 338 | -+ | ||
| 53 | +10x |
- # Resolve all reactivity.+ mae_samplemap <- MultiAssayExperiment::sampleMap(mae) |
|
| 339 | -! | +||
| 54 | +10x |
- cor_result <- cor_result()+ samplemap_experiment <- mae_samplemap[mae_samplemap$assay == experiment_name, ] |
|
| 340 | -! | +||
| 55 | +10x |
- cluster_columns <- input$cluster_columns+ sm_usubjid <- as.character(samplemap_experiment$primary) |
|
| 341 | +56 | ||
| 342 | -! | +||
| 57 | +10x |
- validate(need(+ hd <- suppressWarnings(MultiAssayExperiment::getWithColData(mae, experiment_name)) |
|
| 343 | -! | +||
| 58 | +9x |
- !any(is.na(cor_result)),+ assert_class(hd, "AnyHermesData") |
|
| 344 | -! | +||
| 59 | +9x |
- "Obtained NA results in the correlation matrix, therefore no plot can be produced"+ hd_usubjid <- as.character(SummarizedExperiment::colData(hd)[[usubjid_var]]) |
|
| 345 | +60 |
- ))+ |
|
| 346 | -! | +||
| 61 | +9x |
- hermes::autoplot(+ assert_subset( |
|
| 347 | -! | +||
| 62 | +9x |
- object = cor_result,+ x = hd_usubjid, |
|
| 348 | -! | +||
| 63 | +9x |
- cluster_columns = cluster_columns+ choices = sm_usubjid |
|
| 349 | +64 |
- )+ ) |
|
| 350 | +65 |
- })+ |
|
| 351 | -+ | ||
| 66 | +8x |
-
+ mae_coldata <- MultiAssayExperiment::colData(mae) |
|
| 352 | -! | +||
| 67 | +8x |
- pws_cor <- teal.widgets::plot_with_settings_srv(+ if (usubjid_var %in% colnames(mae_coldata)) {
|
|
| 353 | -! | +||
| 68 | +8x |
- id = "plot_cor",+ mae_usubjid <- as.character(mae_coldata[[usubjid_var]]) |
|
| 354 | -! | +||
| 69 | +8x |
- plot_r = plot_cor+ assert_subset( |
|
| 355 | +|||
| 70 | +8x | +
+ x = sm_usubjid,+ |
+ |
| 71 | +8x | +
+ choices = mae_usubjid+ |
+ |
| 72 |
) |
||
| 356 | +73 | ++ |
+ }+ |
+
| 74 | |||
| 75 | +7x | +
+ gene_data <- hermes::col_data_with_genes(+ |
+ |
| 76 | +7x | +
+ object = hd,+ |
+ |
| 77 | +7x | +
+ assay_name = assay_name,+ |
+ |
| 78 | +7x | +
+ genes = genes+ |
+ |
| 357 | +79 |
- ### REPORTER+ ) |
|
| 358 | -! | +||
| 80 | +5x |
- if (with_reporter) {
+ merged_adtte <- hermes::inner_join_cdisc( |
|
| 359 | -! | +||
| 81 | +5x |
- card_fun <- function(comment, label) {
+ gene_data = gene_data, |
|
| 360 | -! | +||
| 82 | +5x |
- card <- report_card_template(+ cdisc_data = adtte, |
|
| 361 | -! | +||
| 83 | +5x |
- title = "PCA",+ patient_key = usubjid_var |
|
| 362 | -! | +||
| 84 | +
- label = label,+ ) |
||
| 363 | -! | +||
| 85 | +5x |
- with_filter = TRUE,+ structure( |
|
| 364 | -! | +||
| 86 | +5x |
- filter_panel_api = filter_panel_api+ merged_adtte,+ |
+ |
| 87 | +5x | +
+ gene_cols = attr(gene_data, "gene_cols") |
|
| 365 | +88 |
- )+ ) |
|
| 366 | -! | +||
| 89 | +
- card$append_text("Selected Options", "header3")
+ } |
||
| 367 | -! | +||
| 90 | +
- if (input$tab_selected == "PCA") {
+
|
||
| 368 | -! | +||
| 91 | +
- encodings_list <- list(+ #' Module Input for `ADTTE` Specification |
||
| 369 | -! | +||
| 92 | +
- "Experiment:",+ #' |
||
| 370 | -! | +||
| 93 | +
- input$`experiment-name`,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 371 | -! | +||
| 94 | +
- "\nAssay:",+ #' |
||
| 372 | -! | +||
| 95 | +
- input$`assay-name`,+ #' This defines the input for the `ADTTE` specification. |
||
| 373 | -! | +||
| 96 | +
- "\nOptional Color Variable:",+ #' |
||
| 374 | -! | +||
| 97 | +
- input$`color-sample_var`,+ #' @inheritParams module_arguments |
||
| 375 | -! | +||
| 98 | +
- "\nX-axis PC:",+ #' @param label_paramcd (`string`)\cr label for the endpoint (`PARAMCD`) selection. |
||
| 376 | -! | +||
| 99 | +
- input$x_var,+ #' |
||
| 377 | -! | +||
| 100 | +
- "\nY-axis PC:",+ #' @return The UI part. |
||
| 378 | -! | +||
| 101 | +
- input$y_var,+ #' @seealso [adtteSpecServer()] for the module server and a complete example. |
||
| 379 | -! | +||
| 102 | +
- "\nUse Top Variance Genes:",+ #' @export |
||
| 380 | -! | +||
| 103 | +
- input$filter_top,+ adtteSpecInput <- function(inputId, # nolint |
||
| 381 | -! | +||
| 104 | +
- "\nNumber of Top Genes:",+ label_paramcd = "Select Endpoint") {
|
||
| 382 | -! | +||
| 105 | +3x |
- input$n_top,+ assert_string(inputId) |
|
| 383 | -! | +||
| 106 | +3x |
- "\nShow Variance %:",+ assert_string(label_paramcd, min.chars = 1L) |
|
| 384 | -! | +||
| 107 | +
- input$var_pct,+ |
||
| 385 | -! | +||
| 108 | +3x |
- "\nShow Matrix:",+ ns <- NS(inputId) |
|
| 386 | -! | +||
| 109 | +
- input$show_matrix,+ |
||
| 387 | -! | +||
| 110 | +3x |
- "\nShow Label:",+ tagList( |
|
| 388 | -! | +||
| 111 | +3x |
- input$label+ selectizeInput(+ |
+ |
| 112 | +3x | +
+ inputId = ns("paramcd"),
+ |
+ |
| 113 | +3x | +
+ label = label_paramcd,+ |
+ |
| 114 | +3x | +
+ choices = "",+ |
+ |
| 115 | +3x | +
+ options = list(placeholder = "- Nothing selected -") |
|
| 389 | +116 |
- )+ ), |
|
| 390 | -! | +||
| 117 | +3x |
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ include_js_files("dropdown.js")
|
|
| 391 | -! | +||
| 118 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ ) |
||
| 392 | -! | +||
| 119 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ } |
||
| 393 | -! | +||
| 120 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ |
||
| 394 | +121 |
- } else {
+ #' Module Server for `ADTTE` Specification |
|
| 395 | -! | +||
| 122 | +
- paste(encodings_list, collapse = " ")+ #' |
||
| 396 | +123 |
- }+ #' @description `r lifecycle::badge("experimental")`
|
|
| 397 | -! | +||
| 124 | ++ |
+ #'+ |
+ |
| 125 | ++ |
+ #' This defines the server part for the `ADTTE` specification. The resulting data+ |
+ |
| 126 | ++ |
+ #' set `binned_adtte_subset` contains the subset of `ADTTE` selected by the time-to-event+ |
+ |
| 127 | ++ |
+ #' endpoint, joined together with the gene information extracted from specified assay+ |
+ |
| 128 | ++ |
+ #' and experiment, as numeric and factor columns. The factor column is created by binning+ |
+ |
| 129 | ++ |
+ #' the numeric column according to the quantile cutoffs specified in `probs`.+ |
+ |
| 130 | ++ |
+ #'+ |
+ |
| 131 | ++ |
+ #' @inheritParams module_arguments+ |
+ |
| 132 | ++ |
+ #' @param experiment_data (reactive `AnyHermesData`)\cr input experiment.+ |
+ |
| 133 | ++ |
+ #' @param experiment_name (reactive `string`)\cr name of the input experiment.+ |
+ |
| 134 | ++ |
+ #' @param assay (reactive `string`)\cr name of the assay.+ |
+ |
| 135 | ++ |
+ #' @param genes (reactive `GeneSpec`)\cr gene specification.+ |
+ |
| 136 | ++ |
+ #' @param probs (reactive `numeric`)\cr probabilities to bin the gene or gene signature+ |
+ |
| 137 | ++ |
+ #' into.+ |
+ |
| 138 | ++ |
+ #'+ |
+ |
| 139 | ++ |
+ #' @return List with the following elements:+ |
+ |
| 140 | ++ |
+ #' - `binned_adtte_subset`: reactive containing the joined `ADTTE` and gene data.+ |
+ |
| 141 | ++ |
+ #' - `gene_col`: reactive containing the string with the column name of the original+ |
+ |
| 142 | ++ |
+ #' numeric gene variable.+ |
+ |
| 143 | ++ |
+ #' - `gene_factor`: string with the variable name for the binned gene data.+ |
+ |
| 144 | ++ |
+ #' - `time_unit`: reactive string with the time unit for the current subset.+ |
+ |
| 145 | ++ |
+ #'+ |
+ |
| 146 | ++ |
+ #' @seealso [adtteSpecInput()] for the module UI.+ |
+ |
| 147 | ++ |
+ #'+ |
+ |
| 148 | +
- card$append_text(final_encodings, style = "verbatim")+ #' @export |
||
| 398 | -! | +||
| 149 | +
- card$append_text("Plot", "header3")
+ #' |
||
| 399 | -! | +||
| 150 | +
- card$append_plot(plot_pca(), dim = pws_pca$dim())+ #' @examples |
||
| 400 | -! | +||
| 151 | +
- card$append_text("Table", "header3")
+ #' ui <- function(id) {
|
||
| 401 | -! | +||
| 152 | +
- card$append_table(show_matrix_pca())+ #' ns <- NS(id) |
||
| 402 | +153 |
- } else {
+ #' |
|
| 403 | -! | +||
| 154 | +
- encodings_list <- list(+ #' teal.widgets::standard_layout( |
||
| 404 | -! | +||
| 155 | +
- "Experiment:",+ #' encoding = uiOutput(ns("encoding_ui")),
|
||
| 405 | -! | +||
| 156 | +
- input$`experiment-name`,+ #' output = verbatimTextOutput(ns("summary"))
|
||
| 406 | -! | +||
| 157 | +
- "\nAssay:",+ #' ) |
||
| 407 | -! | +||
| 158 | +
- input$`assay-name`,+ #' } |
||
| 408 | -! | +||
| 159 | +
- "\nUse Top Variance Genes:",+ #' |
||
| 409 | -! | +||
| 160 | +
- input$filter_top,+ #' server <- function(id, data, filter_panel_api) {
|
||
| 410 | -! | +||
| 161 | +
- "\nNumber of Top Genes:",+ #' checkmate::assert_class(data, "reactive") |
||
| 411 | -! | +||
| 162 | +
- input$top_n,+ #' checkmate::assert_class(shiny::isolate(data()), "teal_data") |
||
| 412 | -! | +||
| 163 | +
- "\nCluster Columns:",+ #' moduleServer(id, function(input, output, session) {
|
||
| 413 | -! | +||
| 164 | +
- paste0(input$cluster_columns, collapse = ", "),+ #' output$encoding_ui <- renderUI({
|
||
| 414 | -! | +||
| 165 | +
- "\nShow Matrix:",+ #' tags$div( |
||
| 415 | -! | +||
| 166 | +
- input$show_matrix+ #' experimentSpecInput(session$ns("experiment"), data, mae_name = "MAE"),
|
||
| 416 | +167 |
- )+ #' assaySpecInput(session$ns("assay")),
|
|
| 417 | -! | +||
| 168 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ #' geneSpecInput(session$ns("genes"), funs = list(Mean = colMeans)),
|
||
| 418 | -! | +||
| 169 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ #' adtteSpecInput(session$ns("adtte"))
|
||
| 419 | -! | +||
| 170 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ #' ) |
||
| 420 | -! | +||
| 171 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ #' }) |
||
| 421 | +172 |
- } else {
+ #' experiment <- experimentSpecServer( |
|
| 422 | -! | +||
| 173 | +
- paste(encodings_list, collapse = " ")+ #' "experiment", |
||
| 423 | +174 |
- }+ #' data = data, |
|
| 424 | +175 |
-
+ #' filter_panel_api = filter_panel_api, |
|
| 425 | -! | +||
| 176 | +
- card$append_text(final_encodings, style = "verbatim")+ #' mae_name = "MAE" |
||
| 426 | -! | +||
| 177 | +
- card$append_text("Plot", "header3")
+ #' ) |
||
| 427 | -! | +||
| 178 | +
- card$append_plot(plot_cor())+ #' assay <- assaySpecServer( |
||
| 428 | -! | +||
| 179 | +
- card$append_plot(plot_cor(), dim = pws_cor$dim())+ #' "assay", |
||
| 429 | -! | +||
| 180 | +
- card$append_text("Table", "header3")
+ #' assays = experiment$assays |
||
| 430 | -! | +||
| 181 | +
- card$append_table(show_matrix_cor())+ #' ) |
||
| 431 | +182 |
- }+ #' genes <- geneSpecServer( |
|
| 432 | -! | +||
| 183 | +
- if (!comment == "") {
+ #' "genes", |
||
| 433 | -! | +||
| 184 | +
- card$append_text("Comment", "header3")
+ #' funs = list(Mean = colMeans), |
||
| 434 | -! | +||
| 185 | +
- card$append_text(comment)+ #' gene_choices = experiment$genes |
||
| 435 | +186 |
- }+ #' ) |
|
| 436 | -! | +||
| 187 | +
- card+ #' adtte <- adtteSpecServer( |
||
| 437 | +188 |
- }+ #' "adtte", |
|
| 438 | -! | +||
| 189 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' data = data, |
||
| 439 | +190 |
- }+ #' adtte_name = "ADTTE", |
|
| 440 | +191 |
- ###+ #' mae_name = "MAE", |
|
| 441 | +192 |
- })+ #' adtte_vars = list( |
|
| 442 | +193 |
- }+ #' aval = "AVAL", |
|
| 443 | +194 |
-
+ #' avalu = "AVALU", |
|
| 444 | +195 |
- #' @describeIn tm_g_pca sample module function.+ #' is_event = "is_event", |
|
| 445 | +196 |
- #' @export+ #' paramcd = "PARAMCD", |
|
| 446 | +197 |
- #' @examples+ #' usubjid = "USUBJID" |
|
| 447 | +198 |
- #'+ #' ), |
|
| 448 | +199 |
- #' # Alternatively you can run the sample module with this function call:+ #' experiment_data = experiment$data, |
|
| 449 | +200 |
- #' if (interactive()) {
+ #' experiment_name = experiment$name, |
|
| 450 | +201 |
- #' sample_tm_g_pca()+ #' assay = assay, |
|
| 451 | +202 |
- #' }+ #' genes = genes, |
|
| 452 | +203 |
- sample_tm_g_pca <- function() {
+ #' probs = reactive({
|
|
| 453 | -! | +||
| 204 | +
- data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment)+ #' 0.5 |
||
| 454 | -! | +||
| 205 | +
- app <- teal::init(+ #' }) |
||
| 455 | -! | +||
| 206 | +
- data = data,+ #' ) |
||
| 456 | -! | +||
| 207 | +
- modules = teal::modules(+ #' output$summary <- renderPrint({
|
||
| 457 | -! | +||
| 208 | +
- tm_g_pca(+ #' binned_adtte_subset <- adtte$binned_adtte_subset() |
||
| 458 | -! | +||
| 209 | +
- label = "pca",+ #' summary(binned_adtte_subset) |
||
| 459 | -! | +||
| 210 | +
- mae_name = "MAE"+ #' }) |
||
| 460 | +211 |
- )+ #' }) |
|
| 461 | +212 |
- )+ #' } |
|
| 462 | +213 |
- )+ #' |
|
| 463 | -! | +||
| 214 | +
- shinyApp(app$ui, app$server)+ #' my_app <- function() {
|
||
| 464 | +215 |
- }+ #' data <- teal_data() |
| 1 | +216 |
- #' Teal Module for RNA-seq Scatterplot+ #' data <- within(data, {
|
|
| 2 | +217 |
- #'+ #' ADSL <- teal.data::rADSL |
|
| 3 | +218 |
- #' @description `r lifecycle::badge("experimental")`
+ #' ADTTE <- teal.modules.hermes::rADTTE %>% |
|
| 4 | +219 |
- #'+ #' dplyr::mutate(is_event = .data$CNSR == 0) |
|
| 5 | +220 |
- #' This module provides an interactive scatterplot for RNA-seq gene expression+ #' MAE <- hermes::multi_assay_experiment |
|
| 6 | +221 |
- #' analysis.+ #' }) |
|
| 7 | +222 |
- #'+ #' datanames <- c("ADSL", "ADTTE", "MAE")
|
|
| 8 | +223 |
- #' @inheritParams module_arguments+ #' datanames(data) <- datanames |
|
| 9 | +224 |
- #'+ #' join_keys(data) <- default_cdisc_join_keys[datanames] |
|
| 10 | +225 |
- #' @return Shiny module to be used in the teal app.+ #' |
|
| 11 | +226 |
- #'+ #' app <- init( |
|
| 12 | +227 |
- #' @export+ #' data = data, |
|
| 13 | +228 |
- #'+ #' modules = modules( |
|
| 14 | +229 |
- #' @examples+ #' module( |
|
| 15 | +230 |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ #' label = "adtteSpec example", |
|
| 16 | +231 |
- #' app <- init(+ #' server = server, |
|
| 17 | +232 |
- #' data = data,+ #' ui = ui, |
|
| 18 | +233 |
- #' modules = modules(+ #' datanames = "all" |
|
| 19 | +234 |
- #' tm_g_scatterplot(+ #' ) |
|
| 20 | +235 |
- #' label = "scatterplot",+ #' ) |
|
| 21 | +236 |
- #' mae_name = "MAE"+ #' ) |
|
| 22 | +237 |
- #' )+ #' shinyApp(app$ui, app$server) |
|
| 23 | +238 |
- #' )+ #' } |
|
| 24 | +239 |
- #' )+ #' |
|
| 25 | +240 |
#' if (interactive()) {
|
|
| 26 | +241 |
- #' shinyApp(app$ui, app$server)+ #' my_app() |
|
| 27 | +242 |
#' } |
|
| 28 | +243 |
- tm_g_scatterplot <- function(label,+ adtteSpecServer <- function(id, # nolint |
|
| 29 | +244 |
- mae_name,+ data, |
|
| 30 | +245 |
- exclude_assays = "counts",+ mae_name, |
|
| 31 | +246 |
- summary_funs = list(+ adtte_name, |
|
| 32 | +247 |
- Mean = colMeans,+ adtte_vars, |
|
| 33 | +248 |
- Median = matrixStats::colMedians,+ experiment_data, |
|
| 34 | +249 |
- Max = matrixStats::colMaxs+ experiment_name, |
|
| 35 | +250 |
- ),+ assay, |
|
| 36 | +251 |
- pre_output = NULL,+ genes, |
|
| 37 | +252 |
- post_output = NULL) {
- |
- |
| 38 | -! | -
- message("Initializing tm_g_scatterplot")
+ probs) {
|
|
| 39 | +253 | ! |
- assert_string(label)+ assert_string(id) |
| 40 | +254 | ! |
assert_string(mae_name) |
| 41 | +255 | ! |
- assert_character(exclude_assays, any.missing = FALSE)+ assert_string(adtte_name) |
| 42 | +256 | ! |
- assert_summary_funs(summary_funs)+ assert_adtte_vars(adtte_vars) |
| 43 | +257 | ! |
- assert_tag(pre_output, null.ok = TRUE)+ assert_reactive(experiment_data) |
| 44 | +258 | ! |
- assert_tag(post_output, null.ok = TRUE)- |
-
| 45 | -- |
-
+ assert_reactive(experiment_name) |
|
| 46 | +259 | ! |
- teal::module(+ assert_reactive(assay) |
| 47 | +260 | ! |
- label = label,+ assert_reactive(genes) |
| 48 | +261 | ! |
- server = srv_g_scatterplot,+ assert_reactive(probs) |
| 49 | +262 | ! |
- server_args = list(+ checkmate::assert_class(data, "reactive") |
| 50 | +263 | ! |
- mae_name = mae_name,+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 51 | -! | +||
| 264 | +
- summary_funs = summary_funs,+ |
||
| 52 | +265 | ! |
- exclude_assays = exclude_assays+ moduleServer(id, function(input, output, session) {
|
| 53 | +266 |
- ),- |
- |
| 54 | -! | -
- ui = ui_g_scatterplot,+ # Join ADTTE with gene data. |
|
| 55 | +267 | ! |
- ui_args = list(+ adtte_joined <- reactive({
|
| 56 | +268 | ! |
- mae_name = mae_name,+ experiment_data <- experiment_data() |
| 57 | +269 | ! |
- summary_funs = summary_funs,+ experiment_name <- experiment_name() |
| 58 | +270 | ! |
- pre_output = pre_output,+ assay <- assay() |
| 59 | +271 | ! |
- post_output = post_output+ genes <- genes() |
| 60 | +272 |
- ),+ |
|
| 61 | +273 | ! |
- datanames = mae_name- |
-
| 62 | -- |
- )- |
- |
| 63 | -- |
- }+ validate_gene_spec(genes, rownames(experiment_data)) |
|
| 64 | +274 | ||
| 65 | -- |
- #' @describeIn tm_g_scatterplot sets up the user interface.- |
- |
| 66 | -+ | ||
| 275 | +! |
- #' @inheritParams module_arguments+ req( |
|
| 67 | -+ | ||
| 276 | +! |
- #' @export+ genes$returns_vector(), |
|
| 68 | -+ | ||
| 277 | +! |
- ui_g_scatterplot <- function(id,+ experiment_name, |
|
| 69 | -+ | ||
| 278 | +! |
- mae_name,+ assay |
|
| 70 | +279 |
- summary_funs,+ ) |
|
| 71 | +280 |
- pre_output,+ |
|
| 72 | -+ | ||
| 281 | +! |
- post_output) {
+ mae <- data()[[mae_name]] |
|
| 73 | -1x | +||
| 282 | +! |
- ns <- NS(id)+ adtte <- data()[[adtte_name]] |
|
| 74 | +283 | ||
| 75 | -1x | +||
| 284 | +! |
- smooth_method_choices <- c(+ mae[[experiment_name]] <- experiment_data |
|
| 76 | -1x | +||
| 285 | +! |
- Linear = "lm",+ h_km_mae_to_adtte( |
|
| 77 | -1x | +||
| 286 | +! |
- Loess = "loess",+ adtte, |
|
| 78 | -1x | +||
| 287 | +! |
- None = "none"+ mae, |
|
| 79 | -+ | ||
| 288 | +! |
- )+ genes = genes, |
|
| 80 | -+ | ||
| 289 | +! |
-
+ experiment_name = experiment_name, |
|
| 81 | -1x | +||
| 290 | +! |
- teal.widgets::standard_layout(+ assay_name = assay, |
|
| 82 | -1x | +||
| 291 | +! |
- encoding = tags$div(+ usubjid_var = adtte_vars$usubjid |
|
| 83 | +292 |
- ### Reporter- |
- |
| 84 | -1x | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ) |
|
| 85 | +293 |
- ###- |
- |
| 86 | -1x | -
- tags$label("Encodings", class = "text-primary"),
- |
- |
| 87 | -1x | -
- helpText("Analysis of MAE:", tags$code(mae_name)),
- |
- |
| 88 | -1x | -
- uiOutput(ns("experiment_ui")),
- |
- |
| 89 | -1x | -
- assaySpecInput(ns("assay")),
- |
- |
| 90 | -1x | -
- geneSpecInput(ns("x_spec"), summary_funs, label_genes = "Select x Gene(s)"),
- |
- |
| 91 | -1x | -
- geneSpecInput(ns("y_spec"), summary_funs, label_genes = "Select y Gene(s)"),
- |
- |
| 92 | -1x | -
- teal.widgets::panel_group(- |
- |
| 93 | -1x | -
- teal.widgets::panel_item(- |
- |
| 94 | -1x | -
- input_id = "settings_item",- |
- |
| 95 | -1x | -
- collapsed = TRUE,- |
- |
| 96 | -1x | -
- title = "Additional Settings",+ }) |
|
| 97 | -1x | +||
| 294 | +
- sampleVarSpecInput(ns("color_var"), "Optional color variable"),
+
|
||
| 98 | -1x | +||
| 295 | +! |
- sampleVarSpecInput(ns("facet_var"), "Optional facet variable"),
+ gene_col <- reactive({
|
|
| 99 | -1x | +||
| 296 | +! |
- selectInput(ns("smooth_method"), "Select smoother", smooth_method_choices)
+ attr(adtte_joined(), "gene_cols") |
|
| 100 | +297 |
- )+ }) |
|
| 101 | +298 |
- )+ |
|
| 102 | +299 |
- ),- |
- |
| 103 | -1x | -
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ # After joining, we recompute available endpoints. |
|
| 104 | -1x | +||
| 300 | +! |
- pre_output = pre_output,+ paramcd_choices <- reactive({
|
|
| 105 | -1x | +||
| 301 | +! |
- post_output = post_output+ adtte_joined <- adtte_joined() |
|
| 106 | -+ | ||
| 302 | +! |
- )+ sort(unique(adtte_joined[[adtte_vars$paramcd]])) # Order should not matter. |
|
| 107 | +303 |
- }+ }) |
|
| 108 | +304 | ||
| 109 | +305 |
- #' @describeIn tm_g_scatterplot sets up the server with reactive graph.+ # Start by disabling selection, will be overriden if there are valid choices. |
|
| 110 | -+ | ||
| 306 | +! |
- #' @inheritParams module_arguments+ session$sendCustomMessage( |
|
| 111 | -+ | ||
| 307 | +! |
- #' @export+ "toggle_dropdown", |
|
| 112 | -+ | ||
| 308 | +! |
- srv_g_scatterplot <- function(id,+ list(input_id = session$ns("paramcd"), disabled = TRUE)
|
|
| 113 | +309 |
- data,+ ) |
|
| 114 | +310 |
- filter_panel_api,+ |
|
| 115 | +311 |
- reporter,+ # Once available endpoints change, we update choices (and also the selection |
|
| 116 | +312 |
- mae_name,+ # if nothing was selected earlier) and warn the user if previous endpoint is |
|
| 117 | +313 |
- exclude_assays,+ # not available. |
|
| 118 | -+ | ||
| 314 | +! |
- summary_funs) {
+ observeEvent(paramcd_choices(), {
|
|
| 119 | +315 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ paramcd_choices <- paramcd_choices() |
| 120 | -! | +||
| 316 | +
- assert_class(filter_panel_api, "FilterPanelAPI")+ |
||
| 121 | +317 | ! |
- checkmate::assert_class(data, "reactive")+ new_selected <- if (is_blank(input$paramcd) || (input$paramcd %in% paramcd_choices)) {
|
| 122 | +318 | ! |
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ input$paramcd |
| 123 | +319 |
-
+ } else {
|
|
| 124 | +320 | ! |
- moduleServer(id, function(input, output, session) {
+ showNotification(type = "warning", paste( |
| 125 | +321 | ! |
- output$experiment_ui <- renderUI({
+ "Endpoint", input$paramcd, "not available in this data subset, please", |
| 126 | +322 | ! |
- experimentSpecInput(session$ns("experiment"), data, mae_name)
+ "change filter options or select another endpoint" |
| 127 | +323 |
- })+ ))+ |
+ |
| 324 | ++ |
+ ""+ |
+ |
| 325 | ++ |
+ } |
|
| 128 | +326 | ! |
- experiment <- experimentSpecServer(+ updateSelectizeInput( |
| 129 | +327 | ! |
- "experiment",+ "paramcd", |
| 130 | +328 | ! |
- data = data,+ choices = paramcd_choices, |
| 131 | +329 | ! |
- filter_panel_api = filter_panel_api,+ selected = new_selected, |
| 132 | +330 | ! |
- mae_name = mae_name+ session = session |
| 133 | +331 |
- )+ ) |
|
| 134 | +332 | ! |
- assay <- assaySpecServer(+ session$sendCustomMessage( |
| 135 | +333 | ! |
- "assay",+ "toggle_dropdown", |
| 136 | +334 | ! |
- assays = experiment$assays,+ list(input_id = session$ns("paramcd"), disabled = (length(paramcd_choices) == 0))
|
| 137 | -! | +||
| 335 | +
- exclude_assays = exclude_assays+ ) |
||
| 138 | +336 |
- )+ }) |
|
| 139 | -! | +||
| 337 | +
- sample_var_specs <- multiSampleVarSpecServer(+ + |
+ ||
| 338 | ++ |
+ # Subset zooming in on a specified endpoint. |
|
| 140 | +339 | ! |
- inputIds = c("facet_var", "color_var"),
+ adtte_subset <- reactive({
|
| 141 | +340 | ! |
- experiment_name = experiment$name,+ endpoint <- input$paramcd |
| 142 | +341 | ! |
- original_data = experiment$data+ adtte_joined <- adtte_joined() |
| 143 | +342 |
- )+ |
|
| 144 | +343 | ! |
- x_spec <- geneSpecServer("x_spec", summary_funs, experiment$genes)
+ validate(need( |
| 145 | +344 | ! |
- y_spec <- geneSpecServer("y_spec", summary_funs, experiment$genes)
+ endpoint, |
| 146 | -+ | ||
| 345 | +! |
-
+ "please select an endpoint" |
|
| 147 | -! | +||
| 346 | +
- plot_r <- reactive({
+ )) |
||
| 148 | +347 |
- # Resolve all reactivity.+ # Validate that adtte_data is not empty. |
|
| 149 | +348 | ! |
- experiment_data <- sample_var_specs$experiment_data()+ validate(need( |
| 150 | +349 | ! |
- x_spec <- x_spec()+ nrow(adtte_joined) > 0, |
| 151 | +350 | ! |
- y_spec <- y_spec()+ "Joined ADTTE is empty - please relax the filter criteria" |
| 152 | -! | +||
| 351 | +
- facet_var <- sample_var_specs$vars$facet_var()+ ))+ |
+ ||
| 352 | ++ | + | |
| 153 | +353 | ! |
- color_var <- sample_var_specs$vars$color_var()+ subset_rows <- adtte_joined[[adtte_vars$paramcd]] == endpoint |
| 154 | +354 | ! |
- assay_name <- assay()+ result <- adtte_joined[subset_rows, , drop = FALSE] |
| 155 | +355 | ! |
- smooth_method <- input$smooth_method+ droplevels(result) |
| 156 | +356 | ++ |
+ })+ |
+
| 357 | |||
| 157 | +358 | ! |
- validate_gene_spec(x_spec, rownames(experiment_data))+ binned_adtte_subset <- reactive({
|
| 158 | +359 | ! |
- validate_gene_spec(y_spec, rownames(experiment_data))+ gene_col <- gene_col() |
| 159 | -+ | ||
| 360 | +! |
-
+ probs <- probs()+ |
+ |
| 361 | +! | +
+ adtte_subset <- adtte_subset() |
|
| 160 | +362 |
- # Require which states need to be truthy.+ |
|
| 161 | +363 | ! |
- req(+ result <- tryCatch( |
| 162 | +364 | ! |
- smooth_method,+ expr = {
|
| 163 | -+ | ||
| 365 | +! |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ dplyr::mutate( |
|
| 164 | +366 | ! |
- isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)),+ adtte_subset, |
| 165 | +367 | ! |
- is.null(facet_var) || isTRUE(facet_var %in% names(SummarizedExperiment::colData(experiment_data))),+ gene_factor = tern::cut_quantile_bins( |
| 166 | +368 | ! |
- is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))),+ adtte_subset[, gene_col], |
| 167 | +369 | ! |
- cancelOutput = FALSE+ probs = probs |
| 168 | +370 |
- )+ ) |
|
| 169 | +371 | - - | -|
| 170 | -! | -
- hermes::draw_scatterplot(- |
- |
| 171 | -! | -
- object = experiment_data,+ ) |
|
| 172 | -! | +||
| 372 | +
- assay_name = assay_name,+ }, |
||
| 173 | +373 | ! |
- x_spec = x_spec,+ error = function(e) {
|
| 174 | +374 | ! |
- y_spec = y_spec,+ if (grepl("Contains duplicated values", e)) {
|
| 175 | +375 | ! |
- facet_var = facet_var,+ validate(paste( |
| 176 | +376 | ! |
- color_var = color_var,+ "please adjust filters or select (slightly) different quantiles", |
| 177 | +377 | ! |
- smooth_method = smooth_method+ "to avoid duplicate quantiles" |
| 178 | +378 |
- )+ )) |
|
| 179 | +379 |
- })+ } else {
|
|
| 180 | +380 | ! |
- output$plot <- renderPlot(plot_r())+ stop(e) |
| 181 | +381 |
-
+ } |
|
| 182 | -! | +||
| 382 | +
- pws <- teal.widgets::plot_with_settings_srv(+ } |
||
| 183 | -! | +||
| 383 | +
- id = "plot",+ ) |
||
| 184 | +384 | ! |
- plot_r = plot_r+ result |
| 185 | +385 |
- )+ }) |
|
| 186 | +386 | ||
| 187 | -- |
- ### REPORTER- |
- |
| 188 | -! | -
- if (with_reporter) {
- |
- |
| 189 | +387 | ! |
- card_fun <- function(comment, label) {
+ time_unit <- reactive({
|
| 190 | +388 | ! |
- card <- report_card_template(+ adtte_subset <- adtte_subset() |
| 191 | +389 | ! |
- title = "Scatter Plot",+ result <- unique(as.character(adtte_subset[[adtte_vars$avalu]])) |
| 192 | +390 | ! |
- label = label,+ assert_string(result) |
| 193 | +391 | ! |
- with_filter = TRUE,+ result |
| 194 | -! | +||
| 392 | +
- filter_panel_api = filter_panel_api+ }) |
||
| 195 | +393 |
- )+ |
|
| 196 | +394 | ! |
- card$append_text("Selected Options", "header3")
+ list( |
| 197 | +395 | ! |
- encodings_list <- list(+ binned_adtte_subset = binned_adtte_subset, |
| 198 | +396 | ! |
- "Experiment:",+ gene_col = gene_col, |
| 199 | +397 | ! |
- input$`experiment-name`,+ gene_factor = "gene_factor", |
| 200 | +398 | ! |
- "\nAssay:",+ time_unit = time_unit |
| 201 | -! | +||
| 399 | +
- input$`assay-name`,+ ) |
||
| 202 | -! | +||
| 400 | +
- "\nX Genes Selected:",+ }) |
||
| 203 | -! | +||
| 401 | +
- paste0(x_spec()$get_gene_labels(), collapse = ", "),+ } |
||
| 204 | -! | +
| 1 | ++ |
+ #' Most Expressed Genes Plot+ |
+ |
| 2 | ++ |
+ #'+ |
+ |
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+ |
| 4 | +
- "\nX Genes Summary:",+ #' |
||
| 205 | -! | +||
| 5 | +
- input$`x_spec-fun_name`,+ #' This function plots the most expressed genes. |
||
| 206 | -! | +||
| 6 | +
- "\nY Genes Selected:",+ #' |
||
| 207 | -! | +||
| 7 | +
- paste0(y_spec()$get_gene_labels(), collapse = ", "),+ #' @inheritParams function_arguments |
||
| 208 | -! | +||
| 8 | +
- "\nY Genes Summary:",+ #' |
||
| 209 | -! | +||
| 9 | +
- input$`y_spec-fun_name`,+ #' @return Plot to be displayed in the teal app. |
||
| 210 | -! | +||
| 10 | +
- "\nOptional Color Variable:",+ #' |
||
| 211 | -! | +||
| 11 | +
- input$`color_var-sample_var`,+ #' @export |
||
| 212 | -! | +||
| 12 | +
- "\nOptional Facetting Variable:",+ #' |
||
| 213 | -! | +||
| 13 | +
- input$`facet_var-sample_var`,+ #' @examples |
||
| 214 | -! | +||
| 14 | +
- "\nSmoother:",+ #' library(hermes) |
||
| 215 | -! | +||
| 15 | +
- input$smooth_method+ #' object <- HermesData(summarized_experiment) |
||
| 216 | +16 |
- )+ #' result <- top_gene_plot(object, assay_name = "counts") |
|
| 217 | -! | +||
| 17 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ top_gene_plot <- function(object, assay_name) {
|
||
| 218 | +18 | ! |
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ top_gene <- hermes::top_genes( |
| 219 | +19 | ! |
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ object = object, |
| 220 | +20 | ! |
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")- |
-
| 221 | -- |
- } else {
+ assay_name = assay_name, |
|
| 222 | +21 | ! |
- paste(encodings_list, collapse = " ")- |
-
| 223 | -- |
- }+ summary_fun = rowMeans |
|
| 224 | +22 |
-
+ ) |
|
| 225 | +23 | ! |
- card$append_text(final_encodings, style = "verbatim")+ hermes::autoplot( |
| 226 | +24 | ! |
- card$append_text("Plot", "header3")
+ top_gene, |
| 227 | +25 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ x_lab = "Gene", |
| 228 | +26 | ! |
- if (!comment == "") {
+ y_lab = paste("Mean", assay_name, "across samples")
|
| 229 | -! | +||
| 27 | +
- card$append_text("Comment", "header3")
+ ) |
||
| 230 | -! | +||
| 28 | +
- card$append_text(comment)+ } |
||
| 231 | +29 |
- }+ |
|
| 232 | -! | +||
| 30 | +
- card+ #' Correlation Heatmap Plot |
||
| 233 | +31 |
- }+ #' |
|
| 234 | -! | +||
| 32 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 235 | +33 |
- }+ #' |
|
| 236 | +34 |
- ###+ #' This function plots the correlation heatmap. |
|
| 237 | +35 |
- })+ #' |
|
| 238 | +36 |
- }+ #' @inheritParams function_arguments |
|
| 239 | +37 |
-
+ #' |
|
| 240 | +38 |
- #' @describeIn tm_g_scatterplot sample module function.+ #' @return Plot to be displayed in the teal app. |
|
| 241 | +39 |
- #' @export+ #' |
|
| 242 | +40 |
- #' @examples+ #' @export |
|
| 243 | +41 |
#' |
|
| 244 | +42 |
- #' # Alternatively you can run the sample module with this function call:+ #' @examples |
|
| 245 | +43 |
- #' if (interactive()) {
+ #' library(hermes) |
|
| 246 | +44 |
- #' sample_tm_g_scatterplot()+ #' object <- HermesData(summarized_experiment) |
|
| 247 | +45 |
- #' }+ #' result <- heatmap_plot(object, assay_name = "counts") |
|
| 248 | +46 |
- sample_tm_g_scatterplot <- function() {
- |
- |
| 249 | -! | -
- data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment)+ heatmap_plot <- function(object, assay_name) {
|
|
| 250 | +47 | ! |
- app <- teal::init(+ heatmap <- hermes::correlate( |
| 251 | +48 | ! |
- data = data,+ object = object, |
| 252 | +49 | ! |
- modules = teal::modules(+ assay_name = assay_name |
| 253 | -! | +||
| 50 | +
- tm_g_scatterplot(+ ) |
||
| 254 | +51 | ! |
- label = "scatterplot",+ hermes::autoplot(heatmap) |
| 255 | -! | +||
| 52 | +
- mae_name = "MAE"+ } |
||
| 256 | +53 |
- )+ |
|
| 257 | +54 |
- )+ #' Teal Module for RNA-seq Quality Control |
|
| 258 | +55 |
- )+ #' |
|
| 259 | -! | +||
| 56 | +
- shinyApp(app$ui, app$server)+ #' @description `r lifecycle::badge("experimental")`
|
||
| 260 | +57 |
- }+ #' |
| 1 | +58 |
- #' Data Preprocessing for `ADTTE` Module+ #' This module adds quality flags, filters by genes and/or samples, |
||
| 2 | +59 |
- #'+ #' normalizes `AnyHermesData` objects and provides interactive plots |
||
| 3 | +60 |
- #' @description `r lifecycle::badge("experimental")`
+ #' for RNA-seq gene expression quality control. |
||
| 4 | +61 |
#' |
||
| 5 | +62 |
- #' A function to help with merging of MAE to `ADTTE`.+ #' @inheritParams module_arguments |
||
| 6 | +63 |
#' |
||
| 7 | +64 |
- #' @inheritParams function_arguments+ #' @return Shiny module to be used in the teal app. |
||
| 8 | +65 |
#' |
||
| 9 | +66 |
- #' @return A data frame containing all columns/rows from `adtte` that match+ #' @export |
||
| 10 | +67 |
- #' by subject ID with the row names of the MAE and have the gene samples available+ #' |
||
| 11 | +68 |
- #' in the given experiment. The attribute `gene_cols` contains the column names+ #' @examples |
||
| 12 | +69 |
- #' for the gene columns.+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 13 | +70 |
- #'+ #' app <- init( |
||
| 14 | +71 |
- #' @note The final gene column names can start with a different string than+ #' data = data, |
||
| 15 | +72 |
- #' the original gene IDs (or labels), in particular white space and colons are removed.+ #' modules = modules( |
||
| 16 | +73 |
- #'+ #' tm_g_quality( |
||
| 17 | +74 |
- #' @export+ #' label = "Quality Control", |
||
| 18 | +75 |
- #' @examples+ #' mae_name = "MAE" |
||
| 19 | +76 |
- #' mae <- hermes::multi_assay_experiment+ #' ) |
||
| 20 | +77 |
- #' adtte <- teal.modules.hermes::rADTTE %>%+ #' ) |
||
| 21 | +78 |
- #' dplyr::mutate(CNSR = as.logical(CNSR))+ #' ) |
||
| 22 | +79 |
- #'+ #' if (interactive()) {
|
||
| 23 | +80 |
- #' new_adtte <- h_km_mae_to_adtte(+ #' shinyApp(app$ui, app$server) |
||
| 24 | +81 |
- #' adtte,+ #' } |
||
| 25 | +82 |
- #' mae,+ tm_g_quality <- function(label, |
||
| 26 | +83 |
- #' genes = hermes::gene_spec("GeneID:1820"),
+ mae_name, |
||
| 27 | +84 |
- #' experiment_name = "hd2"+ exclude_assays = character(), |
||
| 28 | +85 |
- #' )+ pre_output = NULL, |
||
| 29 | +86 |
- #' new_adtte2 <- h_km_mae_to_adtte(+ post_output = NULL, |
||
| 30 | +87 |
- #' adtte,+ .test = FALSE) {
+ |
+ ||
| 88 | +! | +
+ assert_string(label)+ |
+ ||
| 89 | +! | +
+ assert_string(mae_name)+ |
+ ||
| 90 | +! | +
+ assert_character(exclude_assays, any.missing = FALSE)+ |
+ ||
| 91 | +! | +
+ assert_tag(pre_output, null.ok = TRUE)+ |
+ ||
| 92 | +! | +
+ assert_tag(post_output, null.ok = TRUE) |
||
| 31 | +93 |
- #' mae,+ + |
+ ||
| 94 | +! | +
+ teal::module(+ |
+ ||
| 95 | +! | +
+ label = label,+ |
+ ||
| 96 | +! | +
+ server = srv_g_quality,+ |
+ ||
| 97 | +! | +
+ server_args = list(+ |
+ ||
| 98 | +! | +
+ mae_name = mae_name,+ |
+ ||
| 99 | +! | +
+ exclude_assays = exclude_assays,+ |
+ ||
| 100 | +! | +
+ .test = .test |
||
| 32 | +101 |
- #' genes = hermes::gene_spec(c("GeneID:1820", "GeneID:94115"), fun = colMeans),
+ ), |
||
| 33 | -+ | |||
| 102 | +! |
- #' experiment_name = "hd2"+ ui = ui_g_quality, |
||
| 34 | -+ | |||
| 103 | +! |
- #' )+ ui_args = list( |
||
| 35 | -+ | |||
| 104 | +! |
- #' new_adtte3 <- h_km_mae_to_adtte(+ mae_name = mae_name, |
||
| 36 | -+ | |||
| 105 | +! |
- #' adtte,+ pre_output = pre_output, |
||
| 37 | -+ | |||
| 106 | +! |
- #' mae,+ post_output = post_output, |
||
| 38 | -+ | |||
| 107 | +! |
- #' genes = hermes::gene_spec(c(A = "GeneID:1820", B = "GeneID:94115")),+ .test = .test |
||
| 39 | +108 |
- #' experiment_name = "hd2"+ ), |
||
| 40 | -+ | |||
| 109 | +! |
- #' )+ datanames = mae_name |
||
| 41 | +110 |
- h_km_mae_to_adtte <- function(adtte,+ ) |
||
| 42 | +111 |
- mae,+ } |
||
| 43 | +112 |
- genes,+ |
||
| 44 | +113 |
- experiment_name = "hd1",+ #' @describeIn tm_g_quality sets up the user interface. |
||
| 45 | +114 |
- assay_name = "counts",+ #' @inheritParams module_arguments |
||
| 46 | +115 |
- usubjid_var = "USUBJID") {
- |
- ||
| 47 | -11x | -
- assert_class(mae, "MultiAssayExperiment")+ #' @export |
||
| 48 | -11x | +|||
| 116 | +
- assert_string(experiment_name)+ ui_g_quality <- function(id, |
|||
| 49 | -10x | +|||
| 117 | +
- assert_string(usubjid_var)+ mae_name, |
|||
| 50 | -10x | +|||
| 118 | +
- assert_names(names(adtte), must.include = usubjid_var)+ pre_output, |
|||
| 51 | +119 |
-
+ post_output, |
||
| 52 | +120 |
- # Check subject ID across experiment, sample map, and MAE colData.+ .test = FALSE) {
|
||
| 53 | -10x | +121 | +1x |
- mae_samplemap <- MultiAssayExperiment::sampleMap(mae)+ ns <- NS(id) |
| 54 | -10x | +122 | +1x |
- samplemap_experiment <- mae_samplemap[mae_samplemap$assay == experiment_name, ]+ teal.widgets::standard_layout( |
| 55 | -10x | +123 | +1x |
- sm_usubjid <- as.character(samplemap_experiment$primary)+ encoding = tags$div( |
| 56 | +124 | - - | -||
| 57 | -10x | -
- hd <- suppressWarnings(MultiAssayExperiment::getWithColData(mae, experiment_name))- |
- ||
| 58 | -9x | -
- assert_class(hd, "AnyHermesData")+ ### Reporter |
||
| 59 | -9x | +125 | +1x |
- hd_usubjid <- as.character(SummarizedExperiment::colData(hd)[[usubjid_var]])+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 60 | +126 |
-
+ ### |
||
| 61 | -9x | +127 | +1x |
- assert_subset(+ tags$label("Encodings", class = "text-primary"),
|
| 62 | -9x | +128 | +1x |
- x = hd_usubjid,+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
| 63 | -9x | -
- choices = sm_usubjid- |
- ||
| 64 | -- |
- )- |
- ||
| 65 | -+ | 129 | +1x |
-
+ uiOutput(ns("experiment_ui")),
|
| 66 | -8x | +130 | +1x |
- mae_coldata <- MultiAssayExperiment::colData(mae)+ selectInput( |
| 67 | -8x | +131 | +1x |
- if (usubjid_var %in% colnames(mae_coldata)) {
+ ns("plot_type"),
|
| 68 | -8x | +132 | +1x |
- mae_usubjid <- as.character(mae_coldata[[usubjid_var]])+ "Plot Type", |
| 69 | -8x | +133 | +1x |
- assert_subset(+ choices = c( |
| 70 | -8x | +134 | +1x |
- x = sm_usubjid,+ "Histogram", |
| 71 | -8x | -
- choices = mae_usubjid- |
- ||
| 72 | -- |
- )- |
- ||
| 73 | -+ | 135 | +1x |
- }+ "Q-Q Plot", |
| 74 | -+ | |||
| 136 | +1x |
-
+ "Density", |
||
| 75 | -7x | +137 | +1x |
- gene_data <- hermes::col_data_with_genes(+ "Boxplot", |
| 76 | -7x | +138 | +1x |
- object = hd,+ "Top Genes Plot", |
| 77 | -7x | +139 | +1x |
- assay_name = assay_name,+ "Correlation Heatmap" |
| 78 | -7x | +|||
| 140 | +
- genes = genes+ ) |
|||
| 79 | +141 |
- )+ ), |
||
| 80 | -5x | +142 | +1x |
- merged_adtte <- hermes::inner_join_cdisc(+ conditionalPanel( |
| 81 | -5x | +143 | +1x |
- gene_data = gene_data,+ condition = "input.plot_type == 'Top Genes Plot' || input.plot_type == 'Correlation Heatmap'", |
| 82 | -5x | +144 | +1x |
- cdisc_data = adtte,+ ns = ns, |
| 83 | -5x | +145 | +1x |
- patient_key = usubjid_var+ assaySpecInput(ns("assay"))
|
| 84 | +146 |
- )+ ), |
||
| 85 | -5x | +147 | +1x |
- structure(+ tags$label("Gene Filter Settings", class = "text-primary"),
|
| 86 | -5x | +148 | +1x |
- merged_adtte,+ shinyWidgets::switchInput( |
| 87 | -5x | +149 | +1x |
- gene_cols = attr(gene_data, "gene_cols")+ ns("filter_gene"),
|
| 88 | -+ | |||
| 150 | +1x |
- )+ value = TRUE, |
||
| 89 | -+ | |||
| 151 | +1x |
- }+ size = "mini" |
||
| 90 | +152 |
-
+ ), |
||
| 91 | -+ | |||
| 153 | +1x |
- #' Module Input for `ADTTE` Specification+ conditionalPanel( |
||
| 92 | -+ | |||
| 154 | +1x |
- #'+ condition = "input.filter_gene", |
||
| 93 | -+ | |||
| 155 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ ns = ns, |
||
| 94 | -+ | |||
| 156 | +1x |
- #'+ sliderInput(ns("min_cpm"), label = ("Minimum CPM"), min = 1, max = 10, value = 5),
|
||
| 95 | -+ | |||
| 157 | +1x |
- #' This defines the input for the `ADTTE` specification.+ sliderInput(ns("min_cpm_prop"), label = ("Minimum CPM Proportion"), min = 0.01, max = 0.99, value = 0.25),
|
||
| 96 | -+ | |||
| 158 | +1x |
- #'+ teal.widgets::optionalSelectInput( |
||
| 97 | -+ | |||
| 159 | +1x |
- #' @inheritParams module_arguments+ ns("annotate"),
|
||
| 98 | -+ | |||
| 160 | +1x |
- #' @param label_paramcd (`string`)\cr label for the endpoint (`PARAMCD`) selection.+ label = "Required Annotations", |
||
| 99 | -+ | |||
| 161 | +1x |
- #'+ choices = "", |
||
| 100 | -+ | |||
| 162 | +1x |
- #' @return The UI part.+ selected = "", |
||
| 101 | -+ | |||
| 163 | +1x |
- #' @seealso [adtteSpecServer()] for the module server and a complete example.+ multiple = TRUE |
||
| 102 | +164 |
- #' @export+ ) |
||
| 103 | +165 |
- adtteSpecInput <- function(inputId, # nolint+ ), |
||
| 104 | -+ | |||
| 166 | +1x |
- label_paramcd = "Select Endpoint") {
+ tags$label("Sample Filter Settings", class = "text-primary"),
|
||
| 105 | -3x | +167 | +1x |
- assert_string(inputId)+ shinyWidgets::switchInput( |
| 106 | -3x | +168 | +1x |
- assert_string(label_paramcd, min.chars = 1L)+ ns("filter_sample"),
|
| 107 | -+ | |||
| 169 | +1x |
-
+ value = TRUE, |
||
| 108 | -3x | +170 | +1x |
- ns <- NS(inputId)+ size = "mini" |
| 109 | +171 |
-
+ ), |
||
| 110 | -3x | +172 | +1x |
- tagList(+ conditionalPanel( |
| 111 | -3x | +173 | +1x |
- selectizeInput(+ condition = "input.filter_sample", |
| 112 | -3x | +174 | +1x |
- inputId = ns("paramcd"),
+ ns = ns, |
| 113 | -3x | +175 | +1x |
- label = label_paramcd,+ sliderInput(ns("min_corr"), label = ("Minimum Correlation"), min = 0.01, max = 0.99, value = 0.5),
|
| 114 | -3x | +176 | +1x |
- choices = "",+ radioButtons( |
| 115 | -3x | +177 | +1x |
- options = list(placeholder = "- Nothing selected -")+ ns("min_depth"),
|
| 116 | -+ | |||
| 178 | +1x |
- ),+ label = "Minimum Depth", |
||
| 117 | -3x | +179 | +1x |
- include_js_files("dropdown.js")
+ choices = c("Default", "Specify"),
|
| 118 | -+ | |||
| 180 | +1x |
- )+ selected = "Default" |
||
| 119 | +181 |
- }+ ), |
||
| 120 | -+ | |||
| 182 | +1x |
-
+ conditionalPanel( |
||
| 121 | -+ | |||
| 183 | +1x |
- #' Module Server for `ADTTE` Specification+ condition = "input.min_depth == 'Specify'", |
||
| 122 | -+ | |||
| 184 | +1x |
- #'+ ns = ns, |
||
| 123 | -+ | |||
| 185 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ sliderInput(ns("min_depth_continuous"), label = NULL, min = 1, max = 10, value = 1)
|
||
| 124 | +186 |
- #'+ ) |
||
| 125 | +187 |
- #' This defines the server part for the `ADTTE` specification. The resulting data+ ) |
||
| 126 | +188 |
- #' set `binned_adtte_subset` contains the subset of `ADTTE` selected by the time-to-event+ ), |
||
| 127 | -+ | |||
| 189 | +1x |
- #' endpoint, joined together with the gene information extracted from specified assay+ output = div( |
||
| 128 | -+ | |||
| 190 | +1x |
- #' and experiment, as numeric and factor columns. The factor column is created by binning+ if (.test) verbatimTextOutput(ns("table")) else NULL,
|
||
| 129 | -+ | |||
| 191 | +1x |
- #' the numeric column according to the quantile cutoffs specified in `probs`.+ teal.widgets::plot_with_settings_ui(ns("plot"))
|
||
| 130 | +192 |
- #'+ ), |
||
| 131 | -+ | |||
| 193 | +1x |
- #' @inheritParams module_arguments+ pre_output = pre_output, |
||
| 132 | -+ | |||
| 194 | +1x |
- #' @param experiment_data (reactive `AnyHermesData`)\cr input experiment.+ post_output = post_output |
||
| 133 | +195 |
- #' @param experiment_name (reactive `string`)\cr name of the input experiment.+ ) |
||
| 134 | +196 |
- #' @param assay (reactive `string`)\cr name of the assay.+ } |
||
| 135 | +197 |
- #' @param genes (reactive `GeneSpec`)\cr gene specification.+ |
||
| 136 | +198 |
- #' @param probs (reactive `numeric`)\cr probabilities to bin the gene or gene signature+ #' @describeIn tm_g_quality sets up the server with reactive graphs. |
||
| 137 | +199 |
- #' into.+ #' @inheritParams module_arguments |
||
| 138 | +200 |
- #'+ #' @export |
||
| 139 | +201 |
- #' @return List with the following elements:+ srv_g_quality <- function(id, |
||
| 140 | +202 |
- #' - `binned_adtte_subset`: reactive containing the joined `ADTTE` and gene data.+ data, |
||
| 141 | +203 |
- #' - `gene_col`: reactive containing the string with the column name of the original+ filter_panel_api, |
||
| 142 | +204 |
- #' numeric gene variable.+ reporter, |
||
| 143 | +205 |
- #' - `gene_factor`: string with the variable name for the binned gene data.+ mae_name, |
||
| 144 | +206 |
- #' - `time_unit`: reactive string with the time unit for the current subset.+ exclude_assays, |
||
| 145 | +207 |
- #'+ .test = FALSE) {
|
||
| 146 | -+ | |||
| 208 | +! |
- #' @seealso [adtteSpecInput()] for the module UI.+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
||
| 147 | -+ | |||
| 209 | +! |
- #'+ assert_class(filter_panel_api, "FilterPanelAPI") |
||
| 148 | -+ | |||
| 210 | +! |
- #' @export+ checkmate::assert_class(data, "reactive") |
||
| 149 | -+ | |||
| 211 | +! |
- #'+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
||
| 150 | +212 |
- #' @examples+ |
||
| 151 | -+ | |||
| 213 | +! |
- #' ui <- function(id) {
+ moduleServer(id, function(input, output, session) {
|
||
| 152 | -+ | |||
| 214 | +! |
- #' ns <- NS(id)+ output$experiment_ui <- renderUI({
|
||
| 153 | -+ | |||
| 215 | +! |
- #'+ experimentSpecInput(session$ns("experiment"), data, mae_name)
|
||
| 154 | +216 |
- #' teal.widgets::standard_layout(+ }) |
||
| 155 | -+ | |||
| 217 | +! |
- #' encoding = uiOutput(ns("encoding_ui")),
+ experiment <- experimentSpecServer( |
||
| 156 | -+ | |||
| 218 | +! |
- #' output = verbatimTextOutput(ns("summary"))
+ "experiment", |
||
| 157 | -+ | |||
| 219 | +! |
- #' )+ data = data, |
||
| 158 | -+ | |||
| 220 | +! |
- #' }+ filter_panel_api = filter_panel_api, |
||
| 159 | -+ | |||
| 221 | +! |
- #'+ mae_name = mae_name |
||
| 160 | +222 |
- #' server <- function(id, data, filter_panel_api) {
+ ) |
||
| 161 | +223 |
- #' checkmate::assert_class(data, "reactive")+ |
||
| 162 | -+ | |||
| 224 | +! |
- #' checkmate::assert_class(shiny::isolate(data()), "teal_data")+ assay <- assaySpecServer( |
||
| 163 | -+ | |||
| 225 | +! |
- #' moduleServer(id, function(input, output, session) {
+ "assay", |
||
| 164 | -+ | |||
| 226 | +! |
- #' output$encoding_ui <- renderUI({
+ assays = reactive({
|
||
| 165 | -+ | |||
| 227 | +! |
- #' tags$div(+ union( |
||
| 166 | -+ | |||
| 228 | +! |
- #' experimentSpecInput(session$ns("experiment"), data, mae_name = "MAE"),
+ experiment$assays(), |
||
| 167 | +229 |
- #' assaySpecInput(session$ns("assay")),
+ # Add all the additional normalized assays. |
||
| 168 | -+ | |||
| 230 | +! |
- #' geneSpecInput(session$ns("genes"), funs = list(Mean = colMeans)),
+ c("cpm", "rpkm", "tpm", "voom", "vst")
|
||
| 169 | +231 |
- #' adtteSpecInput(session$ns("adtte"))
+ ) |
||
| 170 | +232 |
- #' )+ }), |
||
| 171 | -+ | |||
| 233 | +! |
- #' })+ exclude_assays = exclude_assays |
||
| 172 | +234 |
- #' experiment <- experimentSpecServer(+ ) |
||
| 173 | +235 |
- #' "experiment",+ |
||
| 174 | -+ | |||
| 236 | +! |
- #' data = data,+ experiment_properties <- eventReactive(experiment$name(), {
|
||
| 175 | -+ | |||
| 237 | +! |
- #' filter_panel_api = filter_panel_api,+ data <- experiment$data() |
||
| 176 | -+ | |||
| 238 | +! |
- #' mae_name = "MAE"+ cpm <- edgeR::cpm(hermes::counts(data)) |
||
| 177 | -+ | |||
| 239 | +! |
- #' )+ depth <- colSums(hermes::counts(data)) |
||
| 178 | -+ | |||
| 240 | +! |
- #' assay <- assaySpecServer(+ list( |
||
| 179 | -+ | |||
| 241 | +! |
- #' "assay",+ annotations = names(hermes::annotation(data)), |
||
| 180 | -+ | |||
| 242 | +! |
- #' assays = experiment$assays+ min_cpm_calc = floor(min(cpm)), |
||
| 181 | -+ | |||
| 243 | +! |
- #' )+ max_cpm_calc = floor(max(cpm)), |
||
| 182 | -+ | |||
| 244 | +! |
- #' genes <- geneSpecServer(+ min_depth_calc = min(depth), |
||
| 183 | -+ | |||
| 245 | +! |
- #' "genes",+ max_depth_calc = max(depth) |
||
| 184 | +246 |
- #' funs = list(Mean = colMeans),+ ) |
||
| 185 | +247 |
- #' gene_choices = experiment$genes+ }) |
||
| 186 | +248 |
- #' )+ |
||
| 187 | -+ | |||
| 249 | +! |
- #' adtte <- adtteSpecServer(+ observeEvent(experiment_properties(), {
|
||
| 188 | -+ | |||
| 250 | +! |
- #' "adtte",+ properties <- experiment_properties() |
||
| 189 | +251 |
- #' data = data,+ |
||
| 190 | -+ | |||
| 252 | +! |
- #' adtte_name = "ADTTE",+ teal.widgets::updateOptionalSelectInput( |
||
| 191 | -+ | |||
| 253 | +! |
- #' mae_name = "MAE",+ session, |
||
| 192 | -+ | |||
| 254 | +! |
- #' adtte_vars = list(+ "annotate", |
||
| 193 | -+ | |||
| 255 | +! |
- #' aval = "AVAL",+ choices = properties$annotations, |
||
| 194 | -+ | |||
| 256 | +! |
- #' avalu = "AVALU",+ selected = "WidthBP" |
||
| 195 | +257 |
- #' is_event = "is_event",+ ) |
||
| 196 | -+ | |||
| 258 | +! |
- #' paramcd = "PARAMCD",+ updateSliderInput( |
||
| 197 | -+ | |||
| 259 | +! |
- #' usubjid = "USUBJID"+ session, |
||
| 198 | -+ | |||
| 260 | +! |
- #' ),+ "min_cpm", |
||
| 199 | -+ | |||
| 261 | +! |
- #' experiment_data = experiment$data,+ min = properties$min_cpm_calc, |
||
| 200 | -+ | |||
| 262 | +! |
- #' experiment_name = experiment$name,+ max = properties$max_cpm_calc, |
||
| 201 | -+ | |||
| 263 | +! |
- #' assay = assay,+ value = properties$min_cpm_calc |
||
| 202 | +264 |
- #' genes = genes,+ ) |
||
| 203 | -+ | |||
| 265 | +! |
- #' probs = reactive({
+ updateSliderInput( |
||
| 204 | -+ | |||
| 266 | +! |
- #' 0.5+ session, |
||
| 205 | -+ | |||
| 267 | +! |
- #' })+ "min_depth_continuous", |
||
| 206 | -+ | |||
| 268 | +! |
- #' )+ min = properties$min_depth_calc, |
||
| 207 | -+ | |||
| 269 | +! |
- #' output$summary <- renderPrint({
+ max = properties$max_depth_calc, |
||
| 208 | -+ | |||
| 270 | +! |
- #' binned_adtte_subset <- adtte$binned_adtte_subset()+ value = properties$min_depth_calc |
||
| 209 | +271 |
- #' summary(binned_adtte_subset)+ ) |
||
| 210 | +272 |
- #' })+ }) |
||
| 211 | +273 |
- #' })+ |
||
| 212 | -+ | |||
| 274 | +! |
- #' }+ min_depth_final <- reactive({
|
||
| 213 | -+ | |||
| 275 | +! |
- #'+ min_depth <- input$min_depth |
||
| 214 | -+ | |||
| 276 | +! |
- #' my_app <- function() {
+ min_depth_continuous <- input$min_depth_continuous |
||
| 215 | -+ | |||
| 277 | +! |
- #' data <- teal_data()+ if (min_depth == "Specify") {
|
||
| 216 | -+ | |||
| 278 | +! |
- #' data <- within(data, {
+ req(min_depth_continuous) |
||
| 217 | -+ | |||
| 279 | +! |
- #' ADSL <- teal.data::rADSL+ min_depth_continuous |
||
| 218 | +280 |
- #' ADTTE <- teal.modules.hermes::rADTTE %>%+ } else {
|
||
| 219 | -+ | |||
| 281 | +! |
- #' dplyr::mutate(is_event = .data$CNSR == 0)+ NULL |
||
| 220 | +282 |
- #' MAE <- hermes::multi_assay_experiment+ } |
||
| 221 | +283 |
- #' })+ }) |
||
| 222 | +284 |
- #' datanames <- c("ADSL", "ADTTE", "MAE")
+
|
||
| 223 | -+ | |||
| 285 | +! |
- #' datanames(data) <- datanames+ control <- reactive({
|
||
| 224 | -+ | |||
| 286 | +! |
- #' join_keys(data) <- default_cdisc_join_keys[datanames]+ min_cpm <- input$min_cpm |
||
| 225 | -+ | |||
| 287 | +! |
- #'+ min_cpm_prop <- input$min_cpm_prop |
||
| 226 | -+ | |||
| 288 | +! |
- #' app <- init(+ min_corr <- input$min_corr |
||
| 227 | -+ | |||
| 289 | +! |
- #' data = data,+ min_depth_final <- min_depth_final() |
||
| 228 | +290 |
- #' modules = modules(+ |
||
| 229 | -+ | |||
| 291 | +! |
- #' module(+ req( |
||
| 230 | -+ | |||
| 292 | +! |
- #' label = "adtteSpec example",+ min_cpm, |
||
| 231 | -+ | |||
| 293 | +! |
- #' server = server,+ min_cpm_prop, |
||
| 232 | -+ | |||
| 294 | +! |
- #' ui = ui,+ min_corr |
||
| 233 | +295 |
- #' datanames = "all"+ ) |
||
| 234 | +296 |
- #' )+ |
||
| 235 | -+ | |||
| 297 | +! |
- #' )+ hermes::control_quality( |
||
| 236 | -+ | |||
| 298 | +! |
- #' )+ min_cpm = min_cpm, |
||
| 237 | -+ | |||
| 299 | +! |
- #' shinyApp(app$ui, app$server)+ min_cpm_prop = min_cpm_prop, |
||
| 238 | -+ | |||
| 300 | +! |
- #' }+ min_corr = min_corr, |
||
| 239 | -+ | |||
| 301 | +! |
- #'+ min_depth = min_depth_final |
||
| 240 | +302 |
- #' if (interactive()) {
+ ) |
||
| 241 | +303 |
- #' my_app()+ }) |
||
| 242 | +304 |
- #' }+ |
||
| 243 | -+ | |||
| 305 | +! |
- adtteSpecServer <- function(id, # nolint+ object_flagged <- reactive({
|
||
| 244 | -+ | |||
| 306 | +! |
- data,+ control <- control() |
||
| 245 | -+ | |||
| 307 | +! |
- mae_name,+ object <- experiment$data() |
||
| 246 | +308 |
- adtte_name,+ |
||
| 247 | -+ | |||
| 309 | +! |
- adtte_vars,+ already_added <- ("control_quality_flags" %in% names(hermes::metadata(object)))
|
||
| 248 | -+ | |||
| 310 | +! |
- experiment_data,+ validate(need(!already_added, "Quality flags have already been added to this experiment")) |
||
| 249 | -+ | |||
| 311 | +! |
- experiment_name,+ if (any(c("cpm", "rpkm", "tpm", "voom", "vst") %in% SummarizedExperiment::assayNames(object))) {
|
||
| 250 | -+ | |||
| 312 | +! |
- assay,+ showNotification("Original normalized assays will be overwritten", type = "warning")
|
||
| 251 | +313 |
- genes,+ } |
||
| 252 | +314 |
- probs) {
- |
- ||
| 253 | -! | -
- assert_string(id)+ |
||
| 254 | +315 | ! |
- assert_string(mae_name)+ hermes::add_quality_flags( |
|
| 255 | +316 | ! |
- assert_string(adtte_name)+ object, |
|
| 256 | +317 | ! |
- assert_adtte_vars(adtte_vars)+ control = control |
|
| 257 | -! | +|||
| 318 | +
- assert_reactive(experiment_data)+ ) |
|||
| 258 | -! | +|||
| 319 | +
- assert_reactive(experiment_name)+ }) |
|||
| 259 | -! | +|||
| 320 | +
- assert_reactive(assay)+ |
|||
| 260 | +321 | ! |
- assert_reactive(genes)+ object_final <- reactive({
|
|
| 261 | +322 | ! |
- assert_reactive(probs)+ object_flagged <- object_flagged() |
|
| 262 | +323 | ! |
- checkmate::assert_class(data, "reactive")+ filter <- input$filter |
|
| 263 | +324 | ! |
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ annotate <- input$annotate |
|
| 264 | +325 | |||
| 265 | +326 | ! |
- moduleServer(id, function(input, output, session) {
+ req(!is_blank(annotate)) |
|
| 266 | +327 |
- # Join ADTTE with gene data.- |
- ||
| 267 | -! | -
- adtte_joined <- reactive({
+
|
||
| 268 | +328 | ! |
- experiment_data <- experiment_data()+ result <- hermes::filter( |
|
| 269 | +329 | ! |
- experiment_name <- experiment_name()+ object_flagged, |
|
| 270 | +330 | ! |
- assay <- assay()+ what = filter, |
|
| 271 | +331 | ! |
- genes <- genes()+ annotation_required = annotate |
|
| 272 | +332 | - - | -||
| 273 | -! | -
- validate_gene_spec(genes, rownames(experiment_data))+ ) |
||
| 274 | +333 | |||
| 275 | -! | -
- req(- |
- ||
| 276 | +334 | ! |
- genes$returns_vector(),+ validate(need( |
|
| 277 | +335 | ! |
- experiment_name,+ nrow(result) >= 2, |
|
| 278 | +336 | ! |
- assay+ "Please change gene filters to ensure that there are at least 2 genes" |
|
| 279 | +337 |
- )+ )) |
||
| 280 | +338 | |||
| 281 | +339 | ! |
- mae <- data()[[mae_name]]+ hermes::normalize(result) |
|
| 282 | -! | +|||
| 340 | +
- adtte <- data()[[adtte_name]]+ }) |
|||
| 283 | +341 | |||
| 284 | +342 | ! |
- mae[[experiment_name]] <- experiment_data+ plot_r <- reactive({
|
|
| 285 | +343 | ! |
- h_km_mae_to_adtte(+ object_final <- object_final() |
|
| 286 | +344 | ! |
- adtte,+ plot_type <- input$plot_type |
|
| 287 | +345 | ! |
- mae,+ assay_name <- assay() |
|
| 288 | -! | +|||
| 346 | +
- genes = genes,+ |
|||
| 289 | +347 | ! |
- experiment_name = experiment_name,+ switch(plot_type, |
|
| 290 | +348 | ! |
- assay_name = assay,+ "Histogram" = hermes::draw_libsize_hist(object_final), |
|
| 291 | +349 | ! |
- usubjid_var = adtte_vars$usubjid- |
- |
| 292 | -- |
- )+ "Density" = hermes::draw_libsize_densities(object_final), |
||
| 293 | -+ | |||
| 350 | +! |
- })+ "Q-Q Plot" = hermes::draw_libsize_qq(object_final), |
||
| 294 | -+ | |||
| 351 | +! |
-
+ "Boxplot" = hermes::draw_nonzero_boxplot(object_final), |
||
| 295 | +352 | ! |
- gene_col <- reactive({
+ "Top Genes Plot" = top_gene_plot(object_final, assay_name = assay_name), |
|
| 296 | +353 | ! |
- attr(adtte_joined(), "gene_cols")+ "Correlation Heatmap" = heatmap_plot(object_final, assay_name = assay_name) |
|
| 297 | +354 |
- })+ ) |
||
| 298 | +355 |
-
+ })+ |
+ ||
| 356 | +! | +
+ output$plot <- renderPlot(plot_r()) |
||
| 299 | +357 |
- # After joining, we recompute available endpoints.+ |
||
| 300 | +358 | ! |
- paramcd_choices <- reactive({
+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 301 | +359 | ! |
- adtte_joined <- adtte_joined()+ id = "plot", |
|
| 302 | +360 | ! |
- sort(unique(adtte_joined[[adtte_vars$paramcd]])) # Order should not matter.+ plot_r = plot_r |
|
| 303 | +361 |
- })+ ) |
||
| 304 | +362 | |||
| 305 | -+ | |||
| 363 | +! |
- # Start by disabling selection, will be overriden if there are valid choices.+ if (.test) {
|
||
| 306 | +364 | ! |
- session$sendCustomMessage(+ table <- reactive({
|
|
| 307 | +365 | ! |
- "toggle_dropdown",+ plot_type <- input$plot_type |
|
| 308 | +366 | ! |
- list(input_id = session$ns("paramcd"), disabled = TRUE)
+ if (plot_type == "Correlation Heatmap") {
|
|
| 309 | -+ | |||
| 367 | +! |
- )+ object_final() |
||
| 310 | +368 |
-
+ } else {
|
||
| 311 | -+ | |||
| 369 | +! |
- # Once available endpoints change, we update choices (and also the selection+ layer_data(plot_r()) |
||
| 312 | +370 |
- # if nothing was selected earlier) and warn the user if previous endpoint is+ } |
||
| 313 | +371 |
- # not available.+ }) |
||
| 314 | +372 | ! |
- observeEvent(paramcd_choices(), {
+ output$table <- renderPrint(table()) |
|
| 315 | -! | +|||
| 373 | +
- paramcd_choices <- paramcd_choices()+ } |
|||
| 316 | +374 | |||
| 317 | -! | -
- new_selected <- if (is_blank(input$paramcd) || (input$paramcd %in% paramcd_choices)) {
- |
- ||
| 318 | -! | -
- input$paramcd- |
- ||
| 319 | +375 |
- } else {
+ ### REPORTER |
||
| 320 | +376 | ! |
- showNotification(type = "warning", paste(+ if (with_reporter) {
|
|
| 321 | +377 | ! |
- "Endpoint", input$paramcd, "not available in this data subset, please",+ card_fun <- function(comment, label) {
|
|
| 322 | +378 | ! |
- "change filter options or select another endpoint"- |
- |
| 323 | -- |
- ))- |
- ||
| 324 | -- |
- ""- |
- ||
| 325 | -- |
- }+ card <- report_card_template( |
||
| 326 | +379 | ! |
- updateSelectizeInput(+ title = "Quality Control Plot", |
|
| 327 | +380 | ! |
- "paramcd",+ label = label, |
|
| 328 | +381 | ! |
- choices = paramcd_choices,+ description = tools::toTitleCase(input$plot_type), |
|
| 329 | +382 | ! |
- selected = new_selected,+ with_filter = TRUE, |
|
| 330 | +383 | ! |
- session = session+ filter_panel_api = filter_panel_api |
|
| 331 | +384 |
- )+ ) |
||
| 332 | +385 | ! |
- session$sendCustomMessage(+ card$append_text("Selected Options", "header3")
|
|
| 333 | +386 | ! |
- "toggle_dropdown",+ encodings_list <- list( |
|
| 334 | +387 | ! |
- list(input_id = session$ns("paramcd"), disabled = (length(paramcd_choices) == 0))
+ "Experiment:", |
|
| 335 | -+ | |||
| 388 | +! |
- )+ input$`experiment-name`, |
||
| 336 | -+ | |||
| 389 | +! |
- })+ "\nPlot Type:", |
||
| 337 | -+ | |||
| 390 | +! |
-
+ input$plot_type, |
||
| 338 | -+ | |||
| 391 | +! |
- # Subset zooming in on a specified endpoint.+ "\nAssay:", |
||
| 339 | +392 | ! |
- adtte_subset <- reactive({
+ input$`assay-name`, |
|
| 340 | +393 | ! |
- endpoint <- input$paramcd+ "\nShow Gene Filter Settings:", |
|
| 341 | +394 | ! |
- adtte_joined <- adtte_joined()+ input$filter_gene, |
|
| 342 | -+ | |||
| 395 | +! |
-
+ "\nMinimum CPM:", |
||
| 343 | +396 | ! |
- validate(need(+ input$min_cpm, |
|
| 344 | +397 | ! |
- endpoint,+ "\nMinimum CPM Proportion:", |
|
| 345 | +398 | ! |
- "please select an endpoint"+ input$min_cpm_prop, |
|
| 346 | -+ | |||
| 399 | +! |
- ))+ "\nRequired Annotations:", |
||
| 347 | -+ | |||
| 400 | +! |
- # Validate that adtte_data is not empty.+ paste(input$annotate, collapse = ", "), |
||
| 348 | +401 | ! |
- validate(need(+ "\nShow Sample Filter Settings:", |
|
| 349 | +402 | ! |
- nrow(adtte_joined) > 0,+ input$filter_sample, |
|
| 350 | +403 | ! |
- "Joined ADTTE is empty - please relax the filter criteria"+ "\nMinimum Correlation:", |
|
| 351 | -+ | |||
| 404 | +! |
- ))+ input$min_corr, |
||
| 352 | -+ | |||
| 405 | +! |
-
+ "\nMinimum Depth:", |
||
| 353 | +406 | ! |
- subset_rows <- adtte_joined[[adtte_vars$paramcd]] == endpoint+ input$min_depth, |
|
| 354 | +407 | ! |
- result <- adtte_joined[subset_rows, , drop = FALSE]+ "\nMinimum Depth Value:", |
|
| 355 | +408 | ! |
- droplevels(result)+ input$min_depth_continuous |
|
| 356 | +409 |
- })+ ) |
||
| 357 | -+ | |||
| 410 | +! |
-
+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
||
| 358 | +411 | ! |
- binned_adtte_subset <- reactive({
+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 359 | +412 | ! |
- gene_col <- gene_col()+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 360 | +413 | ! |
- probs <- probs()+ paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ |
+ |
| 414 | ++ |
+ } else {
|
||
| 361 | +415 | ! |
- adtte_subset <- adtte_subset()+ paste(encodings_list, collapse = " ") |
|
| 362 | +416 |
-
+ } |
||
| 363 | -! | +|||
| 417 | +
- result <- tryCatch(+ |
|||
| 364 | +418 | ! |
- expr = {
+ card$append_text(final_encodings, style = "verbatim") |
|
| 365 | +419 | ! |
- dplyr::mutate(+ card$append_text("Plot", "header3")
|
|
| 366 | +420 | ! |
- adtte_subset,+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 367 | +421 | ! |
- gene_factor = tern::cut_quantile_bins(+ if (!comment == "") {
|
|
| 368 | +422 | ! |
- adtte_subset[, gene_col],+ card$append_text("Comment", "header3")
|
|
| 369 | +423 | ! |
- probs = probs+ card$append_text(comment) |
|
| 370 | +424 |
- )+ } |
||
| 371 | -+ | |||
| 425 | +! |
- )+ card |
||
| 372 | +426 |
- },+ } |
||
| 373 | +427 | ! |
- error = function(e) {
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 374 | -! | +|||
| 428 | +
- if (grepl("Contains duplicated values", e)) {
+ } |
|||
| 375 | -! | +|||
| 429 | +
- validate(paste(+ ### |
|||
| 376 | -! | +|||
| 430 | +
- "please adjust filters or select (slightly) different quantiles",+ }) |
|||
| 377 | -! | +|||
| 431 | +
- "to avoid duplicate quantiles"+ } |
|||
| 378 | +432 |
- ))+ |
||
| 379 | +433 |
- } else {
+ #' @describeIn tm_g_quality sample module function. |
||
| 380 | -! | +|||
| 434 | +
- stop(e)+ #' @export |
|||
| 381 | +435 |
- }+ #' @examples |
||
| 382 | +436 |
- }+ #' |
||
| 383 | +437 |
- )+ #' # Alternatively you can run the sample module with this function call: |
||
| 384 | -! | +|||
| 438 | +
- result+ #' if (interactive()) {
|
|||
| 385 | +439 |
- })+ #' sample_tm_g_quality() |
||
| 386 | +440 |
-
+ #' } |
||
| 387 | -! | +|||
| 441 | +
- time_unit <- reactive({
+ sample_tm_g_quality <- function(.test = FALSE) {
|
|||
| 388 | +442 | ! |
- adtte_subset <- adtte_subset()+ data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment) |
|
| 389 | +443 | ! |
- result <- unique(as.character(adtte_subset[[adtte_vars$avalu]]))+ app <- teal::init( |
|
| 390 | +444 | ! |
- assert_string(result)+ data = data, |
|
| 391 | +445 | ! |
- result- |
- |
| 392 | -- |
- })- |
- ||
| 393 | -- |
-
+ modules = teal::modules( |
||
| 394 | +446 | ! |
- list(+ tm_g_quality( |
|
| 395 | +447 | ! |
- binned_adtte_subset = binned_adtte_subset,+ label = "quality", |
|
| 396 | +448 | ! |
- gene_col = gene_col,+ mae_name = "MAE", |
|
| 397 | +449 | ! |
- gene_factor = "gene_factor",+ .test = .test |
|
| 398 | -! | +|||
| 450 | +
- time_unit = time_unit+ ) |
|||
| 399 | +451 |
) |
||
| 400 | +452 |
- })+ )+ |
+ ||
| 453 | +! | +
+ shinyApp(app$ui, app$server) |
||
| 401 | +454 |
}@@ -8004,14 +8074,14 @@ teal.modules.hermes coverage - 26.11% |
| 1 |
- #' Teal Module for RNA-seq Boxplot+ #' Teal Module for `Kaplan-Meier` Plot |
||
| 5 |
- #' This module provides an interactive boxplot for RNA-seq gene expression+ #' This teal module produces a grid style `Kaplan-Meier` plot for data with |
||
| 6 |
- #' analysis.+ #' `ADaM` structure. |
||
| 15 |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ #' data <- teal_data() |
||
| 16 |
- #' app <- init(+ #' data <- within(data, {
|
||
| 17 |
- #' data = data,+ #' ADTTE <- teal.modules.hermes::rADTTE %>% |
||
| 18 |
- #' modules = modules(+ #' dplyr::mutate(is_event = .data$CNSR == 0) |
||
| 19 |
- #' tm_g_boxplot(+ #' MAE <- hermes::multi_assay_experiment |
||
| 20 |
- #' label = "boxplot",+ #' }) |
||
| 21 |
- #' mae_name = "MAE"+ #' datanames <- c("ADTTE", "MAE")
|
||
| 22 |
- #' )+ #' datanames(data) <- datanames |
||
| 23 |
- #' )+ #' join_keys(data)["ADTTE", "ADTTE"] <- c("STUDYID", "USUBJID", "PARAMCD")
|
||
| 24 |
- #' )+ #' |
||
| 25 |
- #' if (interactive()) {
+ #' |
||
| 26 |
- #' shinyApp(app$ui, app$server)+ #' modules <- modules( |
||
| 27 |
- #' }+ #' tm_g_km( |
||
| 28 |
- tm_g_boxplot <- function(label,+ #' label = "kaplan-meier", |
||
| 29 |
- mae_name,+ #' adtte_name = "ADTTE", |
||
| 30 |
- exclude_assays = character(),+ #' mae_name = "MAE" |
||
| 31 |
- summary_funs = list(+ #' ) |
||
| 32 |
- None = NULL,+ #' ) |
||
| 33 |
- Mean = colMeans,+ #' |
||
| 34 |
- Median = matrixStats::colMedians,+ #' app <- init( |
||
| 35 |
- Max = matrixStats::colMaxs+ #' data = data, |
||
| 36 |
- ),+ #' modules = modules |
||
| 37 |
- pre_output = NULL,+ #' ) |
||
| 38 |
- post_output = NULL) {
+ #' |
||
| 39 | ++ |
+ #' if (interactive()) {
+ |
+ |
| 40 | ++ |
+ #' shinyApp(ui = app$ui, server = app$server)+ |
+ |
| 41 | ++ |
+ #' }+ |
+ |
| 42 | ++ |
+ tm_g_km <- function(label,+ |
+ |
| 43 | ++ |
+ adtte_name,+ |
+ |
| 44 | ++ |
+ mae_name,+ |
+ |
| 45 | ++ |
+ adtte_vars = list(+ |
+ |
| 46 | ++ |
+ aval = "AVAL",+ |
+ |
| 47 | ++ |
+ is_event = "is_event",+ |
+ |
| 48 | ++ |
+ paramcd = "PARAMCD",+ |
+ |
| 49 | ++ |
+ usubjid = "USUBJID",+ |
+ |
| 50 | ++ |
+ avalu = "AVALU"+ |
+ |
| 51 | ++ |
+ ),+ |
+ |
| 52 | ++ |
+ exclude_assays = "counts",+ |
+ |
| 53 | ++ |
+ summary_funs = list(+ |
+ |
| 54 | ++ |
+ Mean = colMeans,+ |
+ |
| 55 | ++ |
+ Median = matrixStats::colMedians,+ |
+ |
| 56 | ++ |
+ Max = matrixStats::colMaxs+ |
+ |
| 57 | ++ |
+ ),+ |
+ |
| 58 | ++ |
+ pre_output = NULL,+ |
+ |
| 59 | ++ |
+ post_output = NULL,+ |
+ |
| 60 | ++ |
+ .test = FALSE) {
+ |
+ |
| 61 | ! |
- message("Initializing tm_g_boxplot")
+ message("Initializing tm_g_km")
|
|
| 40 | +62 | ! |
assert_string(label) |
| 41 | +63 | +! | +
+ assert_string(adtte_name)+ |
+
| 64 | ! |
assert_string(mae_name) |
|
| 42 | +65 | +! | +
+ assert_adtte_vars(adtte_vars)+ |
+
| 66 | ! |
assert_character(exclude_assays, any.missing = FALSE) |
|
| 43 | +67 | ! |
- assert_summary_funs(summary_funs, null.ok = TRUE)+ assert_summary_funs(summary_funs) |
| 44 | +68 | ! |
assert_tag(pre_output, null.ok = TRUE) |
| 45 | +69 | ! |
assert_tag(post_output, null.ok = TRUE) |
| 46 | +70 | ||
| 47 | +71 | ! |
teal::module( |
| 48 | +72 | ! |
label = label, |
| 49 | +73 | ! |
- server = srv_g_boxplot,+ server = srv_g_km, |
| 50 | +74 | ! |
server_args = list( |
| 51 | +75 | +! | +
+ adtte_name = adtte_name,+ |
+
| 76 | ! |
mae_name = mae_name, |
|
| 52 | +77 | +! | +
+ adtte_vars = adtte_vars,+ |
+
| 78 | +! | +
+ exclude_assays = exclude_assays,+ |
+ |
| 79 | ! |
summary_funs = summary_funs, |
|
| 53 | +80 | ! |
- exclude_assays = exclude_assays+ .test = .test |
| 54 | +81 |
), |
|
| 55 | +82 | ! |
- ui = ui_g_boxplot,+ ui = ui_g_km, |
| 56 | +83 | ! |
ui_args = list( |
| 57 | +84 | +! | +
+ adtte_name = adtte_name,+ |
+
| 85 | ! |
mae_name = mae_name, |
|
| 58 | +86 | ! |
summary_funs = summary_funs, |
| 59 | +87 | ! |
pre_output = pre_output, |
| 60 | +88 | ! |
- post_output = post_output+ post_output = post_output,+ |
+
| 89 | +! | +
+ .test = .test |
|
| 61 | +90 |
), |
|
| 62 | +91 | ! |
- datanames = mae_name+ datanames = c(adtte_name, mae_name) |
| 63 | +92 |
) |
|
| 64 | +93 |
} |
|
| 65 | +94 | ||
| 66 | +95 |
- #' @describeIn tm_g_boxplot sets up the user interface.+ #' @describeIn tm_g_km sets up the user interface. |
|
| 67 | +96 |
#' @inheritParams module_arguments |
|
| 68 | +97 |
#' @export |
|
| 69 | +98 |
- ui_g_boxplot <- function(id,+ ui_g_km <- function(id, |
|
| 70 | +99 |
- mae_name,+ adtte_name, |
|
| 71 | +100 |
- summary_funs,+ mae_name, |
|
| 72 | +101 |
- pre_output,+ summary_funs, |
|
| 73 | +102 | ++ |
+ pre_output,+ |
+
| 103 | ++ |
+ post_output,+ |
+ |
| 104 |
- post_output) {
+ .test = FALSE) {
|
||
| 74 | +105 | 1x |
ns <- NS(id) |
| 75 | +106 | 1x |
teal.widgets::standard_layout( |
| 76 | +107 | 1x |
encoding = tags$div( |
| 77 | +108 |
### Reporter |
|
| 78 | +109 | 1x |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 79 | +110 |
### |
|
| 80 | +111 | 1x |
tags$label("Encodings", class = "text-primary"),
|
| 81 | +112 | 1x |
helpText("Analysis of MAE:", tags$code(mae_name)),
|
| 82 | +113 | +1x | +
+ uiOutput(ns("experiment_ui")),
+ |
+
| 114 | +1x | +
+ assaySpecInput(ns("assay")),
+ |
+ |
| 115 | 1x |
- uiOutput(ns("experiment_ui")),
+ geneSpecInput(ns("genes"), summary_funs),
|
|
| 83 | +116 | 1x |
- assaySpecInput(ns("assay")),
+ helpText("Analysis of ADTTE:", tags$code(adtte_name)),
|
| 84 | +117 | 1x |
- geneSpecInput(ns("genes"), summary_funs),
+ adtteSpecInput(ns("adtte")),
|
| 85 | +118 | 1x |
- tags$label("Jitter"),
+ teal.widgets::panel_group( |
| 86 | +119 | 1x |
- shinyWidgets::switchInput(ns("jitter"), value = FALSE, size = "mini"),
+ teal.widgets::panel_item( |
| 87 | +120 | 1x |
- tags$label("Violin Plot"),
+ input_id = "settings_item", |
| 88 | +121 | 1x |
- shinyWidgets::switchInput(ns("violin"), value = FALSE, size = "mini"),
+ collapsed = TRUE, |
| 89 | +122 | 1x |
- teal.widgets::panel_group(+ title = "Additional Settings", |
| 90 | +123 | 1x |
- teal.widgets::panel_item(+ sampleVarSpecInput(ns("strata"), "Select Strata"),
|
| 91 | +124 | 1x |
- input_id = "settings_item",+ sliderInput( |
| 92 | +125 | 1x |
- collapsed = TRUE,+ ns("percentiles"),
|
| 93 | +126 | 1x |
- title = "Additional Settings",+ "Select quantiles to be displayed", |
| 94 | +127 | 1x |
- sampleVarSpecInput(ns("strat"), "Optional stratifying variable"),
+ min = 0, |
| 95 | +128 | 1x |
- sampleVarSpecInput(ns("color"), "Optional color variable"),
+ max = 1, |
| 96 | +129 | 1x |
- sampleVarSpecInput(ns("facet"), "Optional facet variable")
+ value = c(0, 0.5) |
| 97 | +130 | ++ |
+ )+ |
+
| 131 |
) |
||
| 98 | +132 |
) |
|
| 99 | +133 |
), |
|
| 100 | +134 | 1x |
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ output = div( |
| 101 | +135 | +1x | +
+ if (.test) verbatimTextOutput(ns("table")) else NULL,
+ |
+
| 136 | +1x | +
+ teal.widgets::plot_with_settings_ui(ns("plot"))
+ |
+ |
| 137 | ++ |
+ ),+ |
+ |
| 138 | 1x |
pre_output = pre_output, |
|
| 102 | +139 | 1x |
post_output = post_output |
| 103 | +140 |
) |
|
| 104 | +141 |
} |
|
| 105 | +142 | ||
| 106 | +143 |
- #' @describeIn tm_g_boxplot sets up the server with reactive graph.+ #' @describeIn tm_g_km sets up the user interface. |
|
| 107 | +144 |
#' @inheritParams module_arguments |
|
| 108 | +145 |
#' @export |
|
| 109 | +146 |
- srv_g_boxplot <- function(id,+ srv_g_km <- function(id, |
|
| 110 | +147 |
- data,+ data, |
|
| 111 | +148 |
- filter_panel_api,+ filter_panel_api, |
|
| 112 | +149 |
- reporter,+ reporter, |
|
| 113 | +150 |
- mae_name,+ adtte_name, |
|
| 114 | +151 |
- exclude_assays,+ mae_name, |
|
| 115 | +152 | ++ |
+ adtte_vars,+ |
+
| 153 | ++ |
+ summary_funs,+ |
+ |
| 154 |
- summary_funs) {
+ exclude_assays,+ |
+ ||
| 155 | ++ |
+ .test = FALSE) {
|
|
| 116 | +156 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 117 | +157 | ! |
assert_class(filter_panel_api, "FilterPanelAPI") |
| 118 | +158 | ! |
checkmate::assert_class(data, "reactive") |
| 119 | +159 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 120 | +160 | ||
| 121 | +161 | ! |
moduleServer(id, function(input, output, session) {
|
| 122 | +162 | ! |
output$experiment_ui <- renderUI({
|
| 123 | +163 | ! |
experimentSpecInput(session$ns("experiment"), data, mae_name)
|
| 124 | +164 |
}) |
|
| 125 | +165 | ! |
experiment <- experimentSpecServer( |
| 126 | +166 | ! |
"experiment", |
| 127 | +167 | ! |
data = data, |
| 128 | +168 | ! |
filter_panel_api = filter_panel_api, |
| 129 | +169 | ! |
- mae_name = mae_name+ mae_name = mae_name,+ |
+
| 170 | +! | +
+ sample_vars_as_factors = FALSE # To avoid converting logical `event` to factor. |
|
| 130 | +171 |
) |
|
| 131 | +172 | ! |
assay <- assaySpecServer( |
| 132 | +173 | ! |
"assay", |
| 133 | +174 | ! |
assays = experiment$assays, |
| 134 | +175 | ! |
exclude_assays = exclude_assays |
| 135 | +176 |
) |
|
| 136 | +177 | ! |
- multi <- multiSampleVarSpecServer(+ genes <- geneSpecServer( |
| 137 | +178 | ! |
- inputIds = c("strat", "color", "facet"),
+ "genes", |
| 138 | +179 | ! |
- experiment_name = experiment$name,+ funs = summary_funs, |
| 139 | +180 | ! |
- original_data = experiment$data+ gene_choices = experiment$genes |
| 140 | +181 |
) |
|
| 141 | +182 | ! |
- genes <- geneSpecServer(+ strata <- sampleVarSpecServer( |
| 142 | +183 | ! |
- "genes",+ "strata", |
| 143 | +184 | ! |
- funs = summary_funs,+ experiment_name = experiment$name, |
| 144 | +185 | ! |
- gene_choices = experiment$genes+ original_data = experiment$data |
| 145 | +186 |
) |
|
| 146 | +187 | ! |
- plot_r <- reactive({
+ percentiles_without_borders <- reactive({
+ |
+
| 188 | +! | +
+ percentiles <- input$percentiles |
|
| 147 | +189 |
- # Resolve all reactivity.+ |
|
| 148 | +190 | ! |
- experiment_data <- multi$experiment_data()+ result <- setdiff(percentiles, c(0, 1)) |
| 149 | +191 | ! |
- strat <- multi$vars$strat()+ validate(need( |
| 150 | +192 | ! |
- genes <- genes()+ length(result) > 0, |
| 151 | +193 | ! |
- facet <- multi$vars$facet()+ "Please select at least one quantile other than 0 and 1" |
| 152 | -! | +||
| 194 | +
- color <- multi$vars$color()+ )) |
||
| 153 | +195 | ! |
- assay <- assay()+ result+ |
+
| 196 | ++ |
+ }) |
|
| 154 | +197 | ! |
- jitter <- input$jitter+ adtte <- adtteSpecServer( |
| 155 | +198 | ! |
- violin <- input$violin+ "adtte", |
| 156 | -+ | ||
| 199 | +! |
-
+ data = data, |
|
| 157 | +200 | ! |
- req(+ adtte_name = adtte_name, |
| 158 | +201 | ! |
- assay,+ mae_name = mae_name, |
| 159 | -+ | ||
| 202 | +! |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ adtte_vars = adtte_vars, |
|
| 160 | +203 | ! |
- isTRUE(assay %in% SummarizedExperiment::assayNames(experiment_data)),+ experiment_data = strata$experiment_data, |
| 161 | +204 | ! |
- is.null(facet) || isTRUE(facet %in% names(SummarizedExperiment::colData(experiment_data))),+ experiment_name = experiment$name, |
| 162 | +205 | ! |
- is.null(color) || isTRUE(color %in% names(SummarizedExperiment::colData(experiment_data))),+ assay = assay, |
| 163 | +206 | ! |
- is.null(strat) || isTRUE(strat %in% names(SummarizedExperiment::colData(experiment_data))),+ genes = genes, |
| 164 | +207 | ! |
- cancelOutput = FALSE+ probs = percentiles_without_borders |
| 165 | +208 |
- )+ ) |
|
| 166 | +209 | ||
| 167 | +210 | ! |
- validate_gene_spec(genes, rownames(experiment_data))+ km_data <- reactive({
+ |
+
| 211 | +! | +
+ strata_var <- strata$sample_var()+ |
+ |
| 212 | +! | +
+ binned_adtte <- adtte$binned_adtte_subset() |
|
| 168 | +213 | ||
| 169 | +214 | ! |
- hermes::draw_boxplot(+ variables <- list( |
| 170 | +215 | ! |
- object = experiment_data,+ tte = adtte_vars$aval, |
| 171 | +216 | ! |
- assay_name = assay,+ is_event = adtte_vars$is_event, |
| 172 | +217 | ! |
- genes = genes,+ arm = adtte$gene_factor, |
| 173 | +218 | ! |
- x_var = strat,+ strat = strata_var+ |
+
| 219 | ++ |
+ )+ |
+ |
| 220 | ++ | + | |
| 174 | +221 | ! |
- facet_var = facet,+ list(binned_adtte = binned_adtte, variables = variables)+ |
+
| 222 | ++ |
+ })+ |
+ |
| 223 | ++ | + | |
| 175 | +224 | ! |
- color_var = color,+ km_plot <- reactive({
|
| 176 | +225 | ! |
- jitter = jitter,+ km_data <- km_data()+ |
+
| 226 | ++ | + | |
| 177 | +227 | ! |
- violin = violin+ binned_adtte <- km_data$binned_adtte+ |
+
| 228 | +! | +
+ variables <- km_data$variables+ |
+ |
| 229 | +! | +
+ tern::g_km(binned_adtte, variables = variables, annot_coxph = TRUE) |
|
| 178 | +230 |
- )+ }) |
|
| 179 | +231 |
- })+ |
|
| 180 | +232 | ! |
- output$plot <- renderPlot(plot_r())+ output$km_plot <- renderPlot(km_plot()) |
| 181 | +233 | ||
| 182 | +234 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
| 183 | +235 | ! |
id = "plot", |
| 184 | +236 | ! |
- plot_r = plot_r+ plot_r = km_plot |
| 185 | +237 |
) |
|
| 186 | +238 | ++ | + + | +
| 239 | +! | +
+ if (.test) {
+ |
+ |
| 240 | +! | +
+ output$table <- renderPrint(km_data())+ |
+ |
| 241 | ++ |
+ }+ |
+ |
| 242 | |||
| 187 | +243 |
### REPORTER |
|
| 188 | +244 | ! |
if (with_reporter) {
|
| 189 | +245 | ! |
card_fun <- function(comment, label) {
|
| 190 | +246 | ! |
card <- report_card_template( |
| 191 | +247 | ! |
- title = "Boxplot",+ title = "Kaplan-Meier Plot", |
| 192 | +248 | ! |
label = label, |
| 193 | +249 | ! |
with_filter = TRUE, |
| 194 | +250 | ! |
filter_panel_api = filter_panel_api |
| 195 | +251 |
) |
|
| 196 | +252 | ! |
card$append_text("Selected Options", "header3")
|
| 197 | +253 | ! |
encodings_list <- list( |
| 198 | +254 | ! |
"Experiment:", |
| 199 | +255 | ! |
input$`experiment-name`, |
| 200 | +256 | ! |
"\nAssay:", |
| 201 | +257 | ! |
input$`assay-name`, |
| 202 | -! | -
- "\nFacetting Variable:",- |
- |
| 203 | -! | -
- input$`facet-sample_var`,- |
- |
| 204 | +258 | ! |
"\nGenes Selected:", |
| 205 | +259 | ! |
paste0(genes()$get_gene_labels(), collapse = ", "), |
| 206 | +260 | ! |
"\nGene Summary:", |
| 207 | +261 | ! |
input$`genes-fun_name`, |
| 208 | -! | -
- "\nJitter:",- |
- |
| 209 | -! | -
- input$jitter,- |
- |
| 210 | -! | -
- "\nViolin:",- |
- |
| 211 | -! | -
- input$violin,- |
- |
| 212 | +262 | ! |
- "\nOptional Stratifying Variable:",+ "\nEndpoint:", |
| 213 | +263 | ! |
- input$`strat-sample_var`,+ input$`adtte-paramcd`, |
| 214 | +264 | ! |
- "\nOptional Color Variable:",+ "\nStrata Selected:", |
| 215 | +265 | ! |
- input$`color-sample_var`,+ input$`strata-sample_var`, |
| 216 | +266 | ! |
- "\nOptional Facet Variable:",+ "\nQuantiles Displayed:", |
| 217 | +267 | ! |
- input$`facet-sample_var`+ paste0(input$percentiles, collapse = "-") |
| 218 | +268 |
) |
|
| 219 | +269 | ! |
null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
| 220 | +270 | ! |
final_encodings <- if (length(null_encodings_indices) > 0) {
|
| 221 | +271 | ! |
null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
| 222 | +272 | ! |
paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
| 223 | +273 |
} else {
|
|
| 224 | +274 | ! |
paste(encodings_list, collapse = " ") |
| 225 | +275 |
} |
|
| 226 | +276 | ||
| 227 | +277 | ! |
card$append_text(final_encodings, style = "verbatim") |
| 228 | +278 | ! |
card$append_text("Plot", "header3")
|
| 229 | +279 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ card$append_plot(km_plot(), dim = pws$dim()) |
| 230 | +280 | ! |
if (!comment == "") {
|
| 231 | +281 | ! |
card$append_text("Comment", "header3")
|
| 232 | +282 | ! |
card$append_text(comment) |
| 233 | +283 |
} |
|
| 234 | +284 | ! |
card |
| 235 | +285 |
} |
|
| 236 | +286 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 237 | +287 |
} |
|
| 238 | +288 |
### |
|
| 239 | +289 |
}) |
|
| 240 | +290 |
} |
|
| 241 | +291 | ||
| 242 | +292 |
- #' @describeIn tm_g_boxplot sample module function.+ #' @describeIn tm_g_km sample module function. |
|
| 243 | +293 |
#' @export |
|
| 244 | +294 |
#' @examples |
|
| 245 | +295 |
#' |
|
| 246 | +296 |
#' # Alternatively you can run the sample module with this function call: |
|
| 247 | +297 |
#' if (interactive()) {
|
|
| 248 | +298 |
- #' sample_tm_g_boxplot()+ #' sample_tm_g_km() |
|
| 249 | +299 |
#' } |
|
| 250 | +300 |
- sample_tm_g_boxplot <- function() {
+ sample_tm_g_km <- function(.test = FALSE) { # nolint
|
|
| 251 | +301 | ! |
- data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment)+ data <- teal_data() |
| 252 | +302 | ! |
- app <- teal::init(+ data <- within(data, {
|
| 253 | +303 | ! |
- data = data,+ ADTTE <- teal.modules.hermes::rADTTE %>% # nolint |
| 254 | +304 | ! |
- modules = teal::modules(+ dplyr::mutate(is_event = .data$CNSR == 0) |
| 255 | +305 | ! |
- tm_g_boxplot(+ MAE <- hermes::multi_assay_experiment # nolint+ |
+
| 306 | ++ |
+ }) |
|
| 256 | +307 | ! |
- label = "boxplot",+ datanames <- c("ADTTE", "MAE")
|
| 257 | +308 | +! | +
+ datanames(data) <- datanames+ |
+
| 309 | ! |
- mae_name = "MAE"+ join_keys(data)["ADTTE", "ADTTE"] <- c("STUDYID", "USUBJID", "PARAMCD")
|
|
| 258 | +310 |
- )+ + |
+ |
| 311 | +! | +
+ modules <- teal::modules(+ |
+ |
| 312 | +! | +
+ tm_g_km(+ |
+ |
| 313 | +! | +
+ label = "kaplan-meier",+ |
+ |
| 314 | +! | +
+ adtte_name = "ADTTE",+ |
+ |
| 315 | +! | +
+ mae_name = "MAE",+ |
+ |
| 316 | +! | +
+ .test = .test |
|
| 259 | +317 |
) |
|
| 260 | +318 |
) |
|
| 319 | ++ | + + | +|
| 261 | +320 | ! |
- shinyApp(app$ui, app$server)+ app <- teal::init(+ |
+
| 321 | +! | +
+ data = data,+ |
+ |
| 322 | +! | +
+ modules = modules |
|
| 262 | +323 | ++ |
+ )+ |
+
| 324 | ++ | + + | +|
| 325 | +! | +
+ shinyApp(ui = app$ui, server = app$server)+ |
+ |
| 326 |
}@@ -9844,14 +10362,14 @@ teal.modules.hermes coverage - 26.11% |
| 1 |
- #' Teal Module for `Kaplan-Meier` Plot+ #' Module Input for Sample Variable Specification |
||
| 5 |
- #' This teal module produces a grid style `Kaplan-Meier` plot for data with+ #' This defines the input for the sample variable specification. |
||
| 6 |
- #' `ADaM` structure.+ #' |
||
| 7 |
- #'+ #' @inheritParams module_arguments |
||
| 8 |
- #' @inheritParams module_arguments+ #' @param label_vars (`string`)\cr label for the sample variable selection. |
||
| 9 |
- #'+ #' @param label_levels_button (`string`)\cr label for the levels combination button. |
||
| 10 |
- #' @return Shiny module to be used in the teal app.+ #' |
||
| 11 |
- #'+ #' @return The UI part. |
||
| 12 |
- #' @export+ #' @seealso [sampleVarSpecServer()] for the module server and a complete example. |
||
| 13 |
- #'+ #' @export |
||
| 14 |
- #' @examples+ #' |
||
| 15 |
- #' data <- teal_data()+ #' @examples |
||
| 16 |
- #' data <- within(data, {
+ #' sampleVarSpecInput("my_vars", label_vars = "Select faceting variable")
|
||
| 17 |
- #' ADTTE <- teal.modules.hermes::rADTTE %>%+ sampleVarSpecInput <- function(inputId, # nolint |
||
| 18 |
- #' dplyr::mutate(is_event = .data$CNSR == 0)+ label_vars = "Select sample variable", |
||
| 19 |
- #' MAE <- hermes::multi_assay_experiment+ label_levels_button = "Combine factor levels") {
|
||
| 20 | -+ | 4x |
- #' })+ assert_string(inputId) |
| 21 | -+ | 4x |
- #' datanames <- c("ADTTE", "MAE")
+ assert_string(label_vars) |
| 22 | -+ | 4x |
- #' datanames(data) <- datanames+ assert_string(label_levels_button) |
| 23 |
- #' join_keys(data)["ADTTE", "ADTTE"] <- c("STUDYID", "USUBJID", "PARAMCD")
+
|
||
| 24 | -+ | 4x |
- #'+ ns <- NS(inputId) |
| 25 | -+ | 4x |
- #'+ tagList( |
| 26 | -+ | 4x |
- #' modules <- modules(+ include_css_files(pattern = "*"), |
| 27 | -+ | 4x |
- #' tm_g_km(+ tags$div( |
| 28 | -+ | 4x |
- #' label = "kaplan-meier",+ class = "row", |
| 29 | -+ | 4x |
- #' adtte_name = "ADTTE",+ tags$div( |
| 30 | -+ | 4x |
- #' mae_name = "MAE"+ class = "col-sm-8", |
| 31 | -+ | 4x |
- #' )+ tags$label( |
| 32 | -+ | 4x |
- #' )+ class = "control-label", |
| 33 | -+ | 4x |
- #'+ label_vars |
| 34 |
- #' app <- init(+ ) |
||
| 35 |
- #' data = data,+ ), |
||
| 36 | -+ | 4x |
- #' modules = modules+ tags$div( |
| 37 | -+ | 4x |
- #' )+ class = "col-sm-4", |
| 38 | -+ | 4x |
- #'+ actionButton( |
| 39 | -+ | 4x |
- #' if (interactive()) {
+ ns("levels_button"),
|
| 40 | -+ | 4x |
- #' shinyApp(ui = app$ui, server = app$server)+ tags$span(icon("fas fa-table")),
|
| 41 | -+ | 4x |
- #' }+ title = label_levels_button, |
| 42 | -+ | 4x |
- tm_g_km <- function(label,+ class = "pull-right list-genes" |
| 43 |
- adtte_name,+ ) |
||
| 44 |
- mae_name,+ ) |
||
| 45 |
- adtte_vars = list(+ ), |
||
| 46 | -+ | 4x |
- aval = "AVAL",+ tags$div( |
| 47 | -+ | 4x |
- is_event = "is_event",+ class = "custom-select-input", |
| 48 | -+ | 4x |
- paramcd = "PARAMCD",+ teal.widgets::optionalSelectInput( |
| 49 | -+ | 4x |
- usubjid = "USUBJID",+ ns("sample_var"),
|
| 50 | -+ | 4x |
- avalu = "AVALU"+ label = NULL, |
| 51 | -+ | 4x |
- ),+ choices = "", |
| 52 | -+ | 4x |
- exclude_assays = "counts",+ multiple = FALSE |
| 53 |
- summary_funs = list(+ ) |
||
| 54 |
- Mean = colMeans,+ ) |
||
| 55 |
- Median = matrixStats::colMedians,+ ) |
||
| 56 |
- Max = matrixStats::colMaxs+ } |
||
| 57 |
- ),+ |
||
| 58 |
- pre_output = NULL,+ #' Helper Function For Group List Creation |
||
| 59 |
- post_output = NULL) {
+ #' |
||
| 60 | -! | +
- message("Initializing tm_g_km")
+ #' @description `r lifecycle::badge("experimental")`
|
|
| 61 | -! | +
- assert_string(label)+ #' |
|
| 62 | -! | +
- assert_string(adtte_name)+ #' This helper function takes an assignment list and converts it to a |
|
| 63 | -! | +
- assert_string(mae_name)+ #' group list. |
|
| 64 | -! | +
- assert_adtte_vars(adtte_vars)+ #' |
|
| 65 | -! | +
- assert_character(exclude_assays, any.missing = FALSE)+ #' @param x (named `list` of `character`)\cr input assignment list. |
|
| 66 | -! | +
- assert_summary_funs(summary_funs)+ #' @return A combination list. |
|
| 67 | -! | +
- assert_tag(pre_output, null.ok = TRUE)+ #' |
|
| 68 | -! | +
- assert_tag(post_output, null.ok = TRUE)+ #' @export |
|
| 69 |
-
+ #' |
||
| 70 | -! | +
- teal::module(+ #' @examples |
|
| 71 | -! | +
- label = label,+ #' assign_list <- list( |
|
| 72 | -! | +
- server = srv_g_km,+ #' "ASIAN" = "1", |
|
| 73 | -! | +
- server_args = list(+ #' "BLACK OR AFRICAN AMERICAN" = "1", |
|
| 74 | -! | +
- adtte_name = adtte_name,+ #' "MULTIPLE" = "2", |
|
| 75 | -! | +
- mae_name = mae_name,+ #' "UNKNOWN" = "2", |
|
| 76 | -! | +
- adtte_vars = adtte_vars,+ #' "WHITE" = "4" |
|
| 77 | -! | +
- exclude_assays = exclude_assays,+ #' ) |
|
| 78 | -! | +
- summary_funs = summary_funs+ #' objective_list <- list( |
|
| 79 |
- ),+ #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
|
||
| 80 | -! | +
- ui = ui_g_km,+ #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
|
|
| 81 | -! | +
- ui_args = list(+ #' "WHITE" = "WHITE" |
|
| 82 | -! | +
- adtte_name = adtte_name,+ #' ) |
|
| 83 | -! | +
- mae_name = mae_name,+ #' result_list <- h_assign_to_group_list(assign_list) |
|
| 84 | -! | +
- summary_funs = summary_funs,+ #' stopifnot(identical(result_list, objective_list)) |
|
| 85 | -! | +
- pre_output = pre_output,+ h_assign_to_group_list <- function(x) {
|
|
| 86 | -! | +2x |
- post_output = post_output+ assert_list( |
| 87 | -+ | 2x |
- ),+ x, |
| 88 | -! | +2x |
- datanames = c(adtte_name, mae_name)+ types = "character", |
| 89 | -+ | 2x |
- )+ any.missing = FALSE, |
| 90 | -+ | 2x |
- }+ names = "unique", |
| 91 | -+ | 2x |
-
+ unique = FALSE |
| 92 |
- #' @describeIn tm_g_km sets up the user interface.+ ) |
||
| 93 | -+ | 2x |
- #' @inheritParams module_arguments+ x_vec <- unlist(x) |
| 94 | -+ | 2x |
- #' @export+ x_split <- split(names(x_vec), x_vec) |
| 95 | -+ | 2x |
- ui_g_km <- function(id,+ new_levels <- sapply(x_split, hermes::h_short_list, sep = "/") |
| 96 | -+ | 2x |
- adtte_name,+ stats::setNames(x_split, new_levels) |
| 97 |
- mae_name,+ } |
||
| 98 |
- summary_funs,+ |
||
| 99 |
- pre_output,+ #' Helper Function for Collapsing of Factor Levels |
||
| 100 |
- post_output) {
+ #' |
||
| 101 | -1x | +
- ns <- NS(id)+ #' @description `r lifecycle::badge("experimental")`
|
|
| 102 | -1x | +
- teal.widgets::standard_layout(+ #' |
|
| 103 | -1x | +
- encoding = tags$div(+ #' Given a group list and a factor, this helper function collapses the |
|
| 104 |
- ### Reporter+ #' levels in the factor accordingly and also ensures that the resulting |
||
| 105 | -1x | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' levels are in the order given in the group list. |
|
| 106 |
- ###+ #' |
||
| 107 | -1x | +
- tags$label("Encodings", class = "text-primary"),
+ #' @param x (`factor`)\cr original factor. |
|
| 108 | -1x | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ #' @param group_list (named `list` of `character`)\cr includes the collapsing |
|
| 109 | -1x | +
- uiOutput(ns("experiment_ui")),
+ #' specification. |
|
| 110 | -1x | +
- assaySpecInput(ns("assay")),
+ #' |
|
| 111 | -1x | +
- geneSpecInput(ns("genes"), summary_funs),
+ #' @return The transformed factor `x` with new levels. |
|
| 112 | -1x | +
- helpText("Analysis of ADTTE:", tags$code(adtte_name)),
+ #' @export |
|
| 113 | -1x | +
- adtteSpecInput(ns("adtte")),
+ #' |
|
| 114 | -1x | +
- teal.widgets::panel_group(+ #' @examples |
|
| 115 | -1x | +
- teal.widgets::panel_item(+ #' set.seed(123) |
|
| 116 | -1x | +
- input_id = "settings_item",+ #' x <- factor(sample( |
|
| 117 | -1x | +
- collapsed = TRUE,+ #' c("ASIAN", "BLACK OR AFRICAN AMERICAN", "MULTIPLE", "UNKNOWN", "WHITE"),
|
|
| 118 | -1x | +
- title = "Additional Settings",+ #' size = 30L, |
|
| 119 | -1x | +
- sampleVarSpecInput(ns("strata"), "Select Strata"),
+ #' replace = TRUE |
|
| 120 | -1x | +
- sliderInput(+ #' )) |
|
| 121 | -1x | +
- ns("percentiles"),
+ #' group_list <- list( |
|
| 122 | -1x | +
- "Select quantiles to be displayed",+ #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
|
|
| 123 | -1x | +
- min = 0,+ #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
|
|
| 124 | -1x | +
- max = 1,+ #' "WHITE" = "WHITE" |
|
| 125 | -1x | +
- value = c(0, 0.5)+ #' ) |
|
| 126 |
- )+ #' x_collapsed <- h_collapse_levels(x, group_list) |
||
| 127 |
- )+ #' stopifnot(identical(levels(x_collapsed), names(group_list))) |
||
| 128 |
- )+ h_collapse_levels <- function(x, group_list) {
|
||
| 129 | -+ | 3x |
- ),+ assert_factor(x) |
| 130 | -1x | +2x |
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ assert_list(group_list, names = "unique", types = "character") |
| 131 | 1x |
- pre_output = pre_output,+ x_collapsed <- do.call( |
|
| 132 | 1x |
- post_output = post_output+ forcats::fct_collapse, |
|
| 133 | -+ | 1x |
- )+ args = c( |
| 134 | -+ | 1x |
- }+ list(.f = x), |
| 135 | -+ | 1x |
-
+ group_list |
| 136 |
- #' @describeIn tm_g_km sets up the user interface.+ ) |
||
| 137 |
- #' @inheritParams module_arguments+ ) |
||
| 138 | -+ | 1x |
- #' @export+ factor(x_collapsed, levels = names(group_list)) |
| 139 |
- srv_g_km <- function(id,+ } |
||
| 140 |
- data,+ |
||
| 141 |
- filter_panel_api,+ #' Validation of Number of Levels |
||
| 142 |
- reporter,+ #' |
||
| 143 |
- adtte_name,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 144 |
- mae_name,+ #' |
||
| 145 |
- adtte_vars,+ #' This validation function checks that a given vector `x` is a factor with |
||
| 146 |
- summary_funs,+ #' the specified number of levels. |
||
| 147 |
- exclude_assays) {
+ #' |
||
| 148 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' @param x (`factor`)\cr factor to validate. |
|
| 149 | -! | +
- assert_class(filter_panel_api, "FilterPanelAPI")+ #' @param name (`string`)\cr name of `x` in the app. |
|
| 150 | -! | +
- checkmate::assert_class(data, "reactive")+ #' @param n_levels (`count`)\cr required number of factor levels in `x`. |
|
| 151 | -! | +
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ #' |
|
| 152 |
-
+ #' @export |
||
| 153 | -! | +
- moduleServer(id, function(input, output, session) {
+ validate_n_levels <- function(x, name, n_levels) {
|
|
| 154 | -! | +3x |
- output$experiment_ui <- renderUI({
+ validate(need( |
| 155 | -! | +3x |
- experimentSpecInput(session$ns("experiment"), data, mae_name)
+ is.factor(x), |
| 156 | -+ | 3x |
- })+ paste("Variable", name, "is not a factor but a", class(x))
|
| 157 | -! | +
- experiment <- experimentSpecServer(+ )) |
|
| 158 | -! | +2x |
- "experiment",+ assert_string(name, min.chars = 1L) |
| 159 | -! | +2x |
- data = data,+ assert_count(n_levels, positive = TRUE) |
| 160 | -! | +2x |
- filter_panel_api = filter_panel_api,+ validate(need( |
| 161 | -! | +2x |
- mae_name = mae_name,+ identical(n_levels, nlevels(x)), |
| 162 | -! | +2x |
- sample_vars_as_factors = FALSE # To avoid converting logical `event` to factor.+ paste( |
| 163 | -+ | 2x |
- )+ "Please combine the original levels of", name, |
| 164 | -! | +2x |
- assay <- assaySpecServer(+ "into exactly", n_levels, "levels" |
| 165 | -! | +
- "assay",+ ) |
|
| 166 | -! | +
- assays = experiment$assays,+ )) |
|
| 167 | -! | +
- exclude_assays = exclude_assays+ } |
|
| 168 |
- )+ |
||
| 169 | -! | +
- genes <- geneSpecServer(+ #' Module Server for Sample Variable Specification |
|
| 170 | -! | +
- "genes",+ #' |
|
| 171 | -! | +
- funs = summary_funs,+ #' @description `r lifecycle::badge("experimental")`
|
|
| 172 | -! | +
- gene_choices = experiment$genes+ #' |
|
| 173 |
- )+ #' This defines the server part for the sample variable specification. |
||
| 174 | -! | +
- strata <- sampleVarSpecServer(+ #' |
|
| 175 | -! | +
- "strata",+ #' @inheritParams module_arguments |
|
| 176 | -! | +
- experiment_name = experiment$name,+ #' @param experiment_name (reactive `string`)\cr name of the input experiment. |
|
| 177 | -! | +
- original_data = experiment$data+ #' @param original_data (reactive `SummarizedExperiment`)\cr input experiment where the |
|
| 178 |
- )+ #' sample variables extracted via [SummarizedExperiment::colData()] should be eligible for |
||
| 179 | -! | +
- percentiles_without_borders <- reactive({
+ #' selection. |
|
| 180 | -! | +
- percentiles <- input$percentiles+ #' @param transformed_data (reactive `SummarizedExperiment`)\cr used when multiple sample |
|
| 181 |
-
+ #' variables can be selected in the app. In that case, pass here the pre-transformed data. |
||
| 182 | -! | +
- result <- setdiff(percentiles, c(0, 1))+ #' @param assign_lists (`reactivevalues`)\cr object to share factor level groupings across multiple |
|
| 183 | -! | +
- validate(need(+ #' sample variables. |
|
| 184 | -! | +
- length(result) > 0,+ #' @param num_levels (`count` or `NULL`)\cr required number of levels after combining original levels. |
|
| 185 | -! | +
- "Please select at least one quantile other than 0 and 1"+ #' If `NULL` then all numbers of levels are allowed. |
|
| 186 |
- ))+ #' @param categorical_only (`flag`)\cr whether only categorical variables should be selected |
||
| 187 | -! | +
- result+ #' from. |
|
| 188 |
- })+ #' @param explicit_na (`flag`)\cr whether the `colData` of `original_data` will be transformed with |
||
| 189 | -! | +
- adtte <- adtteSpecServer(+ #' [hermes::h_df_factors_with_explicit_na] before further processing. That means also that |
|
| 190 | -! | +
- "adtte",+ #' `NA` will be made an explicit factor level and counted for `num_levels`. |
|
| 191 | -! | +
- data = data,+ #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input. |
|
| 192 | -! | +
- adtte_name = adtte_name,+ #' |
|
| 193 | -! | +
- mae_name = mae_name,+ #' @return Reactive [`SummarizedExperiment::SummarizedExperiment`] which can be used as |
|
| 194 | -! | +
- adtte_vars = adtte_vars,+ #' input for the relevant `hermes` functions. |
|
| 195 | -! | +
- experiment_data = strata$experiment_data,+ #' @seealso [sampleVarSpecInput()] for the module UI. |
|
| 196 | -! | +
- experiment_name = experiment$name,+ #' |
|
| 197 | -! | +
- assay = assay,+ #' @note Only atomic columns (e.g. not `DataFrame` columns) of the `colData` |
|
| 198 | -! | +
- genes = genes,+ #' which are not completely missing (`NA`) will be shown for selection. |
|
| 199 | -! | +
- probs = percentiles_without_borders+ #' If `num_levels` is specified then only factor columns will be available. |
|
| 200 |
- )+ #' |
||
| 201 |
-
+ #' @export |
||
| 202 | -! | +
- km_plot <- reactive({
+ #' |
|
| 203 | -! | +
- strata_var <- strata$sample_var()+ #' @examples |
|
| 204 | -! | +
- binned_adtte <- adtte$binned_adtte_subset()+ #' ui <- function(id) {
|
|
| 205 |
-
+ #' checkmate::assert_class(data, "teal_data") |
||
| 206 | -! | +
- variables <- list(+ #' ns <- NS(id) |
|
| 207 | -! | +
- tte = adtte_vars$aval,+ #' |
|
| 208 | -! | +
- is_event = adtte_vars$is_event,+ #' teal.widgets::standard_layout( |
|
| 209 | -! | +
- arm = adtte$gene_factor,+ #' encoding = uiOutput(ns("encoding_ui")),
|
|
| 210 | -! | +
- strat = strata_var+ #' output = plotOutput(ns("plot"))
|
|
| 211 |
- )+ #' ) |
||
| 212 | -! | +
- tern::g_km(binned_adtte, variables = variables, annot_coxph = TRUE)+ #' } |
|
| 213 |
- })+ #' server <- function(id, |
||
| 214 |
-
+ #' data) {
|
||
| 215 | -! | +
- output$km_plot <- renderPlot(km_plot())+ #' checkmate::assert_class(data, "reactive") |
|
| 216 |
-
+ #' checkmate::assert_class(shiny::isolate(data()), "teal_data") |
||
| 217 | -! | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' moduleServer(id, function(input, output, session) {
|
|
| 218 | -! | +
- id = "plot",+ #' output$encoding_ui <- renderUI({
|
|
| 219 | -! | +
- plot_r = km_plot+ #' mae <- data()[["MAE"]] |
|
| 220 |
- )+ #' experiment_name_choices <- names(mae) |
||
| 221 |
-
+ #' tags$div( |
||
| 222 |
- ### REPORTER+ #' selectInput(session$ns("experiment_name"), "Select experiment", experiment_name_choices),
|
||
| 223 | -! | +
- if (with_reporter) {
+ #' sampleVarSpecInput(session$ns("facet_var"), "Select faceting variable")
|
|
| 224 | -! | +
- card_fun <- function(comment, label) {
+ #' ) |
|
| 225 | -! | +
- card <- report_card_template(+ #' }) |
|
| 226 | -! | +
- title = "Kaplan-Meier Plot",+ #' experiment_data <- reactive({
|
|
| 227 | -! | +
- label = label,+ #' req(input$experiment_name) |
|
| 228 | -! | +
- with_filter = TRUE,+ #' mae <- data()[["MAE"]] |
|
| 229 | -! | +
- filter_panel_api = filter_panel_api+ #' object <- mae[[input$experiment_name]] |
|
| 230 |
- )+ #' SummarizedExperiment::colData(object) <- |
||
| 231 | -! | +
- card$append_text("Selected Options", "header3")
+ #' hermes::df_cols_to_factor(SummarizedExperiment::colData(object)) |
|
| 232 | -! | +
- encodings_list <- list(+ #' object |
|
| 233 | -! | +
- "Experiment:",+ #' }) |
|
| 234 | -! | +
- input$`experiment-name`,+ #' facet_var_spec <- sampleVarSpecServer( |
|
| 235 | -! | +
- "\nAssay:",+ #' "facet_var", |
|
| 236 | -! | +
- input$`assay-name`,+ #' experiment_name = reactive({
|
|
| 237 | -! | +
- "\nGenes Selected:",+ #' input$experiment_name |
|
| 238 | -! | +
- paste0(genes()$get_gene_labels(), collapse = ", "),+ #' }), |
|
| 239 | -! | +
- "\nGene Summary:",+ #' original_data = experiment_data |
|
| 240 | -! | +
- input$`genes-fun_name`,+ #' ) |
|
| 241 | -! | +
- "\nEndpoint:",+ #' output$plot <- renderPlot({
|
|
| 242 | -! | +
- input$`adtte-paramcd`,+ #' experiment_data_final <- facet_var_spec$experiment_data() |
|
| 243 | -! | +
- "\nStrata Selected:",+ #' facet_var <- facet_var_spec$sample_var() |
|
| 244 | -! | +
- input$`strata-sample_var`,+ #' hermes::draw_boxplot( |
|
| 245 | -! | +
- "\nQuantiles Displayed:",+ #' experiment_data_final, |
|
| 246 | -! | +
- paste0(input$percentiles, collapse = "-")+ #' assay_name = "counts", |
|
| 247 |
- )+ #' genes = hermes::gene_spec(hermes::genes(experiment_data_final)[1]), |
||
| 248 | -! | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ #' facet_var = facet_var |
|
| 249 | -! | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ #' ) |
|
| 250 | -! | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ #' }) |
|
| 251 | -! | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ #' }) |
|
| 252 |
- } else {
+ #' } |
||
| 253 | -! | +
- paste(encodings_list, collapse = " ")+ #' my_app <- function() {
|
|
| 254 |
- }+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 255 |
-
+ #' app <- init( |
||
| 256 | -! | +
- card$append_text(final_encodings, style = "verbatim")+ #' data = data, |
|
| 257 | -! | +
- card$append_text("Plot", "header3")
+ #' modules = modules( |
|
| 258 | -! | +
- card$append_plot(km_plot(), dim = pws$dim())+ #' module( |
|
| 259 | -! | +
- if (!comment == "") {
+ #' label = "sampleVarSpec example", |
|
| 260 | -! | +
- card$append_text("Comment", "header3")
+ #' server = server, |
|
| 261 | -! | +
- card$append_text(comment)+ #' ui = ui, |
|
| 262 |
- }+ #' datanames = "all" |
||
| 263 | -! | +
- card+ #' ) |
|
| 264 |
- }+ #' ) |
||
| 265 | -! | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' ) |
|
| 266 |
- }+ #' shinyApp(app$ui, app$server) |
||
| 267 |
- ###+ #' } |
||
| 268 |
- })+ #' if (interactive()) {
|
||
| 269 |
- }+ #' my_app() |
||
| 270 |
-
+ #' } |
||
| 271 |
- #' @describeIn tm_g_km sample module function.+ sampleVarSpecServer <- function(id, # nolint |
||
| 272 |
- #' @export+ experiment_name, |
||
| 273 |
- #' @examples+ original_data, |
||
| 274 |
- #'+ transformed_data = original_data, |
||
| 275 |
- #' # Alternatively you can run the sample module with this function call:+ assign_lists = reactiveValues(), |
||
| 276 |
- #' if (interactive()) {
+ num_levels = NULL, |
||
| 277 |
- #' sample_tm_g_km()+ categorical_only = !is.null(num_levels), |
||
| 278 |
- #' }+ explicit_na = FALSE, |
||
| 279 |
- sample_tm_g_km <- function() { # nolint
+ label_modal_title = "Please click to group the original factor levels") {
|
||
| 280 | -! | +2x |
- data <- teal_data()+ assert_string(id) |
| 281 | -! | +2x |
- data <- within(data, {
+ assert_reactive(experiment_name) |
| 282 | -! | +2x |
- ADTTE <- teal.modules.hermes::rADTTE %>% # nolint+ assert_reactive(original_data) |
| 283 | -! | +2x |
- dplyr::mutate(is_event = .data$CNSR == 0)+ assert_reactive(transformed_data) |
| 284 | -! | +2x |
- MAE <- hermes::multi_assay_experiment # nolint+ assert_class(assign_lists, "reactivevalues") |
| 285 | -+ | 2x |
- })+ assert_count(num_levels, null.ok = TRUE, positive = TRUE) |
| 286 | -! | +2x |
- datanames <- c("ADTTE", "MAE")
+ assert_flag(categorical_only) |
| 287 | -! | +2x |
- datanames(data) <- datanames+ assert_flag(explicit_na) |
| 288 | -! | +2x |
- join_keys(data)["ADTTE", "ADTTE"] <- c("STUDYID", "USUBJID", "PARAMCD")
+ assert_string(label_modal_title) |
| 290 | -! | +2x |
- modules <- teal::modules(+ moduleServer(id, function(input, output, session) {
|
| 291 | -! | +2x |
- tm_g_km(+ to_observe <- reactive({
|
| 292 | -! | +2x |
- label = "kaplan-meier",+ list(experiment_name(), original_data()) |
| 293 | -! | +
- adtte_name = "ADTTE",+ }) |
|
| 294 | -! | +
- mae_name = "MAE"+ |
|
| 295 | -+ | 2x |
- )+ start_col_data <- eventReactive(to_observe(), {
|
| 296 | -+ | 2x |
- )+ object <- original_data() |
| 297 | -+ | 2x |
-
+ col_data <- SummarizedExperiment::colData(object) |
| 298 | -! | +2x |
- app <- teal::init(+ if (explicit_na) {
|
| 299 | ! |
- data = data,+ hermes::df_cols_to_factor(col_data) |
|
| 300 | -! | +
- modules = modules+ } else {
|
|
| 301 | -+ | 2x |
- )+ col_data |
| 302 |
-
+ } |
||
| 303 | -! | +
- shinyApp(ui = app$ui, server = app$server)+ }) |
|
| 304 |
- }+ |
| 1 | +305 |
- #' Teal Module for RNA-seq Barplot+ # The colData variables to choose the sample variable from. |
|
| 2 | -+ | ||
| 306 | +2x |
- #'+ col_data_vars <- reactive({
+ |
+ |
| 307 | +2x | +
+ col_data <- start_col_data()+ |
+ |
| 308 | +2x | +
+ can_be_used <- vapply(col_data, FUN = function(x) is.atomic(x) && !allMissing(x), FUN.VALUE = logical(1))+ |
+ |
| 309 | +2x | +
+ if (categorical_only) {
+ |
+ |
| 310 | +1x | +
+ col_is_factor <- vapply(col_data, FUN = is.factor, FUN.VALUE = logical(1))+ |
+ |
| 311 | +1x | +
+ can_be_used <- can_be_used & col_is_factor |
|
| 3 | +312 |
- #' @description `r lifecycle::badge("experimental")`
+ }+ |
+ |
| 313 | +2x | +
+ names(col_data)[can_be_used] |
|
| 4 | +314 |
- #'+ }) |
|
| 5 | +315 |
- #' This module provides an interactive barplot for RNA-seq gene expression+ |
|
| 6 | +316 |
- #' analysis.+ # When the colData variables change, update the choices for sample_var.+ |
+ |
| 317 | +2x | +
+ observeEvent(col_data_vars(), {
+ |
+ |
| 318 | +! | +
+ col_data_vars <- col_data_vars() |
|
| 7 | +319 |
- #'+ + |
+ |
| 320 | +! | +
+ sel <- intersect(input$sample_var, col_data_vars) |
|
| 8 | +321 |
- #' @inheritParams module_arguments+ + |
+ |
| 322 | +! | +
+ teal.widgets::updateOptionalSelectInput(+ |
+ |
| 323 | +! | +
+ session,+ |
+ |
| 324 | +! | +
+ "sample_var",+ |
+ |
| 325 | +! | +
+ choices = col_data_vars,+ |
+ |
| 326 | +! | +
+ selected = sel |
|
| 9 | +327 |
- #'+ ) |
|
| 10 | +328 |
- #' @return Shiny module to be used in the teal app.+ }) |
|
| 11 | +329 |
- #'+ |
|
| 12 | +330 |
- #' @export+ # Reactive for the current combination. Takes the assignment list if available |
|
| 13 | +331 |
- #'+ # and converts to combination list.+ |
+ |
| 332 | +2x | +
+ current_combination <- reactive({
+ |
+ |
| 333 | +! | +
+ experiment_name <- experiment_name()+ |
+ |
| 334 | +! | +
+ sample_var <- input$sample_var+ |
+ |
| 335 | +! | +
+ req(experiment_name) |
|
| 14 | +336 |
- #' @examples+ + |
+ |
| 337 | +! | +
+ if (!is.null(sample_var)) {
+ |
+ |
| 338 | +! | +
+ assign_list <- assign_lists[[experiment_name]][[sample_var]]+ |
+ |
| 339 | +! | +
+ if (!is.null(assign_list)) {
+ |
+ |
| 340 | +! | +
+ h_assign_to_group_list(assign_list) |
|
| 15 | +341 |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ } else {
+ |
+ |
| 342 | +! | +
+ NULL |
|
| 16 | +343 |
- #' app <- init(+ } |
|
| 17 | +344 |
- #' data = data,+ } |
|
| 18 | +345 |
- #' modules = modules(+ }) |
|
| 19 | +346 |
- #' tm_g_barplot(+ |
|
| 20 | +347 |
- #' label = "barplot",+ # Here we produce the final object by checking |
|
| 21 | +348 |
- #' mae_name = "MAE"+ # if we should combine for this sample var.+ |
+ |
| 349 | +2x | +
+ final_data <- reactive({
+ |
+ |
| 350 | +! | +
+ sample_var <- input$sample_var+ |
+ |
| 351 | +! | +
+ original_data <- original_data()+ |
+ |
| 352 | +! | +
+ start_col_data <- start_col_data()+ |
+ |
| 353 | +! | +
+ transformed_data <- transformed_data()+ |
+ |
| 354 | +! | +
+ current_combination <- current_combination() |
|
| 22 | +355 |
- #' )+ + |
+ |
| 356 | +! | +
+ if (!is.null(sample_var)) {
+ |
+ |
| 357 | +! | +
+ sample_var_vector <- start_col_data[[sample_var]]+ |
+ |
| 358 | +! | +
+ if (!is.null(current_combination)) {
+ |
+ |
| 359 | +! | +
+ sample_var_vector <- h_collapse_levels( |
|
| 23 | -+ | ||
| 360 | +! |
- #' )+ sample_var_vector, |
|
| 24 | -+ | ||
| 361 | +! |
- #' )+ current_combination |
|
| 25 | +362 |
- #' if (interactive()) {
+ ) |
|
| 26 | +363 |
- #' shinyApp(app$ui, app$server)+ } |
|
| 27 | -+ | ||
| 364 | +! |
- #' }+ if (!is.null(num_levels)) {
|
|
| 28 | -+ | ||
| 365 | +! |
- tm_g_barplot <- function(label,+ validate_n_levels(sample_var_vector, sample_var, num_levels) |
|
| 29 | +366 |
- mae_name,+ } |
|
| 30 | -+ | ||
| 367 | +! |
- exclude_assays = character(),+ SummarizedExperiment::colData(transformed_data)[[sample_var]] <- sample_var_vector |
|
| 31 | +368 |
- summary_funs = list(+ } |
|
| 32 | +369 |
- Mean = colMeans,+ |
|
| 33 | -+ | ||
| 370 | +! |
- Median = matrixStats::colMedians,+ transformed_data |
|
| 34 | +371 |
- Max = matrixStats::colMaxs+ }) |
|
| 35 | +372 |
- ),+ |
|
| 36 | +373 |
- pre_output = NULL,+ # Function to return the UI for a modal dialog with matrix input for combination |
|
| 37 | +374 |
- post_output = NULL) {
+ # assignment. |
|
| 38 | -! | +||
| 375 | +2x |
- message("Initializing tm_g_barplot")
+ combModal <- function(sample_var_levels, # nolint |
|
| 39 | -! | +||
| 376 | +2x |
- assert_string(label)+ n_max_groups, |
|
| 40 | -! | +||
| 377 | +2x |
- assert_string(mae_name)+ selected_groups) {
|
|
| 41 | +378 | ! |
- assert_character(exclude_assays)+ if (is.null(selected_groups)) {
|
| 42 | +379 | ! |
- assert_summary_funs(summary_funs)+ selected_groups <- pmin( |
| 43 | +380 | ! |
- assert_tag(pre_output, null.ok = TRUE)+ seq_along(sample_var_levels), |
| 44 | +381 | ! |
- assert_tag(post_output, null.ok = TRUE)+ n_max_groups |
| 45 | +382 |
-
+ ) |
|
| 46 | -! | +||
| 383 | +
- module(+ } |
||
| 47 | +384 | ! |
- label = label,+ modalDialog( |
| 48 | +385 | ! |
- server = srv_g_barplot,+ shinyRadioMatrix::radioMatrixInput( |
| 49 | +386 | ! |
- server_args = list(+ session$ns("comb_assignment"),
|
| 50 | +387 | ! |
- mae_name = mae_name,+ rowIDs = sample_var_levels, |
| 51 | +388 | ! |
- exclude_assays = exclude_assays,+ rowIDsName = "Original levels", |
| 52 | +389 | ! |
- summary_funs = summary_funs+ rowLLabels = rep("", length = length(sample_var_levels)),
|
| 53 | -+ | ||
| 390 | +! |
- ),+ choices = seq_len(n_max_groups), |
|
| 54 | +391 | ! |
- ui = ui_g_barplot,+ selected = selected_groups |
| 55 | -! | +||
| 392 | +
- ui_args = list(+ ), |
||
| 56 | +393 | ! |
- mae_name = mae_name,+ tags$span(label_modal_title), |
| 57 | +394 | ! |
- summary_funs = summary_funs,+ footer = tagList( |
| 58 | +395 | ! |
- pre_output = pre_output,+ modalButton("Cancel"),
|
| 59 | +396 | ! |
- post_output = post_output+ actionButton(session$ns("ok"), "OK")
|
| 60 | +397 |
- ),+ ), |
|
| 61 | +398 | ! |
- datanames = mae_name+ include_js_files("checkbox.js")
|
| 62 | +399 |
- )+ ) |
|
| 63 | +400 |
- }+ } |
|
| 64 | +401 | ||
| 65 | -- |
- #' @describeIn tm_g_barplot sets up the user interface.- |
- |
| 66 | -- |
- #' @inheritParams module_arguments- |
- |
| 67 | -- |
- #' @export- |
- |
| 68 | -- |
- ui_g_barplot <- function(id,- |
- |
| 69 | -- |
- mae_name,- |
- |
| 70 | +402 |
- summary_funs,+ # Show modal when button is clicked and the current variable is a factor variable. |
|
| 71 | -+ | ||
| 403 | +2x |
- pre_output,+ observeEvent(input$levels_button, {
|
|
| 72 | -+ | ||
| 404 | +! |
- post_output) {
+ sample_var <- input$sample_var |
|
| 73 | -1x | +||
| 405 | +! |
- ns <- NS(id)+ original_data <- original_data() |
|
| 74 | -1x | +||
| 406 | +! |
- teal.widgets::standard_layout(+ start_col_data <- start_col_data() |
|
| 75 | -1x | +||
| 407 | +! |
- encoding = tags$div(+ experiment_name <- experiment_name() |
|
| 76 | +408 |
- ### Reporter+ |
|
| 77 | -1x | +||
| 409 | +! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ req(experiment_name) |
|
| 78 | +410 |
- ###- |
- |
| 79 | -1x | -
- tags$label("Encodings", class = "text-primary"),
- |
- |
| 80 | -1x | -
- helpText("Analysis of MAE:", tags$code(mae_name)),
- |
- |
| 81 | -1x | -
- uiOutput(ns("experiment_ui")),
- |
- |
| 82 | -1x | -
- assaySpecInput(ns("assay")),
- |
- |
| 83 | -1x | -
- sampleVarSpecInput(ns("facet"), "Select Facet Variable"),
- |
- |
| 84 | -1x | -
- geneSpecInput(ns("x"), summary_funs),
- |
- |
| 85 | -1x | -
- sliderInput(- |
- |
| 86 | -1x | -
- ns("percentiles"),
- |
- |
| 87 | -1x | -
- "Select Quantiles",- |
- |
| 88 | -1x | -
- min = 0,+ |
|
| 89 | -1x | +||
| 411 | +! |
- max = 1,+ if (!is.null(sample_var)) {
|
|
| 90 | -1x | +||
| 412 | +! |
- value = c(0.2, 0.8)+ current_sample_var <- start_col_data[[sample_var]] |
|
| 91 | +413 |
- ),- |
- |
| 92 | -1x | -
- teal.widgets::panel_group(+ |
|
| 93 | -1x | +||
| 414 | +! |
- teal.widgets::panel_item(+ if (is.factor(current_sample_var)) {
|
|
| 94 | -1x | +||
| 415 | +! |
- input_id = "settings_item",+ sample_var_levels <- levels(current_sample_var) |
|
| 95 | -1x | +||
| 416 | +
- collapsed = TRUE,+ |
||
| 96 | -1x | +||
| 417 | +
- title = "Additional Settings",+ # Note: here we make sure we load with previous choice so the user |
||
| 97 | -1x | +||
| 418 | +
- sampleVarSpecInput(+ # does not constantly need to start from scratch again. |
||
| 98 | -1x | +||
| 419 | +
- ns("fill"),
+ # although we do not do this if the levels do not match (i.e. if |
||
| 99 | -1x | +||
| 420 | +
- label_vars = "Optional Fill Variable"+ # some levels have been filtered out) |
||
| 100 | +421 |
- )+ |
|
| 101 | -+ | ||
| 422 | +! |
- )+ selected_groups <- NULL |
|
| 102 | +423 |
- )+ |
|
| 103 | -+ | ||
| 424 | +! |
- ),+ old_values <- names(assign_lists[[experiment_name]][[sample_var]]) |
|
| 104 | -1x | +||
| 425 | +! |
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ if (!is.null(old_values) && |
|
| 105 | -1x | +||
| 426 | +! |
- pre_output = pre_output,+ length(old_values) == length(sample_var_levels) && # nolint |
|
| 106 | -1x | +||
| 427 | +! |
- post_output = post_output+ all(sort(old_values) == sort(sample_var_levels))) { # nolint
|
|
| 107 | -+ | ||
| 428 | +! |
- )+ selected_groups <- assign_lists[[experiment_name]][[sample_var]] # nolint |
|
| 108 | +429 |
- }+ } |
|
| 109 | +430 | ||
| 110 | -+ | ||
| 431 | +! |
- #' @describeIn tm_g_barplot sets up the server with reactive graph.+ showModal(combModal( |
|
| 111 | -+ | ||
| 432 | +! |
- #' @inheritParams module_arguments+ sample_var_levels = sample_var_levels, |
|
| 112 | -+ | ||
| 433 | +! |
- #' @export+ n_max_groups = `if`(!is.null(num_levels), num_levels, length(sample_var_levels)), |
|
| 113 | -+ | ||
| 434 | +! |
- srv_g_barplot <- function(id,+ selected_groups = selected_groups |
|
| 114 | +435 |
- data,+ )) |
|
| 115 | +436 |
- filter_panel_api,+ } else {
+ |
+ |
| 437 | +! | +
+ showNotification("Can only group levels for factor variables", type = "message")
|
|
| 116 | +438 |
- reporter,+ } |
|
| 117 | +439 |
- mae_name,+ } |
|
| 118 | +440 |
- exclude_assays,+ }) |
|
| 119 | +441 |
- summary_funs) {
+
|
|
| 120 | -! | +||
| 442 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ # When OK button is pressed, save the settings, and remove the modal. |
||
| 121 | -! | +||
| 443 | +2x |
- assert_class(filter_panel_api, "FilterPanelAPI")+ observeEvent(input$ok, {
|
|
| 122 | +444 | ! |
- checkmate::assert_class(data, "reactive")+ experiment_name <- experiment_name() |
| 123 | +445 | ! |
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ sample_var <- input$sample_var |
| 124 | +446 | ! |
- moduleServer(id, function(input, output, session) {
+ comb_assignment <- input$comb_assignment |
| 125 | -! | +||
| 447 | +
- output$experiment_ui <- renderUI({
+
|
||
| 126 | +448 | ! |
- experimentSpecInput(session$ns("experiment"), data, mae_name)
+ req(experiment_name, sample_var, comb_assignment) |
| 127 | +449 |
- })- |
- |
| 128 | -! | -
- experiment <- experimentSpecServer(+ |
|
| 129 | +450 | ! |
- "experiment",+ if (!is.null(num_levels) && !identical(length(unique(unlist(comb_assignment))), num_levels)) {
|
| 130 | +451 | ! |
- data = data,+ showNotification( |
| 131 | +452 | ! |
- filter_panel_api = filter_panel_api,+ paste("Please group the original levels into exactly", num_levels, "levels"),
|
| 132 | +453 | ! |
- mae_name = mae_name+ type = "error" |
| 133 | +454 |
- )- |
- |
| 134 | -! | -
- assay <- assaySpecServer(+ ) |
|
| 135 | -! | +||
| 455 | +
- "assay",+ } else {
|
||
| 136 | +456 | ! |
- assays = experiment$assays,+ assign_lists[[experiment_name]][[sample_var]] <- comb_assignment |
| 137 | +457 | ! |
- exclude_assays = exclude_assays+ removeModal() |
| 138 | +458 |
- )- |
- |
| 139 | -! | -
- multi <- multiSampleVarSpecServer(- |
- |
| 140 | -! | -
- c("facet", "fill"),
+ } |
|
| 141 | -! | +||
| 459 | +
- experiment_name = experiment$name,+ }) |
||
| 142 | -! | +||
| 460 | +
- original_data = experiment$data+ |
||
| 143 | +461 |
- )+ # Return both the reactives with the experiment data as well as the sample variable. |
|
| 144 | -! | +||
| 462 | +2x |
- x <- geneSpecServer(+ list( |
|
| 145 | -! | +||
| 463 | +2x |
- "x",+ experiment_data = final_data, |
|
| 146 | -! | +||
| 464 | +2x |
- funs = summary_funs,+ sample_var = reactive({
|
|
| 147 | +465 | ! |
- gene_choices = experiment$genes+ input$sample_var |
| 148 | +466 |
- )+ }) |
|
| 149 | +467 | - - | -|
| 150 | -! | -
- plot_r <- reactive({
+ ) |
|
| 151 | +468 |
- # Resolve all reactivity.+ }) |
|
| 152 | -! | +||
| 469 | +
- experiment_data <- multi$experiment_data()+ } |
||
| 153 | -! | +||
| 470 | +
- facet_var <- multi$vars$facet()+ |
||
| 154 | -! | +||
| 471 | +
- fill_var <- multi$vars$fill()+ #' Module Server for Specification of Multiple Sample Variables |
||
| 155 | -! | +||
| 472 | +
- percentiles <- input$percentiles+ #' |
||
| 156 | -! | +||
| 473 | +
- assay <- assay()+ #' @description `r lifecycle::badge("experimental")`
|
||
| 157 | -! | +||
| 474 | +
- x <- x()+ #' |
||
| 158 | +475 |
-
+ #' When multiple sample variables are used in a given module, then this |
|
| 159 | +476 |
- # Require which states need to be truthy.+ #' wrapper makes it much easier to specify in the server function. |
|
| 160 | -! | +||
| 477 | +
- req(+ #' |
||
| 161 | -! | +||
| 478 | +
- assay,+ #' @param inputIds (`character`)\cr multiple input IDs corresponding to the |
||
| 162 | +479 |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ #' different sample variables specified in the UI function. |
|
| 163 | -! | +||
| 480 | +
- isTRUE(assay %in% SummarizedExperiment::assayNames(experiment_data)),+ #' @inheritParams sampleVarSpecServer |
||
| 164 | -! | +||
| 481 | +
- isTRUE(all(c(facet_var, fill_var) %in% names(SummarizedExperiment::colData(experiment_data)))),+ #' @param ... additional arguments as documented in [sampleVarSpecServer()], |
||
| 165 | -! | +||
| 482 | +
- cancelOutput = FALSE+ #' namely the mandatory `experiment_name` and the optional `categorical_only`, |
||
| 166 | +483 |
- )+ #' `num_levels` and `label_modal_title`. |
|
| 167 | +484 |
-
+ #' `transformed_data` and `assign_lists` should not be |
|
| 168 | +485 |
- # Validate and give useful messages to the user. Note: no need to duplicate here req() from above.+ #' specified as they are already specified internally here. |
|
| 169 | -! | +||
| 486 | +
- validate(need(+ #' |
||
| 170 | -! | +||
| 487 | +
- percentiles[1] != percentiles[2],+ #' @return List with the final transformed `experiment_data` reactive and a |
||
| 171 | -! | +||
| 488 | +
- "please select two different quantiles - if you want only 2 groups, choose one quantile as 0 or 1"+ #' list `vars` which contains the selected sample variables as reactives |
||
| 172 | +489 |
- ))+ #' under their input ID. |
|
| 173 | -! | +||
| 490 | +
- validate_gene_spec(x, rownames(experiment_data))+ #' |
||
| 174 | +491 |
-
+ #' @export |
|
| 175 | -! | +||
| 492 | +
- hermes::draw_barplot(+ #' @examples |
||
| 176 | -! | +||
| 493 | +
- object = experiment_data,+ #' \dontrun{
|
||
| 177 | -! | +||
| 494 | +
- assay_name = assay,+ #' # In the server use: |
||
| 178 | -! | +||
| 495 | +
- x_spec = x,+ #' sample_var_specs <- multiSampleVarSpecServer( |
||
| 179 | -! | +||
| 496 | +
- facet_var = facet_var,+ #' inputIds = c("facet_var", "color_var"),
|
||
| 180 | -! | +||
| 497 | +
- fill_var = fill_var,+ #' experiment_name = reactive({
|
||
| 181 | -! | +||
| 498 | +
- percentiles = percentiles+ #' input$experiment_name |
||
| 182 | +499 |
- )+ #' }), |
|
| 183 | +500 |
- })+ #' original_data = ori_data # nolint Please update the <ori_data> |
|
| 184 | +501 |
-
+ #' ) |
|
| 185 | -! | +||
| 502 | +
- output$plot <- renderPlot(plot_r())+ #' # Then can extract the transformed data and selected variables later: |
||
| 186 | +503 |
-
+ #' experiment_data <- sample_var_specs$experiment_data() |
|
| 187 | -! | +||
| 504 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' facet_var <- sample_var_specs$vars$facet_var() |
||
| 188 | -! | +||
| 505 | +
- id = "plot",+ #' color_var <- sample_var_specs$vars$color_var() |
||
| 189 | -! | +||
| 506 | +
- plot_r = plot_r+ #' } |
||
| 190 | +507 |
- )+ multiSampleVarSpecServer <- function(inputIds, # nolint |
|
| 191 | +508 |
-
+ original_data, |
|
| 192 | +509 |
- ### REPORTER+ ...) {
|
|
| 193 | +510 | ! |
- if (with_reporter) {
+ assert_character(inputIds, any.missing = FALSE, unique = TRUE) |
| 194 | +511 | ! |
- card_fun <- function(comment, label) {
+ assign_lists <- reactiveValues() |
| 195 | +512 | ! |
- card <- report_card_template(+ spec_list <- list() |
| 196 | +513 | ! |
- title = "Barplot",+ transformed_data <- original_data |
| 197 | +514 | ! |
- label = label,+ for (id in inputIds) {
|
| 198 | +515 | ! |
- with_filter = TRUE,+ spec_list[[id]] <- sampleVarSpecServer( |
| 199 | +516 | ! |
- filter_panel_api = filter_panel_api- |
-
| 200 | -- |
- )+ id, |
|
| 201 | +517 | ! |
- card$append_text("Selected Options", "header3")
+ original_data = original_data, |
| 202 | +518 | ! |
- encodings_list <- list(+ transformed_data = transformed_data, |
| 203 | +519 | ! |
- "Experiment:",+ assign_lists = assign_lists, |
| 204 | -! | +||
| 520 | +
- input$`experiment-name`,+ ... |
||
| 205 | -! | +||
| 521 | +
- "\nAssay:",+ ) |
||
| 206 | +522 | ! |
- input$`assay-name`,+ transformed_data <- spec_list[[id]]$experiment_data |
| 207 | -! | +||
| 523 | +
- "\nFacetting Variable:",+ } |
||
| 208 | +524 | ! |
- input$`facet-sample_var`,+ list( |
| 209 | +525 | ! |
- "\nGenes Selected:",+ experiment_data = transformed_data, |
| 210 | +526 | ! |
- paste0(x()$get_gene_labels(), collapse = ", "),+ vars = lapply(spec_list, "[[", "sample_var") |
| 211 | -! | +||
| 527 | +
- "\nGene Summary:",+ ) |
||
| 212 | -! | +||
| 528 | +
- input$`x-fun_name`,+ } |
||
| 213 | -! | +
| 1 | +
- "\nQuantiles:",+ #' Module Input for Gene Signature Specification |
||
| 214 | -! | +||
| 2 | +
- paste0(input$percentiles, collapse = ", "),+ #' |
||
| 215 | -! | +||
| 3 | +
- "\nOptional Fill Variable:",+ #' @description `r lifecycle::badge("experimental")`
|
||
| 216 | -! | +||
| 4 | +
- input$`fill-sample_var`+ #' |
||
| 217 | +5 |
- )+ #' This defines the input for the gene signature specification. |
|
| 218 | -! | +||
| 6 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ #' |
||
| 219 | -! | +||
| 7 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ #' @inheritParams module_arguments |
||
| 220 | -! | +||
| 8 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ #' @param funs (named `list`)\cr names of this list will be used for the function |
||
| 221 | -! | +||
| 9 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ #' selection drop down menu. |
||
| 222 | +10 |
- } else {
+ #' @param label_genes (`string`)\cr label for the gene selection. |
|
| 223 | -! | +||
| 11 | +
- paste(encodings_list, collapse = " ")+ #' @param label_funs (`string`)\cr label for the function selection. |
||
| 224 | +12 |
- }+ #' @param label_text_button (`string`)\cr label for the text input button. |
|
| 225 | +13 |
-
+ #' @param label_lock_button (`string`)\cr label for the lock button. |
|
| 226 | -! | +||
| 14 | +
- card$append_text(final_encodings, style = "verbatim")+ #' @param label_select_all_button (`string`)\cr label for the selecting all genes button. |
||
| 227 | -! | +||
| 15 | +
- card$append_text("Plot", "header3")
+ #' @param label_select_none_button (`string`)\cr label for the selecting no genes button. |
||
| 228 | -! | +||
| 16 | +
- card$append_plot(plot_r(), dim = pws$dim())+ #' @param max_options (`count`)\cr maximum number of gene options rendering and selected via |
||
| 229 | -! | +||
| 17 | +
- if (!comment == "") {
+ #' "Select All". |
||
| 230 | -! | +||
| 18 | +
- card$append_text("Comment", "header3")
+ #' @param max_selected (`count`)\cr maximum number of genes which can be selected. |
||
| 231 | -! | +||
| 19 | +
- card$append_text(comment)+ #' |
||
| 232 | +20 |
- }+ #' @return The UI part. |
|
| 233 | -! | +||
| 21 | +
- card+ #' @seealso [geneSpecServer()] for the module server and a complete example. |
||
| 234 | +22 |
- }+ #' @export |
|
| 235 | -! | +||
| 23 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' |
||
| 236 | +24 |
- }+ #' @examples |
|
| 237 | +25 |
- ###+ #' geneSpecInput("my_genes", list(mean = colMeans), label_funs = "Please select function")
|
|
| 238 | +26 |
- })+ geneSpecInput <- function(inputId, # nolint |
|
| 239 | +27 |
- }+ funs, |
|
| 240 | +28 |
-
+ label_genes = "Select Gene(s)", |
|
| 241 | +29 |
- #' @describeIn tm_g_barplot sample module function.+ label_funs = "Select Gene Summary", |
|
| 242 | +30 |
- #' @export+ label_text_button = "Enter list of genes", |
|
| 243 | +31 |
- #' @examples+ label_lock_button = "Lock gene selection (so that it does not get updated when filtering)", |
|
| 244 | +32 |
- #'+ label_select_all_button = paste0("Select All Genes (first ", max_options, ")"),
|
|
| 245 | +33 |
- #' # Alternatively you can run the sample module with this function call:+ label_select_none_button = "Select None", |
|
| 246 | +34 |
- #' if (interactive()) {
+ max_options = 200L, |
|
| 247 | +35 |
- #' sample_tm_g_barplot()+ max_selected = max_options) {
+ |
+ |
| 36 | +7x | +
+ assert_string(inputId)+ |
+ |
| 37 | +7x | +
+ assert_list(funs, names = "unique", min.len = 1L)+ |
+ |
| 38 | +7x | +
+ assert_string(label_genes)+ |
+ |
| 39 | +7x | +
+ assert_string(label_funs)+ |
+ |
| 40 | +7x | +
+ assert_string(label_text_button)+ |
+ |
| 41 | +7x | +
+ assert_string(label_lock_button)+ |
+ |
| 42 | +7x | +
+ assert_string(label_select_all_button)+ |
+ |
| 43 | +7x | +
+ assert_string(label_select_none_button)+ |
+ |
| 44 | +7x | +
+ assert_count(max_options, positive = TRUE)+ |
+ |
| 45 | +7x | +
+ assert_count(max_selected, positive = TRUE) |
|
| 248 | +46 |
- #' }+ + |
+ |
| 47 | +7x | +
+ ns <- NS(inputId)+ |
+ |
| 48 | +7x | +
+ tagList(+ |
+ |
| 49 | +7x | +
+ include_css_files(pattern = "*"),+ |
+ |
| 50 | +7x | +
+ tags$div(+ |
+ |
| 51 | +7x | +
+ class = "row",+ |
+ |
| 52 | +7x | +
+ tags$div(+ |
+ |
| 53 | +7x | +
+ class = "col-sm-8",+ |
+ |
| 54 | +7x | +
+ tags$label(+ |
+ |
| 55 | +7x | +
+ class = "control-label",+ |
+ |
| 56 | +7x | +
+ label_genes |
|
| 249 | +57 |
- sample_tm_g_barplot <- function() {
+ ) |
|
| 250 | -! | +||
| 58 | +
- data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment)+ ), |
||
| 251 | -! | +||
| 59 | +7x |
- app <- teal::init(+ tags$div( |
|
| 252 | -! | +||
| 60 | +7x |
- data = data,+ class = "col-sm-2", |
|
| 253 | -! | +||
| 61 | +7x |
- modules = teal::modules(+ actionButton( |
|
| 254 | -! | +||
| 62 | +7x |
- tm_g_barplot(+ ns("select_none_button"),
|
|
| 255 | -! | +||
| 63 | +7x |
- label = "barplot",+ tags$span(icon("remove-circle", lib = "glyphicon")),
|
|
| 256 | -! | +||
| 64 | +7x |
- mae_name = "MAE"+ title = label_select_none_button, |
|
| 257 | -+ | ||
| 65 | +7x |
- )+ class = "pull-right list-genes" |
|
| 258 | +66 |
- )+ ), |
|
| 259 | -+ | ||
| 67 | +7x |
- )+ actionButton( |
|
| 260 | -! | +||
| 68 | +7x |
- shinyApp(app$ui, app$server)+ ns("select_all_button"),
|
|
| 261 | -+ | ||
| 69 | +7x |
- }+ tags$span(icon("ok-circle", lib = "glyphicon")),
|
| 1 | -+ | |||
| 70 | +7x |
- #' Module Input for Experiment Specification+ title = label_select_all_button, |
||
| 2 | -+ | |||
| 71 | +7x |
- #'+ class = "pull-right list-genes" |
||
| 3 | +72 |
- #' @description `r lifecycle::badge("experimental")`
+ ) |
||
| 4 | +73 |
- #'+ ), |
||
| 5 | -+ | |||
| 74 | +7x |
- #' This defines the input for the experiment specification.+ tags$div( |
||
| 6 | -+ | |||
| 75 | +7x |
- #'+ class = "col-sm-2", |
||
| 7 | -+ | |||
| 76 | +7x |
- #' @inheritParams module_arguments+ actionButton( |
||
| 8 | -+ | |||
| 77 | +7x |
- #' @param label_experiments (`string`)\cr label for the experiment selection.+ ns("text_button"),
|
||
| 9 | -+ | |||
| 78 | +7x |
- #'+ tags$span(icon("fas fa-font")),
|
||
| 10 | -+ | |||
| 79 | +7x |
- #' @return The UI part.+ title = label_text_button, |
||
| 11 | -+ | |||
| 80 | +7x |
- #' @seealso [experimentSpecServer()] for the module server and a complete example.+ class = "pull-right list-genes" |
||
| 12 | +81 |
- #' @export+ ), |
||
| 13 | -+ | |||
| 82 | +7x |
- experimentSpecInput <- function(inputId, # nolint+ tags$div( |
||
| 14 | -+ | |||
| 83 | +7x |
- data,+ class = "pull-right", |
||
| 15 | -+ | |||
| 84 | +7x |
- mae_name,+ title = label_lock_button, |
||
| 16 | -+ | |||
| 85 | +7x |
- label_experiments = "Select Experiment") {
+ shinyWidgets::prettyToggle( |
||
| 17 | -1x | +86 | +7x |
- assert_string(inputId)+ ns("lock_button"),
|
| 18 | -1x | +87 | +7x |
- assert_string(mae_name, min.chars = 1L)+ value = FALSE, |
| 19 | -1x | +88 | +7x |
- assert_string(label_experiments, min.chars = 1L)+ label_on = NULL, |
| 20 | -1x | +89 | +7x |
- mae <- shiny::isolate(data()[[mae_name]])+ label_off = NULL, |
| 21 | -1x | +90 | +7x |
- name_choices <- names(mae)+ status_on = "default", |
| 22 | -+ | |||
| 91 | +7x |
-
+ status_off = "default", |
||
| 23 | -1x | +92 | +7x |
- ns <- NS(inputId)+ outline = FALSE, |
| 24 | -1x | +93 | +7x |
- selectInput(+ plain = TRUE, |
| 25 | -1x | +94 | +7x |
- inputId = ns("name"),
+ icon_on = icon("fas fa-lock"),
|
| 26 | -1x | +95 | +7x |
- label = label_experiments,+ icon_off = icon("fas fa-lock-open"),
|
| 27 | -1x | +96 | +7x |
- choices = name_choices+ animation = "pulse" |
| 28 | +97 |
- )+ ) |
||
| 29 | +98 |
- }+ ) |
||
| 30 | +99 |
-
+ ) |
||
| 31 | +100 |
- #' Helper Function to Order Gene Choices+ ), |
||
| 32 | -+ | |||
| 101 | +7x |
- #'+ tags$div( |
||
| 33 | -+ | |||
| 102 | +7x |
- #' @description `r lifecycle::badge("experimental")`
+ class = "custom-select-input", |
||
| 34 | -+ | |||
| 103 | +7x |
- #'+ selectizeInput( |
||
| 35 | -+ | |||
| 104 | +7x |
- #' The possible gene choices are ordered as follows. First come all genes which+ ns("genes"),
|
||
| 36 | -+ | |||
| 105 | +7x |
- #' have a non-empty name, ordered by their name alphabetically. Last come+ label = NULL, |
||
| 37 | -+ | |||
| 106 | +7x |
- #' all genes with an empty name, ordered by their ID alphabetically.+ choices = "", |
||
| 38 | -+ | |||
| 107 | +7x |
- #'+ multiple = TRUE, |
||
| 39 | -+ | |||
| 108 | +7x |
- #' @param genes (`data.frame`)\cr containing `id` and `name` columns of the+ selected = 1, |
||
| 40 | -+ | |||
| 109 | +7x |
- #' gene choices. Note that no missing values are allowed.+ options = list( |
||
| 41 | -+ | |||
| 110 | +7x |
- #'+ placeholder = "- Nothing selected -", |
||
| 42 | -+ | |||
| 111 | +7x |
- #' @return The ordered `data.frame`.+ render = I("{
|
||
| 43 | -+ | |||
| 112 | +7x |
- #' @export+ option: function(item, escape) {
|
||
| 44 | -+ | |||
| 113 | +7x |
- #'+ return '<div> <span style=\"font-size: inherit;\">' + item.label + '</div>' + |
||
| 45 | -+ | |||
| 114 | +7x |
- #' @examples+ ' <span style=\"color: #808080; font-size: xx-small;\" >' + item.value + '</div> </div>' |
||
| 46 | +115 |
- #' genes <- data.frame(+ } |
||
| 47 | +116 |
- #' id = c("7", "1", "2", "345346", "0"),
+ }"), |
||
| 48 | -+ | |||
| 117 | +7x |
- #' name = c("e", "", "c", "", "a")
+ searchField = c("value", "label"),
+ |
+ ||
| 118 | +7x | +
+ maxOptions = max_options,+ |
+ ||
| 119 | +7x | +
+ maxItems = max_selected |
||
| 49 | +120 |
- #' )+ ) |
||
| 50 | +121 |
- #' h_order_genes(genes)+ ) |
||
| 51 | +122 |
- h_order_genes <- function(genes) {
+ ), |
||
| 52 | -4x | +123 | +7x |
- assert_data_frame(genes, types = "character", any.missing = FALSE)+ conditionalPanel( |
| 53 | -4x | +124 | +7x |
- assert_set_equal(names(genes), c("id", "name"))
+ condition = "input.genes && input.genes.length > 1", |
| 54 | -+ | |||
| 125 | +7x |
-
+ ns = ns, |
||
| 55 | -4x | +126 | +7x |
- has_empty_name <- genes$name == ""+ selectInput( |
| 56 | -4x | +127 | +7x |
- first_genes <- which(!has_empty_name)[order(genes[!has_empty_name, ]$name)]+ ns("fun_name"),
|
| 57 | -4x | +128 | +7x |
- last_genes <- which(has_empty_name)[order(genes[has_empty_name, ]$id)]+ label_funs, |
| 58 | -4x | +129 | +7x |
- genes[c(first_genes, last_genes), ]+ names(funs) |
| 59 | +130 |
- }+ ) |
||
| 60 | +131 |
-
+ ) |
||
| 61 | +132 |
- #' Helper Function to Format Gene Choices+ ) |
||
| 62 | +133 |
- #'+ } |
||
| 63 | +134 |
- #' @description `r lifecycle::badge("experimental")`
+
|
||
| 64 | +135 | ++ |
+ #' Helper Function to Update Gene Selection+ |
+ |
| 136 |
#' |
|||
| 65 | +137 |
- #' Given a [`hermes::AnyHermesData`] data object, as well as the annotation+ #' @description `r lifecycle::badge("experimental")`
|
||
| 66 | +138 |
- #' column name to use as gene name, this function formats the contained genes+ #' |
||
| 67 | +139 |
- #' as a `data.frame` ready for consumption in [h_order_genes()] e.g.+ #' This helper function takes the intersection of `selected` and |
||
| 68 | +140 |
- #'+ #' `choices` for genes and updates the `inputId` accordingly. It then |
||
| 69 | +141 |
- #' @details+ #' shows a notification if not all `selected` genes were available. |
||
| 70 | +142 |
- #' Note that missing names or names that only contain whitespace+ #' |
||
| 71 | +143 |
- #' are replaced by empty strings for consistency and better labeling in the+ #' @inheritParams module_arguments |
||
| 72 | +144 |
- #' UI downstream+ #' @param session (`ShinySession`)\cr the session object. |
||
| 73 | +145 |
- #'+ #' @param selected (`character`)\cr currently selected gene IDs. |
||
| 74 | +146 |
- #' @inheritParams function_arguments+ #' @param choices (`data.frame`)\cr containing `id` and `name` columns of the |
||
| 75 | +147 |
- #' @inheritParams experimentSpecServer+ #' new choices. |
||
| 76 | +148 |
#' |
||
| 77 | +149 |
- #' @return A `data.frame` with `id` and `name` columns containing all genes from+ #' @export |
||
| 78 | +150 |
- #' `object`.+ h_update_gene_selection <- function(session, |
||
| 79 | +151 |
- #' @export+ inputId, # nolint |
||
| 80 | +152 |
- #'+ selected, |
||
| 81 | +153 |
- #' @examples+ choices) {
|
||
| 82 | -+ | |||
| 154 | +! |
- #' object <- hermes::hermes_data[1:10, ]+ is_new_selected <- selected %in% choices$id |
||
| 83 | -+ | |||
| 155 | +! |
- #' h_gene_data(object, "symbol")+ is_removed <- !is_new_selected |
||
| 84 | -+ | |||
| 156 | +! |
- h_gene_data <- function(object, name_annotation) {
+ updateSelectizeInput( |
||
| 85 | -2x | +|||
| 157 | +! |
- assert_true(hermes::is_hermes_data(object))+ session = session, |
||
| 86 | -2x | +|||
| 158 | +! |
- assert_string(name_annotation, null.ok = TRUE)+ inputId = inputId, |
||
| 87 | -+ | |||
| 159 | +! |
-
+ selected = selected[is_new_selected], |
||
| 88 | -2x | +|||
| 160 | +! |
- gene_ids <- hermes::genes(object)+ choices = stats::setNames(choices$id, choices$name), |
||
| 89 | -2x | +|||
| 161 | +! |
- gene_names <- if (!is.null(name_annotation)) {
+ server = TRUE |
||
| 90 | -2x | +|||
| 162 | +
- annotation_data <- hermes::annotation(object)+ ) |
|||
| 91 | -2x | +|||
| 163 | +
- assert_subset(name_annotation, names(annotation_data))+ |
|||
| 92 | -2x | +|||
| 164 | +! |
- annotation_vector <- annotation_data[[name_annotation]]+ n_removed <- sum(is_removed) |
||
| 93 | -2x | +|||
| 165 | +! |
- annotation_missing <- is.na(annotation_vector) | grepl("^\\s+$", annotation_vector)
+ if (n_removed > 0) {
|
||
| 94 | -2x | +|||
| 166 | +! |
- annotation_vector[annotation_missing] <- ""+ showNotification(paste( |
||
| 95 | -2x | +|||
| 167 | +! |
- annotation_vector+ "Removed", n_removed, ifelse(n_removed > 1, "genes", "gene"),+ |
+ ||
| 168 | +! | +
+ hermes::h_parens(hermes::h_short_list(selected[is_removed])) |
||
| 96 | +169 |
- } else {
+ )) |
||
| 97 | +170 |
- ""+ } |
||
| 98 | +171 |
- }+ } |
||
| 99 | -2x | +|||
| 172 | +
- data.frame(+ |
|||
| 100 | -2x | +|||
| 173 | +
- id = gene_ids,+ #' Helper Function to Parse Genes |
|||
| 101 | -2x | +|||
| 174 | +
- name = gene_names+ #' |
|||
| 102 | +175 |
- )+ #' @description `r lifecycle::badge("experimental")`
|
||
| 103 | +176 |
- }+ #' |
||
| 104 | +177 |
-
+ #' This helper function takes a vector of `words` and tries to match them |
||
| 105 | +178 |
- #' Module Server for Experiment Specification+ #' with the `id` and `name` columns of possible gene choices. |
||
| 106 | +179 |
#' |
||
| 107 | +180 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @param words (`character`)\cr containing gene IDs or names. |
||
| 108 | +181 |
- #'+ #' @inheritParams h_update_gene_selection |
||
| 109 | +182 |
- #' This defines the server part for the experiment specification.+ #' @return The subset of `choices` which matches `words` in ID or name. |
||
| 110 | +183 |
#' |
||
| 111 | +184 |
- #' @inheritParams module_arguments+ #' @export |
||
| 112 | +185 |
- #' @param name_annotation (`string` or `NULL`)\cr which annotation column to use as name+ #' @examples |
||
| 113 | +186 |
- #' to return in the `genes` data. If `NULL`, then the `name` column will be set to empty+ #' h_parse_genes( |
||
| 114 | +187 |
- #' strings.+ #' c("a", "2535"),
|
||
| 115 | +188 |
- #' @param sample_vars_as_factors (`flag`)\cr whether to convert the sample variables+ #' data.frame(id = as.character(2533:2537), name = letters[1:5]) |
||
| 116 | +189 |
- #' (columns in `colData()` of the experiment) from character to factor variables.+ #' ) |
||
| 117 | +190 |
- #' @param with_mae_col_data (`flag`)\cr whether to include the `colData()` of the+ h_parse_genes <- function(words, choices) {
+ |
+ ||
| 191 | +2x | +
+ assert_character(words, min.len = 1L)+ |
+ ||
| 192 | +2x | +
+ assert_data_frame(choices, types = "character")+ |
+ ||
| 193 | +2x | +
+ assert_set_equal(names(choices), c("id", "name"))
|
||
| 118 | +194 |
- #' MAE into the experiment `colData()`.+ + |
+ ||
| 195 | +2x | +
+ id_matches <- choices$id %in% words+ |
+ ||
| 196 | +2x | +
+ name_matches <- choices$name %in% words+ |
+ ||
| 197 | +2x | +
+ has_match <- id_matches | name_matches+ |
+ ||
| 198 | +2x | +
+ choices[has_match, , drop = FALSE] |
||
| 119 | +199 |
- #' @return List with the following reactive objects:+ } |
||
| 120 | +200 |
- #' - `data`: the [`hermes::AnyHermesData`] experiment.+ |
||
| 121 | +201 |
- #' - `name`: the name of the experiment as selected by the user.+ #' Module Server for Gene Signature Specification |
||
| 122 | +202 |
- #' - `genes`: a `data.frame` with the genes in `data`, with columns `id` and `name`.+ #' |
||
| 123 | +203 |
- #' - `assays`: the names of the assays in `data`.+ #' @description `r lifecycle::badge("experimental")`
|
||
| 124 | +204 |
#' |
||
| 125 | +205 |
- #' @seealso [experimentSpecInput()] for the module UI.+ #' This defines the server part for the gene signature specification. |
||
| 126 | +206 |
#' |
||
| 127 | +207 |
- #' @export+ #' @inheritParams module_arguments |
||
| 128 | +208 |
- #'+ #' @param funs (static named `list`)\cr names of this list will be used for the function |
||
| 129 | +209 |
- #' @examples+ #' selection drop down menu. |
||
| 130 | +210 |
- #' ui <- function(id,+ #' @param gene_choices (reactive `data.frame`)\cr returns the possible gene choices to |
||
| 131 | +211 |
- #' mae_name) {
+ #' populate in the UI, as a `data.frame` with columns `id` and `name`. |
||
| 132 | +212 |
- #' ns <- NS(id)+ #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input. |
||
| 133 | +213 |
- #' teal.widgets::standard_layout(+ #' @param label_modal_footer (`character`)\cr lines of text to use for the footer of the dialog. |
||
| 134 | +214 |
- #' encoding = uiOutput(ns("encoding_ui")),
+ #' |
||
| 135 | +215 |
- #' output = tags$div(+ #' @return Reactive [`hermes::GeneSpec`] which can be used as input for the relevant |
||
| 136 | +216 |
- #' verbatimTextOutput(ns("summary")),
+ #' `hermes` functions. |
||
| 137 | +217 |
- #' verbatimTextOutput(ns("head"))
+ #' @seealso [geneSpecInput()] for the module UI. |
||
| 138 | +218 |
- #' )+ #' |
||
| 139 | +219 |
- #' )+ #' @export |
||
| 140 | +220 |
- #' }+ #' |
||
| 141 | +221 |
- #'+ #' @examples |
||
| 142 | +222 |
- #' server <- function(id,+ #' ui <- function(id, funs) {
|
||
| 143 | +223 |
- #' data,+ #' ns <- NS(id) |
||
| 144 | +224 |
- #' filter_panel_api,+ #' teal.widgets::standard_layout( |
||
| 145 | +225 |
- #' mae_name) {
+ #' encoding = tags$div( |
||
| 146 | +226 |
- #' moduleServer(id, function(input, output, session) {
+ #' geneSpecInput( |
||
| 147 | +227 |
- #' output$encoding_ui <- renderUI({
+ #' ns("my_genes"),
|
||
| 148 | +228 |
- #' tags$div(+ #' funs = funs, |
||
| 149 | +229 |
- #' experimentSpecInput(+ #' label_funs = "Please select function" |
||
| 150 | +230 |
- #' session$ns("my_experiment"),
+ #' ) |
||
| 151 | +231 |
- #' data,+ #' ), |
||
| 152 | +232 |
- #' mae_name,+ #' output = textOutput(ns("result"))
|
||
| 153 | +233 |
- #' label_experiments = "Please choose experiment"+ #' ) |
||
| 154 | +234 |
- #' ),+ #' } |
||
| 155 | +235 |
- #' selectInput(+ #' server <- function(id, |
||
| 156 | +236 |
- #' session$ns("property"),
+ #' data, |
||
| 157 | +237 |
- #' "Please choose property",+ #' funs) {
|
||
| 158 | +238 |
- #' c("data", "name", "genes", "assays")
+ #' checkmate::assert_class(data, "reactive") |
||
| 159 | +239 |
- #' )+ #' checkmate::assert_class(shiny::isolate(data()), "teal_data") |
||
| 160 | +240 |
- #' )+ #' moduleServer(id, function(input, output, session) {
|
||
| 161 | +241 |
- #' })+ #' gene_choices <- reactive({
|
||
| 162 | +242 |
- #' experiment <- experimentSpecServer(+ #' mae <- data()[["MAE"]] |
||
| 163 | +243 |
- #' "my_experiment",+ #' object <- mae[[1]] |
||
| 164 | +244 |
- #' data,+ #' gene_ids <- rownames(object) |
||
| 165 | +245 |
- #' filter_panel_api,+ #' gene_names <- SummarizedExperiment::rowData(object)$symbol |
||
| 166 | +246 |
- #' mae_name+ #' gene_data <- data.frame( |
||
| 167 | +247 |
- #' )+ #' id = gene_ids, |
||
| 168 | +248 |
- #' result <- reactive({
+ #' name = gene_names |
||
| 169 | +249 |
- #' req(input$property)+ #' ) |
||
| 170 | +250 |
- #' switch(input$property,+ #' gene_data[order(gene_data$name), ] |
||
| 171 | +251 |
- #' data = experiment$data(),+ #' }) |
||
| 172 | +252 |
- #' name = experiment$name(),+ #' gene_spec <- geneSpecServer( |
||
| 173 | +253 |
- #' genes = experiment$genes(),+ #' "my_genes", |
||
| 174 | +254 |
- #' assays = experiment$assays()+ #' funs = funs, |
||
| 175 | +255 |
- #' )+ #' gene_choices = gene_choices |
||
| 176 | +256 |
- #' })+ #' ) |
||
| 177 | +257 |
- #' output$summary <- renderPrint({
+ #' output$result <- renderText({
|
||
| 178 | +258 |
- #' result <- result()+ #' validate_gene_spec( |
||
| 179 | +259 |
- #' hermes::summary(result)+ #' gene_spec(), |
||
| 180 | +260 |
- #' })+ #' gene_choices()$id |
||
| 181 | +261 |
- #' output$head <- renderPrint({
+ #' ) |
||
| 182 | +262 |
- #' result <- result()+ #' gene_spec <- gene_spec() |
||
| 183 | +263 |
- #' utils::head(result)+ #' gene_spec$get_label() |
||
| 184 | +264 |
#' }) |
||
| 185 | +265 |
#' }) |
||
| 186 | +266 |
#' } |
||
| 187 | +267 |
- #'+ #' funs <- list(mean = colMeans) |
||
| 188 | +268 |
#' my_app <- function() {
|
||
| 189 | +269 |
#' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 190 | +270 |
#' app <- init( |
||
| 191 | +271 |
#' data = data, |
||
| 192 | +272 |
#' modules = modules( |
||
| 193 | +273 |
#' module( |
||
| 194 | +274 |
- #' label = "experimentSpec example",+ #' label = "GeneSpec example", |
||
| 195 | +275 |
#' server = server, |
||
| 196 | +276 |
- #' server_args = list(mae_name = "MAE"),+ #' server_args = list(funs = funs), |
||
| 197 | +277 |
#' ui = ui, |
||
| 198 | +278 |
- #' ui_args = list(mae_name = "MAE"),+ #' ui_args = list(funs = funs), |
||
| 199 | +279 |
#' datanames = "all" |
||
| 200 | +280 |
#' ) |
||
| 201 | +281 |
#' ) |
||
| 202 | +282 |
#' ) |
||
| 203 | +283 |
#' shinyApp(app$ui, app$server) |
||
| 204 | +284 |
#' } |
||
| 205 | +285 |
#' if (interactive()) {
|
||
| 206 | +286 |
#' my_app() |
||
| 207 | +287 |
#' } |
||
| 208 | +288 |
- experimentSpecServer <- function(id, # nolint+ geneSpecServer <- function(id, # nolint |
||
| 209 | +289 |
- data,+ funs, |
||
| 210 | +290 |
- filter_panel_api,+ gene_choices, |
||
| 211 | +291 |
- mae_name,+ label_modal_title = "Enter list of genes", |
||
| 212 | +292 |
- name_annotation = "symbol",+ label_modal_footer = c( |
||
| 213 | +293 |
- sample_vars_as_factors = TRUE,+ "Please enter a comma-separated list of gene IDs and/or names.", |
||
| 214 | +294 |
- with_mae_col_data = TRUE) {
- |
- ||
| 215 | -! | -
- assert_string(id)+ "(Note that genes not included in current choices will be removed)" |
||
| 216 | -! | +|||
| 295 | +
- checkmate::assert_class(data, "reactive")+ )) {
|
|||
| 217 | +296 | ! |
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ assert_string(id) |
|
| 218 | +297 | ! |
- assert_string(mae_name, min.chars = 1L)+ assert_list(funs, names = "unique", min.len = 1L) |
|
| 219 | +298 | ! |
- assert_string(name_annotation, min.chars = 1L, null.ok = TRUE)+ assert_reactive(gene_choices) |
|
| 220 | +299 | ! |
- assert_flag(sample_vars_as_factors)+ assert_string(label_modal_title) |
|
| 221 | +300 | ! |
- assert_flag(with_mae_col_data)+ assert_character(label_modal_footer) |
|
| 222 | +301 | |||
| 223 | +302 | ! |
moduleServer(id, function(input, output, session) {
|
|
| 224 | +303 |
- # When the filtered data set of the chosen experiment changes, update the+ # The `reactiveValues` object for storing current gene text input. |
||
| 225 | +304 |
- # experiment data object.- |
- ||
| 226 | -! | -
- data_return <- reactive({
- |
- ||
| 227 | -! | -
- name <- input$name+ # This will also be a data frame with id and name columns. |
||
| 228 | +305 | ! |
- req(name)+ parsed_genes <- reactiveVal(NULL, label = "Parsed genes") |
|
| 229 | -! | +|||
| 306 | +
- mae <- data()[[mae_name]]+ |
|||
| 230 | -! | +|||
| 307 | +
- orig_object <- mae[[name]]+ # If the parsed genes are entered via text, update gene selection. |
|||
| 231 | +308 | ! |
- validate(need(+ observeEvent(parsed_genes(), ignoreNULL = TRUE, {
|
|
| 232 | +309 | ! |
- hermes::is_hermes_data(orig_object),+ gene_choices <- gene_choices() |
|
| 233 | +310 | ! |
- "Please first convert your experiment to HermesData class"+ parsed_genes <- parsed_genes() |
|
| 234 | +311 |
- ))+ |
||
| 235 | +312 | ! |
- validate(need(+ h_update_gene_selection( |
|
| 236 | +313 | ! |
- !hermes::isEmpty(orig_object),+ session, |
|
| 237 | +314 | ! |
- "No genes or samples included in this experiment, please adjust filters"- |
- |
| 238 | -- |
- ))+ inputId = "genes", |
||
| 239 | +315 | ! |
- object <- if (with_mae_col_data) {
+ selected = parsed_genes$id, |
|
| 240 | +316 | ! |
- MultiAssayExperiment::getWithColData(mae, name)+ choices = gene_choices |
|
| 241 | +317 |
- } else {
- |
- ||
| 242 | -! | -
- orig_object+ ) |
||
| 243 | +318 |
- }- |
- ||
| 244 | -! | -
- if (sample_vars_as_factors) {
- |
- ||
| 245 | -! | -
- SummarizedExperiment::colData(object) <-- |
- ||
| 246 | -! | -
- hermes::df_cols_to_factor(SummarizedExperiment::colData(object))+ }) |
||
| 247 | +319 |
- }- |
- ||
| 248 | -! | -
- object+ |
||
| 249 | +320 |
- })+ # When |
||
| 250 | +321 |
-
+ # 1) the gene choices are recomputed, |
||
| 251 | +322 |
- # When the filtered data set or the chosen experiment changes, update+ # 2) the lock is pressed and then switched off, |
||
| 252 | +323 |
- # the calls that subset the genes of the chosen experiment data object.- |
- ||
| 253 | -! | -
- subset_calls <- reactive({
+ # then update gene selection. |
||
| 254 | +324 | ! |
- name <- input$name+ observeEvent(list(gene_choices(), input$lock_button), {
|
|
| 255 | +325 | ! |
- req(name)- |
- |
| 256 | -- |
-
+ gene_choices <- gene_choices() |
||
| 257 | +326 | ! |
- filter_states <- filter_panel_api$get_filter_state()[[mae_name]][[name]]["subset"]+ lock_button <- input$lock_button |
|
| 258 | +327 | ! |
- filter_states- |
- |
| 259 | -- |
- })+ old_selected <- input$genes |
||
| 260 | +328 | |||
| 261 | -+ | |||
| 329 | +! |
- # Only when the chosen gene subset changes, we recompute gene choices+ if (isFALSE(lock_button)) {
|
||
| 262 | +330 | ! |
- genes <- eventReactive(subset_calls(), ignoreNULL = FALSE, {
+ h_update_gene_selection( |
|
| 263 | +331 | ! |
- data_return <- data_return()+ session, |
|
| 264 | +332 | ! |
- genes <- h_gene_data(data_return, name_annotation)+ inputId = "genes", |
|
| 265 | +333 | ! |
- h_order_genes(genes)+ selected = old_selected, |
|
| 266 | -+ | |||
| 334 | +! |
- })+ choices = gene_choices |
||
| 267 | +335 |
-
+ ) |
||
| 268 | +336 |
- # When the chosen experiment changes, recompute the assay names.- |
- ||
| 269 | -! | -
- assays <- eventReactive(input$name, ignoreNULL = TRUE, {
- |
- ||
| 270 | -! | -
- data_return <- data_return()- |
- ||
| 271 | -! | -
- SummarizedExperiment::assayNames(data_return)+ } |
||
| 272 | +337 |
}) |
||
| 273 | +338 | |||
| 274 | +339 | - - | -||
| 275 | -! | -
- list(- |
- ||
| 276 | -! | -
- data = data_return,- |
- ||
| 277 | -! | -
- name = reactive({
- |
- ||
| 278 | -! | -
- input$name+ # When the Select All button is pressed and not locked, select all genes. |
||
| 279 | +340 | ! |
- }), # nolint+ observeEvent(input$select_all_button, {
|
|
| 280 | +341 | ! |
- genes = genes,+ gene_choices <- gene_choices() |
|
| 281 | +342 | ! |
- assays = assays- |
- |
| 282 | -- |
- )- |
- ||
| 283 | -- |
- })- |
- ||
| 284 | -- |
- }- |
-
| 1 | -- |
- #' Most Expressed Genes Plot+ lock_button <- input$lock_button |
|
| 2 | +343 |
- #'+ |
|
| 3 | -+ | ||
| 344 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ if (isFALSE(lock_button)) {
|
|
| 4 | -+ | ||
| 345 | +! |
- #'+ h_update_gene_selection( |
|
| 5 | -+ | ||
| 346 | +! |
- #' This function plots the most expressed genes.+ session, |
|
| 6 | -+ | ||
| 347 | +! |
- #'+ inputId = "genes", |
|
| 7 | -+ | ||
| 348 | +! |
- #' @inheritParams function_arguments+ selected = gene_choices$id, |
|
| 8 | -+ | ||
| 349 | +! |
- #'+ choices = gene_choices |
|
| 9 | +350 |
- #' @return Plot to be displayed in the teal app.+ ) |
|
| 10 | +351 |
- #'+ } else {
|
|
| 11 | -+ | ||
| 352 | +! |
- #' @export+ showNotification( |
|
| 12 | -+ | ||
| 353 | +! |
- #'+ "Please unlock if you would like to select all genes", |
|
| 13 | -+ | ||
| 354 | +! |
- #' @examples+ type = "warning" |
|
| 14 | +355 |
- #' library(hermes)+ ) |
|
| 15 | +356 |
- #' object <- HermesData(summarized_experiment)+ } |
|
| 16 | +357 |
- #' result <- top_gene_plot(object, assay_name = "counts")+ }) |
|
| 17 | +358 |
- top_gene_plot <- function(object, assay_name) {
+
|
|
| 18 | -! | +||
| 359 | +
- top_gene <- hermes::top_genes(+ # When the Select None button is pressed and not locked, select none. |
||
| 19 | +360 | ! |
- object = object,+ observeEvent(input$select_none_button, {
|
| 20 | +361 | ! |
- assay_name = assay_name,+ gene_choices <- gene_choices() |
| 21 | +362 | ! |
- summary_fun = rowMeans+ lock_button <- input$lock_button |
| 22 | +363 |
- )+ |
|
| 23 | +364 | ! |
- hermes::autoplot(+ if (isFALSE(lock_button)) {
|
| 24 | +365 | ! |
- top_gene,+ h_update_gene_selection( |
| 25 | +366 | ! |
- x_lab = "Gene",+ session, |
| 26 | +367 | ! |
- y_lab = paste("Mean", assay_name, "across samples")
+ inputId = "genes", |
| 27 | -+ | ||
| 368 | +! |
- )+ selected = character(), |
|
| 28 | -+ | ||
| 369 | +! |
- }+ choices = gene_choices |
|
| 29 | +370 |
-
+ ) |
|
| 30 | +371 |
- #' Correlation Heatmap Plot+ } else {
|
|
| 31 | -+ | ||
| 372 | +! |
- #'+ showNotification( |
|
| 32 | -+ | ||
| 373 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ "Please unlock if you would like to select none", |
|
| 33 | -+ | ||
| 374 | +! |
- #'+ type = "warning" |
|
| 34 | +375 |
- #' This function plots the correlation heatmap.+ ) |
|
| 35 | +376 |
- #'+ } |
|
| 36 | +377 |
- #' @inheritParams function_arguments+ }) |
|
| 37 | +378 |
- #'+ |
|
| 38 | +379 |
- #' @return Plot to be displayed in the teal app.+ # Return the UI for a modal dialog with gene text input, showing examples. |
|
| 39 | -+ | ||
| 380 | +! |
- #'+ dataModal <- function(example_list) { # nolint
|
|
| 40 | -+ | ||
| 381 | +! |
- #' @export+ modalDialog( |
|
| 41 | -+ | ||
| 382 | +! |
- #'+ textInput( |
|
| 42 | -+ | ||
| 383 | +! |
- #' @examples+ session$ns("gene_text"),
|
|
| 43 | -+ | ||
| 384 | +! |
- #' library(hermes)+ label = label_modal_title, |
|
| 44 | -+ | ||
| 385 | +! |
- #' object <- HermesData(summarized_experiment)+ placeholder = example_list |
|
| 45 | +386 |
- #' result <- heatmap_plot(object, assay_name = "counts")+ ), |
|
| 46 | -+ | ||
| 387 | +! |
- heatmap_plot <- function(object, assay_name) {
+ do.call("span", as.list(label_modal_footer)),
|
|
| 47 | +388 | ! |
- heatmap <- hermes::correlate(+ footer = tagList( |
| 48 | +389 | ! |
- object = object,+ modalButton("Cancel"),
|
| 49 | +390 | ! |
- assay_name = assay_name+ actionButton(session$ns("ok_button"), "OK")
|
| 50 | +391 |
- )- |
- |
| 51 | -! | -
- hermes::autoplot(heatmap)+ ) |
|
| 52 | +392 |
- }+ ) |
|
| 53 | +393 |
-
+ } |
|
| 54 | +394 |
- #' Teal Module for RNA-seq Quality Control+ |
|
| 55 | +395 |
- #'+ # Show modal when the text button is clicked. |
|
| 56 | -+ | ||
| 396 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ observeEvent(input$text_button, {
|
|
| 57 | -+ | ||
| 397 | +! |
- #'+ gene_choices <- gene_choices() |
|
| 58 | -+ | ||
| 398 | +! |
- #' This module adds quality flags, filters by genes and/or samples,+ example_list <- hermes::h_short_list(utils::head(setdiff(gene_choices$name, ""))) |
|
| 59 | -+ | ||
| 399 | +! |
- #' normalizes `AnyHermesData` objects and provides interactive plots+ showModal(dataModal(example_list)) |
|
| 60 | +400 |
- #' for RNA-seq gene expression quality control.+ }) |
|
| 61 | +401 |
- #'+ |
|
| 62 | +402 |
- #' @inheritParams module_arguments+ # When OK button is pressed, attempt to parse the genes from the text. |
|
| 63 | +403 |
- #'+ # This can be IDs and/or names of genes. |
|
| 64 | +404 |
- #' @return Shiny module to be used in the teal app.+ # Remove the modal and display notification message. |
|
| 65 | -+ | ||
| 405 | +! |
- #'+ observeEvent(input$ok_button, {
|
|
| 66 | -+ | ||
| 406 | +! |
- #' @export+ gene_text <- input$gene_text |
|
| 67 | -+ | ||
| 407 | +! |
- #'+ gene_choices <- gene_choices() |
|
| 68 | +408 |
- #' @examples+ |
|
| 69 | -+ | ||
| 409 | +! |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ if (!nzchar(gene_text)) {
|
|
| 70 | -+ | ||
| 410 | +! |
- #' app <- init(+ showNotification( |
|
| 71 | -+ | ||
| 411 | +! |
- #' data = data,+ "Please enter at least one full gene ID.", |
|
| 72 | -+ | ||
| 412 | +! |
- #' modules = modules(+ type = "error" |
|
| 73 | +413 |
- #' tm_g_quality(+ ) |
|
| 74 | +414 |
- #' label = "Quality Control",+ } else {
|
|
| 75 | -+ | ||
| 415 | +! |
- #' mae_name = "MAE"+ words <- h_extract_words(gene_text) |
|
| 76 | -+ | ||
| 416 | +! |
- #' )+ parse_result <- h_parse_genes(words, choices = gene_choices) |
|
| 77 | -+ | ||
| 417 | +! |
- #' )+ showNotification(paste( |
|
| 78 | -+ | ||
| 418 | +! |
- #' )+ "Parsed total", nrow(parse_result), "genes from", length(words), "words" |
|
| 79 | +419 |
- #' if (interactive()) {
+ )) |
|
| 80 | -+ | ||
| 420 | +! |
- #' shinyApp(app$ui, app$server)+ parsed_genes(parse_result) |
|
| 81 | -+ | ||
| 421 | +! |
- #' }+ removeModal() |
|
| 82 | +422 |
- tm_g_quality <- function(label,+ } |
|
| 83 | +423 |
- mae_name,+ }) |
|
| 84 | +424 |
- exclude_assays = character(),+ |
|
| 85 | +425 |
- pre_output = NULL,+ # When the gene choice is updated, then also set the names |
|
| 86 | +426 |
- post_output = NULL) {
+ # correctly by looking up in current choices. |
|
| 87 | +427 | ! |
- assert_string(label)+ named_genes <- eventReactive(input$genes, ignoreNULL = FALSE, {
|
| 88 | +428 | ! |
- assert_string(mae_name)+ genes <- input$genes |
| 89 | +429 | ! |
- assert_character(exclude_assays, any.missing = FALSE)+ gene_choices <- gene_choices() |
| 90 | +430 | ! |
- assert_tag(pre_output, null.ok = TRUE)+ ret <- if (!is.null(genes)) {
|
| 91 | +431 | ! |
- assert_tag(post_output, null.ok = TRUE)+ which_id <- match(genes, gene_choices$id) |
| 92 | -+ | ||
| 432 | +! |
-
+ gene_names <- gene_choices$name[which_id] |
|
| 93 | +433 | ! |
- teal::module(+ stats::setNames(genes, gene_names) |
| 94 | -! | +||
| 434 | +
- label = label,+ } else {
|
||
| 95 | +435 | ! |
- server = srv_g_quality,+ NULL |
| 96 | -! | +||
| 436 | +
- server_args = list(+ } |
||
| 97 | +437 | ! |
- mae_name = mae_name,+ ret |
| 98 | -! | +||
| 438 | +
- exclude_assays = exclude_assays+ }) |
||
| 99 | +439 |
- ),+ |
|
| 100 | +440 | ! |
- ui = ui_g_quality,+ reactive({
|
| 101 | +441 | ! |
- ui_args = list(+ hermes::gene_spec( |
| 102 | +442 | ! |
- mae_name = mae_name,+ genes = named_genes(), |
| 103 | +443 | ! |
- pre_output = pre_output,+ fun = funs[[input$fun_name]], |
| 104 | +444 | ! |
- post_output = post_output+ fun_name = input$fun_name |
| 105 | +445 |
- ),+ ) |
|
| 106 | -! | +||
| 446 | +
- datanames = mae_name+ }) |
||
| 107 | +447 |
- )+ }) |
|
| 108 | +448 |
} |
|
| 109 | +449 | ||
| 110 | +450 |
- #' @describeIn tm_g_quality sets up the user interface.+ #' Validation of Gene Specification |
|
| 111 | +451 |
- #' @inheritParams module_arguments+ #' |
|
| 112 | +452 |
- #' @export+ #' @description `r lifecycle::badge("experimental")`
|
|
| 113 | +453 |
- ui_g_quality <- function(id,+ #' |
|
| 114 | +454 |
- mae_name,+ #' This validation function checks that a given [`hermes::GeneSpec`] has at least |
|
| 115 | +455 |
- pre_output,+ #' one gene selected and that all genes are included in possible choices. |
|
| 116 | +456 |
- post_output) {
- |
- |
| 117 | -1x | -
- ns <- NS(id)- |
- |
| 118 | -1x | -
- teal.widgets::standard_layout(- |
- |
| 119 | -1x | -
- encoding = tags$div(+ #' |
|
| 120 | +457 |
- ### Reporter+ #' @param gene_spec (`GeneSpec`)\cr gene specification. |
|
| 121 | -1x | +||
| 458 | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' @param gene_choices (`character`)\cr all possible gene choices. |
||
| 122 | +459 |
- ###+ #' |
|
| 123 | -1x | +||
| 460 | +
- tags$label("Encodings", class = "text-primary"),
+ #' @export |
||
| 124 | -1x | +||
| 461 | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ validate_gene_spec <- function(gene_spec, |
||
| 125 | -1x | +||
| 462 | +
- uiOutput(ns("experiment_ui")),
+ gene_choices) {
|
||
| 126 | -1x | +||
| 463 | +! |
- selectInput(+ assert_r6(gene_spec, "GeneSpec") |
|
| 127 | -1x | +||
| 464 | +! |
- ns("plot_type"),
+ assert_character(gene_choices) |
|
| 128 | -1x | +||
| 465 | +
- "Plot Type",+ |
||
| 129 | -1x | +||
| 466 | +! |
- choices = c(+ validate(need( |
|
| 130 | -1x | +||
| 467 | +! |
- "Histogram",+ !is.null(gene_spec$get_genes()), |
|
| 131 | -1x | +||
| 468 | +! |
- "Q-Q Plot",+ "please select at least one gene" |
|
| 132 | -1x | +||
| 469 | +
- "Density",+ )) |
||
| 133 | -1x | +||
| 470 | +! |
- "Boxplot",+ genes_not_included <- setdiff(gene_spec$get_genes(), gene_choices) |
|
| 134 | -1x | +||
| 471 | +! |
- "Top Genes Plot",+ n_not_incl <- length(genes_not_included) |
|
| 135 | -1x | +||
| 472 | +! |
- "Correlation Heatmap"+ validate(need( |
|
| 136 | -+ | ||
| 473 | +! |
- )+ identical(n_not_incl, 0L), |
|
| 137 | -+ | ||
| 474 | +! |
- ),+ paste( |
|
| 138 | -1x | +||
| 475 | +! |
- conditionalPanel(+ n_not_incl, |
|
| 139 | -1x | +||
| 476 | +! |
- condition = "input.plot_type == 'Top Genes Plot' || input.plot_type == 'Correlation Heatmap'",+ ifelse(n_not_incl > 1, "genes", "gene"), |
|
| 140 | -1x | +||
| 477 | +! |
- ns = ns,+ hermes::h_parens(hermes::h_short_list(genes_not_included)), |
|
| 141 | -1x | +||
| 478 | +! |
- assaySpecInput(ns("assay"))
+ "not included, please unlock or change filters" |
|
| 142 | +479 |
- ),- |
- |
| 143 | -1x | -
- tags$label("Gene Filter Settings", class = "text-primary"),
+ ) |
|
| 144 | -1x | +||
| 480 | +
- shinyWidgets::switchInput(+ )) |
||
| 145 | -1x | +||
| 481 | +
- ns("filter_gene"),
+ } |
||
| 146 | -1x | +
| 1 | +
- value = TRUE,+ #' Module Input for Experiment Specification |
||
| 147 | -1x | +||
| 2 | +
- size = "mini"+ #' |
||
| 148 | +3 |
- ),+ #' @description `r lifecycle::badge("experimental")`
|
|
| 149 | -1x | +||
| 4 | +
- conditionalPanel(+ #' |
||
| 150 | -1x | +||
| 5 | +
- condition = "input.filter_gene",+ #' This defines the input for the experiment specification. |
||
| 151 | -1x | +||
| 6 | +
- ns = ns,+ #' |
||
| 152 | -1x | +||
| 7 | +
- sliderInput(ns("min_cpm"), label = ("Minimum CPM"), min = 1, max = 10, value = 5),
+ #' @inheritParams module_arguments |
||
| 153 | -1x | +||
| 8 | +
- sliderInput(ns("min_cpm_prop"), label = ("Minimum CPM Proportion"), min = 0.01, max = 0.99, value = 0.25),
+ #' @param label_experiments (`string`)\cr label for the experiment selection. |
||
| 154 | -1x | +||
| 9 | +
- teal.widgets::optionalSelectInput(+ #' |
||
| 155 | -1x | +||
| 10 | +
- ns("annotate"),
+ #' @return The UI part. |
||
| 156 | -1x | +||
| 11 | +
- label = "Required Annotations",+ #' @seealso [experimentSpecServer()] for the module server and a complete example. |
||
| 157 | -1x | +||
| 12 | +
- choices = "",+ #' @export |
||
| 158 | -1x | +||
| 13 | +
- selected = "",+ experimentSpecInput <- function(inputId, # nolint |
||
| 159 | -1x | +||
| 14 | +
- multiple = TRUE+ data, |
||
| 160 | +15 |
- )+ mae_name, |
|
| 161 | +16 |
- ),+ label_experiments = "Select Experiment") {
|
|
| 162 | +17 | 1x |
- tags$label("Sample Filter Settings", class = "text-primary"),
+ assert_string(inputId) |
| 163 | +18 | 1x |
- shinyWidgets::switchInput(+ assert_string(mae_name, min.chars = 1L) |
| 164 | +19 | 1x |
- ns("filter_sample"),
+ assert_string(label_experiments, min.chars = 1L) |
| 165 | +20 | 1x |
- value = TRUE,+ mae <- shiny::isolate(data()[[mae_name]]) |
| 166 | +21 | 1x |
- size = "mini"+ name_choices <- names(mae) |
| 167 | +22 |
- ),- |
- |
| 168 | -1x | -
- conditionalPanel(- |
- |
| 169 | -1x | -
- condition = "input.filter_sample",+ |
|
| 170 | +23 | 1x |
- ns = ns,+ ns <- NS(inputId) |
| 171 | +24 | 1x |
- sliderInput(ns("min_corr"), label = ("Minimum Correlation"), min = 0.01, max = 0.99, value = 0.5),
+ selectInput( |
| 172 | +25 | 1x |
- radioButtons(+ inputId = ns("name"),
|
| 173 | +26 | 1x |
- ns("min_depth"),
+ label = label_experiments, |
| 174 | +27 | 1x |
- label = "Minimum Depth",+ choices = name_choices |
| 175 | -1x | +||
| 28 | +
- choices = c("Default", "Specify"),
+ ) |
||
| 176 | -1x | +||
| 29 | +
- selected = "Default"+ } |
||
| 177 | +30 |
- ),+ |
|
| 178 | -1x | +||
| 31 | +
- conditionalPanel(+ #' Helper Function to Order Gene Choices |
||
| 179 | -1x | +||
| 32 | +
- condition = "input.min_depth == 'Specify'",+ #' |
||
| 180 | -1x | +||
| 33 | +
- ns = ns,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 181 | -1x | +||
| 34 | +
- sliderInput(ns("min_depth_continuous"), label = NULL, min = 1, max = 10, value = 1)
+ #' |
||
| 182 | +35 |
- )+ #' The possible gene choices are ordered as follows. First come all genes which |
|
| 183 | +36 |
- )+ #' have a non-empty name, ordered by their name alphabetically. Last come |
|
| 184 | +37 |
- ),+ #' all genes with an empty name, ordered by their ID alphabetically. |
|
| 185 | -1x | +||
| 38 | +
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ #' |
||
| 186 | -1x | +||
| 39 | +
- pre_output = pre_output,+ #' @param genes (`data.frame`)\cr containing `id` and `name` columns of the |
||
| 187 | -1x | +||
| 40 | +
- post_output = post_output+ #' gene choices. Note that no missing values are allowed. |
||
| 188 | +41 |
- )+ #' |
|
| 189 | +42 |
- }+ #' @return The ordered `data.frame`. |
|
| 190 | +43 |
-
+ #' @export |
|
| 191 | +44 |
- #' @describeIn tm_g_quality sets up the server with reactive graphs.+ #' |
|
| 192 | +45 |
- #' @inheritParams module_arguments+ #' @examples |
|
| 193 | +46 |
- #' @export+ #' genes <- data.frame( |
|
| 194 | +47 |
- srv_g_quality <- function(id,+ #' id = c("7", "1", "2", "345346", "0"),
|
|
| 195 | +48 |
- data,+ #' name = c("e", "", "c", "", "a")
|
|
| 196 | +49 |
- filter_panel_api,+ #' ) |
|
| 197 | +50 |
- reporter,+ #' h_order_genes(genes) |
|
| 198 | +51 |
- mae_name,+ h_order_genes <- function(genes) {
+ |
+ |
| 52 | +4x | +
+ assert_data_frame(genes, types = "character", any.missing = FALSE)+ |
+ |
| 53 | +4x | +
+ assert_set_equal(names(genes), c("id", "name"))
|
|
| 199 | +54 |
- exclude_assays) {
+
|
|
| 200 | -! | +||
| 55 | +4x |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ has_empty_name <- genes$name == "" |
|
| 201 | -! | +||
| 56 | +4x |
- assert_class(filter_panel_api, "FilterPanelAPI")+ first_genes <- which(!has_empty_name)[order(genes[!has_empty_name, ]$name)] |
|
| 202 | -! | +||
| 57 | +4x |
- checkmate::assert_class(data, "reactive")+ last_genes <- which(has_empty_name)[order(genes[has_empty_name, ]$id)] |
|
| 203 | -! | +||
| 58 | +4x |
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ genes[c(first_genes, last_genes), ] |
|
| 204 | +59 |
-
+ } |
|
| 205 | -! | +||
| 60 | +
- moduleServer(id, function(input, output, session) {
+
|
||
| 206 | -! | +||
| 61 | +
- output$experiment_ui <- renderUI({
+ #' Helper Function to Format Gene Choices |
||
| 207 | -! | +||
| 62 | +
- experimentSpecInput(session$ns("experiment"), data, mae_name)
+ #' |
||
| 208 | +63 |
- })+ #' @description `r lifecycle::badge("experimental")`
|
|
| 209 | -! | +||
| 64 | +
- experiment <- experimentSpecServer(+ #' |
||
| 210 | -! | +||
| 65 | +
- "experiment",+ #' Given a [`hermes::AnyHermesData`] data object, as well as the annotation |
||
| 211 | -! | +||
| 66 | +
- data = data,+ #' column name to use as gene name, this function formats the contained genes |
||
| 212 | -! | +||
| 67 | +
- filter_panel_api = filter_panel_api,+ #' as a `data.frame` ready for consumption in [h_order_genes()] e.g. |
||
| 213 | -! | +||
| 68 | +
- mae_name = mae_name+ #' |
||
| 214 | +69 |
- )+ #' @details |
|
| 215 | +70 |
-
+ #' Note that missing names or names that only contain whitespace |
|
| 216 | -! | +||
| 71 | +
- assay <- assaySpecServer(+ #' are replaced by empty strings for consistency and better labeling in the |
||
| 217 | -! | +||
| 72 | +
- "assay",+ #' UI downstream |
||
| 218 | -! | +||
| 73 | +
- assays = reactive({
+ #' |
||
| 219 | -! | +||
| 74 | +
- union(+ #' @inheritParams function_arguments |
||
| 220 | -! | +||
| 75 | +
- experiment$assays(),+ #' @inheritParams experimentSpecServer |
||
| 221 | +76 |
- # Add all the additional normalized assays.+ #' |
|
| 222 | -! | +||
| 77 | +
- c("cpm", "rpkm", "tpm", "voom", "vst")
+ #' @return A `data.frame` with `id` and `name` columns containing all genes from |
||
| 223 | +78 |
- )+ #' `object`. |
|
| 224 | +79 |
- }),+ #' @export |
|
| 225 | -! | +||
| 80 | +
- exclude_assays = exclude_assays+ #' |
||
| 226 | +81 |
- )+ #' @examples |
|
| 227 | +82 |
-
+ #' object <- hermes::hermes_data[1:10, ] |
|
| 228 | -! | +||
| 83 | +
- experiment_properties <- eventReactive(experiment$name(), {
+ #' h_gene_data(object, "symbol") |
||
| 229 | -! | +||
| 84 | +
- data <- experiment$data()+ h_gene_data <- function(object, name_annotation) {
|
||
| 230 | -! | +||
| 85 | +2x |
- cpm <- edgeR::cpm(hermes::counts(data))+ assert_true(hermes::is_hermes_data(object)) |
|
| 231 | -! | +||
| 86 | +2x |
- depth <- colSums(hermes::counts(data))+ assert_string(name_annotation, null.ok = TRUE) |
|
| 232 | -! | +||
| 87 | +
- list(+ |
||
| 233 | -! | +||
| 88 | +2x |
- annotations = names(hermes::annotation(data)),+ gene_ids <- hermes::genes(object) |
|
| 234 | -! | +||
| 89 | +2x |
- min_cpm_calc = floor(min(cpm)),+ gene_names <- if (!is.null(name_annotation)) {
|
|
| 235 | -! | +||
| 90 | +2x |
- max_cpm_calc = floor(max(cpm)),+ annotation_data <- hermes::annotation(object) |
|
| 236 | -! | +||
| 91 | +2x |
- min_depth_calc = min(depth),+ assert_subset(name_annotation, names(annotation_data)) |
|
| 237 | -! | +||
| 92 | +2x |
- max_depth_calc = max(depth)+ annotation_vector <- annotation_data[[name_annotation]] |
|
| 238 | -+ | ||
| 93 | +2x |
- )+ annotation_missing <- is.na(annotation_vector) | grepl("^\\s+$", annotation_vector)
|
|
| 239 | -+ | ||
| 94 | +2x |
- })+ annotation_vector[annotation_missing] <- "" |
|
| 240 | -+ | ||
| 95 | +2x |
-
+ annotation_vector |
|
| 241 | -! | +||
| 96 | +
- observeEvent(experiment_properties(), {
+ } else {
|
||
| 242 | -! | +||
| 97 | +
- properties <- experiment_properties()+ "" |
||
| 243 | +98 |
-
+ } |
|
| 244 | -! | +||
| 99 | +2x |
- teal.widgets::updateOptionalSelectInput(+ data.frame( |
|
| 245 | -! | +||
| 100 | +2x |
- session,+ id = gene_ids, |
|
| 246 | -! | +||
| 101 | +2x |
- "annotate",+ name = gene_names |
|
| 247 | -! | +||
| 102 | +
- choices = properties$annotations,+ ) |
||
| 248 | -! | +||
| 103 | +
- selected = "WidthBP"+ } |
||
| 249 | +104 |
- )+ |
|
| 250 | -! | +||
| 105 | +
- updateSliderInput(+ #' Module Server for Experiment Specification |
||
| 251 | -! | +||
| 106 | +
- session,+ #' |
||
| 252 | -! | +||
| 107 | +
- "min_cpm",+ #' @description `r lifecycle::badge("experimental")`
|
||
| 253 | -! | +||
| 108 | +
- min = properties$min_cpm_calc,+ #' |
||
| 254 | -! | +||
| 109 | +
- max = properties$max_cpm_calc,+ #' This defines the server part for the experiment specification. |
||
| 255 | -! | +||
| 110 | +
- value = properties$min_cpm_calc+ #' |
||
| 256 | +111 |
- )+ #' @inheritParams module_arguments |
|
| 257 | -! | +||
| 112 | +
- updateSliderInput(+ #' @param name_annotation (`string` or `NULL`)\cr which annotation column to use as name |
||
| 258 | -! | +||
| 113 | +
- session,+ #' to return in the `genes` data. If `NULL`, then the `name` column will be set to empty |
||
| 259 | -! | +||
| 114 | +
- "min_depth_continuous",+ #' strings. |
||
| 260 | -! | +||
| 115 | +
- min = properties$min_depth_calc,+ #' @param sample_vars_as_factors (`flag`)\cr whether to convert the sample variables |
||
| 261 | -! | +||
| 116 | +
- max = properties$max_depth_calc,+ #' (columns in `colData()` of the experiment) from character to factor variables. |
||
| 262 | -! | +||
| 117 | +
- value = properties$min_depth_calc+ #' @param with_mae_col_data (`flag`)\cr whether to include the `colData()` of the |
||
| 263 | +118 |
- )+ #' MAE into the experiment `colData()`. |
|
| 264 | +119 |
- })+ #' @return List with the following reactive objects: |
|
| 265 | +120 |
-
+ #' - `data`: the [`hermes::AnyHermesData`] experiment. |
|
| 266 | -! | +||
| 121 | +
- min_depth_final <- reactive({
+ #' - `name`: the name of the experiment as selected by the user. |
||
| 267 | -! | +||
| 122 | +
- min_depth <- input$min_depth+ #' - `genes`: a `data.frame` with the genes in `data`, with columns `id` and `name`. |
||
| 268 | -! | +||
| 123 | +
- min_depth_continuous <- input$min_depth_continuous+ #' - `assays`: the names of the assays in `data`. |
||
| 269 | -! | +||
| 124 | +
- if (min_depth == "Specify") {
+ #' |
||
| 270 | -! | +||
| 125 | +
- req(min_depth_continuous)+ #' @seealso [experimentSpecInput()] for the module UI. |
||
| 271 | -! | +||
| 126 | +
- min_depth_continuous+ #' |
||
| 272 | +127 |
- } else {
+ #' @export |
|
| 273 | -! | +||
| 128 | +
- NULL+ #' |
||
| 274 | +129 |
- }+ #' @examples |
|
| 275 | +130 |
- })+ #' ui <- function(id, |
|
| 276 | +131 |
-
+ #' mae_name) {
|
|
| 277 | -! | +||
| 132 | +
- control <- reactive({
+ #' ns <- NS(id) |
||
| 278 | -! | +||
| 133 | +
- min_cpm <- input$min_cpm+ #' teal.widgets::standard_layout( |
||
| 279 | -! | +||
| 134 | +
- min_cpm_prop <- input$min_cpm_prop+ #' encoding = uiOutput(ns("encoding_ui")),
|
||
| 280 | -! | +||
| 135 | +
- min_corr <- input$min_corr+ #' output = tags$div( |
||
| 281 | -! | +||
| 136 | +
- min_depth_final <- min_depth_final()+ #' verbatimTextOutput(ns("summary")),
|
||
| 282 | +137 |
-
+ #' verbatimTextOutput(ns("head"))
|
|
| 283 | -! | +||
| 138 | +
- req(+ #' ) |
||
| 284 | -! | +||
| 139 | +
- min_cpm,+ #' ) |
||
| 285 | -! | +||
| 140 | +
- min_cpm_prop,+ #' } |
||
| 286 | -! | +||
| 141 | +
- min_corr+ #' |
||
| 287 | +142 |
- )+ #' server <- function(id, |
|
| 288 | +143 |
-
+ #' data, |
|
| 289 | -! | +||
| 144 | +
- hermes::control_quality(+ #' filter_panel_api, |
||
| 290 | -! | +||
| 145 | +
- min_cpm = min_cpm,+ #' mae_name) {
|
||
| 291 | -! | +||
| 146 | +
- min_cpm_prop = min_cpm_prop,+ #' moduleServer(id, function(input, output, session) {
|
||
| 292 | -! | +||
| 147 | +
- min_corr = min_corr,+ #' output$encoding_ui <- renderUI({
|
||
| 293 | -! | +||
| 148 | +
- min_depth = min_depth_final+ #' tags$div( |
||
| 294 | +149 |
- )+ #' experimentSpecInput( |
|
| 295 | +150 |
- })+ #' session$ns("my_experiment"),
|
|
| 296 | +151 |
-
+ #' data, |
|
| 297 | -! | +||
| 152 | +
- object_flagged <- reactive({
+ #' mae_name, |
||
| 298 | -! | +||
| 153 | +
- control <- control()+ #' label_experiments = "Please choose experiment" |
||
| 299 | -! | +||
| 154 | +
- object <- experiment$data()+ #' ), |
||
| 300 | +155 |
-
+ #' selectInput( |
|
| 301 | -! | +||
| 156 | +
- already_added <- ("control_quality_flags" %in% names(hermes::metadata(object)))
+ #' session$ns("property"),
|
||
| 302 | -! | +||
| 157 | +
- validate(need(!already_added, "Quality flags have already been added to this experiment"))+ #' "Please choose property", |
||
| 303 | -! | +||
| 158 | +
- if (any(c("cpm", "rpkm", "tpm", "voom", "vst") %in% SummarizedExperiment::assayNames(object))) {
+ #' c("data", "name", "genes", "assays")
|
||
| 304 | -! | +||
| 159 | +
- showNotification("Original normalized assays will be overwritten", type = "warning")
+ #' ) |
||
| 305 | +160 |
- }+ #' ) |
|
| 306 | +161 |
-
+ #' }) |
|
| 307 | -! | +||
| 162 | +
- hermes::add_quality_flags(+ #' experiment <- experimentSpecServer( |
||
| 308 | -! | +||
| 163 | +
- object,+ #' "my_experiment", |
||
| 309 | -! | +||
| 164 | +
- control = control+ #' data, |
||
| 310 | +165 |
- )+ #' filter_panel_api, |
|
| 311 | +166 |
- })+ #' mae_name |
|
| 312 | +167 |
-
+ #' ) |
|
| 313 | -! | +||
| 168 | +
- object_final <- reactive({
+ #' result <- reactive({
|
||
| 314 | -! | +||
| 169 | +
- object_flagged <- object_flagged()+ #' req(input$property) |
||
| 315 | -! | +||
| 170 | +
- filter <- input$filter+ #' switch(input$property, |
||
| 316 | -! | +||
| 171 | +
- annotate <- input$annotate+ #' data = experiment$data(), |
||
| 317 | +172 |
-
+ #' name = experiment$name(), |
|
| 318 | -! | +||
| 173 | +
- req(!is_blank(annotate))+ #' genes = experiment$genes(), |
||
| 319 | +174 |
-
+ #' assays = experiment$assays() |
|
| 320 | -! | +||
| 175 | +
- result <- hermes::filter(+ #' ) |
||
| 321 | -! | +||
| 176 | +
- object_flagged,+ #' }) |
||
| 322 | -! | +||
| 177 | +
- what = filter,+ #' output$summary <- renderPrint({
|
||
| 323 | -! | +||
| 178 | +
- annotation_required = annotate+ #' result <- result() |
||
| 324 | +179 |
- )+ #' hermes::summary(result) |
|
| 325 | +180 |
-
+ #' }) |
|
| 326 | -! | +||
| 181 | +
- validate(need(+ #' output$head <- renderPrint({
|
||
| 327 | -! | +||
| 182 | +
- nrow(result) >= 2,+ #' result <- result() |
||
| 328 | -! | +||
| 183 | +
- "Please change gene filters to ensure that there are at least 2 genes"+ #' utils::head(result) |
||
| 329 | +184 |
- ))+ #' }) |
|
| 330 | +185 |
-
+ #' }) |
|
| 331 | -! | +||
| 186 | +
- hermes::normalize(result)+ #' } |
||
| 332 | +187 |
- })+ #' |
|
| 333 | +188 |
-
+ #' my_app <- function() {
|
|
| 334 | -! | +||
| 189 | +
- plot_r <- reactive({
+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 335 | -! | +||
| 190 | +
- object_final <- object_final()+ #' app <- init( |
||
| 336 | -! | +||
| 191 | +
- plot_type <- input$plot_type+ #' data = data, |
||
| 337 | -! | +||
| 192 | +
- assay_name <- assay()+ #' modules = modules( |
||
| 338 | +193 |
-
+ #' module( |
|
| 339 | -! | +||
| 194 | +
- switch(plot_type,+ #' label = "experimentSpec example", |
||
| 340 | -! | +||
| 195 | +
- "Histogram" = hermes::draw_libsize_hist(object_final),+ #' server = server, |
||
| 341 | -! | +||
| 196 | +
- "Density" = hermes::draw_libsize_densities(object_final),+ #' server_args = list(mae_name = "MAE"), |
||
| 342 | -! | +||
| 197 | +
- "Q-Q Plot" = hermes::draw_libsize_qq(object_final),+ #' ui = ui, |
||
| 343 | -! | +||
| 198 | +
- "Boxplot" = hermes::draw_nonzero_boxplot(object_final),+ #' ui_args = list(mae_name = "MAE"), |
||
| 344 | -! | +||
| 199 | +
- "Top Genes Plot" = top_gene_plot(object_final, assay_name = assay_name),+ #' datanames = "all" |
||
| 345 | -! | +||
| 200 | +
- "Correlation Heatmap" = heatmap_plot(object_final, assay_name = assay_name)+ #' ) |
||
| 346 | +201 |
- )+ #' ) |
|
| 347 | +202 |
- })+ #' ) |
|
| 348 | -! | +||
| 203 | +
- output$plot <- renderPlot(plot_r())+ #' shinyApp(app$ui, app$server) |
||
| 349 | +204 |
-
+ #' } |
|
| 350 | -! | +||
| 205 | +
- pws <- teal.widgets::plot_with_settings_srv(+ #' if (interactive()) {
|
||
| 351 | -! | +||
| 206 | +
- id = "plot",+ #' my_app() |
||
| 352 | -! | +||
| 207 | +
- plot_r = plot_r+ #' } |
||
| 353 | +208 |
- )+ experimentSpecServer <- function(id, # nolint |
|
| 354 | +209 |
-
+ data, |
|
| 355 | +210 |
- ### REPORTER+ filter_panel_api, |
|
| 356 | -! | +||
| 211 | +
- if (with_reporter) {
+ mae_name, |
||
| 357 | -! | +||
| 212 | +
- card_fun <- function(comment, label) {
+ name_annotation = "symbol", |
||
| 358 | -! | +||
| 213 | +
- card <- report_card_template(+ sample_vars_as_factors = TRUE, |
||
| 359 | -! | +||
| 214 | +
- title = "Quality Control Plot",+ with_mae_col_data = TRUE) {
|
||
| 360 | +215 | ! |
- label = label,+ assert_string(id) |
| 361 | +216 | ! |
- description = tools::toTitleCase(input$plot_type),+ checkmate::assert_class(data, "reactive") |
| 362 | +217 | ! |
- with_filter = TRUE,+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 363 | +218 | ! |
- filter_panel_api = filter_panel_api- |
-
| 364 | -- |
- )+ assert_string(mae_name, min.chars = 1L) |
|
| 365 | +219 | ! |
- card$append_text("Selected Options", "header3")
+ assert_string(name_annotation, min.chars = 1L, null.ok = TRUE) |
| 366 | +220 | ! |
- encodings_list <- list(+ assert_flag(sample_vars_as_factors) |
| 367 | +221 | ! |
- "Experiment:",+ assert_flag(with_mae_col_data) |
| 368 | -! | +||
| 222 | +
- input$`experiment-name`,+ |
||
| 369 | +223 | ! |
- "\nPlot Type:",+ moduleServer(id, function(input, output, session) {
|
| 370 | -! | +||
| 224 | +
- input$plot_type,+ # When the filtered data set of the chosen experiment changes, update the |
||
| 371 | -! | +||
| 225 | +
- "\nAssay:",+ # experiment data object. |
||
| 372 | +226 | ! |
- input$`assay-name`,+ data_return <- reactive({
|
| 373 | +227 | ! |
- "\nShow Gene Filter Settings:",+ name <- input$name |
| 374 | +228 | ! |
- input$filter_gene,+ req(name) |
| 375 | +229 | ! |
- "\nMinimum CPM:",+ mae <- data()[[mae_name]] |
| 376 | +230 | ! |
- input$min_cpm,+ orig_object <- mae[[name]] |
| 377 | +231 | ! |
- "\nMinimum CPM Proportion:",+ validate(need( |
| 378 | +232 | ! |
- input$min_cpm_prop,+ hermes::is_hermes_data(orig_object), |
| 379 | +233 | ! |
- "\nRequired Annotations:",+ "Please first convert your experiment to HermesData class" |
| 380 | -! | +||
| 234 | +
- paste(input$annotate, collapse = ", "),+ )) |
||
| 381 | +235 | ! |
- "\nShow Sample Filter Settings:",+ validate(need( |
| 382 | +236 | ! |
- input$filter_sample,+ !hermes::isEmpty(orig_object), |
| 383 | +237 | ! |
- "\nMinimum Correlation:",+ "No genes or samples included in this experiment, please adjust filters" |
| 384 | -! | +||
| 238 | +
- input$min_corr,+ )) |
||
| 385 | +239 | ! |
- "\nMinimum Depth:",+ object <- if (with_mae_col_data) {
|
| 386 | +240 | ! |
- input$min_depth,+ MultiAssayExperiment::getWithColData(mae, name) |
| 387 | -! | +||
| 241 | +
- "\nMinimum Depth Value:",+ } else {
|
||
| 388 | +242 | ! |
- input$min_depth_continuous+ orig_object |
| 389 | +243 |
- )+ } |
|
| 390 | +244 | ! |
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ if (sample_vars_as_factors) {
|
| 391 | +245 | ! |
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ SummarizedExperiment::colData(object) <- |
| 392 | +246 | ! |
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ hermes::df_cols_to_factor(SummarizedExperiment::colData(object))+ |
+
| 247 | ++ |
+ } |
|
| 393 | +248 | ! |
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ object |
| 394 | +249 |
- } else {
+ }) |
|
| 395 | -! | +||
| 250 | +
- paste(encodings_list, collapse = " ")+ |
||
| 396 | +251 |
- }+ # When the filtered data set or the chosen experiment changes, update |
|
| 397 | +252 |
-
+ # the calls that subset the genes of the chosen experiment data object. |
|
| 398 | +253 | ! |
- card$append_text(final_encodings, style = "verbatim")+ subset_calls <- reactive({
|
| 399 | +254 | ! |
- card$append_text("Plot", "header3")
+ name <- input$name |
| 400 | +255 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ req(name) |
| 401 | -! | +||
| 256 | +
- if (!comment == "") {
+
|
||
| 402 | +257 | ! |
- card$append_text("Comment", "header3")
+ filter_states <- filter_panel_api$get_filter_state()[[mae_name]][[name]]["subset"] |
| 403 | +258 | ! |
- card$append_text(comment)+ filter_states |
| 404 | +259 |
- }+ }) |
|
| 405 | -! | +||
| 260 | +
- card+ |
||
| 406 | +261 |
- }+ # Only when the chosen gene subset changes, we recompute gene choices |
|
| 407 | +262 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ genes <- eventReactive(subset_calls(), ignoreNULL = FALSE, {
|
| 408 | -+ | ||
| 263 | +! |
- }+ data_return <- data_return() |
|
| 409 | -+ | ||
| 264 | +! |
- ###+ genes <- h_gene_data(data_return, name_annotation) |
|
| 410 | -+ | ||
| 265 | +! |
- })+ h_order_genes(genes) |
|
| 411 | +266 |
- }+ }) |
|
| 412 | +267 | ||
| 413 | -- |
- #' @describeIn tm_g_quality sample module function.- |
- |
| 414 | -- |
- #' @export- |
- |
| 415 | +268 |
- #' @examples+ # When the chosen experiment changes, recompute the assay names. |
|
| 416 | -+ | ||
| 269 | +! |
- #'+ assays <- eventReactive(input$name, ignoreNULL = TRUE, {
|
|
| 417 | -+ | ||
| 270 | +! |
- #' # Alternatively you can run the sample module with this function call:+ data_return <- data_return() |
|
| 418 | -+ | ||
| 271 | +! |
- #' if (interactive()) {
+ SummarizedExperiment::assayNames(data_return) |
|
| 419 | +272 |
- #' sample_tm_g_quality()+ }) |
|
| 420 | +273 |
- #' }+ |
|
| 421 | +274 |
- sample_tm_g_quality <- function() {
+
|
|
| 422 | +275 | ! |
- data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment)+ list( |
| 423 | +276 | ! |
- app <- teal::init(+ data = data_return, |
| 424 | +277 | ! |
- data = data,+ name = reactive({
|
| 425 | +278 | ! |
- modules = teal::modules(+ input$name |
| 426 | +279 | ! |
- tm_g_quality(+ }), # nolint |
| 427 | +280 | ! |
- label = "quality",+ genes = genes, |
| 428 | +281 | ! |
- mae_name = "MAE"- |
-
| 429 | -- |
- )+ assays = assays |
|
| 430 | +282 |
) |
|
| 431 | +283 |
- )- |
- |
| 432 | -! | -
- shinyApp(app$ui, app$server)+ }) |
|
| 433 | +284 |
}@@ -18842,14 +19431,14 @@ teal.modules.hermes coverage - 26.11% |
| 1 |
- #' Module Input for Gene Signature Specification+ #' Teal Module for PCA Analysis |
|||||
| 5 |
- #' This defines the input for the gene signature specification.+ #' This module provides an interactive principal components plot and an |
|||||
| 6 |
- #'+ #' interactive heatmap with correlation of principal components with sample |
|||||
| 7 |
- #' @inheritParams module_arguments+ #' variables. |
|||||
| 8 |
- #' @param funs (named `list`)\cr names of this list will be used for the function+ #' |
|||||
| 9 |
- #' selection drop down menu.+ #' @inheritParams module_arguments |
|||||
| 10 |
- #' @param label_genes (`string`)\cr label for the gene selection.+ #' |
|||||
| 11 |
- #' @param label_funs (`string`)\cr label for the function selection.+ #' @return Shiny module to be used in the teal app. |
|||||
| 12 |
- #' @param label_text_button (`string`)\cr label for the text input button.+ #' @export |
|||||
| 13 |
- #' @param label_lock_button (`string`)\cr label for the lock button.+ #' |
|||||
| 14 |
- #' @param label_select_all_button (`string`)\cr label for the selecting all genes button.+ #' @examples |
|||||
| 15 |
- #' @param label_select_none_button (`string`)\cr label for the selecting no genes button.+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
|||||
| 16 |
- #' @param max_options (`count`)\cr maximum number of gene options rendering and selected via+ #' app <- init( |
|||||
| 17 |
- #' "Select All".+ #' data = data, |
|||||
| 18 |
- #' @param max_selected (`count`)\cr maximum number of genes which can be selected.+ #' modules = modules( |
|||||
| 19 |
- #'+ #' tm_g_pca( |
|||||
| 20 |
- #' @return The UI part.+ #' label = "PCA plot", |
|||||
| 21 |
- #' @seealso [geneSpecServer()] for the module server and a complete example.+ #' mae_name = "MAE" |
|||||
| 22 |
- #' @export+ #' ) |
|||||
| 23 |
- #'+ #' ) |
|||||
| 24 |
- #' @examples+ #' ) |
|||||
| 25 |
- #' geneSpecInput("my_genes", list(mean = colMeans), label_funs = "Please select function")
+ #' if (interactive()) {
|
|||||
| 26 |
- geneSpecInput <- function(inputId, # nolint+ #' shinyApp(app$ui, app$server) |
|||||
| 27 |
- funs,+ #' } |
|||||
| 28 |
- label_genes = "Select Gene(s)",+ tm_g_pca <- function(label, |
|||||
| 29 |
- label_funs = "Select Gene Summary",+ mae_name, |
|||||
| 30 |
- label_text_button = "Enter list of genes",+ exclude_assays = character(), |
|||||
| 31 |
- label_lock_button = "Lock gene selection (so that it does not get updated when filtering)",+ pre_output = NULL, |
|||||
| 32 |
- label_select_all_button = paste0("Select All Genes (first ", max_options, ")"),
+ post_output = NULL, |
|||||
| 33 |
- label_select_none_button = "Select None",+ .test = FALSE) {
|
|||||
| 34 | -+ | ! |
- max_options = 200L,+ message("Initializing tm_g_pca")
|
|||
| 35 | -+ | ! |
- max_selected = max_options) {
+ assert_string(label) |
|||
| 36 | -7x | +! |
- assert_string(inputId)+ assert_string(mae_name) |
|||
| 37 | -7x | +! |
- assert_list(funs, names = "unique", min.len = 1L)+ assert_tag(pre_output, null.ok = TRUE) |
|||
| 38 | -7x | +! |
- assert_string(label_genes)+ assert_tag(post_output, null.ok = TRUE) |
|||
| 39 | -7x | +
- assert_string(label_funs)+ |
||||
| 40 | -7x | +! |
- assert_string(label_text_button)+ teal::module( |
|||
| 41 | -7x | +! |
- assert_string(label_lock_button)+ label = label, |
|||
| 42 | -7x | +! |
- assert_string(label_select_all_button)+ server = srv_g_pca, |
|||
| 43 | -7x | +! |
- assert_string(label_select_none_button)+ server_args = list( |
|||
| 44 | -7x | +! |
- assert_count(max_options, positive = TRUE)+ mae_name = mae_name, |
|||
| 45 | -7x | +! |
- assert_count(max_selected, positive = TRUE)+ exclude_assays = exclude_assays, |
|||
| 46 | -+ | ! |
-
+ .test = .test |
|||
| 47 | -7x | +
- ns <- NS(inputId)+ ), |
||||
| 48 | -7x | +! |
- tagList(+ ui = ui_g_pca, |
|||
| 49 | -7x | +! |
- include_css_files(pattern = "*"),+ ui_args = list( |
|||
| 50 | -7x | +! |
- tags$div(+ mae_name = mae_name, |
|||
| 51 | -7x | +! |
- class = "row",+ pre_output = pre_output, |
|||
| 52 | -7x | +! |
- tags$div(+ post_output = post_output, |
|||
| 53 | -7x | +! |
- class = "col-sm-8",+ .test = .test |
|||
| 54 | -7x | +
- tags$label(+ ), |
||||
| 55 | -7x | +! |
- class = "control-label",+ datanames = mae_name |
|||
| 56 | -7x | +
- label_genes+ ) |
||||
| 57 |
- )+ } |
|||||
| 58 |
- ),+ |
|||||
| 59 | -7x | +
- tags$div(+ #' @describeIn tm_g_pca sets up the user interface. |
||||
| 60 | -7x | +
- class = "col-sm-2",+ #' @inheritParams module_arguments |
||||
| 61 | -7x | +
- actionButton(+ #' @export |
||||
| 62 | -7x | +
- ns("select_none_button"),
+ ui_g_pca <- function(id, |
||||
| 63 | -7x | +
- tags$span(icon("remove-circle", lib = "glyphicon")),
+ mae_name, |
||||
| 64 | -7x | +
- title = label_select_none_button,+ pre_output, |
||||
| 65 | -7x | +
- class = "pull-right list-genes"+ post_output, |
||||
| 66 |
- ),+ .test = FALSE) {
|
|||||
| 67 | -7x | +1x |
- actionButton(+ ns <- NS(id) |
|||
| 68 | -7x | +
- ns("select_all_button"),
+
|
||||
| 69 | -7x | +1x |
- tags$span(icon("ok-circle", lib = "glyphicon")),
+ tagList( |
|||
| 70 | -7x | +1x |
- title = label_select_all_button,+ teal.widgets::standard_layout( |
|||
| 71 | -7x | +1x |
- class = "pull-right list-genes"+ include_css_files(pattern = "*"), |
|||
| 72 | -+ | 1x |
- )+ encoding = tags$div( |
|||
| 73 |
- ),+ ### Reporter |
|||||
| 74 | -7x | +1x |
- tags$div(+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|||
| 75 | -7x | +
- class = "col-sm-2",+ ### |
||||
| 76 | -7x | +1x |
- actionButton(+ tags$label("Encodings", class = "text-primary"),
|
|||
| 77 | -7x | +1x |
- ns("text_button"),
+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|||
| 78 | -7x | +1x |
- tags$span(icon("fas fa-font")),
+ uiOutput(ns("experiment_ui")),
|
|||
| 79 | -7x | +1x |
- title = label_text_button,+ assaySpecInput(ns("assay")),
|
|||
| 80 | -7x | +1x |
- class = "pull-right list-genes"+ conditionalPanel( |
|||
| 81 | -+ | 1x |
- ),+ condition = "input.tab_selected == 'PCA'", |
|||
| 82 | -7x | +1x |
- tags$div(+ ns = ns, |
|||
| 83 | -7x | +1x |
- class = "pull-right",+ sampleVarSpecInput(ns("color"), "Optional color variable"),
|
|||
| 84 | -7x | +1x |
- title = label_lock_button,+ selectizeInput(ns("x_var"), "Select X-axis PC", choices = ""),
|
|||
| 85 | -7x | +1x |
- shinyWidgets::prettyToggle(+ selectizeInput(ns("y_var"), "Select Y-axis PC", choices = "")
|
|||
| 86 | -7x | +
- ns("lock_button"),
+ ), |
||||
| 87 | -7x | +1x |
- value = FALSE,+ teal.widgets::panel_group( |
|||
| 88 | -7x | +1x |
- label_on = NULL,+ teal.widgets::panel_item( |
|||
| 89 | -7x | +1x |
- label_off = NULL,+ input_id = "settings_item", |
|||
| 90 | -7x | +1x |
- status_on = "default",+ collapsed = TRUE, |
|||
| 91 | -7x | +1x |
- status_off = "default",+ title = "Additional Settings", |
|||
| 92 | -7x | +1x |
- outline = FALSE,+ tags$label("Use only Top Variance Genes"),
|
|||
| 93 | -7x | +1x |
- plain = TRUE,+ shinyWidgets::switchInput(ns("filter_top"), value = FALSE, size = "mini"),
|
|||
| 94 | -7x | +1x |
- icon_on = icon("fas fa-lock"),
+ conditionalPanel( |
|||
| 95 | -7x | +1x |
- icon_off = icon("fas fa-lock-open"),
+ condition = "input.filter_top", |
|||
| 96 | -7x | +1x |
- animation = "pulse"+ ns = ns, |
|||
| 97 | -+ | 1x |
- )+ sliderInput(ns("n_top"), label = "Number of Top Genes", min = 10, max = 5000, value = 500)
|
|||
| 98 |
- )+ ), |
|||||
| 99 | -+ | 1x |
- )+ conditionalPanel( |
|||
| 100 | -+ | 1x |
- ),+ condition = "input.tab_selected == 'PCA'", |
|||
| 101 | -7x | +1x |
- tags$div(+ ns = ns, |
|||
| 102 | -7x | +1x |
- class = "custom-select-input",+ tags$label("Show Variance %"),
|
|||
| 103 | -7x | +1x |
- selectizeInput(+ shinyWidgets::switchInput(ns("var_pct"), value = TRUE, size = "mini"),
|
|||
| 104 | -7x | +1x |
- ns("genes"),
+ tags$label("Show Label"),
|
|||
| 105 | -7x | +1x |
- label = NULL,+ shinyWidgets::switchInput(ns("label"), value = TRUE, size = "mini")
|
|||
| 106 | -7x | +
- choices = "",+ ), |
||||
| 107 | -7x | +1x |
- multiple = TRUE,+ conditionalPanel( |
|||
| 108 | -7x | +1x |
- selected = 1,+ condition = "input.tab_selected == 'PC and Sample Correlation'", |
|||
| 109 | -7x | +1x |
- options = list(+ ns = ns, |
|||
| 110 | -7x | +1x |
- placeholder = "- Nothing selected -",+ tags$label("Cluster columns"),
|
|||
| 111 | -7x | +1x |
- render = I("{
+ shinyWidgets::switchInput(ns("cluster_columns"), value = FALSE, size = "mini")
|
|||
| 112 | -7x | +
- option: function(item, escape) {
+ ), |
||||
| 113 | -7x | +1x |
- return '<div> <span style=\"font-size: inherit;\">' + item.label + '</div>' ++ tags$label("View Matrix"),
|
|||
| 114 | -7x | +1x |
- ' <span style=\"color: #808080; font-size: xx-small;\" >' + item.value + '</div> </div>'+ shinyWidgets::switchInput(ns("show_matrix"), value = TRUE, size = "mini")
|
|||
| 115 |
- }+ ) |
|||||
| 116 |
- }"),+ ) |
|||||
| 117 | -7x | +
- searchField = c("value", "label"),
+ ), |
||||
| 118 | -7x | +1x |
- maxOptions = max_options,+ output = tags$div( |
|||
| 119 | -7x | +1x |
- maxItems = max_selected+ style = "display:flow-root", |
|||
| 120 | -+ | 1x |
- )+ tabsetPanel( |
|||
| 121 | -+ | 1x |
- )+ id = ns("tab_selected"),
|
|||
| 122 | -+ | 1x |
- ),+ type = "tabs", |
|||
| 123 | -7x | +1x |
- conditionalPanel(+ tabPanel( |
|||
| 124 | -7x | +1x |
- condition = "input.genes && input.genes.length > 1",+ "PCA", |
|||
| 125 | -7x | +1x |
- ns = ns,+ column( |
|||
| 126 | -7x | +1x |
- selectInput(+ width = 12, |
|||
| 127 | -7x | +1x |
- ns("fun_name"),
+ if (.test) verbatimTextOutput(ns("test_pca")) else NULL,
|
|||
| 128 | -7x | +1x |
- label_funs,+ div( |
|||
| 129 | -7x | +1x |
- names(funs)+ class = "my-5", |
|||
| 130 | -+ | 1x |
- )+ teal.widgets::plot_with_settings_ui(ns("plot_pca"))
|
|||
| 131 |
- )+ ), |
|||||
| 132 | -+ | 1x |
- )+ DT::DTOutput(ns("table_pca"))
|
|||
| 133 |
- }+ ) |
|||||
| 134 |
-
+ ), |
|||||
| 135 | -+ | 1x |
- #' Helper Function to Update Gene Selection+ tabPanel( |
|||
| 136 | -+ | 1x |
- #'+ "PC and Sample Correlation", |
|||
| 137 | -+ | 1x |
- #' @description `r lifecycle::badge("experimental")`
+ column( |
|||
| 138 | -+ | 1x |
- #'+ width = 12, |
|||
| 139 | -+ | 1x |
- #' This helper function takes the intersection of `selected` and+ if (.test) verbatimTextOutput(ns("test_cor")) else NULL,
|
|||
| 140 | -+ | 1x |
- #' `choices` for genes and updates the `inputId` accordingly. It then+ div( |
|||
| 141 | -+ | 1x |
- #' shows a notification if not all `selected` genes were available.+ class = "my-5", |
|||
| 142 | -+ | 1x |
- #'+ teal.widgets::plot_with_settings_ui(ns("plot_cor"))
|
|||
| 143 |
- #' @inheritParams module_arguments+ ), |
|||||
| 144 | -+ | 1x |
- #' @param session (`ShinySession`)\cr the session object.+ DT::DTOutput(ns("table_cor"))
|
|||
| 145 |
- #' @param selected (`character`)\cr currently selected gene IDs.+ ) |
|||||
| 146 |
- #' @param choices (`data.frame`)\cr containing `id` and `name` columns of the+ ) |
|||||
| 147 |
- #' new choices.+ ) |
|||||
| 148 |
- #'+ ), |
|||||
| 149 | -+ | 1x |
- #' @export+ pre_output = pre_output, |
|||
| 150 | -+ | 1x |
- h_update_gene_selection <- function(session,+ post_output = post_output |
|||
| 151 |
- inputId, # nolint+ ) |
|||||
| 152 |
- selected,+ ) |
|||||
| 153 |
- choices) {
+ } |
|||||
| 154 | -! | +
- is_new_selected <- selected %in% choices$id+ |
||||
| 155 | -! | +
- is_removed <- !is_new_selected+ #' @describeIn tm_g_pca sets up the server with reactive graph. |
||||
| 156 | -! | +
- updateSelectizeInput(+ #' @inheritParams module_arguments |
||||
| 157 | -! | +
- session = session,+ #' @export |
||||
| 158 | -! | +
- inputId = inputId,+ srv_g_pca <- function(id, |
||||
| 159 | -! | +
- selected = selected[is_new_selected],+ data, |
||||
| 160 | -! | +
- choices = stats::setNames(choices$id, choices$name),+ filter_panel_api, |
||||
| 161 | -! | +
- server = TRUE+ reporter, |
||||
| 162 |
- )+ mae_name, |
|||||
| 163 |
-
+ exclude_assays, |
|||||
| 164 | -! | +
- n_removed <- sum(is_removed)+ .test = FALSE) {
|
||||
| 165 | ! |
- if (n_removed > 0) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
||||
| 166 | ! |
- showNotification(paste(+ assert_class(filter_panel_api, "FilterPanelAPI") |
||||
| 167 | ! |
- "Removed", n_removed, ifelse(n_removed > 1, "genes", "gene"),+ checkmate::assert_class(data, "reactive") |
||||
| 168 | ! |
- hermes::h_parens(hermes::h_short_list(selected[is_removed]))+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
||||
| 169 |
- ))+ |
|||||
| 170 | -+ | ! |
- }+ moduleServer(id, function(input, output, session) {
|
|||
| 171 | -+ | ! |
- }+ output$experiment_ui <- renderUI({
|
|||
| 172 | -+ | ! |
-
+ experimentSpecInput(session$ns("experiment"), data, mae_name)
|
|||
| 173 |
- #' Helper Function to Parse Genes+ }) |
|||||
| 174 | -+ | ! |
- #'+ experiment <- experimentSpecServer( |
|||
| 175 | -+ | ! |
- #' @description `r lifecycle::badge("experimental")`
+ "experiment", |
|||
| 176 | -+ | ! |
- #'+ data = data, |
|||
| 177 | -+ | ! |
- #' This helper function takes a vector of `words` and tries to match them+ filter_panel_api = filter_panel_api, |
|||
| 178 | -+ | ! |
- #' with the `id` and `name` columns of possible gene choices.+ mae_name = mae_name |
|||
| 179 |
- #'+ ) |
|||||
| 180 | -+ | ! |
- #' @param words (`character`)\cr containing gene IDs or names.+ assay <- assaySpecServer( |
|||
| 181 | -+ | ! |
- #' @inheritParams h_update_gene_selection+ "assay", |
|||
| 182 | -+ | ! |
- #' @return The subset of `choices` which matches `words` in ID or name.+ assays = experiment$assays, |
|||
| 183 | -+ | ! |
- #'+ exclude_assays = exclude_assays |
|||
| 184 |
- #' @export+ ) |
|||||
| 185 | -+ | ! |
- #' @examples+ color <- sampleVarSpecServer( |
|||
| 186 | -+ | ! |
- #' h_parse_genes(+ "color", |
|||
| 187 | -+ | ! |
- #' c("a", "2535"),
+ experiment_name = experiment$name, |
|||
| 188 | -+ | ! |
- #' data.frame(id = as.character(2533:2537), name = letters[1:5])+ original_data = experiment$data |
|||
| 189 |
- #' )+ ) |
|||||
| 190 |
- h_parse_genes <- function(words, choices) {
+
|
|||||
| 191 | -2x | +
- assert_character(words, min.len = 1L)+ # Total number of genes at the moment. |
||||
| 192 | -2x | +! |
- assert_data_frame(choices, types = "character")+ n_genes <- reactive({
|
|||
| 193 | -2x | +! |
- assert_set_equal(names(choices), c("id", "name"))
+ experiment_data <- color$experiment_data() |
|||
| 194 | -+ | ! |
-
+ nrow(experiment_data) |
|||
| 195 | -2x | +
- id_matches <- choices$id %in% words+ }) |
||||
| 196 | -2x | +
- name_matches <- choices$name %in% words+ |
||||
| 197 | -2x | +
- has_match <- id_matches | name_matches+ # When the total number changes or gene filter is activated, update slider max. |
||||
| 198 | -2x | +! |
- choices[has_match, , drop = FALSE]+ observeEvent(list(n_genes(), input$filter_top), {
|
|||
| 199 | -+ | ! |
- }+ n_genes <- n_genes() |
|||
| 200 | -+ | ! |
-
+ filter_top <- input$filter_top |
|||
| 201 | -+ | ! |
- #' Module Server for Gene Signature Specification+ if (filter_top) {
|
|||
| 202 | -+ | ! |
- #'+ n_top <- input$n_top |
|||
| 203 | -+ | ! |
- #' @description `r lifecycle::badge("experimental")`
+ updateSliderInput( |
|||
| 204 | -+ | ! |
- #'+ session = session, |
|||
| 205 | -+ | ! |
- #' This defines the server part for the gene signature specification.+ inputId = "n_top", |
|||
| 206 | -+ | ! |
- #'+ value = min(n_top, n_genes), |
|||
| 207 | -+ | ! |
- #' @inheritParams module_arguments+ max = n_genes |
|||
| 208 |
- #' @param funs (static named `list`)\cr names of this list will be used for the function+ ) |
|||||
| 209 |
- #' selection drop down menu.+ } |
|||||
| 210 |
- #' @param gene_choices (reactive `data.frame`)\cr returns the possible gene choices to+ }) |
|||||
| 211 |
- #' populate in the UI, as a `data.frame` with columns `id` and `name`.+ |
|||||
| 212 |
- #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input.+ # When the chosen experiment or assay name changes, recompute the PC. |
|||||
| 213 | -+ | ! |
- #' @param label_modal_footer (`character`)\cr lines of text to use for the footer of the dialog.+ pca_result <- reactive({
|
|||
| 214 | -+ | ! |
- #'+ experiment_data <- color$experiment_data() |
|||
| 215 | -+ | ! |
- #' @return Reactive [`hermes::GeneSpec`] which can be used as input for the relevant+ filter_top <- input$filter_top |
|||
| 216 | -+ | ! |
- #' `hermes` functions.+ n_top <- input$n_top |
|||
| 217 | -+ | ! |
- #' @seealso [geneSpecInput()] for the module UI.+ assay_name <- assay() |
|||
| 218 |
- #'+ |
|||||
| 219 | -+ | ! |
- #' @export+ validate(need(hermes::is_hermes_data(experiment_data), "please use HermesData() on input experiments")) |
|||
| 220 | -+ | ! |
- #'+ req(isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data))) |
|||
| 221 | -+ | ! |
- #' @examples+ validate(need( |
|||
| 222 | -+ | ! |
- #' ui <- function(id, funs) {
+ ncol(experiment_data) > 2, |
|||
| 223 | -+ | ! |
- #' ns <- NS(id)+ "Sample size is too small. PCA needs more than 2 samples." |
|||
| 224 |
- #' teal.widgets::standard_layout(+ )) |
|||||
| 225 | -+ | ! |
- #' encoding = tags$div(+ validate(need( |
|||
| 226 | -+ | ! |
- #' geneSpecInput(+ nrow(experiment_data) > 1, |
|||
| 227 | -+ | ! |
- #' ns("my_genes"),
+ "Number of genes is too small. PCA needs more than 1 gene." |
|||
| 228 |
- #' funs = funs,+ )) |
|||||
| 229 |
- #' label_funs = "Please select function"+ |
|||||
| 230 | -+ | ! |
- #' )+ hermes::calc_pca(experiment_data, assay_name, n_top = if (filter_top) n_top else NULL) |
|||
| 231 |
- #' ),+ }) |
|||||
| 232 |
- #' output = textOutput(ns("result"))
+
|
|||||
| 233 |
- #' )+ # When experiment or assay name changes, update choices for PCs in x_var and y_var. |
|||||
| 234 | -+ | ! |
- #' }+ observeEvent(pca_result(), {
|
|||
| 235 | -+ | ! |
- #' server <- function(id,+ pca_result_x <- pca_result()$x |
|||
| 236 | -+ | ! |
- #' data,+ pc_choices <- seq_len(ncol(pca_result_x)) |
|||
| 237 |
- #' funs) {
+
|
|||||
| 238 | -+ | ! |
- #' checkmate::assert_class(data, "reactive")+ id_names <- c("x_var", "y_var")
|
|||
| 239 | -+ | ! |
- #' checkmate::assert_class(shiny::isolate(data()), "teal_data")+ for (i in seq_along(id_names)) {
|
|||
| 240 | -+ | ! |
- #' moduleServer(id, function(input, output, session) {
+ updateSelectizeInput( |
|||
| 241 | -+ | ! |
- #' gene_choices <- reactive({
+ session, |
|||
| 242 | -+ | ! |
- #' mae <- data()[["MAE"]]+ id_names[i], |
|||
| 243 | -+ | ! |
- #' object <- mae[[1]]+ choices = pc_choices, |
|||
| 244 | -+ | ! |
- #' gene_ids <- rownames(object)+ selected = pc_choices[i] |
|||
| 245 |
- #' gene_names <- SummarizedExperiment::rowData(object)$symbol+ ) |
|||||
| 246 |
- #' gene_data <- data.frame(+ } |
|||||
| 247 |
- #' id = gene_ids,+ }) |
|||||
| 248 |
- #' name = gene_names+ |
|||||
| 249 |
- #' )+ # Compute correlation of PC with sample variables. |
|||||
| 250 | -+ | ! |
- #' gene_data[order(gene_data$name), ]+ cor_result <- reactive({
|
|||
| 251 | -+ | ! |
- #' })+ pca_result <- pca_result() |
|||
| 252 | -+ | ! |
- #' gene_spec <- geneSpecServer(+ experiment_data <- color$experiment_data() |
|||
| 253 |
- #' "my_genes",+ |
|||||
| 254 | -+ | ! |
- #' funs = funs,+ hermes::correlate(pca_result, experiment_data) |
|||
| 255 |
- #' gene_choices = gene_choices+ }) |
|||||
| 256 |
- #' )+ |
|||||
| 257 |
- #' output$result <- renderText({
+ # Compute & display PCA matrix table if show_matrix is TRUE. |
|||||
| 258 | -+ | ! |
- #' validate_gene_spec(+ show_matrix_pca <- reactive({
|
|||
| 259 | -+ | ! |
- #' gene_spec(),+ if (input$show_matrix) {
|
|||
| 260 | -+ | ! |
- #' gene_choices()$id+ pca_result_x <- pca_result()$x |
|||
| 261 | -+ | ! |
- #' )+ pca_result_x <- round(pca_result_x, 3) |
|||
| 262 | -+ | ! |
- #' gene_spec <- gene_spec()+ as.data.frame(pca_result_x) |
|||
| 263 |
- #' gene_spec$get_label()+ } else {
|
|||||
| 264 | -+ | ! |
- #' })+ NULL |
|||
| 265 |
- #' })+ } |
|||||
| 266 |
- #' }+ }) |
|||||
| 267 |
- #' funs <- list(mean = colMeans)+ |
|||||
| 268 | -+ | ! |
- #' my_app <- function() {
+ output$table_pca <- DT::renderDT({
|
|||
| 269 | -+ | ! |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ show_matrix_pca <- show_matrix_pca() |
|||
| 270 | -+ | ! |
- #' app <- init(+ DT::datatable( |
|||
| 271 | -+ | ! |
- #' data = data,+ show_matrix_pca, |
|||
| 272 | -+ | ! |
- #' modules = modules(+ rownames = TRUE, |
|||
| 273 | -+ | ! |
- #' module(+ options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)), |
|||
| 274 | -+ | ! |
- #' label = "GeneSpec example",+ caption = "PCA Matrix" |
|||
| 275 |
- #' server = server,+ ) |
|||||
| 276 |
- #' server_args = list(funs = funs),+ }) |
|||||
| 277 |
- #' ui = ui,+ |
|||||
| 278 |
- #' ui_args = list(funs = funs),+ # Compute & display correlation matrix if show_matrix is TRUE |
|||||
| 279 | -+ | ! |
- #' datanames = "all"+ show_matrix_cor <- reactive({
|
|||
| 280 | -+ | ! |
- #' )+ if (input$show_matrix) {
|
|||
| 281 | -+ | ! |
- #' )+ cor_result <- cor_result() |
|||
| 282 | -+ | ! |
- #' )+ cor_result <- round(cor_result, 3) |
|||
| 283 | -+ | ! |
- #' shinyApp(app$ui, app$server)+ as.data.frame(cor_result) |
|||
| 284 |
- #' }+ } else {
|
|||||
| 285 | -+ | ! |
- #' if (interactive()) {
+ NULL |
|||
| 286 |
- #' my_app()+ } |
|||||
| 287 |
- #' }+ }) |
|||||
| 288 | -+ | ! |
- geneSpecServer <- function(id, # nolint+ output$table_cor <- DT::renderDT({
|
|||
| 289 | -+ | ! |
- funs,+ show_matrix_cor <- show_matrix_cor() |
|||
| 290 | -+ | ! |
- gene_choices,+ DT::datatable( |
|||
| 291 | -+ | ! |
- label_modal_title = "Enter list of genes",+ show_matrix_cor, |
|||
| 292 | -+ | ! |
- label_modal_footer = c(+ rownames = TRUE, |
|||
| 293 | -+ | ! |
- "Please enter a comma-separated list of gene IDs and/or names.",+ options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)), |
|||
| 294 | -+ | ! |
- "(Note that genes not included in current choices will be removed)"+ caption = "PC and Sample Correlation Matrix" |
|||
| 295 |
- )) {
+ ) |
|||||
| 296 | -! | +
- assert_string(id)+ }) |
||||
| 297 | -! | +
- assert_list(funs, names = "unique", min.len = 1L)+ |
||||
| 298 | -! | +
- assert_reactive(gene_choices)+ # Render plot PCA output. |
||||
| 299 | ! |
- assert_string(label_modal_title)+ plot_pca <- reactive({
|
||||
| 300 | -! | +
- assert_character(label_modal_footer)+ # Resolve all reactivity. |
||||
| 301 | -+ | ! |
-
+ pca_result <- pca_result() |
|||
| 302 | ! |
- moduleServer(id, function(input, output, session) {
+ experiment_data <- color$experiment_data() |
||||
| 303 | -+ | ! |
- # The `reactiveValues` object for storing current gene text input.+ x_var <- as.numeric(input$x_var) |
|||
| 304 | -+ | ! |
- # This will also be a data frame with id and name columns.+ y_var <- as.numeric(input$y_var) |
|||
| 305 | ! |
- parsed_genes <- reactiveVal(NULL, label = "Parsed genes")+ data <- as.data.frame(SummarizedExperiment::colData(color$experiment_data())) |
||||
| 306 | -+ | ! |
-
+ color_var <- color$sample_var() |
|||
| 307 | -+ | ! |
- # If the parsed genes are entered via text, update gene selection.+ assay_name <- assay() |
|||
| 308 | ! |
- observeEvent(parsed_genes(), ignoreNULL = TRUE, {
+ var_pct <- input$var_pct |
||||
| 309 | ! |
- gene_choices <- gene_choices()+ label <- input$label |
||||
| 310 | -! | +
- parsed_genes <- parsed_genes()+ |
||||
| 311 |
-
+ # Require which states need to be truthy. |
|||||
| 312 | ! |
- h_update_gene_selection(+ req( |
||||
| 313 | ! |
- session,+ assay_name, |
||||
| 314 | -! | +
- inputId = "genes",+ # Note: The following statements are important to make sure the UI inputs have been updated. |
||||
| 315 | ! |
- selected = parsed_genes$id,+ isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)), |
||||
| 316 | ! |
- choices = gene_choices+ is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))), |
||||
| 317 | -+ | ! |
- )+ cancelOutput = FALSE |
|||
| 318 |
- })+ ) |
|||||
| 320 |
- # When+ # Validate and give useful messages to the user. Note: no need to duplicate here req() from above. |
|||||
| 321 | -+ | ! |
- # 1) the gene choices are recomputed,+ validate(need(x_var != y_var, "please select two different principal components")) |
|||
| 322 |
- # 2) the lock is pressed and then switched off,+ |
|||||
| 323 | -+ | ! |
- # then update gene selection.+ hermes::autoplot( |
|||
| 324 | ! |
- observeEvent(list(gene_choices(), input$lock_button), {
+ object = pca_result, |
||||
| 325 | ! |
- gene_choices <- gene_choices()+ assay_name = assay_name, |
||||
| 326 | ! |
- lock_button <- input$lock_button+ x = x_var, |
||||
| 327 | ! |
- old_selected <- input$genes+ y = y_var, |
||||
| 328 | -+ | ! |
-
+ data = data, |
|||
| 329 | ! |
- if (isFALSE(lock_button)) {
+ colour = color_var, |
||||
| 330 | ! |
- h_update_gene_selection(+ variance_percentage = var_pct, |
||||
| 331 | ! |
- session,+ label = label, |
||||
| 332 | ! |
- inputId = "genes",+ label.repel = label, |
||||
| 333 | ! |
- selected = old_selected,+ label.show.legend = FALSE |
||||
| 334 | -! | +
- choices = gene_choices+ ) |
||||
| 335 |
- )+ }) |
|||||
| 336 | -+ | ! |
- }+ output$plot_pca <- renderPlot(plot_pca()) |
|||
| 337 |
- })+ |
|||||
| 338 | -+ | ! |
-
+ pws_pca <- teal.widgets::plot_with_settings_srv( |
|||
| 339 | -+ | ! |
- # When the Select All button is pressed and not locked, select all genes.+ id = "plot_pca", |
|||
| 340 | ! |
- observeEvent(input$select_all_button, {
+ plot_r = plot_pca |
||||
| 341 | -! | +
- gene_choices <- gene_choices()+ ) |
||||
| 342 | -! | +
- lock_button <- input$lock_button+ |
||||
| 343 |
-
+ # render correlation heatmap |
|||||
| 344 | ! |
- if (isFALSE(lock_button)) {
+ plot_cor <- reactive({
|
||||
| 345 | -! | +
- h_update_gene_selection(+ # Resolve all reactivity. |
||||
| 346 | ! |
- session,+ cor_result <- cor_result() |
||||
| 347 | ! |
- inputId = "genes",+ cluster_columns <- input$cluster_columns |
||||
| 348 | -! | +
- selected = gene_choices$id,+ |
||||
| 349 | ! |
- choices = gene_choices+ validate(need( |
||||
| 350 | -+ | ! |
- )+ !any(is.na(cor_result)), |
|||
| 351 | -+ | ! |
- } else {
+ "Obtained NA results in the correlation matrix, therefore no plot can be produced" |
|||
| 352 | -! | +
- showNotification(+ )) |
||||
| 353 | ! |
- "Please unlock if you would like to select all genes",+ hermes::autoplot( |
||||
| 354 | ! |
- type = "warning"+ object = cor_result, |
||||
| 355 | -+ | ! |
- )+ cluster_columns = cluster_columns |
|||
| 356 |
- }+ ) |
|||||
| 359 | -+ | ! |
- # When the Select None button is pressed and not locked, select none.+ pws_cor <- teal.widgets::plot_with_settings_srv( |
|||
| 360 | ! |
- observeEvent(input$select_none_button, {
+ id = "plot_cor", |
||||
| 361 | ! |
- gene_choices <- gene_choices()+ plot_r = plot_cor |
||||
| 362 | -! | +
- lock_button <- input$lock_button+ ) |
||||
| 364 | ! |
- if (isFALSE(lock_button)) {
+ if (.test) {
|
||||
| 365 | ! |
- h_update_gene_selection(+ output$test_pca <- renderPrint(layer_data(plot_pca())) |
||||
| 366 | ! |
- session,+ output$test_cor <- renderPrint(show_matrix_cor()) |
||||
| 367 | -! | +
- inputId = "genes",+ } |
||||
| 368 | -! | +
- selected = character(),+ |
||||
| 369 | -! | +
- choices = gene_choices+ ### REPORTER |
||||
| 370 | -+ | ! |
- )+ if (with_reporter) {
|
|||
| 371 | -+ | ! |
- } else {
+ card_fun <- function(comment, label) {
|
|||
| 372 | ! |
- showNotification(+ card <- report_card_template( |
||||
| 373 | ! |
- "Please unlock if you would like to select none",+ title = "PCA", |
||||
| 374 | ! |
- type = "warning"+ label = label, |
||||
| 375 | -+ | ! |
- )+ with_filter = TRUE, |
|||
| 376 | -+ | ! |
- }+ filter_panel_api = filter_panel_api |
|||
| 377 |
- })+ ) |
|||||
| 378 | -+ | ! |
-
+ card$append_text("Selected Options", "header3")
|
|||
| 379 | -+ | ! |
- # Return the UI for a modal dialog with gene text input, showing examples.+ if (input$tab_selected == "PCA") {
|
|||
| 380 | ! |
- dataModal <- function(example_list) { # nolint
+ encodings_list <- list( |
||||
| 381 | ! |
- modalDialog(+ "Experiment:", |
||||
| 382 | ! |
- textInput(+ input$`experiment-name`, |
||||
| 383 | ! |
- session$ns("gene_text"),
+ "\nAssay:", |
||||
| 384 | ! |
- label = label_modal_title,+ input$`assay-name`, |
||||
| 385 | ! |
- placeholder = example_list+ "\nOptional Color Variable:", |
||||
| 386 | -+ | ! |
- ),+ input$`color-sample_var`, |
|||
| 387 | ! |
- do.call("span", as.list(label_modal_footer)),
+ "\nX-axis PC:", |
||||
| 388 | ! |
- footer = tagList(+ input$x_var, |
||||
| 389 | ! |
- modalButton("Cancel"),
+ "\nY-axis PC:", |
||||
| 390 | ! |
- actionButton(session$ns("ok_button"), "OK")
+ input$y_var, |
||||
| 391 | -+ | ! |
- )+ "\nUse Top Variance Genes:", |
|||
| 392 | -+ | ! |
- )+ input$filter_top, |
|||
| 393 | -+ | ! |
- }+ "\nNumber of Top Genes:", |
|||
| 394 | -+ | ! |
-
+ input$n_top, |
|||
| 395 | -+ | ! |
- # Show modal when the text button is clicked.+ "\nShow Variance %:", |
|||
| 396 | ! |
- observeEvent(input$text_button, {
+ input$var_pct, |
||||
| 397 | ! |
- gene_choices <- gene_choices()+ "\nShow Matrix:", |
||||
| 398 | ! |
- example_list <- hermes::h_short_list(utils::head(setdiff(gene_choices$name, "")))+ input$show_matrix, |
||||
| 399 | ! |
- showModal(dataModal(example_list))+ "\nShow Label:", |
||||
| 400 | -+ | ! |
- })+ input$label |
|||
| 401 |
-
+ ) |
|||||
| 402 | -+ | ! |
- # When OK button is pressed, attempt to parse the genes from the text.+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|||
| 403 | -+ | ! |
- # This can be IDs and/or names of genes.+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|||
| 404 | -+ | ! |
- # Remove the modal and display notification message.+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|||
| 405 | ! |
- observeEvent(input$ok_button, {
+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
||||
| 406 | -! | +
- gene_text <- input$gene_text+ } else {
|
||||
| 407 | ! |
- gene_choices <- gene_choices()+ paste(encodings_list, collapse = " ") |
||||
| 408 |
-
+ } |
|||||
| 409 | ! |
- if (!nzchar(gene_text)) {
+ card$append_text(final_encodings, style = "verbatim") |
||||
| 410 | ! |
- showNotification(+ card$append_text("Plot", "header3")
|
||||
| 411 | ! |
- "Please enter at least one full gene ID.",+ card$append_plot(plot_pca(), dim = pws_pca$dim()) |
||||
| 412 | ! |
- type = "error"+ card$append_text("Table", "header3")
|
||||
| 413 | -+ | ! |
- )+ card$append_table(show_matrix_pca()) |
|||
| 414 |
- } else {
+ } else {
|
|||||
| 415 | ! |
- words <- h_extract_words(gene_text)+ encodings_list <- list( |
||||
| 416 | ! |
- parse_result <- h_parse_genes(words, choices = gene_choices)+ "Experiment:", |
||||
| 417 | ! |
- showNotification(paste(+ input$`experiment-name`, |
||||
| 418 | ! |
- "Parsed total", nrow(parse_result), "genes from", length(words), "words"+ "\nAssay:", |
||||
| 419 | -+ | ! |
- ))+ input$`assay-name`, |
|||
| 420 | ! |
- parsed_genes(parse_result)+ "\nUse Top Variance Genes:", |
||||
| 421 | ! |
- removeModal()+ input$filter_top, |
||||
| 422 | -+ | ! |
- }+ "\nNumber of Top Genes:", |
|||
| 423 | -+ | ! |
- })+ input$top_n, |
|||
| 424 | -+ | ! |
-
+ "\nCluster Columns:", |
|||
| 425 | -+ | ! |
- # When the gene choice is updated, then also set the names+ paste0(input$cluster_columns, collapse = ", "), |
|||
| 426 | -+ | ! |
- # correctly by looking up in current choices.+ "\nShow Matrix:", |
|||
| 427 | ! |
- named_genes <- eventReactive(input$genes, ignoreNULL = FALSE, {
+ input$show_matrix |
||||
| 428 | -! | +
- genes <- input$genes+ ) |
||||
| 429 | ! |
- gene_choices <- gene_choices()+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
||||
| 430 | ! |
- ret <- if (!is.null(genes)) {
+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
||||
| 431 | ! |
- which_id <- match(genes, gene_choices$id)+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
||||
| 432 | ! |
- gene_names <- gene_choices$name[which_id]+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
||||
| 433 | -! | +
- stats::setNames(genes, gene_names)+ } else {
|
||||
| 434 | -+ | ! |
- } else {
+ paste(encodings_list, collapse = " ") |
|||
| 435 | -! | +
- NULL+ } |
||||
| 436 |
- }+ |
|||||
| 437 | ! |
- ret+ card$append_text(final_encodings, style = "verbatim") |
||||
| 438 | -+ | ! |
- })+ card$append_text("Plot", "header3")
|
|||
| 439 | -+ | ! |
-
+ card$append_plot(plot_cor()) |
|||
| 440 | ! |
- reactive({
+ card$append_plot(plot_cor(), dim = pws_cor$dim()) |
||||
| 441 | ! |
- hermes::gene_spec(+ card$append_text("Table", "header3")
|
||||
| 442 | ! |
- genes = named_genes(),+ card$append_table(show_matrix_cor()) |
||||
| 443 | -! | +
- fun = funs[[input$fun_name]],+ } |
||||
| 444 | ! |
- fun_name = input$fun_name+ if (!comment == "") {
|
||||
| 445 | -+ | ! |
- )+ card$append_text("Comment", "header3")
|
|||
| 446 | -+ | ! |
- })+ card$append_text(comment) |
|||
| 447 |
- })+ } |
|||||
| 448 | -+ | ! |
- }+ card |
|||
| 449 |
-
+ } |
|||||
| 450 | -+ | ! |
- #' Validation of Gene Specification+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|||
| 451 |
- #'+ } |
|||||
| 452 |
- #' @description `r lifecycle::badge("experimental")`
+ ### |
|||||
| 453 |
- #'+ }) |
|||||
| 454 |
- #' This validation function checks that a given [`hermes::GeneSpec`] has at least+ } |
|||||
| 455 |
- #' one gene selected and that all genes are included in possible choices.+ |
|||||
| 456 |
- #'+ #' @describeIn tm_g_pca sample module function. |
|||||
| 457 |
- #' @param gene_spec (`GeneSpec`)\cr gene specification.+ #' @export |
|||||
| 458 |
- #' @param gene_choices (`character`)\cr all possible gene choices.+ #' @examples |
|||||
| 460 |
- #' @export+ #' # Alternatively you can run the sample module with this function call: |
|||||
| 461 |
- validate_gene_spec <- function(gene_spec,+ #' if (interactive()) {
|
|||||
| 462 |
- gene_choices) {
+ #' sample_tm_g_pca() |
|||||
| 463 | -! | +
- assert_r6(gene_spec, "GeneSpec")+ #' } |
||||
| 464 | -! | +
- assert_character(gene_choices)+ sample_tm_g_pca <- function(.test = FALSE) {
|
||||
| 465 | -+ | ! |
-
+ data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment) |
|||
| 466 | ! |
- validate(need(+ app <- teal::init( |
||||
| 467 | ! |
- !is.null(gene_spec$get_genes()),+ data = data, |
||||
| 468 | ! |
- "please select at least one gene"+ modules = teal::modules( |
||||
| 469 | -+ | ! |
- ))+ tm_g_pca( |
|||
| 470 | ! |
- genes_not_included <- setdiff(gene_spec$get_genes(), gene_choices)+ label = "pca", |
||||
| 471 | ! |
- n_not_incl <- length(genes_not_included)+ mae_name = "MAE", |
||||
| 472 | ! |
- validate(need(+ .test = .test |
||||
| 473 | -! | +
- identical(n_not_incl, 0L),+ ) |
||||
| 474 | -! | +
- paste(+ ) |
||||
| 475 | -! | +
- n_not_incl,+ ) |
||||
| 476 | ! |
- ifelse(n_not_incl > 1, "genes", "gene"),- |
- ||||
| 477 | -! | -
- hermes::h_parens(hermes::h_short_list(genes_not_included)),- |
- ||||
| 478 | -! | -
- "not included, please unlock or change filters"- |
- ||||
| 479 | -- |
- )- |
- ||||
| 480 | -- |
- ))+ shinyApp(app$ui, app$server) |
||||
| 481 | +477 |
}@@ -22607,1782 +23168,1901 @@ teal.modules.hermes coverage - 26.11% | 56 |
- plot_width = c(1360L, 500L, 2000L)) {
+ plot_width = c(1360L, 500L, 2000L), |
||
| 57 | ++ |
+ .test = FALSE) {
+ |
+ ||||
| 58 | ! |
message("Initializing tm_g_forest_tte")
|
||||
| 58 | +59 | ! |
assert_string(label) |
|||
| 59 | +60 | ! |
assert_string(adtte_name) |
|||
| 60 | +61 | ! |
assert_string(mae_name) |
|||
| 61 | +62 | ! |
assert_adtte_vars(adtte_vars) |
|||
| 62 | +63 | ! |
assert_character(exclude_assays, any.missing = FALSE) |
|||
| 63 | +64 | ! |
assert_summary_funs(summary_funs) |
|||
| 64 | +65 | ! |
assert_tag(pre_output, null.ok = TRUE) |
|||
| 65 | +66 | +! | +
+ assert_tag(post_output, null.ok = TRUE)+ |
+ |||
| 67 | ! |
- assert_tag(post_output, null.ok = TRUE)+ assert_flag(.test) |
||||
| 66 | +68 | |||||
| 67 | +69 | ! |
teal::module( |
|||
| 68 | +70 | ! |
label = label, |
|||
| 69 | +71 | ! |
server = srv_g_forest_tte, |
|||
| 70 | +72 | ! |
server_args = list( |
|||
| 71 | +73 | ! |
adtte_name = adtte_name, |
|||
| 72 | +74 | ! |
mae_name = mae_name, |
|||
| 73 | +75 | ! |
adtte_vars = adtte_vars, |
|||
| 74 | +76 | ! |
exclude_assays = exclude_assays, |
|||
| 75 | +77 | ! |
summary_funs = summary_funs, |
|||
| 76 | +78 | ! |
plot_height = plot_height, |
|||
| 77 | +79 | +! | +
+ plot_width = plot_width,+ |
+ |||
| 80 | ! |
- plot_width = plot_width+ .test = .test |
||||
| 78 | +81 |
), |
||||
| 79 | +82 | ! |
ui = ui_g_forest_tte, |
|||
| 80 | +83 | ! |
ui_args = list( |
|||
| 81 | +84 | ! |
adtte_name = adtte_name, |
|||
| 82 | +85 | ! |
mae_name = mae_name, |
|||
| 83 | +86 | ! |
summary_funs = summary_funs, |
|||
| 84 | +87 | ! |
pre_output = pre_output, |
|||
| 85 | +88 | ! |
- post_output = post_output+ post_output = post_output,+ |
+ |||
| 89 | +! | +
+ .test = .test |
||||
| 86 | +90 |
), |
||||
| 87 | +91 | ! |
datanames = c(adtte_name, mae_name) |
|||
| 88 | +92 |
) |
||||
| 89 | +93 |
} |
||||
| 90 | +94 | |||||
| 91 | +95 |
#' @describeIn tm_g_forest_tte sets up the user interface. |
||||
| 92 | +96 |
#' @inheritParams module_arguments |
||||
| 93 | +97 |
#' @export |
||||
| 94 | +98 |
ui_g_forest_tte <- function(id, |
||||
| 95 | +99 |
adtte_name, |
||||
| 96 | +100 |
mae_name, |
||||
| 97 | +101 |
summary_funs, |
||||
| 98 | +102 |
pre_output, |
||||
| 99 | +103 | ++ |
+ post_output,+ |
+ |||
| 104 |
- post_output) {
+ .test = FALSE) {
|
|||||
| 100 | +105 | 1x |
ns <- NS(id) |
|||
| 101 | +106 | 1x |
teal.widgets::standard_layout( |
|||
| 102 | +107 | 1x |
encoding = tags$div( |
|||
| 103 | +108 |
### Reporter |
||||
| 104 | +109 | 1x |
teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|||
| 105 | +110 |
### |
||||
| 106 | +111 | 1x |
tags$label("Encodings", class = "text-primary"),
|
|||
| 107 | +112 | 1x |
helpText("Analysis of MAE:", tags$code(mae_name)),
|
|||
| 108 | +113 | 1x |
uiOutput(ns("experiment_ui")),
|
|||
| 109 | +114 | 1x |
assaySpecInput(ns("assay")),
|
|||
| 110 | +115 | 1x |
geneSpecInput(ns("genes"), summary_funs),
|
|||
| 111 | +116 | 1x |
helpText("Analysis of ADTTE:", tags$code(adtte_name)),
|
|||
| 112 | +117 | 1x |
adtteSpecInput(ns("adtte")),
|
|||
| 113 | +118 | 1x |
teal.widgets::panel_group( |
|||
| 114 | +119 | 1x |
teal.widgets::panel_item( |
|||
| 115 | +120 | 1x |
input_id = "settings_item", |
|||
| 116 | +121 | 1x |
collapsed = TRUE, |
|||
| 117 | +122 | 1x |
title = "Additional Settings", |
|||
| 118 | +123 | 1x |
sliderInput(ns("probs"), label = ("Probability Cutoff"), min = 0.01, max = 0.99, value = 0.5),
|
|||
| 119 | +124 | 1x |
sampleVarSpecInput(ns("subgroups"), "Select Categorical Subgroup Variable")
|
|||
| 120 | +125 |
) |
||||
| 121 | +126 |
) |
||||
| 122 | +127 |
), |
||||
| 123 | +128 | 1x |
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ output = div( |
|||
| 124 | +129 | +1x | +
+ if (.test) verbatimTextOutput(ns("table")) else NULL,
+ |
+ |||
| 130 | +1x | +
+ teal.widgets::plot_with_settings_ui(ns("plot"))
+ |
+ ||||
| 131 | ++ |
+ ),+ |
+ ||||
| 132 | 1x |
pre_output = pre_output, |
||||
| 125 | +133 | 1x |
post_output = post_output |
|||
| 126 | +134 |
) |
||||
| 127 | +135 |
} |
||||
| 128 | +136 | |||||
| 129 | +137 |
#' @describeIn tm_g_forest_tte sets up the server with reactive graph. |
||||
| 130 | +138 |
#' @inheritParams module_arguments |
||||
| 131 | +139 |
#' @export |
||||
| 132 | +140 |
srv_g_forest_tte <- function(id, |
||||
| 133 | +141 |
data, |
||||
| 134 | +142 |
filter_panel_api, |
||||
| 135 | +143 |
reporter, |
||||
| 136 | +144 |
adtte_name, |
||||
| 137 | +145 |
mae_name, |
||||
| 138 | +146 |
adtte_vars, |
||||
| 139 | +147 |
exclude_assays, |
||||
| 140 | +148 |
summary_funs, |
||||
| 141 | +149 |
plot_height, |
||||
| 142 | +150 | ++ |
+ plot_width,+ |
+ |||
| 151 |
- plot_width) {
+ .test = FALSE) {
|
|||||
| 143 | +152 | ! |
with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|||
| 144 | +153 | ! |
assert_class(filter_panel_api, "FilterPanelAPI") |
|||
| 145 | +154 | ! |
checkmate::assert_class(data, "reactive") |
|||
| 146 | +155 | ! |
checkmate::assert_class(shiny::isolate(data()), "teal_data") |
|||
| 147 | +156 | |||||
| 148 | +157 | ! |
moduleServer(id, function(input, output, session) {
|
|||
| 149 | +158 | ! |
output$experiment_ui <- renderUI({
|
|||
| 150 | +159 | ! |
experimentSpecInput(session$ns("experiment"), data, mae_name)
|
|||
| 151 | +160 |
}) |
||||
| 152 | +161 | ! |
experiment <- experimentSpecServer( |
|||
| 153 | +162 | ! |
"experiment", |
|||
| 154 | +163 | ! |
data = data, |
|||
| 155 | +164 | ! |
filter_panel_api = filter_panel_api, |
|||
| 156 | +165 | ! |
mae_name = mae_name |
|||
| 157 | +166 |
) |
||||
| 158 | +167 | ! |
assay <- assaySpecServer( |
|||
| 159 | +168 | ! |
"assay", |
|||
| 160 | +169 | ! |
assays = experiment$assays, |
|||
| 161 | +170 | ! |
exclude_assays = exclude_assays |
|||
| 162 | +171 |
) |
||||
| 163 | +172 | ! |
genes <- geneSpecServer( |
|||
| 164 | +173 | ! |
"genes", |
|||
| 165 | +174 | ! |
funs = summary_funs, |
|||
| 166 | +175 | ! |
gene_choices = experiment$genes |
|||
| 167 | +176 |
) |
||||
| 168 | +177 | ! |
subgroups <- sampleVarSpecServer( |
|||
| 169 | +178 | ! |
"subgroups", |
|||
| 170 | +179 | ! |
experiment_name = experiment$name, |
|||
| 171 | +180 | ! |
original_data = experiment$data, |
|||
| 172 | +181 | ! |
categorical_only = TRUE, |
|||
| 173 | +182 | ! |
explicit_na = TRUE |
|||
| 174 | +183 |
) |
||||
| 175 | +184 | ! |
adtte <- adtteSpecServer( |
|||
| 176 | +185 | ! |
"adtte", |
|||
| 177 | +186 | ! |
data = data, |
|||
| 178 | +187 | ! |
adtte_name = adtte_name, |
|||
| 179 | +188 | ! |
mae_name = mae_name, |
|||
| 180 | +189 | ! |
adtte_vars = adtte_vars, |
|||
| 181 | +190 | ! |
experiment_data = subgroups$experiment_data, |
|||
| 182 | +191 | ! |
experiment_name = experiment$name, |
|||
| 183 | +192 | ! |
assay = assay, |
|||
| 184 | +193 | ! |
genes = genes, |
|||
| 185 | +194 | ! |
probs = reactive({
|
|||
| 186 | +195 | ! |
input$probs |
|||
| 187 | +196 |
}) |
||||
| 188 | +197 |
) |
||||
| 189 | +198 | |||||
| 190 | +199 | ! |
surv_subgroups <- reactive({
|
|||
| 191 | +200 | ! |
binned_adtte <- adtte$binned_adtte_subset() |
|||
| 192 | +201 | ! |
subgroups_var <- subgroups$sample_var() |
|||
| 193 | +202 | |||||
| 194 | +203 | ! |
tern::extract_survival_subgroups( |
|||
| 195 | +204 | ! |
variables = list( |
|||
| 196 | +205 | ! |
tte = adtte_vars$aval, |
|||
| 197 | +206 | ! |
is_event = adtte_vars$is_event, |
|||
| 198 | +207 | ! |
arm = adtte$gene_factor, |
|||
| 199 | +208 | ! |
subgroups = subgroups_var |
|||
| 200 | +209 |
), |
||||
| 201 | +210 | ! |
label_all = "All Patients", |
|||
| 202 | +211 | ! |
data = binned_adtte |
|||
| 203 | +212 |
) |
||||
| 204 | +213 |
}) |
||||
| 205 | +214 | |||||
| 206 | +215 | ! |
result <- reactive({
|
|||
| 207 | +216 | ! |
surv_subgroups <- surv_subgroups() |
|||
| 208 | +217 | ! |
lyt <- rtables::basic_table() |
|||
| 209 | +218 | ! |
time_unit <- adtte$time_unit() |
|||
| 210 | +219 | |||||
| 211 | +220 | ! |
tern::tabulate_survival_subgroups( |
|||
| 212 | +221 | ! |
lyt = lyt, |
|||
| 213 | +222 | ! |
df = surv_subgroups, |
|||
| 214 | +223 | ! |
vars = c("n_tot_events", "n", "n_events", "median", "hr", "ci"),
|
|||
| 215 | +224 | ! |
time_unit = time_unit |
|||
| 216 | +225 |
) |
||||
| 217 | +226 |
}) |
||||
| 218 | +227 | |||||
| 219 | +228 | ! |
forest_plot <- reactive({
|
|||
| 220 | +229 | ! |
- result <- result()+ res <- result() |
|||
| 221 | +230 | ! |
- tern::g_forest(result)+ tern::g_forest(res) |
|||
| 222 | +231 |
}) |
||||
| 223 | +232 | |||||
| 224 | +233 | ! |
pws <- teal.widgets::plot_with_settings_srv( |
|||
| 225 | +234 | ! |
id = "plot", |
|||
| 226 | +235 | ! |
plot_r = forest_plot, |
|||
| 227 | +236 | ! |
height = plot_height, |
|||
| 228 | +237 | ! |
width = plot_width |
|||
| 229 | +238 |
) |
||||
| 230 | +239 | ++ | + + | +|||
| 240 | +! | +
+ if (.test) {
+ |
+ ||||
| 241 | +! | +
+ table_r <- reactive({
+ |
+ ||||
| 242 | +! | +
+ rtables::as_result_df(result())+ |
+ ||||
| 243 | ++ |
+ })+ |
+ ||||
| 244 | +! | +
+ output$table <- renderPrint(table_r())+ |
+ ||||
| 245 | ++ |
+ }+ |
+ ||||
| 246 | ||||||
| 231 | +247 |
### REPORTER |
||||
| 232 | +248 | ! |
if (with_reporter) {
|
|||
| 233 | +249 | ! |
card_fun <- function(comment, label) {
|
|||
| 234 | +250 | ! |
card <- report_card_template( |
|||
| 235 | +251 | ! |
title = "Forest Plot", |
|||
| 236 | +252 | ! |
label = label, |
|||
| 237 | +253 | ! |
with_filter = TRUE, |
|||
| 238 | +254 | ! |
filter_panel_api = filter_panel_api |
|||
| 239 | +255 |
) |
||||
| 240 | +256 | ! |
card$append_text("Selected Options", "header3")
|
|||
| 241 | +257 | ! |
encodings_list <- list( |
|||
| 242 | +258 | ! |
"Experiment:", |
|||
| 243 | +259 | ! |
input$`experiment-name`, |
|||
| 244 | +260 | ! |
"\nAssay:", |
|||
| 245 | +261 | ! |
input$`assay-name`, |
|||
| 246 | +262 | ! |
"\nGenes Selected:", |
|||
| 247 | +263 | ! |
paste0(genes()$get_gene_labels(), collapse = ", "), |
|||
| 248 | +264 | ! |
"\nGene Summary:", |
|||
| 249 | +265 | ! |
input$`genes-fun_name`, |
|||
| 250 | +266 | ! |
"\nEndpoint:", |
|||
| 251 | +267 | ! |
input$`adtte-paramcd`, |
|||
| 252 | +268 | ! |
"\nProbability Cutoff:", |
|||
| 253 | +269 | ! |
input$probs, |
|||
| 254 | +270 | ! |
"\nSubgroup Variable:", |
|||
| 255 | +271 | ! |
input$`subgroups-sample_var` |
|||
| 256 | +272 |
) |
||||
| 257 | +273 | ! |
null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|||
| 258 | +274 | ! |
final_encodings <- if (length(null_encodings_indices) > 0) {
|
|||
| 259 | +275 | ! |
null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|||
| 260 | +276 | ! |
paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|||
| 261 | +277 |
} else {
|
||||
| 262 | +278 | ! |
paste(encodings_list, collapse = " ") |
|||
| 263 | +279 |
} |
||||
| 264 | +280 | |||||
| 265 | +281 | ! |
card$append_text(final_encodings, style = "verbatim") |
|||
| 266 | +282 | ! |
card$append_text("Plot", "header3")
|
|||
| 267 | +283 | ! |
card$append_plot(forest_plot(), dim = pws$dim()) |
|||
| 268 | +284 | ! |
if (!comment == "") {
|
|||
| 269 | +285 | ! |
card$append_text("Comment", "header3")
|
|||
| 270 | +286 | ! |
card$append_text(comment) |
|||
| 271 | +287 |
} |
||||
| 272 | +288 | ! |
card |
|||
| 273 | +289 |
} |
||||
| 274 | +290 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|||
| 275 | +291 |
} |
||||
| 276 | +292 |
### |
||||
| 277 | +293 |
}) |
||||
| 278 | +294 |
} |
||||
| 279 | +295 | |||||
| 280 | +296 |
#' @describeIn tm_g_forest_tte sample module function. |
||||
| 281 | +297 |
#' @export |
||||
| 282 | +298 |
#' @examples |
||||
| 283 | +299 |
#' |
||||
| 284 | +300 |
#' # Alternatively you can run the sample module with this function call: |
||||
| 285 | +301 |
#' if (interactive()) {
|
||||
| 286 | +302 |
#' sample_tm_g_forest_tte() |
||||
| 287 | +303 |
#' } |
||||
| 288 | +304 |
- sample_tm_g_forest_tte <- function() { # nolint
+ sample_tm_g_forest_tte <- function(.test = FALSE) { # nolint
|
||||
| 289 | +305 | ! |
data <- teal_data() |
|||
| 290 | +306 | ! |
data <- within(data, {
|
|||
| 291 | +307 | ! |
ADTTE <- teal.modules.hermes::rADTTE %>% # nolint |
|||
| 292 | +308 | ! |
dplyr::mutate(is_event = .data$CNSR == 0) |
|||
| 293 | +309 | ! |
MAE <- hermes::multi_assay_experiment # nolint |
|||
| 294 | +310 |
}) |
||||
| 295 | +311 | ! |
datanames <- c("ADTTE", "MAE")
|
|||
| 296 | +312 | ! |
datanames(data) <- datanames |
|||
| 297 | +313 | ! |
join_keys(data)["ADTTE", "ADTTE"] <- c("STUDYID", "USUBJID", "PARAMCD")
|
|||
| 298 | +314 | |||||
| 299 | +315 | ! |
app <- teal::init( |
|||
| 300 | +316 | ! |
data = data, |
|||
| 301 | +317 | ! |
modules = teal::modules( |
|||
| 302 | +318 | ! |
tm_g_forest_tte( |
|||
| 303 | +319 | ! |
label = "forest", |
|||
| 304 | +320 | ! |
adtte_name = "ADTTE", |
|||
| 305 | +321 | +! | +
+ mae_name = "MAE",+ |
+ |||
| 322 | ! |
- mae_name = "MAE"+ .test = .test |
||||
| 306 | +323 |
) |
||||
| 307 | +324 |
) |
||||
| 308 | +325 |
) |
||||
| 309 | +326 | ! |
shinyApp(app$ui, app$server) |
|||
| 310 | +327 |
}@@ -24391,14 +25071,14 @@ teal.modules.hermes coverage - 26.11% |
| 1 |
- #' Module Input for Sample Variable Specification+ #' Teal Module for RNA-seq Scatterplot |
||
| 5 |
- #' This defines the input for the sample variable specification.+ #' This module provides an interactive scatterplot for RNA-seq gene expression |
||
| 6 |
- #'+ #' analysis. |
||
| 7 |
- #' @inheritParams module_arguments+ #' |
||
| 8 |
- #' @param label_vars (`string`)\cr label for the sample variable selection.+ #' @inheritParams module_arguments |
||
| 9 |
- #' @param label_levels_button (`string`)\cr label for the levels combination button.+ #' |
||
| 10 |
- #'+ #' @return Shiny module to be used in the teal app. |
||
| 11 |
- #' @return The UI part.+ #' |
||
| 12 |
- #' @seealso [sampleVarSpecServer()] for the module server and a complete example.+ #' @export |
||
| 13 |
- #' @export+ #' |
||
| 14 |
- #'+ #' @examples |
||
| 15 |
- #' @examples+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 16 |
- #' sampleVarSpecInput("my_vars", label_vars = "Select faceting variable")
+ #' app <- init( |
||
| 17 |
- sampleVarSpecInput <- function(inputId, # nolint+ #' data = data, |
||
| 18 |
- label_vars = "Select sample variable",+ #' modules = modules( |
||
| 19 |
- label_levels_button = "Combine factor levels") {
+ #' tm_g_scatterplot( |
||
| 20 | -4x | +
- assert_string(inputId)+ #' label = "scatterplot", |
|
| 21 | -4x | +
- assert_string(label_vars)+ #' mae_name = "MAE" |
|
| 22 | -4x | +
- assert_string(label_levels_button)+ #' ) |
|
| 23 |
-
+ #' ) |
||
| 24 | -4x | +
- ns <- NS(inputId)+ #' ) |
|
| 25 | -4x | +
- tagList(+ #' if (interactive()) {
|
|
| 26 | -4x | +
- include_css_files(pattern = "*"),+ #' shinyApp(app$ui, app$server) |
|
| 27 | -4x | +
- tags$div(+ #' } |
|
| 28 | -4x | +
- class = "row",+ tm_g_scatterplot <- function(label, |
|
| 29 | -4x | +
- tags$div(+ mae_name, |
|
| 30 | -4x | +
- class = "col-sm-8",+ exclude_assays = "counts", |
|
| 31 | -4x | +
- tags$label(+ summary_funs = list( |
|
| 32 | -4x | +
- class = "control-label",+ Mean = colMeans, |
|
| 33 | -4x | +
- label_vars+ Median = matrixStats::colMedians, |
|
| 34 |
- )+ Max = matrixStats::colMaxs |
||
| 35 |
- ),+ ), |
||
| 36 | -4x | +
- tags$div(+ pre_output = NULL, |
|
| 37 | -4x | +
- class = "col-sm-4",+ post_output = NULL, |
|
| 38 | -4x | +
- actionButton(+ .test = FALSE) {
|
|
| 39 | -4x | +! |
- ns("levels_button"),
+ message("Initializing tm_g_scatterplot")
|
| 40 | -4x | +! |
- tags$span(icon("fas fa-table")),
+ assert_string(label) |
| 41 | -4x | +! |
- title = label_levels_button,+ assert_string(mae_name) |
| 42 | -4x | +! |
- class = "pull-right list-genes"+ assert_character(exclude_assays, any.missing = FALSE) |
| 43 | -+ | ! |
- )+ assert_summary_funs(summary_funs) |
| 44 | -+ | ! |
- )+ assert_tag(pre_output, null.ok = TRUE) |
| 45 | -+ | ! |
- ),+ assert_tag(post_output, null.ok = TRUE) |
| 46 | -4x | +
- tags$div(+ |
|
| 47 | -4x | +! |
- class = "custom-select-input",+ teal::module( |
| 48 | -4x | +! |
- teal.widgets::optionalSelectInput(+ label = label, |
| 49 | -4x | +! |
- ns("sample_var"),
+ server = srv_g_scatterplot, |
| 50 | -4x | +! |
- label = NULL,+ server_args = list( |
| 51 | -4x | +! |
- choices = "",+ mae_name = mae_name, |
| 52 | -4x | +! |
- multiple = FALSE+ summary_funs = summary_funs, |
| 53 | -+ | ! |
- )+ exclude_assays = exclude_assays, |
| 54 | -+ | ! |
- )+ .test = .test |
| 55 |
- )+ ), |
||
| 56 | -+ | ! |
- }+ ui = ui_g_scatterplot, |
| 57 | -+ | ! |
-
+ ui_args = list( |
| 58 | -+ | ! |
- #' Helper Function For Group List Creation+ mae_name = mae_name, |
| 59 | -+ | ! |
- #'+ summary_funs = summary_funs, |
| 60 | -+ | ! |
- #' @description `r lifecycle::badge("experimental")`
+ pre_output = pre_output, |
| 61 | -+ | ! |
- #'+ post_output = post_output, |
| 62 | -+ | ! |
- #' This helper function takes an assignment list and converts it to a+ .test = .test |
| 63 |
- #' group list.+ ), |
||
| 64 | -+ | ! |
- #'+ datanames = mae_name |
| 65 |
- #' @param x (named `list` of `character`)\cr input assignment list.+ ) |
||
| 66 |
- #' @return A combination list.+ } |
||
| 67 |
- #'+ |
||
| 68 |
- #' @export+ #' @describeIn tm_g_scatterplot sets up the user interface. |
||
| 69 |
- #'+ #' @inheritParams module_arguments |
||
| 70 |
- #' @examples+ #' @export |
||
| 71 |
- #' assign_list <- list(+ ui_g_scatterplot <- function(id, |
||
| 72 |
- #' "ASIAN" = "1",+ mae_name, |
||
| 73 |
- #' "BLACK OR AFRICAN AMERICAN" = "1",+ summary_funs, |
||
| 74 |
- #' "MULTIPLE" = "2",+ pre_output, |
||
| 75 |
- #' "UNKNOWN" = "2",+ post_output, |
||
| 76 |
- #' "WHITE" = "4"+ .test = FALSE) {
|
||
| 77 | -+ | 1x |
- #' )+ ns <- NS(id) |
| 78 |
- #' objective_list <- list(+ |
||
| 79 | -+ | 1x |
- #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
+ smooth_method_choices <- c( |
| 80 | -+ | 1x |
- #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
+ Linear = "lm", |
| 81 | -+ | 1x |
- #' "WHITE" = "WHITE"+ Loess = "loess", |
| 82 | -+ | 1x |
- #' )+ None = "none" |
| 83 |
- #' result_list <- h_assign_to_group_list(assign_list)+ ) |
||
| 84 |
- #' stopifnot(identical(result_list, objective_list))+ |
||
| 85 | -+ | 1x |
- h_assign_to_group_list <- function(x) {
+ teal.widgets::standard_layout( |
| 86 | -2x | +1x |
- assert_list(+ encoding = tags$div( |
| 87 | -2x | +
- x,+ ### Reporter |
|
| 88 | -2x | +1x |
- types = "character",+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 89 | -2x | +
- any.missing = FALSE,+ ### |
|
| 90 | -2x | +1x |
- names = "unique",+ tags$label("Encodings", class = "text-primary"),
|
| 91 | -2x | +1x |
- unique = FALSE+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
| 92 | -+ | 1x |
- )+ uiOutput(ns("experiment_ui")),
|
| 93 | -2x | +1x |
- x_vec <- unlist(x)+ assaySpecInput(ns("assay")),
|
| 94 | -2x | +1x |
- x_split <- split(names(x_vec), x_vec)+ geneSpecInput(ns("x_spec"), summary_funs, label_genes = "Select x Gene(s)"),
|
| 95 | -2x | +1x |
- new_levels <- sapply(x_split, hermes::h_short_list, sep = "/")+ geneSpecInput(ns("y_spec"), summary_funs, label_genes = "Select y Gene(s)"),
|
| 96 | -2x | +1x |
- stats::setNames(x_split, new_levels)+ teal.widgets::panel_group( |
| 97 | -+ | 1x |
- }+ teal.widgets::panel_item( |
| 98 | -+ | 1x |
-
+ input_id = "settings_item", |
| 99 | -+ | 1x |
- #' Helper Function for Collapsing of Factor Levels+ collapsed = TRUE, |
| 100 | -+ | 1x |
- #'+ title = "Additional Settings", |
| 101 | -+ | 1x |
- #' @description `r lifecycle::badge("experimental")`
+ sampleVarSpecInput(ns("color_var"), "Optional color variable"),
|
| 102 | -+ | 1x |
- #'+ sampleVarSpecInput(ns("facet_var"), "Optional facet variable"),
|
| 103 | -+ | 1x |
- #' Given a group list and a factor, this helper function collapses the+ selectInput(ns("smooth_method"), "Select smoother", smooth_method_choices)
|
| 104 |
- #' levels in the factor accordingly and also ensures that the resulting+ ) |
||
| 105 |
- #' levels are in the order given in the group list.+ ) |
||
| 106 |
- #'+ ), |
||
| 107 | -+ | 1x |
- #' @param x (`factor`)\cr original factor.+ output = div( |
| 108 | -+ | 1x |
- #' @param group_list (named `list` of `character`)\cr includes the collapsing+ if (.test) verbatimTextOutput(ns("table")) else NULL,
|
| 109 | -+ | 1x |
- #' specification.+ teal.widgets::plot_with_settings_ui(ns("plot"))
|
| 110 |
- #'+ ), |
||
| 111 | -+ | 1x |
- #' @return The transformed factor `x` with new levels.+ pre_output = pre_output, |
| 112 | -+ | 1x |
- #' @export+ post_output = post_output |
| 113 |
- #'+ ) |
||
| 114 |
- #' @examples+ } |
||
| 115 |
- #' set.seed(123)+ |
||
| 116 |
- #' x <- factor(sample(+ #' @describeIn tm_g_scatterplot sets up the server with reactive graph. |
||
| 117 |
- #' c("ASIAN", "BLACK OR AFRICAN AMERICAN", "MULTIPLE", "UNKNOWN", "WHITE"),
+ #' @inheritParams module_arguments |
||
| 118 |
- #' size = 30L,+ #' @export |
||
| 119 |
- #' replace = TRUE+ srv_g_scatterplot <- function(id, |
||
| 120 |
- #' ))+ data, |
||
| 121 |
- #' group_list <- list(+ filter_panel_api, |
||
| 122 |
- #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
+ reporter, |
||
| 123 |
- #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
+ mae_name, |
||
| 124 |
- #' "WHITE" = "WHITE"+ exclude_assays, |
||
| 125 |
- #' )+ summary_funs, |
||
| 126 |
- #' x_collapsed <- h_collapse_levels(x, group_list)+ .test = FALSE) {
|
||
| 127 | -+ | ! |
- #' stopifnot(identical(levels(x_collapsed), names(group_list)))+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 128 | -+ | ! |
- h_collapse_levels <- function(x, group_list) {
+ assert_class(filter_panel_api, "FilterPanelAPI") |
| 129 | -3x | +! |
- assert_factor(x)+ checkmate::assert_class(data, "reactive") |
| 130 | -2x | +! |
- assert_list(group_list, names = "unique", types = "character")+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 131 | -1x | +
- x_collapsed <- do.call(+ |
|
| 132 | -1x | +! |
- forcats::fct_collapse,+ moduleServer(id, function(input, output, session) {
|
| 133 | -1x | +! |
- args = c(+ output$experiment_ui <- renderUI({
|
| 134 | -1x | +! |
- list(.f = x),+ experimentSpecInput(session$ns("experiment"), data, mae_name)
|
| 135 | -1x | +
- group_list+ }) |
|
| 136 | -+ | ! |
- )+ experiment <- experimentSpecServer( |
| 137 | -+ | ! |
- )+ "experiment", |
| 138 | -1x | +! |
- factor(x_collapsed, levels = names(group_list))+ data = data, |
| 139 | -+ | ! |
- }+ filter_panel_api = filter_panel_api, |
| 140 | -+ | ! |
-
+ mae_name = mae_name |
| 141 |
- #' Validation of Number of Levels+ ) |
||
| 142 | -+ | ! |
- #'+ assay <- assaySpecServer( |
| 143 | -+ | ! |
- #' @description `r lifecycle::badge("experimental")`
+ "assay", |
| 144 | -+ | ! |
- #'+ assays = experiment$assays, |
| 145 | -+ | ! |
- #' This validation function checks that a given vector `x` is a factor with+ exclude_assays = exclude_assays |
| 146 |
- #' the specified number of levels.+ ) |
||
| 147 | -+ | ! |
- #'+ sample_var_specs <- multiSampleVarSpecServer( |
| 148 | -+ | ! |
- #' @param x (`factor`)\cr factor to validate.+ inputIds = c("facet_var", "color_var"),
|
| 149 | -+ | ! |
- #' @param name (`string`)\cr name of `x` in the app.+ experiment_name = experiment$name, |
| 150 | -+ | ! |
- #' @param n_levels (`count`)\cr required number of factor levels in `x`.+ original_data = experiment$data |
| 151 |
- #'+ ) |
||
| 152 | -+ | ! |
- #' @export+ x_spec <- geneSpecServer("x_spec", summary_funs, experiment$genes)
|
| 153 | -+ | ! |
- validate_n_levels <- function(x, name, n_levels) {
+ y_spec <- geneSpecServer("y_spec", summary_funs, experiment$genes)
|
| 154 | -3x | +
- validate(need(+ |
|
| 155 | -3x | +! |
- is.factor(x),+ plot_r <- reactive({
|
| 156 | -3x | +
- paste("Variable", name, "is not a factor but a", class(x))
+ # Resolve all reactivity. |
|
| 157 | -+ | ! |
- ))+ experiment_data <- sample_var_specs$experiment_data() |
| 158 | -2x | +! |
- assert_string(name, min.chars = 1L)+ x_spec <- x_spec() |
| 159 | -2x | +! |
- assert_count(n_levels, positive = TRUE)+ y_spec <- y_spec() |
| 160 | -2x | +! |
- validate(need(+ facet_var <- sample_var_specs$vars$facet_var() |
| 161 | -2x | +! |
- identical(n_levels, nlevels(x)),+ color_var <- sample_var_specs$vars$color_var() |
| 162 | -2x | +! |
- paste(+ assay_name <- assay() |
| 163 | -2x | +! |
- "Please combine the original levels of", name,+ smooth_method <- input$smooth_method |
| 164 | -2x | +
- "into exactly", n_levels, "levels"+ |
|
| 165 | +! | +
+ validate_gene_spec(x_spec, rownames(experiment_data))+ |
+ |
| 166 | +! | +
+ validate_gene_spec(y_spec, rownames(experiment_data))+ |
+ |
| 167 | ++ | + + | +|
| 168 | ++ |
+ # Require which states need to be truthy.+ |
+ |
| 169 | +! | +
+ req(+ |
+ |
| 170 | +! | +
+ smooth_method,+ |
+ |
| 171 | ++ |
+ # Note: The following statements are important to make sure the UI inputs have been updated.+ |
+ |
| 172 | +! | +
+ isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)),+ |
+ |
| 173 | +! | +
+ is.null(facet_var) || isTRUE(facet_var %in% names(SummarizedExperiment::colData(experiment_data))),+ |
+ |
| 174 | +! | +
+ is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))),+ |
+ |
| 175 | +! | +
+ cancelOutput = FALSE+ |
+ |
| 176 | ++ |
+ )+ |
+ |
| 177 | ++ | + + | +|
| 178 | +! | +
+ hermes::draw_scatterplot(+ |
+ |
| 179 | +! | +
+ object = experiment_data,+ |
+ |
| 180 | +! | +
+ assay_name = assay_name,+ |
+ |
| 181 | +! | +
+ x_spec = x_spec,+ |
+ |
| 182 | +! | +
+ y_spec = y_spec,+ |
+ |
| 183 | +! | +
+ facet_var = facet_var,+ |
+ |
| 184 | +! | +
+ color_var = color_var,+ |
+ |
| 185 | +! | +
+ smooth_method = smooth_method+ |
+ |
| 186 | ++ |
+ )+ |
+ |
| 187 | ++ |
+ })+ |
+ |
| 188 | +! | +
+ output$plot <- renderPlot(plot_r())+ |
+ |
| 189 | ++ | + + | +|
| 190 | +! | +
+ pws <- teal.widgets::plot_with_settings_srv(+ |
+ |
| 191 | +! | +
+ id = "plot",+ |
+ |
| 192 | +! | +
+ plot_r = plot_r+ |
+ |
| 193 |
) |
||
| 166 | +194 |
- ))+ + |
+ |
| 195 | +! | +
+ if (.test) {
+ |
+ |
| 196 | +! | +
+ output$table <- renderPrint(plot_r()) |
|
| 167 | +197 | ++ |
+ }+ |
+
| 198 | ++ | + + | +|
| 199 |
- }+ ### REPORTER+ |
+ ||
| 200 | +! | +
+ if (with_reporter) {
|
|
| 168 | -+ | ||
| 201 | +! |
-
+ card_fun <- function(comment, label) {
|
|
| 169 | -+ | ||
| 202 | +! |
- #' Module Server for Sample Variable Specification+ card <- report_card_template( |
|
| 170 | -+ | ||
| 203 | +! |
- #'+ title = "Scatter Plot", |
|
| 171 | -+ | ||
| 204 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ label = label, |
|
| 172 | -+ | ||
| 205 | +! |
- #'+ with_filter = TRUE, |
|
| 173 | -+ | ||
| 206 | +! |
- #' This defines the server part for the sample variable specification.+ filter_panel_api = filter_panel_api |
|
| 174 | +207 |
- #'+ ) |
|
| 175 | -+ | ||
| 208 | +! |
- #' @inheritParams module_arguments+ card$append_text("Selected Options", "header3")
|
|
| 176 | -+ | ||
| 209 | +! |
- #' @param experiment_name (reactive `string`)\cr name of the input experiment.+ encodings_list <- list( |
|
| 177 | -+ | ||
| 210 | +! |
- #' @param original_data (reactive `SummarizedExperiment`)\cr input experiment where the+ "Experiment:", |
|
| 178 | -+ | ||
| 211 | +! |
- #' sample variables extracted via [SummarizedExperiment::colData()] should be eligible for+ input$`experiment-name`, |
|
| 179 | -+ | ||
| 212 | +! |
- #' selection.+ "\nAssay:", |
|
| 180 | -+ | ||
| 213 | +! |
- #' @param transformed_data (reactive `SummarizedExperiment`)\cr used when multiple sample+ input$`assay-name`, |
|
| 181 | -+ | ||
| 214 | +! |
- #' variables can be selected in the app. In that case, pass here the pre-transformed data.+ "\nX Genes Selected:", |
|
| 182 | -+ | ||
| 215 | +! |
- #' @param assign_lists (`reactivevalues`)\cr object to share factor level groupings across multiple+ paste0(x_spec()$get_gene_labels(), collapse = ", "), |
|
| 183 | -+ | ||
| 216 | +! |
- #' sample variables.+ "\nX Genes Summary:", |
|
| 184 | -+ | ||
| 217 | +! |
- #' @param num_levels (`count` or `NULL`)\cr required number of levels after combining original levels.+ input$`x_spec-fun_name`, |
|
| 185 | -+ | ||
| 218 | +! |
- #' If `NULL` then all numbers of levels are allowed.+ "\nY Genes Selected:", |
|
| 186 | -+ | ||
| 219 | +! |
- #' @param categorical_only (`flag`)\cr whether only categorical variables should be selected+ paste0(y_spec()$get_gene_labels(), collapse = ", "), |
|
| 187 | -+ | ||
| 220 | +! |
- #' from.+ "\nY Genes Summary:", |
|
| 188 | -+ | ||
| 221 | +! |
- #' @param explicit_na (`flag`)\cr whether the `colData` of `original_data` will be transformed with+ input$`y_spec-fun_name`, |
|
| 189 | -+ | ||
| 222 | +! |
- #' [hermes::h_df_factors_with_explicit_na] before further processing. That means also that+ "\nOptional Color Variable:", |
|
| 190 | -+ | ||
| 223 | +! |
- #' `NA` will be made an explicit factor level and counted for `num_levels`.+ input$`color_var-sample_var`, |
|
| 191 | -+ | ||
| 224 | +! |
- #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input.+ "\nOptional Facetting Variable:", |
|
| 192 | -+ | ||
| 225 | +! |
- #'+ input$`facet_var-sample_var`, |
|
| 193 | -+ | ||
| 226 | +! |
- #' @return Reactive [`SummarizedExperiment::SummarizedExperiment`] which can be used as+ "\nSmoother:", |
|
| 194 | -+ | ||
| 227 | +! |
- #' input for the relevant `hermes` functions.+ input$smooth_method |
|
| 195 | +228 |
- #' @seealso [sampleVarSpecInput()] for the module UI.+ ) |
|
| 196 | -+ | ||
| 229 | +! |
- #'+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 197 | -+ | ||
| 230 | +! |
- #' @note Only atomic columns (e.g. not `DataFrame` columns) of the `colData`+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 198 | -+ | ||
| 231 | +! |
- #' which are not completely missing (`NA`) will be shown for selection.+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 199 | -+ | ||
| 232 | +! |
- #' If `num_levels` is specified then only factor columns will be available.+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|
| 200 | +233 |
- #'+ } else {
|
|
| 201 | -+ | ||
| 234 | +! |
- #' @export+ paste(encodings_list, collapse = " ") |
|
| 202 | +235 |
- #'+ } |
|
| 203 | +236 |
- #' @examples+ |
|
| 204 | -+ | ||
| 237 | +! |
- #' ui <- function(id) {
+ card$append_text(final_encodings, style = "verbatim") |
|
| 205 | -+ | ||
| 238 | +! |
- #' checkmate::assert_class(data, "teal_data")+ card$append_text("Plot", "header3")
|
|
| 206 | -+ | ||
| 239 | +! |
- #' ns <- NS(id)+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 207 | -+ | ||
| 240 | +! |
- #'+ if (!comment == "") {
|
|
| 208 | -+ | ||
| 241 | +! |
- #' teal.widgets::standard_layout(+ card$append_text("Comment", "header3")
|
|
| 209 | -+ | ||
| 242 | +! |
- #' encoding = uiOutput(ns("encoding_ui")),
+ card$append_text(comment) |
|
| 210 | +243 |
- #' output = plotOutput(ns("plot"))
+ } |
|
| 211 | -+ | ||
| 244 | +! |
- #' )+ card |
|
| 212 | +245 |
- #' }+ } |
|
| 213 | -+ | ||
| 246 | +! |
- #' server <- function(id,+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 214 | +247 |
- #' data) {
+ } |
|
| 215 | +248 |
- #' checkmate::assert_class(data, "reactive")+ ### |
|
| 216 | +249 |
- #' checkmate::assert_class(shiny::isolate(data()), "teal_data")+ }) |
|
| 217 | +250 |
- #' moduleServer(id, function(input, output, session) {
+ } |
|
| 218 | +251 |
- #' output$encoding_ui <- renderUI({
+
|
|
| 219 | +252 |
- #' mae <- data()[["MAE"]]+ #' @describeIn tm_g_scatterplot sample module function. |
|
| 220 | +253 |
- #' experiment_name_choices <- names(mae)+ #' @export |
|
| 221 | +254 |
- #' tags$div(+ #' @examples |
|
| 222 | +255 |
- #' selectInput(session$ns("experiment_name"), "Select experiment", experiment_name_choices),
+ #' |
|
| 223 | +256 |
- #' sampleVarSpecInput(session$ns("facet_var"), "Select faceting variable")
+ #' # Alternatively you can run the sample module with this function call: |
|
| 224 | +257 |
- #' )+ #' if (interactive()) {
|
|
| 225 | +258 |
- #' })+ #' sample_tm_g_scatterplot() |
|
| 226 | +259 |
- #' experiment_data <- reactive({
+ #' } |
|
| 227 | +260 |
- #' req(input$experiment_name)+ sample_tm_g_scatterplot <- function(.test = FALSE) {
|
|
| 228 | -+ | ||
| 261 | +! |
- #' mae <- data()[["MAE"]]+ data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment) |
|
| 229 | -+ | ||
| 262 | +! |
- #' object <- mae[[input$experiment_name]]+ app <- teal::init( |
|
| 230 | -+ | ||
| 263 | +! |
- #' SummarizedExperiment::colData(object) <-+ data = data, |
|
| 231 | -+ | ||
| 264 | +! |
- #' hermes::df_cols_to_factor(SummarizedExperiment::colData(object))+ modules = teal::modules( |
|
| 232 | -+ | ||
| 265 | +! |
- #' object+ tm_g_scatterplot( |
|
| 233 | -+ | ||
| 266 | +! |
- #' })+ label = "scatterplot", |
|
| 234 | -+ | ||
| 267 | +! |
- #' facet_var_spec <- sampleVarSpecServer(+ mae_name = "MAE", |
|
| 235 | -+ | ||
| 268 | +! |
- #' "facet_var",+ .test = .test |
|
| 236 | +269 |
- #' experiment_name = reactive({
+ ) |
|
| 237 | +270 |
- #' input$experiment_name+ ) |
|
| 238 | +271 |
- #' }),+ ) |
|
| 239 | -+ | ||
| 272 | +! |
- #' original_data = experiment_data+ shinyApp(app$ui, app$server) |
|
| 240 | +273 |
- #' )+ } |
| 241 | +1 |
- #' output$plot <- renderPlot({
+ #' Teal Module for RNA-seq Boxplot |
||
| 242 | +2 |
- #' experiment_data_final <- facet_var_spec$experiment_data()+ #' |
||
| 243 | +3 |
- #' facet_var <- facet_var_spec$sample_var()+ #' @description `r lifecycle::badge("experimental")`
|
||
| 244 | +4 |
- #' hermes::draw_boxplot(+ #' |
||
| 245 | +5 |
- #' experiment_data_final,+ #' This module provides an interactive boxplot for RNA-seq gene expression |
||
| 246 | +6 |
- #' assay_name = "counts",+ #' analysis. |
||
| 247 | +7 |
- #' genes = hermes::gene_spec(hermes::genes(experiment_data_final)[1]),+ #' |
||
| 248 | +8 |
- #' facet_var = facet_var+ #' @inheritParams module_arguments |
||
| 249 | +9 |
- #' )+ #' |
||
| 250 | +10 |
- #' })+ #' @return Shiny module to be used in the teal app. |
||
| 251 | +11 |
- #' })+ #' |
||
| 252 | +12 |
- #' }+ #' @export |
||
| 253 | +13 |
- #' my_app <- function() {
+ #' |
||
| 254 | +14 |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ #' @examples |
||
| 255 | +15 |
- #' app <- init(+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 256 | +16 |
- #' data = data,+ #' app <- init( |
||
| 257 | +17 |
- #' modules = modules(+ #' data = data, |
||
| 258 | +18 |
- #' module(+ #' modules = modules( |
||
| 259 | +19 |
- #' label = "sampleVarSpec example",+ #' tm_g_boxplot( |
||
| 260 | +20 |
- #' server = server,+ #' label = "boxplot", |
||
| 261 | +21 |
- #' ui = ui,+ #' mae_name = "MAE" |
||
| 262 | +22 |
- #' datanames = "all"+ #' ) |
||
| 263 | +23 |
- #' )+ #' ) |
||
| 264 | +24 |
- #' )+ #' ) |
||
| 265 | +25 |
- #' )+ #' if (interactive()) {
|
||
| 266 | +26 |
#' shinyApp(app$ui, app$server) |
||
| 267 | +27 |
#' } |
||
| 268 | +28 |
- #' if (interactive()) {
+ tm_g_boxplot <- function(label, |
||
| 269 | +29 |
- #' my_app()+ mae_name, |
||
| 270 | +30 |
- #' }+ exclude_assays = character(), |
||
| 271 | +31 |
- sampleVarSpecServer <- function(id, # nolint+ summary_funs = list( |
||
| 272 | +32 |
- experiment_name,+ None = NULL, |
||
| 273 | +33 |
- original_data,+ Mean = colMeans, |
||
| 274 | +34 |
- transformed_data = original_data,+ Median = matrixStats::colMedians, |
||
| 275 | +35 |
- assign_lists = reactiveValues(),+ Max = matrixStats::colMaxs |
||
| 276 | +36 |
- num_levels = NULL,+ ), |
||
| 277 | +37 |
- categorical_only = !is.null(num_levels),+ pre_output = NULL, |
||
| 278 | +38 |
- explicit_na = FALSE,+ post_output = NULL, |
||
| 279 | +39 |
- label_modal_title = "Please click to group the original factor levels") {
- |
- ||
| 280 | -2x | -
- assert_string(id)+ .test = FALSE) {
|
||
| 281 | -2x | +|||
| 40 | +! |
- assert_reactive(experiment_name)+ message("Initializing tm_g_boxplot")
|
||
| 282 | -2x | +|||
| 41 | +! |
- assert_reactive(original_data)+ assert_string(label) |
||
| 283 | -2x | +|||
| 42 | +! |
- assert_reactive(transformed_data)+ assert_string(mae_name) |
||
| 284 | -2x | +|||
| 43 | +! |
- assert_class(assign_lists, "reactivevalues")+ assert_character(exclude_assays, any.missing = FALSE) |
||
| 285 | -2x | +|||
| 44 | +! |
- assert_count(num_levels, null.ok = TRUE, positive = TRUE)+ assert_summary_funs(summary_funs, null.ok = TRUE) |
||
| 286 | -2x | +|||
| 45 | +! |
- assert_flag(categorical_only)+ assert_tag(pre_output, null.ok = TRUE) |
||
| 287 | -2x | +|||
| 46 | +! |
- assert_flag(explicit_na)+ assert_tag(post_output, null.ok = TRUE) |
||
| 288 | -2x | +|||
| 47 | +! |
- assert_string(label_modal_title)+ assert_flag(.test) |
||
| 289 | +48 | |||
| 290 | -2x | +|||
| 49 | +! |
- moduleServer(id, function(input, output, session) {
+ teal::module( |
||
| 291 | -2x | +|||
| 50 | +! |
- to_observe <- reactive({
+ label = label, |
||
| 292 | -2x | +|||
| 51 | +! |
- list(experiment_name(), original_data())+ server = srv_g_boxplot, |
||
| 293 | -+ | |||
| 52 | +! |
- })+ server_args = list(+ |
+ ||
| 53 | +! | +
+ mae_name = mae_name,+ |
+ ||
| 54 | +! | +
+ summary_funs = summary_funs,+ |
+ ||
| 55 | +! | +
+ exclude_assays = exclude_assays,+ |
+ ||
| 56 | +! | +
+ .test = .test |
||
| 294 | +57 |
-
+ ), |
||
| 295 | -2x | +|||
| 58 | +! |
- start_col_data <- eventReactive(to_observe(), {
+ ui = ui_g_boxplot, |
||
| 296 | -2x | +|||
| 59 | +! |
- object <- original_data()+ ui_args = list( |
||
| 297 | -2x | +|||
| 60 | +! |
- col_data <- SummarizedExperiment::colData(object)+ mae_name = mae_name, |
||
| 298 | -2x | +|||
| 61 | +! |
- if (explicit_na) {
+ summary_funs = summary_funs, |
||
| 299 | +62 | ! |
- hermes::df_cols_to_factor(col_data)+ pre_output = pre_output, |
|
| 300 | -+ | |||
| 63 | +! |
- } else {
+ post_output = post_output, |
||
| 301 | -2x | +|||
| 64 | +! |
- col_data+ .test = .test |
||
| 302 | +65 |
- }+ ), |
||
| 303 | -+ | |||
| 66 | +! |
- })+ datanames = mae_name |
||
| 304 | +67 |
-
+ ) |
||
| 305 | +68 |
- # The colData variables to choose the sample variable from.+ } |
||
| 306 | -2x | +|||
| 69 | +
- col_data_vars <- reactive({
+
|
|||
| 307 | -2x | +|||
| 70 | +
- col_data <- start_col_data()+ #' @describeIn tm_g_boxplot sets up the user interface. |
|||
| 308 | -2x | +|||
| 71 | +
- can_be_used <- vapply(col_data, FUN = function(x) is.atomic(x) && !allMissing(x), FUN.VALUE = logical(1))+ #' @inheritParams module_arguments |
|||
| 309 | -2x | +|||
| 72 | +
- if (categorical_only) {
+ #' @export |
|||
| 310 | -1x | +|||
| 73 | +
- col_is_factor <- vapply(col_data, FUN = is.factor, FUN.VALUE = logical(1))+ ui_g_boxplot <- function(id, |
|||
| 311 | -1x | +|||
| 74 | +
- can_be_used <- can_be_used & col_is_factor+ mae_name, |
|||
| 312 | +75 |
- }+ summary_funs, |
||
| 313 | -2x | +|||
| 76 | +
- names(col_data)[can_be_used]+ pre_output, |
|||
| 314 | +77 |
- })+ post_output, |
||
| 315 | +78 |
-
+ .test = FALSE) {
|
||
| 316 | -+ | |||
| 79 | +1x |
- # When the colData variables change, update the choices for sample_var.+ ns <- NS(id) |
||
| 317 | -2x | +80 | +1x |
- observeEvent(col_data_vars(), {
+ teal.widgets::standard_layout( |
| 318 | -! | +|||
| 81 | +1x |
- col_data_vars <- col_data_vars()+ encoding = tags$div( |
||
| 319 | +82 |
-
+ ### Reporter |
||
| 320 | -! | +|||
| 83 | +1x |
- sel <- intersect(input$sample_var, col_data_vars)+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
||
| 321 | +84 |
-
+ ### |
||
| 322 | -! | +|||
| 85 | +1x |
- teal.widgets::updateOptionalSelectInput(+ tags$label("Encodings", class = "text-primary"),
|
||
| 323 | -! | +|||
| 86 | +1x |
- session,+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
||
| 324 | -! | +|||
| 87 | +1x |
- "sample_var",+ uiOutput(ns("experiment_ui")),
|
||
| 325 | -! | +|||
| 88 | +1x |
- choices = col_data_vars,+ assaySpecInput(ns("assay")),
|
||
| 326 | -! | +|||
| 89 | +1x |
- selected = sel+ geneSpecInput(ns("genes"), summary_funs),
|
||
| 327 | -+ | |||
| 90 | +1x |
- )+ tags$label("Jitter"),
+ |
+ ||
| 91 | +1x | +
+ shinyWidgets::switchInput(ns("jitter"), value = FALSE, size = "mini"),
+ |
+ ||
| 92 | +1x | +
+ tags$label("Violin Plot"),
+ |
+ ||
| 93 | +1x | +
+ shinyWidgets::switchInput(ns("violin"), value = FALSE, size = "mini"),
+ |
+ ||
| 94 | +1x | +
+ teal.widgets::panel_group( |
||
| 328 | -+ | |||
| 95 | +1x |
- })+ teal.widgets::panel_item( |
||
| 329 | -+ | |||
| 96 | +1x |
-
+ input_id = "settings_item", |
||
| 330 | -+ | |||
| 97 | +1x |
- # Reactive for the current combination. Takes the assignment list if available+ collapsed = TRUE, |
||
| 331 | -+ | |||
| 98 | +1x |
- # and converts to combination list.+ title = "Additional Settings", |
||
| 332 | -2x | +99 | +1x |
- current_combination <- reactive({
+ sampleVarSpecInput(ns("strat"), "Optional stratifying variable"),
|
| 333 | -! | +|||
| 100 | +1x |
- experiment_name <- experiment_name()+ sampleVarSpecInput(ns("color"), "Optional color variable"),
|
||
| 334 | -! | +|||
| 101 | +1x |
- sample_var <- input$sample_var+ sampleVarSpecInput(ns("facet"), "Optional facet variable")
|
||
| 335 | -! | +|||
| 102 | +
- req(experiment_name)+ ) |
|||
| 336 | +103 |
-
+ ) |
||
| 337 | -! | +|||
| 104 | +
- if (!is.null(sample_var)) {
+ ), |
|||
| 338 | -! | +|||
| 105 | +1x |
- assign_list <- assign_lists[[experiment_name]][[sample_var]]+ output = div( |
||
| 339 | -! | +|||
| 106 | +1x |
- if (!is.null(assign_list)) {
+ if (.test) verbatimTextOutput(ns("table")) else NULL,
|
||
| 340 | -! | +|||
| 107 | +1x |
- h_assign_to_group_list(assign_list)+ teal.widgets::plot_with_settings_ui(ns("plot"))
|
||
| 341 | +108 |
- } else {
+ ), |
||
| 342 | -! | +|||
| 109 | +1x |
- NULL+ pre_output = pre_output, |
||
| 343 | -+ | |||
| 110 | +1x |
- }+ post_output = post_output |
||
| 344 | +111 |
- }+ ) |
||
| 345 | +112 |
- })+ } |
||
| 346 | +113 | |||
| 347 | +114 |
- # Here we produce the final object by checking+ #' @describeIn tm_g_boxplot sets up the server with reactive graph. |
||
| 348 | +115 |
- # if we should combine for this sample var.+ #' @inheritParams module_arguments |
||
| 349 | -2x | +|||
| 116 | +
- final_data <- reactive({
+ #' @export |
|||
| 350 | -! | +|||
| 117 | +
- sample_var <- input$sample_var+ srv_g_boxplot <- function(id, |
|||
| 351 | -! | +|||
| 118 | +
- original_data <- original_data()+ data, |
|||
| 352 | -! | +|||
| 119 | +
- start_col_data <- start_col_data()+ filter_panel_api, |
|||
| 353 | -! | +|||
| 120 | +
- transformed_data <- transformed_data()+ reporter, |
|||
| 354 | -! | +|||
| 121 | +
- current_combination <- current_combination()+ mae_name, |
|||
| 355 | +122 |
-
+ exclude_assays, |
||
| 356 | -! | +|||
| 123 | +
- if (!is.null(sample_var)) {
+ summary_funs, |
|||
| 357 | -! | +|||
| 124 | +
- sample_var_vector <- start_col_data[[sample_var]]+ .test = FALSE) {
|
|||
| 358 | +125 | ! |
- if (!is.null(current_combination)) {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 359 | +126 | ! |
- sample_var_vector <- h_collapse_levels(+ assert_class(filter_panel_api, "FilterPanelAPI") |
|
| 360 | +127 | ! |
- sample_var_vector,+ checkmate::assert_class(data, "reactive") |
|
| 361 | +128 | ! |
- current_combination- |
- |
| 362 | -- |
- )+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
||
| 363 | +129 |
- }+ |
||
| 364 | +130 | ! |
- if (!is.null(num_levels)) {
+ moduleServer(id, function(input, output, session) {
|
|
| 365 | +131 | ! |
- validate_n_levels(sample_var_vector, sample_var, num_levels)- |
- |
| 366 | -- |
- }+ output$experiment_ui <- renderUI({
|
||
| 367 | +132 | ! |
- SummarizedExperiment::colData(transformed_data)[[sample_var]] <- sample_var_vector- |
- |
| 368 | -- |
- }+ experimentSpecInput(session$ns("experiment"), data, mae_name)
|
||
| 369 | +133 |
-
+ }) |
||
| 370 | +134 | ! |
- transformed_data- |
- |
| 371 | -- |
- })- |
- ||
| 372 | -- | - - | -||
| 373 | -- |
- # Function to return the UI for a modal dialog with matrix input for combination- |
- ||
| 374 | -- |
- # assignment.- |
- ||
| 375 | -2x | -
- combModal <- function(sample_var_levels, # nolint- |
- ||
| 376 | -2x | -
- n_max_groups,- |
- ||
| 377 | -2x | -
- selected_groups) {
+ experiment <- experimentSpecServer( |
||
| 378 | +135 | ! |
- if (is.null(selected_groups)) {
+ "experiment", |
|
| 379 | +136 | ! |
- selected_groups <- pmin(+ data = data, |
|
| 380 | +137 | ! |
- seq_along(sample_var_levels),+ filter_panel_api = filter_panel_api, |
|
| 381 | +138 | ! |
- n_max_groups+ mae_name = mae_name |
|
| 382 | +139 |
- )+ ) |
||
| 383 | -+ | |||
| 140 | +! |
- }+ assay <- assaySpecServer( |
||
| 384 | +141 | ! |
- modalDialog(+ "assay", |
|
| 385 | +142 | ! |
- shinyRadioMatrix::radioMatrixInput(+ assays = experiment$assays, |
|
| 386 | +143 | ! |
- session$ns("comb_assignment"),
+ exclude_assays = exclude_assays |
|
| 387 | -! | +|||
| 144 | +
- rowIDs = sample_var_levels,+ ) |
|||
| 388 | +145 | ! |
- rowIDsName = "Original levels",+ multi <- multiSampleVarSpecServer( |
|
| 389 | +146 | ! |
- rowLLabels = rep("", length = length(sample_var_levels)),
+ inputIds = c("strat", "color", "facet"),
|
|
| 390 | +147 | ! |
- choices = seq_len(n_max_groups),+ experiment_name = experiment$name, |
|
| 391 | +148 | ! |
- selected = selected_groups+ original_data = experiment$data |
|
| 392 | +149 |
- ),+ ) |
||
| 393 | +150 | ! |
- tags$span(label_modal_title),+ genes <- geneSpecServer( |
|
| 394 | +151 | ! |
- footer = tagList(+ "genes", |
|
| 395 | +152 | ! |
- modalButton("Cancel"),
+ funs = summary_funs, |
|
| 396 | +153 | ! |
- actionButton(session$ns("ok"), "OK")
+ gene_choices = experiment$genes |
|
| 397 | +154 |
- ),+ ) |
||
| 398 | +155 | ! |
- include_js_files("checkbox.js")
- |
- |
| 399 | -- |
- )- |
- ||
| 400 | -- |
- }+ plot_r <- reactive({
|
||
| 401 | +156 |
-
+ # Resolve all reactivity. |
||
| 402 | -+ | |||
| 157 | +! |
- # Show modal when button is clicked and the current variable is a factor variable.+ experiment_data <- multi$experiment_data() |
||
| 403 | -2x | +|||
| 158 | +! |
- observeEvent(input$levels_button, {
+ strat <- multi$vars$strat() |
||
| 404 | +159 | ! |
- sample_var <- input$sample_var+ genes <- genes() |
|
| 405 | +160 | ! |
- original_data <- original_data()+ facet <- multi$vars$facet() |
|
| 406 | +161 | ! |
- start_col_data <- start_col_data()+ color <- multi$vars$color() |
|
| 407 | +162 | ! |
- experiment_name <- experiment_name()+ assay <- assay() |
|
| 408 | -+ | |||
| 163 | +! |
-
+ jitter <- input$jitter |
||
| 409 | +164 | ! |
- req(experiment_name)+ violin <- input$violin |
|
| 410 | +165 | |||
| 411 | +166 | ! |
- if (!is.null(sample_var)) {
+ req( |
|
| 412 | +167 | ! |
- current_sample_var <- start_col_data[[sample_var]]+ assay, |
|
| 413 | +168 |
-
+ # Note: The following statements are important to make sure the UI inputs have been updated. |
||
| 414 | +169 | ! |
- if (is.factor(current_sample_var)) {
+ isTRUE(assay %in% SummarizedExperiment::assayNames(experiment_data)), |
|
| 415 | +170 | ! |
- sample_var_levels <- levels(current_sample_var)- |
- |
| 416 | -- |
-
+ is.null(facet) || isTRUE(facet %in% names(SummarizedExperiment::colData(experiment_data))), |
||
| 417 | -+ | |||
| 171 | +! |
- # Note: here we make sure we load with previous choice so the user+ is.null(color) || isTRUE(color %in% names(SummarizedExperiment::colData(experiment_data))), |
||
| 418 | -+ | |||
| 172 | +! |
- # does not constantly need to start from scratch again.+ is.null(strat) || isTRUE(strat %in% names(SummarizedExperiment::colData(experiment_data))), |
||
| 419 | -+ | |||
| 173 | +! |
- # although we do not do this if the levels do not match (i.e. if+ cancelOutput = FALSE |
||
| 420 | +174 |
- # some levels have been filtered out)+ ) |
||
| 421 | +175 | |||
| 422 | +176 | ! |
- selected_groups <- NULL+ validate_gene_spec(genes, rownames(experiment_data)) |
|
| 423 | +177 | |||
| 424 | +178 | ! |
- old_values <- names(assign_lists[[experiment_name]][[sample_var]])+ hermes::draw_boxplot( |
|
| 425 | +179 | ! |
- if (!is.null(old_values) &&+ object = experiment_data, |
|
| 426 | +180 | ! |
- length(old_values) == length(sample_var_levels) && # nolint+ assay_name = assay, |
|
| 427 | +181 | ! |
- all(sort(old_values) == sort(sample_var_levels))) { # nolint
+ genes = genes, |
|
| 428 | +182 | ! |
- selected_groups <- assign_lists[[experiment_name]][[sample_var]] # nolint- |
- |
| 429 | -- |
- }- |
- ||
| 430 | -- |
-
+ x_var = strat, |
||
| 431 | +183 | ! |
- showModal(combModal(+ facet_var = facet, |
|
| 432 | +184 | ! |
- sample_var_levels = sample_var_levels,+ color_var = color, |
|
| 433 | +185 | ! |
- n_max_groups = `if`(!is.null(num_levels), num_levels, length(sample_var_levels)),+ jitter = jitter, |
|
| 434 | +186 | ! |
- selected_groups = selected_groups+ violin = violin |
|
| 435 | +187 |
- ))+ ) |
||
| 436 | +188 |
- } else {
+ }) |
||
| 437 | +189 | ! |
- showNotification("Can only group levels for factor variables", type = "message")
+ output$plot <- renderPlot(plot_r()) |
|
| 438 | +190 |
- }+ |
||
| 439 | -+ | |||
| 191 | +! |
- }+ pws <- teal.widgets::plot_with_settings_srv( |
||
| 440 | -+ | |||
| 192 | +! |
- })+ id = "plot", |
||
| 441 | -+ | |||
| 193 | +! |
-
+ plot_r = plot_r |
||
| 442 | +194 |
- # When OK button is pressed, save the settings, and remove the modal.+ ) |
||
| 443 | -2x | +|||
| 195 | +
- observeEvent(input$ok, {
+
|
|||
| 444 | +196 | ! |
- experiment_name <- experiment_name()+ if (.test) {
|
|
| 445 | +197 | ! |
- sample_var <- input$sample_var+ table_r <- reactive({
|
|
| 446 | +198 | ! |
- comb_assignment <- input$comb_assignment+ str(layer_data(plot_r())) |
|
| 447 | +199 |
-
+ }) |
||
| 448 | +200 | ! |
- req(experiment_name, sample_var, comb_assignment)+ output$table <- renderPrint(table_r()) |
|
| 449 | +201 | ++ |
+ }+ |
+ |
| 202 | ||||
| 450 | -! | +|||
| 203 | +
- if (!is.null(num_levels) && !identical(length(unique(unlist(comb_assignment))), num_levels)) {
+ ### REPORTER |
|||
| 451 | +204 | ! |
- showNotification(+ if (with_reporter) {
|
|
| 452 | +205 | ! |
- paste("Please group the original levels into exactly", num_levels, "levels"),
+ card_fun <- function(comment, label) {
|
|
| 453 | +206 | ! |
- type = "error"+ card <- report_card_template( |
|
| 454 | -+ | |||
| 207 | +! |
- )+ title = "Boxplot", |
||
| 455 | -+ | |||
| 208 | +! |
- } else {
+ label = label, |
||
| 456 | +209 | ! |
- assign_lists[[experiment_name]][[sample_var]] <- comb_assignment+ with_filter = TRUE, |
|
| 457 | +210 | ! |
- removeModal()+ filter_panel_api = filter_panel_api |
|
| 458 | +211 |
- }+ ) |
||
| 459 | -+ | |||
| 212 | +! |
- })+ card$append_text("Selected Options", "header3")
|
||
| 460 | -+ | |||
| 213 | +! |
-
+ encodings_list <- list( |
||
| 461 | -+ | |||
| 214 | +! |
- # Return both the reactives with the experiment data as well as the sample variable.+ "Experiment:", |
||
| 462 | -2x | +|||
| 215 | +! |
- list(+ input$`experiment-name`, |
||
| 463 | -2x | +|||
| 216 | +! |
- experiment_data = final_data,+ "\nAssay:", |
||
| 464 | -2x | +|||
| 217 | +! |
- sample_var = reactive({
+ input$`assay-name`, |
||
| 465 | +218 | ! |
- input$sample_var+ "\nFacetting Variable:", |
|
| 466 | -+ | |||
| 219 | +! |
- })+ input$`facet-sample_var`, |
||
| 467 | -+ | |||
| 220 | +! |
- )+ "\nGenes Selected:", |
||
| 468 | -+ | |||
| 221 | +! |
- })+ paste0(genes()$get_gene_labels(), collapse = ", "), |
||
| 469 | -+ | |||
| 222 | +! |
- }+ "\nGene Summary:", |
||
| 470 | -+ | |||
| 223 | +! |
-
+ input$`genes-fun_name`, |
||
| 471 | -+ | |||
| 224 | +! |
- #' Module Server for Specification of Multiple Sample Variables+ "\nJitter:", |
||
| 472 | -+ | |||
| 225 | +! |
- #'+ input$jitter, |
||
| 473 | -+ | |||
| 226 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ "\nViolin:", |
||
| 474 | -+ | |||
| 227 | +! |
- #'+ input$violin, |
||
| 475 | -+ | |||
| 228 | +! |
- #' When multiple sample variables are used in a given module, then this+ "\nOptional Stratifying Variable:", |
||
| 476 | -+ | |||
| 229 | +! |
- #' wrapper makes it much easier to specify in the server function.+ input$`strat-sample_var`, |
||
| 477 | -+ | |||
| 230 | +! |
- #'+ "\nOptional Color Variable:", |
||
| 478 | -+ | |||
| 231 | +! |
- #' @param inputIds (`character`)\cr multiple input IDs corresponding to the+ input$`color-sample_var`, |
||
| 479 | -+ | |||
| 232 | +! |
- #' different sample variables specified in the UI function.+ "\nOptional Facet Variable:", |
||
| 480 | -+ | |||
| 233 | +! |
- #' @inheritParams sampleVarSpecServer+ input$`facet-sample_var` |
||
| 481 | +234 |
- #' @param ... additional arguments as documented in [sampleVarSpecServer()],+ ) |
||
| 482 | -+ | |||
| 235 | +! |
- #' namely the mandatory `experiment_name` and the optional `categorical_only`,+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
||
| 483 | -+ | |||
| 236 | +! |
- #' `num_levels` and `label_modal_title`.+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
||
| 484 | -+ | |||
| 237 | +! |
- #' `transformed_data` and `assign_lists` should not be+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
||
| 485 | -+ | |||
| 238 | +! |
- #' specified as they are already specified internally here.+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
||
| 486 | +239 |
- #'+ } else {
|
||
| 487 | -+ | |||
| 240 | +! |
- #' @return List with the final transformed `experiment_data` reactive and a+ paste(encodings_list, collapse = " ") |
||
| 488 | +241 |
- #' list `vars` which contains the selected sample variables as reactives+ } |
||
| 489 | +242 |
- #' under their input ID.+ |
||
| 490 | -+ | |||
| 243 | +! |
- #'+ card$append_text(final_encodings, style = "verbatim") |
||
| 491 | -+ | |||
| 244 | +! |
- #' @export+ card$append_text("Plot", "header3")
|
||
| 492 | -+ | |||
| 245 | +! |
- #' @examples+ card$append_plot(plot_r(), dim = pws$dim()) |
||
| 493 | -+ | |||
| 246 | +! |
- #' \dontrun{
+ if (!comment == "") {
|
||
| 494 | -+ | |||
| 247 | +! |
- #' # In the server use:+ card$append_text("Comment", "header3")
|
||
| 495 | -+ | |||
| 248 | +! |
- #' sample_var_specs <- multiSampleVarSpecServer(+ card$append_text(comment) |
||
| 496 | +249 |
- #' inputIds = c("facet_var", "color_var"),
+ }+ |
+ ||
| 250 | +! | +
+ card |
||
| 497 | +251 |
- #' experiment_name = reactive({
+ }+ |
+ ||
| 252 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
||
| 498 | +253 |
- #' input$experiment_name+ } |
||
| 499 | +254 |
- #' }),+ ### |
||
| 500 | +255 |
- #' original_data = ori_data # nolint Please update the <ori_data>+ }) |
||
| 501 | +256 |
- #' )+ } |
||
| 502 | +257 |
- #' # Then can extract the transformed data and selected variables later:+ |
||
| 503 | +258 |
- #' experiment_data <- sample_var_specs$experiment_data()+ #' @describeIn tm_g_boxplot sample module function. |
||
| 504 | +259 |
- #' facet_var <- sample_var_specs$vars$facet_var()+ #' @export |
||
| 505 | +260 |
- #' color_var <- sample_var_specs$vars$color_var()+ #' @examples |
||
| 506 | +261 |
- #' }+ #' |
||
| 507 | +262 |
- multiSampleVarSpecServer <- function(inputIds, # nolint+ #' # Alternatively you can run the sample module with this function call: |
||
| 508 | +263 |
- original_data,+ #' if (interactive()) {
|
||
| 509 | +264 |
- ...) {
+ #' sample_tm_g_boxplot() |
||
| 510 | -! | +|||
| 265 | +
- assert_character(inputIds, any.missing = FALSE, unique = TRUE)+ #' } |
|||
| 511 | -! | +|||
| 266 | +
- assign_lists <- reactiveValues()+ sample_tm_g_boxplot <- function(.test = FALSE) {
|
|||
| 512 | +267 | ! |
- spec_list <- list()+ data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment) |
|
| 513 | +268 | ! |
- transformed_data <- original_data+ app <- teal::init( |
|
| 514 | +269 | ! |
- for (id in inputIds) {
+ data = data, |
|
| 515 | +270 | ! |
- spec_list[[id]] <- sampleVarSpecServer(+ modules = teal::modules( |
|
| 516 | +271 | ! |
- id,+ tm_g_boxplot( |
|
| 517 | +272 | ! |
- original_data = original_data,+ label = "boxplot", |
|
| 518 | +273 | ! |
- transformed_data = transformed_data,+ mae_name = "MAE", |
|
| 519 | +274 | ! |
- assign_lists = assign_lists,+ .test = .test |
|
| 520 | +275 |
- ...+ ) |
||
| 521 | +276 |
) |
||
| 522 | -! | -
- transformed_data <- spec_list[[id]]$experiment_data- |
- ||
| 523 | +277 |
- }- |
- ||
| 524 | -! | -
- list(- |
- ||
| 525 | -! | -
- experiment_data = transformed_data,+ ) |
||
| 526 | +278 | ! |
- vars = lapply(spec_list, "[[", "sample_var")- |
- |
| 527 | -- |
- )+ shinyApp(app$ui, app$server) |
||
| 528 | +279 |
}@@ -28093,14 +28947,14 @@ teal.modules.hermes coverage - 26.11% |
| 1 |
- #' Teal Module for RNA-seq Volcano Plot+ #' Module Input for Assay Specification |
||
| 5 |
- #' This module provides an interactive volcano plot for RNA-seq gene expression+ #' This defines the input for the assay specification. |
||
| 6 |
- #' analysis.+ #' |
||
| 7 |
- #'+ #' @inheritParams module_arguments |
||
| 8 |
- #' @inheritParams module_arguments+ #' @param label_assays (`string`)\cr label for the assay selection. |
||
| 10 |
- #' @return Shiny module to be used in the teal app.+ #' @return The UI part. |
||
| 11 |
- #'+ #' @seealso [assaySpecServer()] for the module server and a complete example. |
||
| 13 |
- #'+ assaySpecInput <- function(inputId, # nolint |
||
| 14 |
- #' @examples+ label_assays = "Select Assay") {
|
||
| 15 | -+ | 9x |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ assert_string(inputId) |
| 16 | -+ | 9x |
- #' app <- init(+ assert_string(label_assays, min.chars = 1L) |
| 17 |
- #' data = data,+ |
||
| 18 | -+ | 9x |
- #' modules = modules(+ ns <- NS(inputId) |
| 19 | -+ | 9x |
- #' tm_g_volcanoplot(+ tagList( |
| 20 | -+ | 9x |
- #' label = "volcanoplot",+ selectizeInput( |
| 21 | -+ | 9x |
- #' mae_name = "MAE"+ inputId = ns("name"),
|
| 22 | -+ | 9x |
- #' )+ label = label_assays, |
| 23 | -+ | 9x |
- #' )+ choices = character(0), |
| 24 | -+ | 9x |
- #' )+ options = list( |
| 25 | -+ | 9x |
- #' if (interactive()) {
+ placeholder = "- Nothing selected -" |
| 26 |
- #' shinyApp(app$ui, app$server)+ ) |
||
| 27 |
- #' }+ ), |
||
| 28 | -+ | 9x |
- tm_g_volcanoplot <- function(label,+ include_js_files("dropdown.js")
|
| 29 |
- mae_name,+ ) |
||
| 30 |
- exclude_assays = character(),+ } |
||
| 31 |
- pre_output = NULL,+ |
||
| 32 |
- post_output = NULL) {
+ #' Module Server for Assay Specification |
||
| 33 | -! | +
- message("Initializing tm_g_volcanoplot")
+ #' |
|
| 34 | -! | +
- assert_string(label)+ #' @description `r lifecycle::badge("experimental")`
|
|
| 35 | -! | +
- assert_string(mae_name)+ #' |
|
| 36 | -! | +
- assert_character(exclude_assays)+ #' This defines the server part for the assay specification. |
|
| 37 | -! | +
- assert_tag(pre_output, null.ok = TRUE)+ #' |
|
| 38 | -! | +
- assert_tag(post_output, null.ok = TRUE)+ #' @inheritParams module_arguments |
|
| 39 |
-
+ #' @param assays (reactive `character`)\cr available assays in the currently selected experiment. |
||
| 40 | -! | +
- teal::module(+ #' @return The chosen assay as a reactive string. |
|
| 41 | -! | +
- label = label,+ #' |
|
| 42 | -! | +
- server = srv_g_volcanoplot,+ #' @seealso [assaySpecInput()] for the module UI. |
|
| 43 | -! | +
- server_args = list(+ #' |
|
| 44 | -! | +
- mae_name = mae_name,+ #' @export |
|
| 45 | -! | +
- exclude_assays = exclude_assays+ #' |
|
| 46 |
- ),+ #' @examples |
||
| 47 | -! | +
- ui = ui_g_volcanoplot,+ #' ui <- function(id) {
|
|
| 48 | -! | +
- ui_args = list(+ #' ns <- NS(id) |
|
| 49 | -! | +
- mae_name = mae_name,+ #' teal.widgets::standard_layout( |
|
| 50 | -! | +
- pre_output = pre_output,+ #' encoding = uiOutput(ns("encoding_ui")),
|
|
| 51 | -! | +
- post_output = post_output+ #' output = textOutput(ns("result"))
|
|
| 52 |
- ),+ #' ) |
||
| 53 | -! | +
- datanames = mae_name+ #' } |
|
| 54 |
- )+ #' |
||
| 55 |
- }+ #' server <- function(id, data, filter_panel_api) {
|
||
| 56 |
-
+ #' moduleServer(id, module = function(input, output, session) {
|
||
| 57 |
- #' @describeIn tm_g_volcanoplot sets up the user interface.+ #' output$encoding_ui <- renderUI({
|
||
| 58 |
- #' @inheritParams module_arguments+ #' tags$div( |
||
| 59 |
- #' @export+ #' experimentSpecInput(session$ns("experiment"), data, "MAE"),
|
||
| 60 |
- ui_g_volcanoplot <- function(id,+ #' assaySpecInput( |
||
| 61 |
- mae_name,+ #' session$ns("assay"),
|
||
| 62 |
- pre_output,+ #' label_assays = "Please choose assay" |
||
| 63 |
- post_output) {
+ #' ) |
||
| 64 | -1x | +
- ns <- NS(id)+ #' ) |
|
| 65 |
-
+ #' }) |
||
| 66 | -1x | +
- teal.widgets::standard_layout(+ #' experiment <- experimentSpecServer( |
|
| 67 | -1x | +
- output = tags$div(+ #' id = "experiment", |
|
| 68 | -1x | +
- teal.widgets::plot_with_settings_ui(ns("plot")),
+ #' data = data, |
|
| 69 | -1x | +
- DT::DTOutput(ns("table"))
+ #' filter_panel_api = filter_panel_api, |
|
| 70 |
- ),+ #' mae_name = "MAE" |
||
| 71 | -1x | +
- pre_output = pre_output,+ #' ) |
|
| 72 | -1x | +
- post_output = post_output,+ #' assay <- assaySpecServer( |
|
| 73 | -1x | +
- encoding = tags$div(+ #' "assay", |
|
| 74 |
- ### Reporter+ #' experiment$assays, |
||
| 75 | -1x | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' exclude_assays = c("counts", "cpm", "tpm", "bla")
|
|
| 76 |
- ###+ #' ) |
||
| 77 | -1x | +
- tags$label("Encodings", class = "text-primary"),
+ #' output$result <- renderPrint({
|
|
| 78 | -1x | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ #' assay() |
|
| 79 | -1x | +
- uiOutput(ns("experiment_ui")),
+ #' }) |
|
| 80 | -1x | +
- assaySpecInput(ns("assay")),
+ #' }) |
|
| 81 | -1x | +
- sampleVarSpecInput(ns("compare_group"), "Compare Groups", "Please group here into 2 levels"),
+ #' } |
|
| 82 | -1x | +
- tags$label("Show Top Differentiated Genes"),
+ #' |
|
| 83 | -1x | +
- shinyWidgets::switchInput(ns("show_top_gene"), value = FALSE, size = "mini"),
+ #' my_app <- function() {
|
|
| 84 | -1x | +
- teal.widgets::panel_group(+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
|
| 85 | -1x | +
- teal.widgets::panel_item(+ #' app <- init( |
|
| 86 | -1x | +
- input_id = "settings_item",+ #' data = data, |
|
| 87 | -1x | +
- collapsed = TRUE,+ #' modules = modules( |
|
| 88 | -1x | +
- title = "Additional Settings",+ #' module( |
|
| 89 | -1x | +
- selectInput(ns("method"), "Method", choices = c("voom", "deseq2")),
+ #' label = "assaySpec example", |
|
| 90 | -1x | +
- sliderInput(ns("log2_fc_thresh"), "Log2 fold change threshold", value = 2.5, min = 0.1, max = 10),
+ #' server = server, |
|
| 91 | -1x | +
- sliderInput(ns("adj_p_val_thresh"), "Adjusted p-value threshold", value = 0.05, min = 0.001, max = 1)
+ #' ui = ui, |
|
| 92 |
- )+ #' datanames = "all" |
||
| 93 |
- )+ #' ) |
||
| 94 |
- )+ #' ) |
||
| 95 |
- )+ #' ) |
||
| 96 |
- }+ #' shinyApp(app$ui, app$server) |
||
| 97 |
-
+ #' } |
||
| 98 |
- #' @describeIn tm_g_volcanoplot sets up the server with reactive graph.+ #' if (interactive()) {
|
||
| 99 |
- #' @inheritParams module_arguments+ #' my_app() |
||
| 100 |
- #' @export+ #' } |
||
| 101 |
- srv_g_volcanoplot <- function(id,+ assaySpecServer <- function(id, # nolint |
||
| 102 |
- data,+ assays, |
||
| 103 |
- filter_panel_api,+ exclude_assays = character()) {
|
||
| 104 | -+ | ! |
- reporter,+ assert_string(id) |
| 105 | -+ | ! |
- mae_name,+ assert_reactive(assays) |
| 106 | -+ | ! |
- exclude_assays) {
+ assert_character(exclude_assays, any.missing = FALSE) |
| 107 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
|
| 108 | ! |
- assert_class(filter_panel_api, "FilterPanelAPI")+ moduleServer(id, function(input, output, session) {
|
|
| 109 | -! | +
- checkmate::assert_class(data, "reactive")+ # When the assay names change, update the choices for assay. |
|
| 110 | ! |
- checkmate::assert_class(shiny::isolate(data()), "teal_data")+ choices <- reactive({
|
|
| 111 | -+ | ! |
-
+ assays <- assays() |
| 112 | ! |
- moduleServer(id, function(input, output, session) {
+ remaining_assays <- setdiff( |
|
| 113 | ! |
- output$experiment_ui <- renderUI({
+ assays, |
|
| 114 | ! |
- experimentSpecInput(session$ns("experiment"), data, mae_name)
+ exclude_assays |
|
| 115 |
- })+ ) |
||
| 116 | ! |
- experiment_data <- experimentSpecServer(+ removed_assays <- setdiff(assays, remaining_assays) |
|
| 117 | ! |
- "experiment",+ if (length(removed_assays) > 0) {
|
|
| 118 | ! |
- data = data,+ showNotification(type = "warning", paste( |
|
| 119 | ! |
- mae_name = mae_name+ "Excluded", ifelse(length(removed_assays) > 1, "assays", "assay"), |
|
| 120 | -+ | ! |
- )+ hermes::h_short_list(removed_assays), "as per app specifications" |
| 121 | -! | +
- assay <- assaySpecServer(+ )) |
|
| 122 | -! | +
- "assay",+ } |
|
| 123 | ! |
- assays = experiment_data$assays,+ if (length(remaining_assays) == 0) {
|
|
| 124 | ! |
- exclude_assays = exclude_assays+ remaining_assays <- character(0) |
|
| 125 |
- )+ } |
||
| 126 | ! |
- compare_group <- sampleVarSpecServer(+ remaining_assays |
|
| 127 | -! | +
- "compare_group",+ }) |
|
| 128 | -! | +
- experiment_name = experiment_data$name,+ |
|
| 129 | ! |
- original_data = experiment_data$data,+ observeEvent(choices(), {
|
|
| 130 | ! |
- num_levels = 2L,+ choices <- choices() |
|
| 131 | ! |
- label_modal_title = "Please click to group into exactly 2 levels, first level is reference"+ updateSelectizeInput(session, "name", choices = choices) |
|
| 132 | -+ | ! |
- )+ session$sendCustomMessage( |
| 133 | -+ | ! |
-
+ "toggle_dropdown", |
| 134 | -+ | ! |
- # When the filtered data set or the chosen experiment changes, update+ list(input_id = session$ns("name"), disabled = (length(choices) == 0))
|
| 135 |
- # the differential expression results.+ ) |
||
| 136 | -! | +
- diff_expr <- reactive({
+ }) |
|
| 137 | -! | +
- object <- compare_group$experiment_data()+ |
|
| 138 | ! |
- compare_group <- compare_group$sample_var()+ reactive({
|
|
| 139 | ! |
- method <- input$method+ choices <- choices() |
|
| 140 | -+ | ! |
-
+ validate(need( |
| 141 | ! |
- req(+ length(choices) > 0, |
|
| 142 | ! |
- object,+ "No assays eligible for this experiment, please make sure to add normalized assays" |
|
| 143 | -! | +
- method+ )) |
|
| 144 | -+ | ! |
- )+ input$name |
| 145 | -! | +
- validate(need(+ }) |
|
| 146 | -! | +
- !is.null(compare_group),+ }) |
|
| 147 | -! | +
- "Please select a group variable"+ } |
| 148 | +1 |
- ))+ #' Teal Module for RNA-seq Volcano Plot |
|
| 149 | +2 |
-
+ #' |
|
| 150 | -! | +||
| 3 | +
- hermes::diff_expression(+ #' @description `r lifecycle::badge("experimental")`
|
||
| 151 | -! | +||
| 4 | +
- object,+ #' |
||
| 152 | -! | +||
| 5 | +
- group = compare_group,+ #' This module provides an interactive volcano plot for RNA-seq gene expression |
||
| 153 | -! | +||
| 6 | +
- method = method+ #' analysis. |
||
| 154 | +7 |
- )+ #' |
|
| 155 | +8 |
- })+ #' @inheritParams module_arguments |
|
| 156 | +9 |
-
+ #' |
|
| 157 | -! | +||
| 10 | +
- plot_r <- reactive({
+ #' @return Shiny module to be used in the teal app. |
||
| 158 | -! | +||
| 11 | +
- diff_expr_result <- diff_expr()+ #' |
||
| 159 | -! | +||
| 12 | +
- log2_fc_thresh <- input$log2_fc_thresh+ #' @export |
||
| 160 | -! | +||
| 13 | +
- adj_p_val_thresh <- input$adj_p_val_thresh+ #' |
||
| 161 | +14 |
-
+ #' @examples |
|
| 162 | -! | +||
| 15 | +
- req(+ #' data <- teal_data(MAE = hermes::multi_assay_experiment) |
||
| 163 | -! | +||
| 16 | +
- log2_fc_thresh,+ #' app <- init( |
||
| 164 | -! | +||
| 17 | +
- adj_p_val_thresh+ #' data = data, |
||
| 165 | +18 |
- )+ #' modules = modules( |
|
| 166 | +19 |
-
+ #' tm_g_volcanoplot( |
|
| 167 | -! | +||
| 20 | +
- hermes::autoplot(+ #' label = "volcanoplot", |
||
| 168 | -! | +||
| 21 | +
- diff_expr_result,+ #' mae_name = "MAE" |
||
| 169 | -! | +||
| 22 | +
- adj_p_val_thresh = adj_p_val_thresh,+ #' ) |
||
| 170 | -! | +||
| 23 | +
- log2_fc_thresh = log2_fc_thresh+ #' ) |
||
| 171 | +24 |
- )+ #' ) |
|
| 172 | +25 |
- })+ #' if (interactive()) {
|
|
| 173 | -! | +||
| 26 | +
- output$plot <- renderPlot(plot_r())+ #' shinyApp(app$ui, app$server) |
||
| 174 | +27 |
-
+ #' } |
|
| 175 | -! | +||
| 28 | +
- pws_p <- teal.widgets::plot_with_settings_srv(+ tm_g_volcanoplot <- function(label, |
||
| 176 | -! | +||
| 29 | +
- id = "plot",+ mae_name, |
||
| 177 | -! | +||
| 30 | +
- plot_r = plot_r+ exclude_assays = character(), |
||
| 178 | +31 |
- )+ pre_output = NULL, |
|
| 179 | +32 |
-
+ post_output = NULL, |
|
| 180 | +33 |
- # Display top genes if switched on.+ .test = FALSE) {
|
|
| 181 | +34 | ! |
- show_top_gene_diffexpr <- reactive({
+ message("Initializing tm_g_volcanoplot")
|
| 182 | +35 | ! |
- if (input$show_top_gene) {
+ assert_string(label) |
| 183 | +36 | ! |
- result <- diff_expr()+ assert_string(mae_name) |
| 184 | +37 | ! |
- with(+ assert_character(exclude_assays) |
| 185 | +38 | ! |
- result,+ assert_tag(pre_output, null.ok = TRUE) |
| 186 | +39 | ! |
- data.frame(+ assert_tag(post_output, null.ok = TRUE)+ |
+
| 40 | ++ | + | |
| 187 | +41 | ! |
- log2_fc = round(log2_fc, 2),+ teal::module( |
| 188 | +42 | ! |
- stat = round(stat, 2),+ label = label, |
| 189 | +43 | ! |
- p_val = format.pval(p_val),+ server = srv_g_volcanoplot, |
| 190 | +44 | ! |
- adj_p_val = format.pval(adj_p_val),+ server_args = list( |
| 191 | +45 | ! |
- row.names = rownames(result)+ mae_name = mae_name, |
| 192 | -+ | ||
| 46 | +! |
- )+ exclude_assays = exclude_assays,+ |
+ |
| 47 | +! | +
+ .test = .test |
|
| 193 | +48 |
- )+ ),+ |
+ |
| 49 | +! | +
+ ui = ui_g_volcanoplot,+ |
+ |
| 50 | +! | +
+ ui_args = list(+ |
+ |
| 51 | +! | +
+ mae_name = mae_name,+ |
+ |
| 52 | +! | +
+ pre_output = pre_output,+ |
+ |
| 53 | +! | +
+ post_output = post_output,+ |
+ |
| 54 | +! | +
+ .test = .test |
|
| 194 | +55 |
- } else {
+ ), |
|
| 195 | +56 | ! |
- NULL+ datanames = mae_name |
| 196 | +57 |
- }+ ) |
|
| 197 | +58 |
- })+ } |
|
| 198 | +59 | ||
| 199 | -! | +||
| 60 | +
- output$table <- DT::renderDT({
+ #' @describeIn tm_g_volcanoplot sets up the user interface. |
||
| 200 | -! | +||
| 61 | +
- DT::datatable(+ #' @inheritParams module_arguments |
||
| 201 | -! | +||
| 62 | +
- show_top_gene_diffexpr(),+ #' @export |
||
| 202 | -! | +||
| 63 | +
- rownames = TRUE,+ ui_g_volcanoplot <- function(id, |
||
| 203 | -! | +||
| 64 | +
- options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)),+ mae_name, |
||
| 204 | -! | +||
| 65 | +
- caption = "Top Differentiated Genes"+ pre_output, |
||
| 205 | +66 |
- )+ post_output, |
|
| 206 | +67 |
- })+ .test = FALSE) {
+ |
+ |
| 68 | +1x | +
+ ns <- NS(id) |
|
| 207 | +69 | ||
| 208 | -+ | ||
| 70 | +1x |
- ### REPORTER+ teal.widgets::standard_layout( |
|
| 209 | -! | +||
| 71 | +1x |
- if (with_reporter) {
+ output = div( |
|
| 210 | -! | +||
| 72 | +1x |
- card_fun <- function(comment, label) {
+ if (.test) verbatimTextOutput(ns("test")) else NULL,
|
|
| 211 | -! | +||
| 73 | +1x |
- card <- report_card_template(+ teal.widgets::plot_with_settings_ui(ns("plot")),
|
|
| 212 | -! | +||
| 74 | +1x |
- title = "Volcano Plot",+ DT::DTOutput(ns("table"))
|
|
| 213 | -! | +||
| 75 | +
- label = label,+ ), |
||
| 214 | -! | +||
| 76 | +1x |
- with_filter = TRUE,+ pre_output = pre_output, |
|
| 215 | -! | +||
| 77 | +1x |
- filter_panel_api = filter_panel_api+ post_output = post_output,+ |
+ |
| 78 | +1x | +
+ encoding = tags$div( |
|
| 216 | +79 |
- )+ ### Reporter |
|
| 217 | -! | +||
| 80 | +1x |
- card$append_text("Selected Options", "header3")
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 218 | -! | +||
| 81 | +
- encodings_list <- list(+ ### |
||
| 219 | -! | +||
| 82 | +1x |
- "Experiment:",+ tags$label("Encodings", class = "text-primary"),
|
|
| 220 | -! | +||
| 83 | +1x |
- input$`experiment-name`,+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|
| 221 | -! | +||
| 84 | +1x |
- "\nAssay:",+ uiOutput(ns("experiment_ui")),
|
|
| 222 | -! | +||
| 85 | +1x |
- input$`assay-name`,+ assaySpecInput(ns("assay")),
|
|
| 223 | -! | +||
| 86 | +1x |
- "\nCompare Groups:",+ sampleVarSpecInput(ns("compare_group"), "Compare Groups", "Please group here into 2 levels"),
|
|
| 224 | -! | +||
| 87 | +1x |
- input$`compare_group-sample_var`,+ tags$label("Show Top Differentiated Genes"),
|
|
| 225 | -! | +||
| 88 | +1x |
- "\nShow Top Differentiated Genes:",+ shinyWidgets::switchInput(ns("show_top_gene"), value = FALSE, size = "mini"),
|
|
| 226 | -! | +||
| 89 | +1x |
- input$show_top_gene,+ teal.widgets::panel_group( |
|
| 227 | -! | +||
| 90 | +1x |
- "\nMethod:",+ teal.widgets::panel_item( |
|
| 228 | -! | +||
| 91 | +1x |
- input$method,+ input_id = "settings_item", |
|
| 229 | -! | +||
| 92 | +1x |
- "\nLog2fold Change Threshold:",+ collapsed = TRUE, |
|
| 230 | -! | +||
| 93 | +1x |
- input$log2_fc_thresh,+ title = "Additional Settings", |
|
| 231 | -! | +||
| 94 | +1x |
- "\nAdjusted P-value Threshold:",+ selectInput(ns("method"), "Method", choices = c("voom", "deseq2")),
|
|
| 232 | -! | +||
| 95 | +1x |
- input$adj_p_val_thresh+ sliderInput(ns("log2_fc_thresh"), "Log2 fold change threshold", value = 2.5, min = 0.1, max = 10),
+ |
+ |
| 96 | +1x | +
+ sliderInput(ns("adj_p_val_thresh"), "Adjusted p-value threshold", value = 0.05, min = 0.001, max = 1)
|
|
| 233 | +97 |
) |
|
| 234 | -! | +||
| 98 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ ) |
||
| 235 | -! | +||
| 99 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ ) |
||
| 236 | -! | +||
| 100 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ ) |
||
| 237 | -! | +||
| 101 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ } |
||
| 238 | +102 |
- } else {
+
|
|
| 239 | -! | +||
| 103 | +
- paste(encodings_list, collapse = " ")+ #' @describeIn tm_g_volcanoplot sets up the server with reactive graph. |
||
| 240 | +104 |
- }+ #' @inheritParams module_arguments |
|
| 241 | +105 |
-
+ #' @export |
|
| 242 | -! | +||
| 106 | +
- card$append_text(final_encodings, style = "verbatim")+ srv_g_volcanoplot <- function(id, |
||
| 243 | -! | +||
| 107 | +
- card$append_text("Plot", "header3")
+ data, |
||
| 244 | -! | +||
| 108 | +
- card$append_plot(plot_r(), dim = pws_p$dim())+ filter_panel_api, |
||
| 245 | -! | +||
| 109 | +
- if (isTRUE(input$show_top_gene)) {
+ reporter, |
||
| 246 | -! | +||
| 110 | +
- card$append_text("Table", "header3")
+ mae_name, |
||
| 247 | -! | +||
| 111 | +
- card$append_table(show_top_gene_diffexpr())+ exclude_assays, |
||
| 248 | +112 |
- }+ .test = FALSE) {
|
|
| 249 | +113 | ! |
- if (!comment == "") {
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 250 | +114 | ! |
- card$append_text("Comment", "header3")
+ assert_class(filter_panel_api, "FilterPanelAPI") |
| 251 | +115 | ! |
- card$append_text(comment)- |
-
| 252 | -- |
- }+ checkmate::assert_class(data, "reactive") |
|
| 253 | +116 | ! |
- card+ checkmate::assert_class(shiny::isolate(data()), "teal_data") |
| 254 | +117 |
- }+ |
|
| 255 | +118 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
-
| 256 | -- |
- }+ moduleServer(id, function(input, output, session) {
|
|
| 257 | -+ | ||
| 119 | +! |
- ###+ output$experiment_ui <- renderUI({
|
|
| 258 | -+ | ||
| 120 | +! |
- })+ experimentSpecInput(session$ns("experiment"), data, mae_name)
|
|
| 259 | +121 |
- }+ }) |
|
| 260 | -+ | ||
| 122 | +! |
-
+ experiment_data <- experimentSpecServer( |
|
| 261 | -+ | ||
| 123 | +! |
- #' @describeIn tm_g_volcanoplot sample module function.+ "experiment", |
|
| 262 | -+ | ||
| 124 | +! |
- #' @export+ data = data, |
|
| 263 | -+ | ||
| 125 | +! |
- #' @examples+ mae_name = mae_name |
|
| 264 | +126 |
- #'+ ) |
|
| 265 | -+ | ||
| 127 | +! |
- #' # Alternatively you can run the sample module with this function call:+ assay <- assaySpecServer( |
|
| 266 | -+ | ||
| 128 | +! |
- #' if (interactive()) {
+ "assay", |
|
| 267 | -+ | ||
| 129 | +! |
- #' sample_tm_g_volcanoplot()+ assays = experiment_data$assays, |
|
| 268 | -+ | ||
| 130 | +! |
- #' }+ exclude_assays = exclude_assays |
|
| 269 | +131 |
- sample_tm_g_volcanoplot <- function() {
+ ) |
|
| 270 | +132 | ! |
- data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment)+ compare_group <- sampleVarSpecServer( |
| 271 | +133 | ! |
- app <- teal::init(+ "compare_group", |
| 272 | +134 | ! |
- data = data,+ experiment_name = experiment_data$name, |
| 273 | +135 | ! |
- modules = teal::modules(+ original_data = experiment_data$data, |
| 274 | +136 | ! |
- tm_g_volcanoplot(+ num_levels = 2L, |
| 275 | +137 | ! |
- label = "volcanoplot",+ label_modal_title = "Please click to group into exactly 2 levels, first level is reference" |
| 276 | -! | +||
| 138 | +
- mae_name = "MAE"+ ) |
||
| 277 | +139 |
- )+ |
|
| 278 | +140 |
- )+ # When the filtered data set or the chosen experiment changes, update |
|
| 279 | +141 |
- )+ # the differential expression results. |
|
| 280 | +142 | ! |
- shinyApp(app$ui, app$server)- |
-
| 281 | -- |
- }+ diff_expr <- reactive({
|
| 1 | -+ | ||
| 143 | +! |
- .onLoad <- function(libname, pkgname) { # nolint
+ object <- compare_group$experiment_data() |
|
| 2 | +144 | ! |
- teal.logger::register_logger(namespace = "teal.modules.hermes")+ compare_group <- compare_group$sample_var() |
| 3 | +145 | ! |
- teal.logger::register_handlers("teal.modules.hermes")
+ method <- input$method |
| 4 | +146 |
- }+ |
| 1 | -+ | ||
| 147 | +! |
- #' Additional Assertions for `checkmate`+ req( |
|
| 2 | -+ | ||
| 148 | +! |
- #'+ object, |
|
| 3 | -+ | ||
| 149 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ method |
|
| 4 | +150 |
- #'+ ) |
|
| 5 | -+ | ||
| 151 | +! |
- #' We provide additional assertion functions which can be used together with+ validate(need( |
|
| 6 | -+ | ||
| 152 | +! |
- #' the `checkmate` functions. These are described in individual help pages+ !is.null(compare_group), |
|
| 7 | -+ | ||
| 153 | +! |
- #' linked below.+ "Please select a group variable" |
|
| 8 | +154 |
- #'+ )) |
|
| 9 | +155 |
- #' @return Depending on the function prefix.+ |
|
| 10 | -+ | ||
| 156 | +! |
- #' - `assert_` functions return the object invisibly if successful, and otherwise+ hermes::diff_expression( |
|
| 11 | -+ | ||
| 157 | +! |
- #' throw an error message.+ object, |
|
| 12 | -+ | ||
| 158 | +! |
- #' - `check_` functions return `TRUE` if successful, otherwise a string with the+ group = compare_group, |
|
| 13 | -+ | ||
| 159 | +! |
- #' error message.+ method = method |
|
| 14 | +160 |
- #' - `test_` functions just return `TRUE` or `FALSE`.+ ) |
|
| 15 | +161 |
- #'+ }) |
|
| 16 | +162 |
- #' @seealso [assert_tag()], [assert_reactive()], [assert_summary_funs()], [assert_adtte_vars()]+ |
|
| 17 | -+ | ||
| 163 | +! |
- #'+ plot_r <- reactive({
|
|
| 18 | -+ | ||
| 164 | +! |
- #' @name assertions+ diff_expr_result <- diff_expr() |
|
| 19 | -+ | ||
| 165 | +! |
- #' @import checkmate+ log2_fc_thresh <- input$log2_fc_thresh |
|
| 20 | -+ | ||
| 166 | +! |
- #' @keywords internal+ adj_p_val_thresh <- input$adj_p_val_thresh |
|
| 21 | +167 |
- #'+ |
|
| 22 | -+ | ||
| 168 | +! |
- NULL+ req( |
|
| 23 | -+ | ||
| 169 | +! |
-
+ log2_fc_thresh, |
|
| 24 | -+ | ||
| 170 | +! |
- # assert_tag ----+ adj_p_val_thresh |
|
| 25 | +171 |
-
+ ) |
|
| 26 | +172 |
- #' Check for Shiny Tag+ |
|
| 27 | -+ | ||
| 173 | +! |
- #'+ hermes::autoplot( |
|
| 28 | -+ | ||
| 174 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ diff_expr_result, |
|
| 29 | -+ | ||
| 175 | +! |
- #'+ adj_p_val_thresh = adj_p_val_thresh, |
|
| 30 | -+ | ||
| 176 | +! |
- #' Check whether `x` is a shiny tag.+ log2_fc_thresh = log2_fc_thresh |
|
| 31 | +177 |
- #'+ ) |
|
| 32 | +178 |
- #' @inheritParams assertion_arguments+ }) |
|
| 33 | -+ | ||
| 179 | +! |
- #' @seealso [`assertions`] for more details.+ output$plot <- renderPlot(plot_r()) |
|
| 34 | +180 |
- #'+ |
|
| 35 | -+ | ||
| 181 | +! |
- #' @export+ pws_p <- teal.widgets::plot_with_settings_srv( |
|
| 36 | -+ | ||
| 182 | +! |
- #'+ id = "plot", |
|
| 37 | -+ | ||
| 183 | +! |
- #' @examples+ plot_r = plot_r |
|
| 38 | +184 |
- #' check_tag("bla")
+ ) |
|
| 39 | +185 |
- #' check_tag(NULL, null.ok = TRUE)+ |
|
| 40 | +186 |
- check_tag <- function(x, null.ok = FALSE) { # nolint
- |
- |
| 41 | -16x | -
- assert_flag(null.ok)+ # Display top genes if switched on. |
|
| 42 | -15x | +||
| 187 | +! |
- ok <- (null.ok && test_null(x)) || test_class(x, "shiny.tag")+ show_top_gene_diffexpr <- reactive({
|
|
| 43 | -15x | +||
| 188 | +! |
- if (!ok) {
+ if (input$show_top_gene) {
|
|
| 44 | -1x | +||
| 189 | +! |
- return("Must be a 'shiny.tag' or NULL")
+ result <- diff_expr() |
|
| 45 | -+ | ||
| 190 | +! |
- }+ with( |
|
| 46 | -14x | +||
| 191 | +! |
- return(TRUE)+ result, |
|
| 47 | -+ | ||
| 192 | +! |
- }+ data.frame( |
|
| 48 | -+ | ||
| 193 | +! |
-
+ log2_fc = round(log2_fc, 2), |
|
| 49 | -+ | ||
| 194 | +! |
- #' @rdname check_tag+ stat = round(stat, 2), |
|
| 50 | -+ | ||
| 195 | +! |
- #' @inheritParams assertion_arguments+ p_val = format.pval(p_val), |
|
| 51 | -+ | ||
| 196 | +! |
- #' @export+ adj_p_val = format.pval(adj_p_val), |
|
| 52 | -+ | ||
| 197 | +! |
- assert_tag <- makeAssertionFunction(check_tag)+ row.names = rownames(result) |
|
| 53 | +198 |
-
+ ) |
|
| 54 | +199 |
- #' @rdname check_tag+ ) |
|
| 55 | +200 |
- #' @export+ } else {
|
|
| 56 | -+ | ||
| 201 | +! |
- test_tag <- makeTestFunction(check_tag)+ NULL |
|
| 57 | +202 |
-
+ } |
|
| 58 | +203 |
- #' @rdname check_tag+ }) |
|
| 59 | +204 |
- #' @inheritParams assertion_arguments+ |
|
| 60 | -+ | ||
| 205 | +! |
- #' @export+ output$table <- DT::renderDT({
|
|
| 61 | -+ | ||
| 206 | +! |
- expect_tag <- makeExpectationFunction(check_tag)+ DT::datatable( |
|
| 62 | -+ | ||
| 207 | +! |
-
+ show_top_gene_diffexpr(), |
|
| 63 | -+ | ||
| 208 | +! |
- # assert_reactive ----+ rownames = TRUE, |
|
| 64 | -+ | ||
| 209 | +! |
-
+ options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)), |
|
| 65 | -+ | ||
| 210 | +! |
- #' Check for Reactive Input+ caption = "Top Differentiated Genes" |
|
| 66 | +211 |
- #'+ ) |
|
| 67 | +212 |
- #' @description `r lifecycle::badge("experimental")`
+ }) |
|
| 68 | +213 |
- #'+ |
|
| 69 | -+ | ||
| 214 | +! |
- #' Check whether `x` is a reactive input.+ if (.test) {
|
|
| 70 | -+ | ||
| 215 | +! |
- #'+ output$test <- renderPrint(layer_data(plot_r())) |
|
| 71 | +216 |
- #' @inheritParams assertion_arguments+ } |
|
| 72 | +217 |
- #' @seealso [`assertions`] for more details.+ |
|
| 73 | +218 |
- #'+ |
|
| 74 | +219 |
- #' @export+ ### REPORTER |
|
| 75 | -+ | ||
| 220 | +! |
- #'+ if (with_reporter) {
|
|
| 76 | -+ | ||
| 221 | +! |
- #' @examples+ card_fun <- function(comment, label) {
|
|
| 77 | -+ | ||
| 222 | +! |
- #' check_reactive("bla")
+ card <- report_card_template( |
|
| 78 | -+ | ||
| 223 | +! |
- #' check_reactive(reactive("bla"))
+ title = "Volcano Plot", |
|
| 79 | -+ | ||
| 224 | +! |
- check_reactive <- function(x) {
+ label = label, |
|
| 80 | -6x | +||
| 225 | +! |
- inherits(x, "reactive")+ with_filter = TRUE, |
|
| 81 | -+ | ||
| 226 | +! |
- }+ filter_panel_api = filter_panel_api |
|
| 82 | +227 |
-
+ ) |
|
| 83 | -+ | ||
| 228 | +! |
- #' @rdname check_reactive+ card$append_text("Selected Options", "header3")
|
|
| 84 | -+ | ||
| 229 | +! |
- #' @inheritParams assertion_arguments+ encodings_list <- list( |
|
| 85 | -+ | ||
| 230 | +! |
- #' @export+ "Experiment:", |
|
| 86 | -+ | ||
| 231 | +! |
- assert_reactive <- makeAssertionFunction(check_reactive)+ input$`experiment-name`, |
|
| 87 | -+ | ||
| 232 | +! |
-
+ "\nAssay:", |
|
| 88 | -+ | ||
| 233 | +! |
- #' @rdname check_reactive+ input$`assay-name`, |
|
| 89 | -+ | ||
| 234 | +! |
- #' @export+ "\nCompare Groups:", |
|
| 90 | -+ | ||
| 235 | +! |
- test_reactive <- makeTestFunction(check_reactive)+ input$`compare_group-sample_var`, |
|
| 91 | -+ | ||
| 236 | +! |
-
+ "\nShow Top Differentiated Genes:", |
|
| 92 | -+ | ||
| 237 | +! |
- # assert_summary_funs ----+ input$show_top_gene, |
|
| 93 | -+ | ||
| 238 | +! |
-
+ "\nMethod:", |
|
| 94 | -+ | ||
| 239 | +! |
- #' Check for List of Summary Functions+ input$method, |
|
| 95 | -+ | ||
| 240 | +! |
- #'+ "\nLog2fold Change Threshold:", |
|
| 96 | -+ | ||
| 241 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ input$log2_fc_thresh, |
|
| 97 | -+ | ||
| 242 | +! |
- #'+ "\nAdjusted P-value Threshold:", |
|
| 98 | -+ | ||
| 243 | +! |
- #' Check whether `x` is a list of summary functions.+ input$adj_p_val_thresh |
|
| 99 | +244 |
- #'+ ) |
|
| 100 | -+ | ||
| 245 | +! |
- #' @inheritParams assertion_arguments+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 101 | -+ | ||
| 246 | +! |
- #' @param null.ok (`flag`)\cr whether `x` may also contain `NULL`, meaning that+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 102 | -+ | ||
| 247 | +! |
- #' a user choice is possible where no summary function should be applied.+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 103 | -+ | ||
| 248 | +! |
- #' @seealso [`assertions`] for more details.+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|
| 104 | +249 |
- #'+ } else {
|
|
| 105 | -+ | ||
| 250 | +! |
- #' @export+ paste(encodings_list, collapse = " ") |
|
| 106 | +251 |
- #'+ } |
|
| 107 | +252 |
- #' @examples+ |
|
| 108 | -+ | ||
| 253 | +! |
- #' assert_summary_funs(list(mean = colMeans, raw = NULL), null.ok = TRUE)+ card$append_text(final_encodings, style = "verbatim") |
|
| 109 | -+ | ||
| 254 | +! |
- assert_summary_funs <- function(x, null.ok = FALSE) { # nolint
+ card$append_text("Plot", "header3")
|
|
| 110 | +255 | ! |
- assert_flag(null.ok)+ card$append_plot(plot_r(), dim = pws_p$dim()) |
| 111 | +256 | ! |
- assert_list(+ if (isTRUE(input$show_top_gene)) {
|
| 112 | +257 | ! |
- x,+ card$append_text("Table", "header3")
|
| 113 | +258 | ! |
- types = c("function", `if`(null.ok, "null", NULL)),
+ card$append_table(show_top_gene_diffexpr())+ |
+
| 259 | ++ |
+ } |
|
| 114 | +260 | ! |
- min.len = 1L,+ if (!comment == "") {
|
| 115 | +261 | ! |
- unique = TRUE,+ card$append_text("Comment", "header3")
|
| 116 | +262 | ! |
- names = "unique"+ card$append_text(comment) |
| 117 | +263 |
- )+ } |
|
| 118 | +264 | ! |
- invisible(x)+ card |
| 119 | +265 |
- }+ }+ |
+ |
| 266 | +! | +
+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 120 | +267 |
-
+ } |
|
| 121 | +268 |
- # assert_adtte_vars ----+ ### |
|
| 122 | +269 |
-
+ }) |
|
| 123 | +270 |
- #' Check for `ADTTE` Variables+ } |
|
| 124 | +271 |
- #'+ |
|
| 125 | +272 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @describeIn tm_g_volcanoplot sample module function. |
|
| 126 | +273 |
- #'+ #' @export |
|
| 127 | +274 |
- #' Check whether `x` is a list of `ADTTE` variables.+ #' @examples |
|
| 128 | +275 |
#' |
|
| 129 | +276 |
- #' @inheritParams assertion_arguments+ #' # Alternatively you can run the sample module with this function call: |
|
| 130 | +277 |
- #' @seealso [`assertions`] for more details.+ #' if (interactive()) {
|
|
| 131 | +278 |
- #'+ #' sample_tm_g_volcanoplot() |
|
| 132 | +279 |
- #' @export+ #' } |
|
| 133 | +280 |
- #'+ sample_tm_g_volcanoplot <- function(.test = FALSE) {
|
|
| 134 | -+ | ||
| 281 | +! |
- #' @examples+ data <- teal.data::teal_data(MAE = hermes::multi_assay_experiment) |
|
| 135 | -+ | ||
| 282 | +! |
- #' assert_adtte_vars(list(aval = "AV", is_event = "EV", paramcd = "PC", usubjid = "ID", avalu = "u"))+ app <- teal::init(+ |
+ |
| 283 | +! | +
+ data = data,+ |
+ |
| 284 | +! | +
+ modules = teal::modules(+ |
+ |
| 285 | +! | +
+ tm_g_volcanoplot(+ |
+ |
| 286 | +! | +
+ label = "volcanoplot",+ |
+ |
| 287 | +! | +
+ mae_name = "MAE",+ |
+ |
| 288 | +! | +
+ .test = .test |
|
| 136 | +289 |
- assert_adtte_vars <- function(x) {
+ ) |
|
| 137 | -3x | +||
| 290 | +
- assert_list(x, types = "character", names = "unique", unique = TRUE)+ ) |
||
| 138 | -2x | +||
| 291 | +
- assert_names(names(x), permutation.of = c("aval", "is_event", "paramcd", "usubjid", "avalu"))
+ ) |
||
| 139 | -1x | +||
| 292 | +! |
- invisible(x)+ shinyApp(app$ui, app$server) |
|
| 140 | +293 |
}@@ -31086,14 +32039,14 @@ teal.modules.hermes coverage - 26.11% |
| 1 |
- #' Module Input for Assay Specification+ #' Additional Assertions for `checkmate` |
||
| 5 |
- #' This defines the input for the assay specification.+ #' We provide additional assertion functions which can be used together with |
||
| 6 |
- #'+ #' the `checkmate` functions. These are described in individual help pages |
||
| 7 |
- #' @inheritParams module_arguments+ #' linked below. |
||
| 8 |
- #' @param label_assays (`string`)\cr label for the assay selection.+ #' |
||
| 9 |
- #'+ #' @return Depending on the function prefix. |
||
| 10 |
- #' @return The UI part.+ #' - `assert_` functions return the object invisibly if successful, and otherwise |
||
| 11 |
- #' @seealso [assaySpecServer()] for the module server and a complete example.+ #' throw an error message. |
||
| 12 |
- #' @export+ #' - `check_` functions return `TRUE` if successful, otherwise a string with the |
||
| 13 |
- assaySpecInput <- function(inputId, # nolint+ #' error message. |
||
| 14 |
- label_assays = "Select Assay") {
+ #' - `test_` functions just return `TRUE` or `FALSE`. |
||
| 15 | -9x | +
- assert_string(inputId)+ #' |
|
| 16 | -9x | +
- assert_string(label_assays, min.chars = 1L)+ #' @seealso [assert_tag()], [assert_reactive()], [assert_summary_funs()], [assert_adtte_vars()] |
|
| 17 |
-
+ #' |
||
| 18 | -9x | +
- ns <- NS(inputId)+ #' @name assertions |
|
| 19 | -9x | +
- tagList(+ #' @import checkmate |
|
| 20 | -9x | +
- selectizeInput(+ #' @keywords internal |
|
| 21 | -9x | +
- inputId = ns("name"),
+ #' |
|
| 22 | -9x | +
- label = label_assays,+ NULL |
|
| 23 | -9x | +
- choices = character(0),+ |
|
| 24 | -9x | +
- options = list(+ # assert_tag ---- |
|
| 25 | -9x | +
- placeholder = "- Nothing selected -"+ |
|
| 26 |
- )+ #' Check for Shiny Tag |
||
| 27 |
- ),+ #' |
||
| 28 | -9x | +
- include_js_files("dropdown.js")
+ #' @description `r lifecycle::badge("experimental")`
|
|
| 29 |
- )+ #' |
||
| 30 |
- }+ #' Check whether `x` is a shiny tag. |
||
| 31 |
-
+ #' |
||
| 32 |
- #' Module Server for Assay Specification+ #' @inheritParams assertion_arguments |
||
| 33 |
- #'+ #' @seealso [`assertions`] for more details. |
||
| 34 |
- #' @description `r lifecycle::badge("experimental")`
+ #' |
||
| 35 |
- #'+ #' @export |
||
| 36 |
- #' This defines the server part for the assay specification.+ #' |
||
| 37 |
- #'+ #' @examples |
||
| 38 |
- #' @inheritParams module_arguments+ #' check_tag("bla")
|
||
| 39 |
- #' @param assays (reactive `character`)\cr available assays in the currently selected experiment.+ #' check_tag(NULL, null.ok = TRUE) |
||
| 40 |
- #' @return The chosen assay as a reactive string.+ check_tag <- function(x, null.ok = FALSE) { # nolint
|
||
| 41 | -+ | 16x |
- #'+ assert_flag(null.ok) |
| 42 | -+ | 15x |
- #' @seealso [assaySpecInput()] for the module UI.+ ok <- (null.ok && test_null(x)) || test_class(x, "shiny.tag") |
| 43 | -+ | 15x |
- #'+ if (!ok) {
|
| 44 | -+ | 1x |
- #' @export+ return("Must be a 'shiny.tag' or NULL")
|
| 45 |
- #'+ } |
||
| 46 | -+ | 14x |
- #' @examples+ return(TRUE) |
| 47 |
- #' ui <- function(id) {
+ } |
||
| 48 |
- #' ns <- NS(id)+ |
||
| 49 |
- #' teal.widgets::standard_layout(+ #' @rdname check_tag |
||
| 50 |
- #' encoding = uiOutput(ns("encoding_ui")),
+ #' @inheritParams assertion_arguments |
||
| 51 |
- #' output = textOutput(ns("result"))
+ #' @export |
||
| 52 |
- #' )+ assert_tag <- makeAssertionFunction(check_tag) |
||
| 53 |
- #' }+ |
||
| 54 |
- #'+ #' @rdname check_tag |
||
| 55 |
- #' server <- function(id, data, filter_panel_api) {
+ #' @export |
||
| 56 |
- #' moduleServer(id, module = function(input, output, session) {
+ test_tag <- makeTestFunction(check_tag) |
||
| 57 |
- #' output$encoding_ui <- renderUI({
+
|
||
| 58 |
- #' tags$div(+ #' @rdname check_tag |
||
| 59 |
- #' experimentSpecInput(session$ns("experiment"), data, "MAE"),
+ #' @inheritParams assertion_arguments |
||
| 60 |
- #' assaySpecInput(+ #' @export |
||
| 61 |
- #' session$ns("assay"),
+ expect_tag <- makeExpectationFunction(check_tag) |
||
| 62 |
- #' label_assays = "Please choose assay"+ |
||
| 63 |
- #' )+ # assert_reactive ---- |
||
| 64 |
- #' )+ |
||
| 65 |
- #' })+ #' Check for Reactive Input |
||
| 66 |
- #' experiment <- experimentSpecServer(+ #' |
||
| 67 |
- #' id = "experiment",+ #' @description `r lifecycle::badge("experimental")`
|
||
| 68 |
- #' data = data,+ #' |
||
| 69 |
- #' filter_panel_api = filter_panel_api,+ #' Check whether `x` is a reactive input. |
||
| 70 |
- #' mae_name = "MAE"+ #' |
||
| 71 |
- #' )+ #' @inheritParams assertion_arguments |
||
| 72 |
- #' assay <- assaySpecServer(+ #' @seealso [`assertions`] for more details. |
||
| 73 |
- #' "assay",+ #' |
||
| 74 |
- #' experiment$assays,+ #' @export |
||
| 75 |
- #' exclude_assays = c("counts", "cpm", "tpm", "bla")
+ #' |
||
| 76 |
- #' )+ #' @examples |
||
| 77 |
- #' output$result <- renderPrint({
+ #' check_reactive("bla")
|
||
| 78 |
- #' assay()+ #' check_reactive(reactive("bla"))
|
||
| 79 |
- #' })+ check_reactive <- function(x) {
|
||
| 80 | -+ | 6x |
- #' })+ inherits(x, "reactive") |
| 81 |
- #' }+ } |
||
| 82 |
- #'+ |
||
| 83 |
- #' my_app <- function() {
+ #' @rdname check_reactive |
||
| 84 |
- #' data <- teal_data(MAE = hermes::multi_assay_experiment)+ #' @inheritParams assertion_arguments |
||
| 85 |
- #' app <- init(+ #' @export |
||
| 86 |
- #' data = data,+ assert_reactive <- makeAssertionFunction(check_reactive) |
||
| 87 |
- #' modules = modules(+ |
||
| 88 |
- #' module(+ #' @rdname check_reactive |
||
| 89 |
- #' label = "assaySpec example",+ #' @export |
||
| 90 |
- #' server = server,+ test_reactive <- makeTestFunction(check_reactive) |
||
| 91 |
- #' ui = ui,+ |
||
| 92 |
- #' datanames = "all"+ # assert_summary_funs ---- |
||
| 93 |
- #' )+ |
||
| 94 |
- #' )+ #' Check for List of Summary Functions |
||
| 95 |
- #' )+ #' |
||
| 96 |
- #' shinyApp(app$ui, app$server)+ #' @description `r lifecycle::badge("experimental")`
|
||
| 97 |
- #' }+ #' |
||
| 98 |
- #' if (interactive()) {
+ #' Check whether `x` is a list of summary functions. |
||
| 99 |
- #' my_app()+ #' |
||
| 100 |
- #' }+ #' @inheritParams assertion_arguments |
||
| 101 |
- assaySpecServer <- function(id, # nolint+ #' @param null.ok (`flag`)\cr whether `x` may also contain `NULL`, meaning that |
||
| 102 |
- assays,+ #' a user choice is possible where no summary function should be applied. |
||
| 103 |
- exclude_assays = character()) {
+ #' @seealso [`assertions`] for more details. |
||
| 104 | -! | +
- assert_string(id)+ #' |
|
| 105 | -! | +
- assert_reactive(assays)+ #' @export |
|
| 106 | -! | +
- assert_character(exclude_assays, any.missing = FALSE)+ #' |
|
| 107 |
-
+ #' @examples |
||
| 108 | -! | +
- moduleServer(id, function(input, output, session) {
+ #' assert_summary_funs(list(mean = colMeans, raw = NULL), null.ok = TRUE) |
|
| 109 |
- # When the assay names change, update the choices for assay.+ assert_summary_funs <- function(x, null.ok = FALSE) { # nolint
|
||
| 110 | ! |
- choices <- reactive({
+ assert_flag(null.ok) |
|
| 111 | ! |
- assays <- assays()+ assert_list( |
|
| 112 | ! |
- remaining_assays <- setdiff(+ x, |
|
| 113 | ! |
- assays,+ types = c("function", `if`(null.ok, "null", NULL)),
|
|
| 114 | ! |
- exclude_assays+ min.len = 1L, |
|
| 115 | -+ | ! |
- )+ unique = TRUE, |
| 116 | ! |
- removed_assays <- setdiff(assays, remaining_assays)+ names = "unique" |
|
| 117 | -! | +
- if (length(removed_assays) > 0) {
+ ) |
|
| 118 | ! |
- showNotification(type = "warning", paste(+ invisible(x) |
|
| 119 | -! | +
- "Excluded", ifelse(length(removed_assays) > 1, "assays", "assay"),+ } |
|
| 120 | -! | +
- hermes::h_short_list(removed_assays), "as per app specifications"+ |
|
| 121 |
- ))+ # assert_adtte_vars ---- |
||
| 122 |
- }+ |
||
| 123 | -! | +
- if (length(remaining_assays) == 0) {
+ #' Check for `ADTTE` Variables |
|
| 124 | -! | +
- remaining_assays <- character(0)+ #' |
|
| 125 |
- }+ #' @description `r lifecycle::badge("experimental")`
|
||
| 126 | -! | +
- remaining_assays+ #' |
|
| 127 |
- })+ #' Check whether `x` is a list of `ADTTE` variables. |
||
| 128 |
-
+ #' |
||
| 129 | -! | +
- observeEvent(choices(), {
+ #' @inheritParams assertion_arguments |
|
| 130 | -! | +
- choices <- choices()+ #' @seealso [`assertions`] for more details. |
|
| 131 | -! | +
- updateSelectizeInput(session, "name", choices = choices)+ #' |
|
| 132 | -! | +
- session$sendCustomMessage(+ #' @export |
|
| 133 | -! | +
- "toggle_dropdown",+ #' |
|
| 134 | -! | +
- list(input_id = session$ns("name"), disabled = (length(choices) == 0))
+ #' @examples |
|
| 135 |
- )+ #' assert_adtte_vars(list(aval = "AV", is_event = "EV", paramcd = "PC", usubjid = "ID", avalu = "u")) |
||
| 136 |
- })+ assert_adtte_vars <- function(x) {
|
||
| 137 | -+ | 3x |
-
+ assert_list(x, types = "character", names = "unique", unique = TRUE) |
| 138 | -! | +2x |
- reactive({
+ assert_names(names(x), permutation.of = c("aval", "is_event", "paramcd", "usubjid", "avalu"))
|
| 139 | -! | -
- choices <- choices()- |
- |
| 140 | -! | -
- validate(need(- |
- |
| 141 | -! | -
- length(choices) > 0,- |
- |
| 142 | -! | -
- "No assays eligible for this experiment, please make sure to add normalized assays"- |
- |
| 143 | -- |
- ))- |
- |
| 144 | -! | -
- input$name- |
- |
| 145 | -- |
- })- |
- |
| 146 | -+ | 1x |
- })+ invisible(x) |
| 147 | +140 |
}@@ -32680,6 +33584,40 @@ teal.modules.hermes coverage - 26.11% |
| 1 | ++ |
+ .onLoad <- function(libname, pkgname) { # nolint
+ |
+
| 2 | +! | +
+ teal.logger::register_logger(namespace = "teal.modules.hermes")+ |
+
| 3 | +! | +
+ teal.logger::register_handlers("teal.modules.hermes")
+ |
+
| 4 | ++ |
+ }+ |
+