| 1 |
- #' Teal Module for RNA-seq Volcano Plot+ #' Module Input for Experiment Specification |
||
| 5 |
- #' This module provides an interactive volcano plot for RNA-seq gene expression+ #' This defines the input for the experiment specification. |
||
| 6 |
- #' analysis.+ #' |
||
| 7 |
- #'+ #' @inheritParams module_arguments |
||
| 8 |
- #' @inheritParams module_arguments+ #' @param label_experiments (`string`)\cr label for the experiment selection. |
||
| 10 |
- #' @return Shiny module to be used in the teal app.+ #' @return The UI part. |
||
| 11 |
- #'+ #' @seealso [experimentSpecServer()] for the module server and a complete example. |
||
| 13 |
- #'+ experimentSpecInput <- function(inputId, # nolint |
||
| 14 |
- #' @examples+ data, |
||
| 15 |
- #' mae <- hermes::multi_assay_experiment+ mae_name, |
||
| 16 |
- #' mae_data <- dataset("MAE", mae)
+ label_experiments = "Select Experiment") {
|
||
| 17 | -+ | 9x |
- #' data <- teal_data(mae_data)+ assert_string(inputId) |
| 18 | -+ | 9x |
- #' app <- init(+ assert_string(mae_name, min.chars = 1L) |
| 19 | -+ | 9x |
- #' data = data,+ assert_string(label_experiments, min.chars = 1L) |
| 20 | -+ | 9x |
- #' modules = modules(+ mae <- data[[mae_name]]() |
| 21 | -+ | 9x |
- #' tm_g_volcanoplot(+ name_choices <- names(mae) |
| 22 |
- #' label = "volcanoplot",+ |
||
| 23 | -+ | 9x |
- #' mae_name = "MAE"+ ns <- NS(inputId) |
| 24 | -+ | 9x |
- #' )+ selectInput( |
| 25 | -+ | 9x |
- #' )+ inputId = ns("name"),
|
| 26 | -+ | 9x |
- #' )+ label = label_experiments, |
| 27 | -+ | 9x |
- #' if (interactive()) {
+ choices = name_choices |
| 28 |
- #' shinyApp(app$ui, app$server)+ ) |
||
| 29 |
- #' }+ } |
||
| 30 |
- tm_g_volcanoplot <- function(label,+ |
||
| 31 |
- mae_name,+ #' Helper Function to Order Gene Choices |
||
| 32 |
- exclude_assays = character(),+ #' |
||
| 33 |
- pre_output = NULL,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 34 |
- post_output = NULL) {
+ #' |
||
| 35 | -! | +
- logger::log_info("Initializing tm_g_volcanoplot")
+ #' The possible gene choices are ordered as follows. First come all genes which |
|
| 36 | -! | +
- assert_string(label)+ #' have a non-empty name, ordered by their name alphabetically. Last come |
|
| 37 | -! | +
- assert_string(mae_name)+ #' all genes with an empty name, ordered by their ID alphabetically. |
|
| 38 | -! | +
- assert_character(exclude_assays)+ #' |
|
| 39 | -! | +
- assert_tag(pre_output, null.ok = TRUE)+ #' @param genes (`data.frame`)\cr containing `id` and `name` columns of the |
|
| 40 | -! | +
- assert_tag(post_output, null.ok = TRUE)+ #' gene choices. Note that no missing values are allowed. |
|
| 41 |
-
+ #' |
||
| 42 | -! | +
- teal::module(+ #' @return The ordered `data.frame`. |
|
| 43 | -! | +
- label = label,+ #' @export |
|
| 44 | -! | +
- server = srv_g_volcanoplot,+ #' |
|
| 45 | -! | +
- server_args = list(+ #' @examples |
|
| 46 | -! | +
- mae_name = mae_name,+ #' genes <- data.frame( |
|
| 47 | -! | +
- exclude_assays = exclude_assays+ #' id = c("7", "1", "2", "345346", "0"),
|
|
| 48 |
- ),+ #' name = c("e", "", "c", "", "a")
|
||
| 49 | -! | +
- ui = ui_g_volcanoplot,+ #' ) |
|
| 50 | -! | +
- ui_args = list(+ #' h_order_genes(genes) |
|
| 51 | -! | +
- mae_name = mae_name,+ h_order_genes <- function(genes) {
|
|
| 52 | -! | +4x |
- pre_output = pre_output,+ assert_data_frame(genes, types = "character", any.missing = FALSE) |
| 53 | -! | +4x |
- post_output = post_output+ assert_set_equal(names(genes), c("id", "name"))
|
| 54 |
- ),+ |
||
| 55 | -! | +4x |
- datanames = mae_name+ has_empty_name <- genes$name == "" |
| 56 | -+ | 4x |
- )+ first_genes <- which(!has_empty_name)[order(genes[!has_empty_name, ]$name)] |
| 57 | -+ | 4x |
- }+ last_genes <- which(has_empty_name)[order(genes[has_empty_name, ]$id)] |
| 58 | -+ | 4x |
-
+ genes[c(first_genes, last_genes), ] |
| 59 |
- #' @describeIn tm_g_volcanoplot sets up the user interface.+ } |
||
| 60 |
- #' @inheritParams module_arguments+ |
||
| 61 |
- #' @export+ #' Helper Function to Format Gene Choices |
||
| 62 |
- ui_g_volcanoplot <- function(id,+ #' |
||
| 63 |
- data,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 64 |
- mae_name,+ #' |
||
| 65 |
- pre_output,+ #' Given a [`hermes::AnyHermesData`] data object, as well as the annotation |
||
| 66 |
- post_output) {
+ #' column name to use as gene name, this function formats the contained genes |
||
| 67 | -1x | +
- ns <- NS(id)+ #' as a `data.frame` ready for consumption in [h_order_genes()] e.g. |
|
| 68 | -1x | +
- mae <- data[[mae_name]]+ #' |
|
| 69 |
-
+ #' @details |
||
| 70 | -1x | +
- teal.widgets::standard_layout(+ #' Note that missing names or names that only contain whitespace |
|
| 71 | -1x | +
- output = div(+ #' are replaced by empty strings for consistency and better labeling in the |
|
| 72 | -1x | +
- teal.widgets::plot_with_settings_ui(ns("plot")),
+ #' UI downstream |
|
| 73 | -1x | +
- DT::DTOutput(ns("table"))
+ #' |
|
| 74 |
- ),+ #' @inheritParams function_arguments |
||
| 75 | -1x | +
- pre_output = pre_output,+ #' @inheritParams experimentSpecServer |
|
| 76 | -1x | +
- post_output = post_output,+ #' |
|
| 77 | -1x | +
- encoding = div(+ #' @return A `data.frame` with `id` and `name` columns containing all genes from |
|
| 78 |
- ### Reporter+ #' `object`. |
||
| 79 | -1x | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ #' @export |
|
| 80 |
- ###+ #' |
||
| 81 | -1x | +
- tags$label("Encodings", class = "text-primary"),
+ #' @examples |
|
| 82 | -1x | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ #' object <- hermes::hermes_data[1:10, ] |
|
| 83 | -1x | +
- experimentSpecInput(ns("experiment"), data, mae_name),
+ #' h_gene_data(object, "symbol") |
|
| 84 | -1x | +
- assaySpecInput(ns("assay")),
+ h_gene_data <- function(object, name_annotation) {
|
|
| 85 | -1x | +2x |
- sampleVarSpecInput(ns("compare_group"), "Compare Groups", "Please group here into 2 levels"),
+ assert_true(hermes::is_hermes_data(object)) |
| 86 | -1x | +2x |
- tags$label("Show Top Differentiated Genes"),
+ assert_string(name_annotation, null.ok = TRUE) |
| 87 | -1x | +
- shinyWidgets::switchInput(ns("show_top_gene"), value = FALSE, size = "mini"),
+
|
|
| 88 | -1x | +2x |
- teal.widgets::panel_group(+ gene_ids <- hermes::genes(object) |
| 89 | -1x | +2x |
- teal.widgets::panel_item(+ gene_names <- if (!is.null(name_annotation)) {
|
| 90 | -1x | +2x |
- input_id = "settings_item",+ annotation_data <- hermes::annotation(object) |
| 91 | -1x | +2x |
- collapsed = TRUE,+ assert_subset(name_annotation, names(annotation_data)) |
| 92 | -1x | +2x |
- title = "Additional Settings",+ annotation_vector <- annotation_data[[name_annotation]] |
| 93 | -1x | +2x |
- selectInput(ns("method"), "Method", choices = c("voom", "deseq2")),
+ annotation_missing <- is.na(annotation_vector) | grepl("^\\s+$", annotation_vector)
|
| 94 | -1x | +2x |
- sliderInput(ns("log2_fc_thresh"), "Log2 fold change threshold", value = 2.5, min = 0.1, max = 10),
+ annotation_vector[annotation_missing] <- "" |
| 95 | -1x | +2x |
- sliderInput(ns("adj_p_val_thresh"), "Adjusted p-value threshold", value = 0.05, min = 0.001, max = 1)
+ annotation_vector |
| 96 |
- )+ } else {
|
||
| 97 |
- )+ "" |
||
| 98 |
- )+ } |
||
| 99 | -+ | 2x |
- )+ data.frame( |
| 100 | -+ | 2x |
- }+ id = gene_ids, |
| 101 | -+ | 2x |
-
+ name = gene_names |
| 102 |
- #' @describeIn tm_g_volcanoplot sets up the server with reactive graph.+ ) |
||
| 103 |
- #' @inheritParams module_arguments+ } |
||
| 104 |
- #' @export+ |
||
| 105 |
- srv_g_volcanoplot <- function(id,+ #' Module Server for Experiment Specification |
||
| 106 |
- data,+ #' |
||
| 107 |
- filter_panel_api,+ #' @description `r lifecycle::badge("experimental")`
|
||
| 108 |
- reporter,+ #' |
||
| 109 |
- mae_name,+ #' This defines the server part for the experiment specification. |
||
| 110 |
- exclude_assays) {
+ #' |
||
| 111 | -! | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' @inheritParams module_arguments |
|
| 112 | -! | +
- assert_class(filter_panel_api, "FilterPanelAPI")+ #' @param name_annotation (`string` or `NULL`)\cr which annotation column to use as name |
|
| 113 | -! | +
- assert_class(data, "tdata")+ #' to return in the `genes` data. If `NULL`, then the `name` column will be set to empty |
|
| 114 |
-
+ #' strings. |
||
| 115 | -! | +
- moduleServer(id, function(input, output, session) {
+ #' @param sample_vars_as_factors (`flag`)\cr whether to convert the sample variables |
|
| 116 | -! | +
- experiment_data <- experimentSpecServer(+ #' (columns in `colData()` of the experiment) from character to factor variables. |
|
| 117 | -! | +
- "experiment",+ #' @param with_mae_col_data (`flag`)\cr whether to include the `colData()` of the |
|
| 118 | -! | +
- data = data,+ #' MAE into the experiment `colData()`. |
|
| 119 | -! | +
- mae_name = mae_name+ #' @return List with the following reactive objects: |
|
| 120 |
- )+ #' - `data`: the [`hermes::AnyHermesData`] experiment. |
||
| 121 | -! | +
- assay <- assaySpecServer(+ #' - `name`: the name of the experiment as selected by the user. |
|
| 122 | -! | +
- "assay",+ #' - `genes`: a `data.frame` with the genes in `data`, with columns `id` and `name`. |
|
| 123 | -! | +
- assays = experiment_data$assays,+ #' - `assays`: the names of the assays in `data`. |
|
| 124 | -! | +
- exclude_assays = exclude_assays+ #' |
|
| 125 |
- )+ #' @seealso [experimentSpecInput()] for the module UI. |
||
| 126 | -! | +
- compare_group <- sampleVarSpecServer(+ #' |
|
| 127 | -! | +
- "compare_group",+ #' @export |
|
| 128 | -! | +
- experiment_name = experiment_data$name,+ #' |
|
| 129 | -! | +
- original_data = experiment_data$data,+ #' @examples |
|
| 130 | -! | +
- num_levels = 2L,+ #' ui <- function(id, |
|
| 131 | -! | +
- label_modal_title = "Please click to group into exactly 2 levels, first level is reference"+ #' data, |
|
| 132 |
- )+ #' mae_name) {
|
||
| 133 |
-
+ #' ns <- NS(id) |
||
| 134 |
- # When the filtered data set or the chosen experiment changes, update+ #' teal.widgets::standard_layout( |
||
| 135 |
- # the differential expression results.+ #' encoding = div( |
||
| 136 | -! | +
- diff_expr <- reactive({
+ #' experimentSpecInput( |
|
| 137 | -! | +
- object <- compare_group$experiment_data()+ #' ns("my_experiment"),
|
|
| 138 | -! | +
- compare_group <- compare_group$sample_var()+ #' data, |
|
| 139 | -! | +
- method <- input$method+ #' mae_name, |
|
| 140 |
-
+ #' label_experiments = "Please choose experiment" |
||
| 141 | -! | +
- req(+ #' ), |
|
| 142 | -! | +
- object,+ #' selectInput( |
|
| 143 | -! | +
- method+ #' ns("property"),
|
|
| 144 |
- )+ #' "Please choose property", |
||
| 145 | -! | +
- validate(need(+ #' c("data", "name", "genes", "assays")
|
|
| 146 | -! | +
- !is.null(compare_group),+ #' ) |
|
| 147 | -! | +
- "Please select a group variable"+ #' ), |
|
| 148 |
- ))+ #' output = div( |
||
| 149 |
-
+ #' verbatimTextOutput(ns("summary")),
|
||
| 150 | -! | +
- hermes::diff_expression(+ #' verbatimTextOutput(ns("head"))
|
|
| 151 | -! | +
- object,+ #' ) |
|
| 152 | -! | +
- group = compare_group,+ #' ) |
|
| 153 | -! | +
- method = method+ #' } |
|
| 154 |
- )+ #' |
||
| 155 |
- })+ #' server <- function(id, |
||
| 156 |
-
+ #' data, |
||
| 157 | -! | +
- plot_r <- reactive({
+ #' filter_panel_api, |
|
| 158 | -! | +
- diff_expr_result <- diff_expr()+ #' mae_name) {
|
|
| 159 | -! | +
- log2_fc_thresh <- input$log2_fc_thresh+ #' moduleServer(id, function(input, output, session) {
|
|
| 160 | -! | +
- adj_p_val_thresh <- input$adj_p_val_thresh+ #' experiment <- experimentSpecServer( |
|
| 161 |
-
+ #' "my_experiment", |
||
| 162 | -! | +
- req(+ #' data, |
|
| 163 | -! | +
- log2_fc_thresh,+ #' filter_panel_api, |
|
| 164 | -! | +
- adj_p_val_thresh+ #' mae_name |
|
| 165 |
- )+ #' ) |
||
| 166 |
-
+ #' result <- reactive({
|
||
| 167 | -! | +
- hermes::autoplot(+ #' switch(input$property, |
|
| 168 | -! | +
- diff_expr_result,+ #' data = experiment$data(), |
|
| 169 | -! | +
- adj_p_val_thresh = adj_p_val_thresh,+ #' name = experiment$name(), |
|
| 170 | -! | +
- log2_fc_thresh = log2_fc_thresh+ #' genes = experiment$genes(), |
|
| 171 |
- )+ #' assays = experiment$assays() |
||
| 172 |
- })+ #' ) |
||
| 173 | -! | +
- output$plot <- renderPlot(plot_r())+ #' }) |
|
| 174 |
-
+ #' output$summary <- renderPrint({
|
||
| 175 | -! | +
- pws_p <- teal.widgets::plot_with_settings_srv(+ #' result <- result() |
|
| 176 | -! | +
- id = "plot",+ #' hermes::summary(result) |
|
| 177 | -! | +
- plot_r = plot_r+ #' }) |
|
| 178 |
- )+ #' output$head <- renderPrint({
|
||
| 179 |
-
+ #' result <- result() |
||
| 180 |
- # Display top genes if switched on.+ #' utils::head(result) |
||
| 181 | -! | +
- show_top_gene_diffexpr <- reactive({
+ #' }) |
|
| 182 | -! | +
- if (input$show_top_gene) {
+ #' }) |
|
| 183 | -! | +
- result <- diff_expr()+ #' } |
|
| 184 | -! | +
- with(+ #' |
|
| 185 | -! | +
- result,+ #' my_app <- function() {
|
|
| 186 | -! | +
- data.frame(+ #' mae <- hermes::multi_assay_experiment |
|
| 187 | -! | +
- log2_fc = round(log2_fc, 2),+ #' mae_name <- "MAE" |
|
| 188 | -! | +
- stat = round(stat, 2),+ #' mae_data <- dataset(mae_name, mae) |
|
| 189 | -! | +
- p_val = format.pval(p_val),+ #' data <- teal_data(mae_data) |
|
| 190 | -! | +
- adj_p_val = format.pval(adj_p_val),+ #' app <- init( |
|
| 191 | -! | +
- row.names = rownames(result)+ #' data = data, |
|
| 192 |
- )+ #' modules = modules( |
||
| 193 |
- )+ #' module( |
||
| 194 |
- } else {
+ #' label = "experimentSpec example", |
||
| 195 | -! | +
- NULL+ #' server = server, |
|
| 196 |
- }+ #' server_args = list(mae_name = mae_name), |
||
| 197 |
- })+ #' ui = ui, |
||
| 198 |
-
+ #' ui_args = list(mae_name = mae_name), |
||
| 199 | -! | +
- output$table <- DT::renderDT({
+ #' datanames = "all" |
|
| 200 | -! | +
- DT::datatable(+ #' ) |
|
| 201 | -! | +
- show_top_gene_diffexpr(),+ #' ) |
|
| 202 | -! | +
- rownames = TRUE,+ #' ) |
|
| 203 | -! | +
- options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)),+ #' shinyApp(app$ui, app$server) |
|
| 204 | -! | +
- caption = "Top Differentiated Genes"+ #' } |
|
| 205 |
- )+ #' if (interactive()) {
|
||
| 206 |
- })+ #' my_app() |
||
| 207 |
-
+ #' } |
||
| 208 |
- ### REPORTER+ experimentSpecServer <- function(id, # nolint |
||
| 209 | -! | +
- if (with_reporter) {
+ data, |
|
| 210 | -! | +
- card_fun <- function(comment) {
+ filter_panel_api, |
|
| 211 | -! | +
- card <- teal::TealReportCard$new()+ mae_name, |
|
| 212 | -! | +
- card$set_name("Volcano Plot")
+ name_annotation = "symbol", |
|
| 213 | -! | +
- card$append_text("Volcano Plot", "header2")
+ sample_vars_as_factors = TRUE, |
|
| 214 | -! | +
- card$append_fs(filter_panel_api$get_filter_state())+ with_mae_col_data = TRUE) {
|
|
| 215 | ! |
- card$append_text("Selected Options", "header3")
+ assert_string(id) |
|
| 216 | ! |
- encodings_list <- list(+ assert_class(data, "tdata") |
|
| 217 | ! |
- "Experiment:",+ assert_string(mae_name, min.chars = 1L) |
|
| 218 | ! |
- input$`experiment-name`,+ assert_string(name_annotation, min.chars = 1L, null.ok = TRUE) |
|
| 219 | ! |
- "\nAssay:",+ assert_flag(sample_vars_as_factors) |
|
| 220 | ! |
- input$`assay-name`,+ assert_flag(with_mae_col_data) |
|
| 221 | -! | +
- "\nCompare Groups:",+ |
|
| 222 | ! |
- input$`compare_group-sample_var`,+ moduleServer(id, function(input, output, session) {
|
|
| 223 | -! | +
- "\nShow Top Differentiated Genes:",+ # When the filtered data set of the chosen experiment changes, update the |
|
| 224 | -! | +
- input$show_top_gene,+ # experiment data object. |
|
| 225 | ! |
- "\nMethod:",+ data_return <- reactive({
|
|
| 226 | ! |
- input$method,+ name <- input$name |
|
| 227 | ! |
- "\nLog2fold Change Threshold:",+ req(name) |
|
| 228 | ! |
- input$log2_fc_thresh,+ mae <- data[[mae_name]]() |
|
| 229 | ! |
- "\nAdjusted P-value Threshold:",+ orig_object <- mae[[name]] |
|
| 230 | ! |
- input$adj_p_val_thresh+ validate(need( |
|
| 231 | -+ | ! |
- )+ hermes::is_hermes_data(orig_object), |
| 232 | ! |
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ "Please first convert your experiment to HermesData class" |
|
| 233 | -! | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ )) |
|
| 234 | ! |
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ validate(need( |
|
| 235 | ! |
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ !hermes::isEmpty(orig_object), |
|
| 236 | -+ | ! |
- } else {
+ "No genes or samples included in this experiment, please adjust filters" |
| 237 | -! | +
- paste(encodings_list, collapse = " ")+ )) |
|
| 238 | -+ | ! |
- }+ object <- if (with_mae_col_data) {
|
| 239 | -+ | ! |
-
+ MultiAssayExperiment::getWithColData(mae, name) |
| 240 | -! | +
- card$append_text(final_encodings, style = "verbatim")+ } else {
|
|
| 241 | ! |
- card$append_text("Plot", "header3")
+ orig_object |
|
| 242 | -! | +
- card$append_plot(plot_r(), dim = pws_p$dim())+ } |
|
| 243 | ! |
- if (isTRUE(input$show_top_gene)) {
+ if (sample_vars_as_factors) {
|
|
| 244 | ! |
- card$append_text("Table", "header3")
+ SummarizedExperiment::colData(object) <- |
|
| 245 | ! |
- card$append_table(show_top_gene_diffexpr())+ hermes::df_cols_to_factor(SummarizedExperiment::colData(object)) |
|
| 246 |
- }+ } |
||
| 247 | ! |
- if (!comment == "") {
+ object |
|
| 248 | -! | +
- card$append_text("Comment", "header3")
+ }) |
|
| 249 | -! | +
- card$append_text(comment)+ |
|
| 250 |
- }+ # When the filtered data set or the chosen experiment changes, update |
||
| 251 | -! | +
- card+ # the calls that subset the genes of the chosen experiment data object. |
|
| 252 | -+ | ! |
- }+ subset_calls <- reactive({
|
| 253 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ name <- input$name |
|
| 254 | -+ | ! |
- }+ req(name) |
| 255 |
- ###+ |
||
| 256 | -+ | ! |
- })+ filter_states <- filter_panel_api$get_filter_state()[[mae_name]][[name]]["subset"] |
| 257 | -+ | ! |
- }+ filter_states |
| 258 |
-
+ }) |
||
| 259 |
- #' @describeIn tm_g_volcanoplot sample module function.+ |
||
| 260 |
- #' @export+ # Only when the chosen gene subset changes, we recompute gene choices |
||
| 261 | -+ | ! |
- #' @examples+ genes <- eventReactive(subset_calls(), ignoreNULL = FALSE, {
|
| 262 | -+ | ! |
- #'+ data_return <- data_return() |
| 263 | -+ | ! |
- #' # Alternatively you can run the sample module with this function call:+ genes <- h_gene_data(data_return, name_annotation) |
| 264 | -+ | ! |
- #' if (interactive()) {
+ h_order_genes(genes) |
| 265 |
- #' sample_tm_g_volcanoplot()+ }) |
||
| 266 |
- #' }+ |
||
| 267 |
- sample_tm_g_volcanoplot <- function() {
+ # When the chosen experiment changes, recompute the assay names. |
||
| 268 | ! |
- mae <- hermes::multi_assay_experiment+ assays <- eventReactive(input$name, ignoreNULL = TRUE, {
|
|
| 269 | ! |
- mae_data <- teal.data::dataset("MAE", mae)
+ data_return <- data_return() |
|
| 270 | ! |
- data <- teal.data::teal_data(mae_data)+ SummarizedExperiment::assayNames(data_return) |
|
| 271 | -! | +
- app <- teal::init(+ }) |
|
| 272 | -! | +
- data = data,+ |
|
| 273 | -! | +
- modules = teal::modules(+ |
|
| 274 | ! |
- tm_g_volcanoplot(+ list( |
|
| 275 | ! |
- label = "volcanoplot",+ data = data_return, |
|
| 276 | ! |
- mae_name = "MAE"+ name = reactive({
|
|
| 277 | -+ | ! |
- )+ input$name |
| 278 | -+ | ! |
- )+ }), # nolint |
| 279 | -+ | ! |
- )+ genes = genes, |
| 280 | ! |
- shinyApp(app$ui, app$server)+ assays = assays |
|
| 281 | + |
+ )+ |
+ |
| 282 | ++ |
+ })+ |
+ |
| 283 | +
} |
@@ -2084,14 +2098,14 @@
| 1 |
- #' Data Preprocessing for `ADTTE` Module+ #' Teal Module for RNA-seq Boxplot |
||
| 5 |
- #' A function to help with merging of MAE to `ADTTE`.+ #' This module provides an interactive boxplot for RNA-seq gene expression |
||
| 6 |
- #'+ #' analysis. |
||
| 7 |
- #' @inheritParams function_arguments+ #' |
||
| 8 |
- #'+ #' @inheritParams module_arguments |
||
| 9 |
- #' @return A data frame containing all columns/rows from `adtte` that match+ #' |
||
| 10 |
- #' by subject ID with the row names of the MAE and have the gene samples available+ #' @return Shiny module to be used in the teal app. |
||
| 11 |
- #' in the given experiment. The attribute `gene_cols` contains the column names+ #' |
||
| 12 |
- #' for the gene columns.+ #' @export |
||
| 14 |
- #' @note The final gene column names can start with a different string than+ #' @examples |
||
| 15 |
- #' the original gene IDs (or labels), in particular white space and colons are removed.+ #' mae <- hermes::multi_assay_experiment |
||
| 16 |
- #'+ #' mae_data <- dataset("MAE", mae)
|
||
| 17 |
- #' @export+ #' data <- teal_data(mae_data) |
||
| 18 |
- #' @examples+ #' app <- init( |
||
| 19 |
- #' mae <- hermes::multi_assay_experiment+ #' data = data, |
||
| 20 |
- #' adtte <- teal.modules.hermes::rADTTE %>%+ #' modules = modules( |
||
| 21 |
- #' dplyr::mutate(CNSR = as.logical(CNSR))+ #' tm_g_boxplot( |
||
| 22 |
- #'+ #' label = "boxplot", |
||
| 23 |
- #' new_adtte <- h_km_mae_to_adtte(+ #' mae_name = "MAE" |
||
| 24 |
- #' adtte,+ #' ) |
||
| 25 |
- #' mae,+ #' ) |
||
| 26 |
- #' genes = hermes::gene_spec("GeneID:1820"),
+ #' ) |
||
| 27 |
- #' experiment_name = "hd2"+ #' if (interactive()) {
|
||
| 28 |
- #' )+ #' shinyApp(app$ui, app$server) |
||
| 29 |
- #' new_adtte2 <- h_km_mae_to_adtte(+ #' } |
||
| 30 |
- #' adtte,+ tm_g_boxplot <- function(label, |
||
| 31 |
- #' mae,+ mae_name, |
||
| 32 |
- #' genes = hermes::gene_spec(c("GeneID:1820", "GeneID:94115"), fun = colMeans),
+ exclude_assays = character(), |
||
| 33 |
- #' experiment_name = "hd2"+ summary_funs = list( |
||
| 34 |
- #' )+ None = NULL, |
||
| 35 |
- #' new_adtte3 <- h_km_mae_to_adtte(+ Mean = colMeans, |
||
| 36 |
- #' adtte,+ Median = matrixStats::colMedians, |
||
| 37 |
- #' mae,+ Max = matrixStats::colMaxs |
||
| 38 |
- #' genes = hermes::gene_spec(c(A = "GeneID:1820", B = "GeneID:94115")),+ ), |
||
| 39 |
- #' experiment_name = "hd2"+ pre_output = NULL, |
||
| 40 |
- #' )+ post_output = NULL) {
|
||
| 41 | -+ | ! |
- h_km_mae_to_adtte <- function(adtte,+ logger::log_info("Initializing tm_g_boxplot")
|
| 42 | -+ | ! |
- mae,+ assert_string(label) |
| 43 | -+ | ! |
- genes,+ assert_string(mae_name) |
| 44 | -+ | ! |
- experiment_name = "hd1",+ assert_character(exclude_assays, any.missing = FALSE) |
| 45 | -+ | ! |
- assay_name = "counts",+ assert_summary_funs(summary_funs, null.ok = TRUE) |
| 46 | -+ | ! |
- usubjid_var = "USUBJID") {
+ assert_tag(pre_output, null.ok = TRUE) |
| 47 | -11x | +! |
- assert_class(mae, "MultiAssayExperiment")+ assert_tag(post_output, null.ok = TRUE) |
| 48 | -11x | +
- assert_string(experiment_name)+ |
|
| 49 | -10x | +! |
- assert_string(usubjid_var)+ teal::module( |
| 50 | -10x | +! |
- assert_names(names(adtte), must.include = usubjid_var)+ label = label, |
| 51 | -+ | ! |
-
+ server = srv_g_boxplot, |
| 52 | -+ | ! |
- # Check subject ID across experiment, sample map, and MAE colData.+ server_args = list( |
| 53 | -10x | +! |
- mae_samplemap <- MultiAssayExperiment::sampleMap(mae)+ mae_name = mae_name, |
| 54 | -10x | +! |
- samplemap_experiment <- mae_samplemap[mae_samplemap$assay == experiment_name, ]+ summary_funs = summary_funs, |
| 55 | -10x | +! |
- sm_usubjid <- as.character(samplemap_experiment$primary)+ exclude_assays = exclude_assays |
| 56 |
-
+ ), |
||
| 57 | -10x | +! |
- hd <- suppressWarnings(MultiAssayExperiment::getWithColData(mae, experiment_name))+ ui = ui_g_boxplot, |
| 58 | -9x | +! |
- assert_class(hd, "AnyHermesData")+ ui_args = list( |
| 59 | -9x | +! |
- hd_usubjid <- as.character(SummarizedExperiment::colData(hd)[[usubjid_var]])+ mae_name = mae_name, |
| 60 | -+ | ! |
-
+ summary_funs = summary_funs, |
| 61 | -9x | +! |
- assert_subset(+ pre_output = pre_output, |
| 62 | -9x | +! |
- x = hd_usubjid,+ post_output = post_output |
| 63 | -9x | +
- choices = sm_usubjid+ ), |
|
| 64 | -+ | ! |
- )+ datanames = mae_name |
| 65 |
-
+ ) |
||
| 66 | -8x | +
- mae_coldata <- MultiAssayExperiment::colData(mae)+ } |
|
| 67 | -8x | +
- if (usubjid_var %in% colnames(mae_coldata)) {
+
|
|
| 68 | -8x | +
- mae_usubjid <- as.character(mae_coldata[[usubjid_var]])+ #' @describeIn tm_g_boxplot sets up the user interface. |
|
| 69 | -8x | +
- assert_subset(+ #' @inheritParams module_arguments |
|
| 70 | -8x | +
- x = sm_usubjid,+ #' @export |
|
| 71 | -8x | +
- choices = mae_usubjid+ ui_g_boxplot <- function(id, |
|
| 72 |
- )+ data, |
||
| 73 |
- }+ mae_name, |
||
| 74 |
-
+ summary_funs, |
||
| 75 | -7x | +
- gene_data <- hermes::col_data_with_genes(+ pre_output, |
|
| 76 | -7x | +
- object = hd,+ post_output) {
|
|
| 77 | -7x | +1x |
- assay_name = assay_name,+ ns <- NS(id) |
| 78 | -7x | +1x |
- genes = genes+ teal.widgets::standard_layout( |
| 79 | -+ | 1x |
- )+ encoding = div( |
| 80 | -5x | +
- merged_adtte <- hermes::inner_join_cdisc(+ ### Reporter |
|
| 81 | -5x | +1x |
- gene_data = gene_data,+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 82 | -5x | +
- cdisc_data = adtte,+ ### |
|
| 83 | -5x | +1x |
- patient_key = usubjid_var+ tags$label("Encodings", class = "text-primary"),
|
| 84 | -+ | 1x |
- )+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
| 85 | -5x | +1x |
- structure(+ experimentSpecInput(ns("experiment"), data, mae_name),
|
| 86 | -5x | +1x |
- merged_adtte,+ assaySpecInput(ns("assay")),
|
| 87 | -5x | +1x |
- gene_cols = attr(gene_data, "gene_cols")+ geneSpecInput(ns("genes"), summary_funs),
|
| 88 | -+ | 1x |
- )+ tags$label("Jitter"),
|
| 89 | -+ | 1x |
- }+ shinyWidgets::switchInput(ns("jitter"), value = FALSE, size = "mini"),
|
| 90 | -+ | 1x |
-
+ tags$label("Violin Plot"),
|
| 91 | -+ | 1x |
- #' Module Input for `ADTTE` Specification+ shinyWidgets::switchInput(ns("violin"), value = FALSE, size = "mini"),
|
| 92 | -+ | 1x |
- #'+ teal.widgets::panel_group( |
| 93 | -+ | 1x |
- #' @description `r lifecycle::badge("experimental")`
+ teal.widgets::panel_item( |
| 94 | -+ | 1x |
- #'+ input_id = "settings_item", |
| 95 | -+ | 1x |
- #' This defines the input for the `ADTTE` specification.+ collapsed = TRUE, |
| 96 | -+ | 1x |
- #'+ title = "Additional Settings", |
| 97 | -+ | 1x |
- #' @inheritParams module_arguments+ sampleVarSpecInput(ns("strat"), "Optional stratifying variable"),
|
| 98 | -+ | 1x |
- #' @param label_paramcd (`string`)\cr label for the endpoint (`PARAMCD`) selection.+ sampleVarSpecInput(ns("color"), "Optional color variable"),
|
| 99 | -+ | 1x |
- #'+ sampleVarSpecInput(ns("facet"), "Optional facet variable")
|
| 100 |
- #' @return The UI part.+ ) |
||
| 101 |
- #' @seealso [adtteSpecServer()] for the module server and a complete example.+ ) |
||
| 102 |
- #' @export+ ), |
||
| 103 | -+ | 1x |
- adtteSpecInput <- function(inputId, # nolint+ output = teal.widgets::plot_with_settings_ui(ns("plot")),
|
| 104 | -+ | 1x |
- label_paramcd = "Select Endpoint") {
+ pre_output = pre_output, |
| 105 | -3x | +1x |
- assert_string(inputId)+ post_output = post_output |
| 106 | -3x | +
- assert_string(label_paramcd, min.chars = 1L)+ ) |
|
| 107 |
-
+ } |
||
| 108 | -3x | +
- ns <- NS(inputId)+ |
|
| 109 |
-
+ #' @describeIn tm_g_boxplot sets up the server with reactive graph. |
||
| 110 | -3x | +
- tagList(+ #' @inheritParams module_arguments |
|
| 111 | -3x | +
- selectizeInput(+ #' @export |
|
| 112 | -3x | +
- inputId = ns("paramcd"),
+ srv_g_boxplot <- function(id, |
|
| 113 | -3x | +
- label = label_paramcd,+ data, |
|
| 114 | -3x | +
- choices = "",+ filter_panel_api, |
|
| 115 | -3x | +
- options = list(placeholder = "- Nothing selected -")+ reporter, |
|
| 116 |
- ),+ mae_name, |
||
| 117 | -3x | +
- include_js_files("dropdown.js")
+ exclude_assays, |
|
| 118 |
- )+ summary_funs) {
|
||
| 119 | -+ | ! |
- }+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 120 | -+ | ! |
-
+ assert_class(filter_panel_api, "FilterPanelAPI") |
| 121 | -+ | ! |
- #' Module Server for `ADTTE` Specification+ assert_class(data, "tdata") |
| 122 |
- #'+ |
||
| 123 | -+ | ! |
- #' @description `r lifecycle::badge("experimental")`
+ moduleServer(id, function(input, output, session) {
|
| 124 | -+ | ! |
- #'+ experiment <- experimentSpecServer( |
| 125 | -+ | ! |
- #' This defines the server part for the `ADTTE` specification. The resulting data+ "experiment", |
| 126 | -+ | ! |
- #' set `binned_adtte_subset` contains the subset of `ADTTE` selected by the time-to-event+ data = data, |
| 127 | -+ | ! |
- #' endpoint, joined together with the gene information extracted from specified assay+ filter_panel_api = filter_panel_api, |
| 128 | -+ | ! |
- #' and experiment, as numeric and factor columns. The factor column is created by binning+ mae_name = mae_name |
| 129 |
- #' the numeric column according to the quantile cutoffs specified in `probs`.+ ) |
||
| 130 | -+ | ! |
- #'+ assay <- assaySpecServer( |
| 131 | -+ | ! |
- #' @inheritParams module_arguments+ "assay", |
| 132 | -+ | ! |
- #' @param experiment_data (reactive `AnyHermesData`)\cr input experiment.+ assays = experiment$assays, |
| 133 | -+ | ! |
- #' @param experiment_name (reactive `string`)\cr name of the input experiment.+ exclude_assays = exclude_assays |
| 134 |
- #' @param assay (reactive `string`)\cr name of the assay.+ ) |
||
| 135 | -+ | ! |
- #' @param genes (reactive `GeneSpec`)\cr gene specification.+ multi <- multiSampleVarSpecServer( |
| 136 | -+ | ! |
- #' @param probs (reactive `numeric`)\cr probabilities to bin the gene or gene signature+ inputIds = c("strat", "color", "facet"),
|
| 137 | -+ | ! |
- #' into.+ experiment_name = experiment$name, |
| 138 | -+ | ! |
- #'+ original_data = experiment$data |
| 139 |
- #' @return List with the following elements:+ ) |
||
| 140 | -+ | ! |
- #' - `binned_adtte_subset`: reactive containing the joined `ADTTE` and gene data.+ genes <- geneSpecServer( |
| 141 | -+ | ! |
- #' - `gene_col`: reactive containing the string with the column name of the original+ "genes", |
| 142 | -+ | ! |
- #' numeric gene variable.+ funs = summary_funs, |
| 143 | -+ | ! |
- #' - `gene_factor`: string with the variable name for the binned gene data.+ gene_choices = experiment$genes |
| 144 |
- #' - `time_unit`: reactive string with the time unit for the current subset.+ ) |
||
| 145 | -+ | ! |
- #'+ plot_r <- reactive({
|
| 146 |
- #' @seealso [adtteSpecInput()] for the module UI.+ # Resolve all reactivity. |
||
| 147 | -+ | ! |
- #'+ experiment_data <- multi$experiment_data() |
| 148 | -+ | ! |
- #' @export+ strat <- multi$vars$strat() |
| 149 | -+ | ! |
- #'+ genes <- genes() |
| 150 | -+ | ! |
- #' @examples+ facet <- multi$vars$facet() |
| 151 | -+ | ! |
- #' ui <- function(id,+ color <- multi$vars$color() |
| 152 | -+ | ! |
- #' data) {
+ assay <- assay() |
| 153 | -+ | ! |
- #' ns <- NS(id)+ jitter <- input$jitter |
| 154 | -+ | ! |
- #'+ violin <- input$violin |
| 155 |
- #' teal.widgets::standard_layout(+ |
||
| 156 | -+ | ! |
- #' encoding = div(+ req( |
| 157 | -+ | ! |
- #' experimentSpecInput(ns("experiment"), data = data, mae_name = "MAE"),
+ assay, |
| 158 |
- #' assaySpecInput(ns("assay")),
+ # Note: The following statements are important to make sure the UI inputs have been updated. |
||
| 159 | -+ | ! |
- #' geneSpecInput(ns("genes"), funs = list(Mean = colMeans)),
+ isTRUE(assay %in% SummarizedExperiment::assayNames(experiment_data)), |
| 160 | -+ | ! |
- #' adtteSpecInput(ns("adtte"))
+ is.null(facet) || isTRUE(facet %in% names(SummarizedExperiment::colData(experiment_data))), |
| 161 | -+ | ! |
- #' ),+ is.null(color) || isTRUE(color %in% names(SummarizedExperiment::colData(experiment_data))), |
| 162 | -+ | ! |
- #' output = verbatimTextOutput(ns("summary"))
+ is.null(strat) || isTRUE(strat %in% names(SummarizedExperiment::colData(experiment_data))), |
| 163 | -+ | ! |
- #' )+ cancelOutput = FALSE |
| 164 |
- #' }+ ) |
||
| 165 |
- #'+ |
||
| 166 | -+ | ! |
- #' server <- function(id, data, filter_panel_api) {
+ validate_gene_spec(genes, rownames(experiment_data)) |
| 167 |
- #' moduleServer(id, function(input, output, session) {
+
|
||
| 168 | -+ | ! |
- #' experiment <- experimentSpecServer(+ hermes::draw_boxplot( |
| 169 | -+ | ! |
- #' "experiment",+ object = experiment_data, |
| 170 | -+ | ! |
- #' data = data,+ assay_name = assay, |
| 171 | -+ | ! |
- #' filter_panel_api = filter_panel_api,+ genes = genes, |
| 172 | -+ | ! |
- #' mae_name = "MAE"+ x_var = strat, |
| 173 | -+ | ! |
- #' )+ facet_var = facet, |
| 174 | -+ | ! |
- #' assay <- assaySpecServer(+ color_var = color, |
| 175 | -+ | ! |
- #' "assay",+ jitter = jitter, |
| 176 | -+ | ! |
- #' assays = experiment$assays+ violin = violin |
| 177 |
- #' )+ ) |
||
| 178 |
- #' genes <- geneSpecServer(+ }) |
||
| 179 | -+ | ! |
- #' "genes",+ output$plot <- renderPlot(plot_r()) |
| 180 |
- #' funs = list(Mean = colMeans),+ |
||
| 181 | -+ | ! |
- #' gene_choices = experiment$genes+ pws <- teal.widgets::plot_with_settings_srv( |
| 182 | -+ | ! |
- #' )+ id = "plot", |
| 183 | -+ | ! |
- #' adtte <- adtteSpecServer(+ plot_r = plot_r |
| 184 |
- #' "adtte",+ ) |
||
| 185 |
- #' data = data,+ |
||
| 186 |
- #' adtte_name = "ADTTE",+ ### REPORTER |
||
| 187 | -+ | ! |
- #' mae_name = "MAE",+ if (with_reporter) {
|
| 188 | -+ | ! |
- #' adtte_vars = list(+ card_fun <- function(comment, label) {
|
| 189 | -+ | ! |
- #' aval = "AVAL",+ card <- report_card_template( |
| 190 | -+ | ! |
- #' avalu = "AVALU",+ title = "Boxplot", |
| 191 | -+ | ! |
- #' is_event = "is_event",+ label = label, |
| 192 | -+ | ! |
- #' paramcd = "PARAMCD",+ with_filter = TRUE, |
| 193 | -+ | ! |
- #' usubjid = "USUBJID"+ filter_panel_api = filter_panel_api |
| 194 |
- #' ),+ ) |
||
| 195 | -+ | ! |
- #' experiment_data = experiment$data,+ card$append_text("Selected Options", "header3")
|
| 196 | -+ | ! |
- #' experiment_name = experiment$name,+ encodings_list <- list( |
| 197 | -+ | ! |
- #' assay = assay,+ "Experiment:", |
| 198 | -+ | ! |
- #' genes = genes,+ input$`experiment-name`, |
| 199 | -+ | ! |
- #' probs = reactive({
+ "\nAssay:", |
| 200 | -+ | ! |
- #' 0.5+ input$`assay-name`, |
| 201 | -+ | ! |
- #' })+ "\nFacetting Variable:", |
| 202 | -+ | ! |
- #' )+ input$`facet-sample_var`, |
| 203 | -+ | ! |
- #' output$summary <- renderPrint({
+ "\nGenes Selected:", |
| 204 | -+ | ! |
- #' binned_adtte_subset <- adtte$binned_adtte_subset()+ paste0(genes()$get_gene_labels(), collapse = ", "), |
| 205 | -+ | ! |
- #' summary(binned_adtte_subset)+ "\nGene Summary:", |
| 206 | -+ | ! |
- #' })+ input$`genes-fun_name`, |
| 207 | -+ | ! |
- #' })+ "\nJitter:", |
| 208 | -+ | ! |
- #' }+ input$jitter, |
| 209 | -+ | ! |
- #'+ "\nViolin:", |
| 210 | -+ | ! |
- #' my_app <- function() {
+ input$violin, |
| 211 | -+ | ! |
- #' mae <- hermes::multi_assay_experiment+ "\nOptional Stratifying Variable:", |
| 212 | -+ | ! |
- #' adtte <- teal.modules.hermes::rADTTE %>%+ input$`strat-sample_var`, |
| 213 | -+ | ! |
- #' dplyr::mutate(is_event = .data$CNSR == 0)+ "\nOptional Color Variable:", |
| 214 | -+ | ! |
- #'+ input$`color-sample_var`, |
| 215 | -+ | ! |
- #' data <- teal_data(+ "\nOptional Facet Variable:", |
| 216 | -+ | ! |
- #' dataset(+ input$`facet-sample_var` |
| 217 |
- #' "ADTTE",+ ) |
||
| 218 | -+ | ! |
- #' adtte,+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
| 219 | -+ | ! |
- #' code = "adtte <- teal.modules.hermes::rADTTE+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
| 220 | -+ | ! |
- #' dplyr::mutate(is_event = .data$CNSR == 0)"+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
| 221 | -+ | ! |
- #' ),+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
| 222 |
- #' dataset("MAE", mae)
+ } else {
|
||
| 223 | -+ | ! |
- #' )+ paste(encodings_list, collapse = " ") |
| 224 |
- #'+ } |
||
| 225 |
- #' app <- init(+ |
||
| 226 | -+ | ! |
- #' data = data,+ card$append_text(final_encodings, style = "verbatim") |
| 227 | -+ | ! |
- #' modules = modules(+ card$append_text("Plot", "header3")
|
| 228 | -+ | ! |
- #' module(+ card$append_plot(plot_r(), dim = pws$dim()) |
| 229 | -+ | ! |
- #' label = "adtteSpec example",+ if (!comment == "") {
|
| 230 | -+ | ! |
- #' server = server,+ card$append_text("Comment", "header3")
|
| 231 | -+ | ! |
- #' ui = ui,+ card$append_text(comment) |
| 232 |
- #' datanames = "all"+ } |
||
| 233 | -+ | ! |
- #' )+ card |
| 234 |
- #' )+ } |
||
| 235 | -+ | ! |
- #' )+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 236 |
- #' shinyApp(app$ui, app$server)+ } |
||
| 237 |
- #' }+ ### |
||
| 238 |
- #'+ }) |
||
| 239 |
- #' if (interactive()) {
+ } |
||
| 240 |
- #' my_app()+ |
||
| 241 |
- #' }+ #' @describeIn tm_g_boxplot sample module function. |
||
| 242 |
- adtteSpecServer <- function(id, # nolint+ #' @export |
||
| 243 |
- data,+ #' @examples |
||
| 244 |
- mae_name,+ #' |
||
| 245 |
- adtte_name,+ #' # Alternatively you can run the sample module with this function call: |
||
| 246 |
- adtte_vars,+ #' if (interactive()) {
|
||
| 247 |
- experiment_data,+ #' sample_tm_g_boxplot() |
||
| 248 |
- experiment_name,+ #' } |
||
| 249 |
- assay,+ sample_tm_g_boxplot <- function() {
|
||
| 250 | -+ | ! |
- genes,+ mae <- hermes::multi_assay_experiment |
| 251 | -+ | ! |
- probs) {
+ mae_data <- teal.data::dataset("MAE", mae)
|
| 252 | ! |
- assert_string(id)+ data <- teal.data::teal_data(mae_data) |
|
| 253 | ! |
- assert_string(mae_name)+ app <- teal::init( |
|
| 254 | ! |
- assert_string(adtte_name)+ data = data, |
|
| 255 | ! |
- assert_adtte_vars(adtte_vars)+ modules = teal::modules( |
|
| 256 | ! |
- assert_reactive(experiment_data)+ tm_g_boxplot( |
|
| 257 | ! |
- assert_reactive(experiment_name)+ label = "boxplot", |
|
| 258 | ! |
- assert_reactive(assay)+ mae_name = "MAE" |
|
| 259 | -! | +
- assert_reactive(genes)+ ) |
|
| 260 | -! | +
- assert_reactive(probs)+ ) |
|
| 261 |
-
+ ) |
||
| 262 | ! |
- moduleServer(id, function(input, output, session) {
+ shinyApp(app$ui, app$server) |
|
| 263 |
- # Join ADTTE with gene data.+ } |
||
| 264 | -! | +
| 1 | +
- adtte_joined <- reactive({
+ #' Most Expressed Genes Plot |
||
| 265 | -! | +||
| 2 | +
- experiment_data <- experiment_data()+ #' |
||
| 266 | -! | +||
| 3 | +
- experiment_name <- experiment_name()+ #' @description `r lifecycle::badge("experimental")`
|
||
| 267 | -! | +||
| 4 | +
- assay <- assay()+ #' |
||
| 268 | -! | +||
| 5 | +
- genes <- genes()+ #' This function plots the most expressed genes. |
||
| 269 | +6 |
-
+ #' |
|
| 270 | -! | +||
| 7 | +
- validate_gene_spec(genes, rownames(experiment_data))+ #' @inheritParams function_arguments |
||
| 271 | +8 |
-
+ #' |
|
| 272 | -! | +||
| 9 | +
- req(+ #' @return Plot to be displayed in the teal app. |
||
| 273 | -! | +||
| 10 | +
- genes$returns_vector(),+ #' |
||
| 274 | -! | +||
| 11 | +
- experiment_name,+ #' @export |
||
| 275 | -! | +||
| 12 | +
- assay+ #' |
||
| 276 | +13 |
- )+ #' @examples |
|
| 277 | +14 |
-
+ #' library(hermes) |
|
| 278 | -! | +||
| 15 | +
- mae <- data[[mae_name]]()+ #' object <- HermesData(summarized_experiment) |
||
| 279 | -! | +||
| 16 | +
- adtte <- data[[adtte_name]]()+ #' result <- top_gene_plot(object, assay_name = "counts") |
||
| 280 | +17 |
-
+ top_gene_plot <- function(object, assay_name) {
|
|
| 281 | +18 | ! |
- mae[[experiment_name]] <- experiment_data+ top_gene <- hermes::top_genes( |
| 282 | +19 | ! |
- h_km_mae_to_adtte(+ object = object, |
| 283 | +20 | ! |
- adtte,+ assay_name = assay_name, |
| 284 | +21 | ! |
- mae,+ summary_fun = rowMeans+ |
+
| 22 | ++ |
+ ) |
|
| 285 | +23 | ! |
- genes = genes,+ hermes::autoplot( |
| 286 | +24 | ! |
- experiment_name = experiment_name,+ top_gene, |
| 287 | +25 | ! |
- assay_name = assay,+ x_lab = "Gene", |
| 288 | +26 | ! |
- usubjid_var = adtte_vars$usubjid+ y_lab = paste("Mean", assay_name, "across samples")
|
| 289 | +27 |
- )+ ) |
|
| 290 | +28 |
- })+ } |
|
| 291 | +29 | ||
| 292 | -! | +||
| 30 | +
- gene_col <- reactive({
+ #' Correlation Heatmap Plot |
||
| 293 | -! | +||
| 31 | +
- attr(adtte_joined(), "gene_cols")+ #' |
||
| 294 | +32 |
- })+ #' @description `r lifecycle::badge("experimental")`
|
|
| 295 | +33 |
-
+ #' |
|
| 296 | +34 |
- # After joining, we recompute available endpoints.+ #' This function plots the correlation heatmap. |
|
| 297 | -! | +||
| 35 | +
- paramcd_choices <- reactive({
+ #' |
||
| 298 | -! | +||
| 36 | +
- adtte_joined <- adtte_joined()+ #' @inheritParams function_arguments |
||
| 299 | -! | +||
| 37 | +
- sort(unique(adtte_joined[[adtte_vars$paramcd]])) # Order should not matter.+ #' |
||
| 300 | +38 |
- })+ #' @return Plot to be displayed in the teal app. |
|
| 301 | +39 |
-
+ #' |
|
| 302 | +40 |
- # Start by disabling selection, will be overriden if there are valid choices.+ #' @export |
|
| 303 | -! | -
- session$sendCustomMessage(- |
- |
| 304 | -! | +||
| 41 | +
- "toggle_dropdown",+ #' |
||
| 305 | -! | +||
| 42 | +
- list(input_id = session$ns("paramcd"), disabled = TRUE)
+ #' @examples |
||
| 306 | +43 |
- )+ #' library(hermes) |
|
| 307 | +44 |
-
+ #' object <- HermesData(summarized_experiment) |
|
| 308 | +45 |
- # Once available endpoints change, we update choices (and also the selection+ #' result <- heatmap_plot(object, assay_name = "counts") |
|
| 309 | +46 |
- # if nothing was selected earlier) and warn the user if previous endpoint is+ heatmap_plot <- function(object, assay_name) {
|
|
| 310 | -+ | ||
| 47 | +! |
- # not available.+ heatmap <- hermes::correlate( |
|
| 311 | +48 | ! |
- observeEvent(paramcd_choices(), {
+ object = object, |
| 312 | +49 | ! |
- paramcd_choices <- paramcd_choices()+ assay_name = assay_name |
| 313 | +50 |
-
+ ) |
|
| 314 | +51 | ! |
- new_selected <- if (is_blank(input$paramcd) || (input$paramcd %in% paramcd_choices)) {
+ hermes::autoplot(heatmap) |
| 315 | -! | +||
| 52 | +
- input$paramcd+ } |
||
| 316 | +53 |
- } else {
+
|
|
| 317 | -! | +||
| 54 | +
- showNotification(type = "warning", paste(+ #' Teal Module for RNA-seq Quality Control |
||
| 318 | -! | +||
| 55 | +
- "Endpoint", input$paramcd, "not available in this data subset, please",+ #' |
||
| 319 | -! | +||
| 56 | +
- "change filter options or select another endpoint"+ #' @description `r lifecycle::badge("experimental")`
|
||
| 320 | +57 |
- ))+ #' |
|
| 321 | +58 |
- ""+ #' This module adds quality flags, filters by genes and/or samples, |
|
| 322 | +59 |
- }+ #' normalizes `AnyHermesData` objects and provides interactive plots |
|
| 323 | -! | +||
| 60 | +
- updateSelectizeInput(+ #' for RNA-seq gene expression quality control. |
||
| 324 | -! | +||
| 61 | +
- "paramcd",+ #' |
||
| 325 | -! | +||
| 62 | +
- choices = paramcd_choices,+ #' @inheritParams module_arguments |
||
| 326 | -! | +||
| 63 | +
- selected = new_selected,+ #' |
||
| 327 | -! | +||
| 64 | +
- session = session+ #' @return Shiny module to be used in the teal app. |
||
| 328 | +65 |
- )+ #' |
|
| 329 | -! | +||
| 66 | +
- session$sendCustomMessage(+ #' @export |
||
| 330 | -! | +||
| 67 | +
- "toggle_dropdown",+ #' |
||
| 331 | -! | +||
| 68 | +
- list(input_id = session$ns("paramcd"), disabled = (length(paramcd_choices) == 0))
+ #' @examples |
||
| 332 | +69 |
- )+ #' mae <- hermes::multi_assay_experiment |
|
| 333 | +70 |
- })+ #' mae_data <- dataset("MAE", mae)
|
|
| 334 | +71 |
-
+ #' data <- teal_data(mae_data) |
|
| 335 | +72 |
- # Subset zooming in on a specified endpoint.+ #' app <- init( |
|
| 336 | -! | +||
| 73 | +
- adtte_subset <- reactive({
+ #' data = data, |
||
| 337 | -! | +||
| 74 | +
- endpoint <- input$paramcd+ #' modules = modules( |
||
| 338 | -! | +||
| 75 | +
- adtte_joined <- adtte_joined()+ #' tm_g_quality( |
||
| 339 | +76 |
-
+ #' label = "Quality Control", |
|
| 340 | -! | +||
| 77 | +
- validate(need(+ #' mae_name = "MAE" |
||
| 341 | -! | +||
| 78 | +
- endpoint,+ #' ) |
||
| 342 | -! | +||
| 79 | +
- "please select an endpoint"+ #' ) |
||
| 343 | +80 |
- ))+ #' ) |
|
| 344 | +81 |
- # Validate that adtte_data is not empty.+ #' if (interactive()) {
|
|
| 345 | -! | -
- validate(need(- |
- |
| 346 | -! | -
- nrow(adtte_joined) > 0,- |
- |
| 347 | -! | +||
| 82 | +
- "Joined ADTTE is empty - please relax the filter criteria"+ #' shinyApp(app$ui, app$server) |
||
| 348 | +83 |
- ))+ #' } |
|
| 349 | +84 |
-
+ tm_g_quality <- function(label, |
|
| 350 | -! | +||
| 85 | +
- subset_rows <- adtte_joined[[adtte_vars$paramcd]] == endpoint+ mae_name, |
||
| 351 | -! | +||
| 86 | +
- result <- adtte_joined[subset_rows, , drop = FALSE]+ exclude_assays = character(), |
||
| 352 | -! | +||
| 87 | +
- droplevels(result)+ pre_output = NULL, |
||
| 353 | +88 |
- })+ post_output = NULL) {
|
|
| 354 | -+ | ||
| 89 | +! |
-
+ assert_string(label) |
|
| 355 | +90 | ! |
- binned_adtte_subset <- reactive({
+ assert_string(mae_name) |
| 356 | +91 | ! |
- gene_col <- gene_col()+ assert_character(exclude_assays, any.missing = FALSE) |
| 357 | +92 | ! |
- probs <- probs()+ assert_tag(pre_output, null.ok = TRUE) |
| 358 | +93 | ! |
- adtte_subset <- adtte_subset()+ assert_tag(post_output, null.ok = TRUE) |
| 359 | +94 | ||
| 360 | -! | -
- result <- tryCatch(- |
- |
| 361 | +95 | ! |
- expr = {
+ teal::module( |
| 362 | +96 | ! |
- dplyr::mutate(+ label = label, |
| 363 | +97 | ! |
- adtte_subset,+ server = srv_g_quality, |
| 364 | +98 | ! |
- gene_factor = tern::cut_quantile_bins(+ server_args = list( |
| 365 | +99 | ! |
- adtte_subset[, gene_col],+ mae_name = mae_name, |
| 366 | +100 | ! |
- probs = probs+ exclude_assays = exclude_assays |
| 367 | +101 |
- )+ ), |
|
| 368 | -+ | ||
| 102 | +! |
- )+ ui = ui_g_quality, |
|
| 369 | -+ | ||
| 103 | +! |
- },+ ui_args = list( |
|
| 370 | +104 | ! |
- error = function(e) {
+ mae_name = mae_name, |
| 371 | +105 | ! |
- if (grepl("Contains duplicated values", e)) {
+ pre_output = pre_output, |
| 372 | +106 | ! |
- validate(paste(+ post_output = post_output |
| 373 | -! | +||
| 107 | +
- "please adjust filters or select (slightly) different quantiles",+ ), |
||
| 374 | +108 | ! |
- "to avoid duplicate quantiles"+ datanames = mae_name |
| 375 | +109 |
- ))+ ) |
|
| 376 | +110 |
- } else {
+ } |
|
| 377 | -! | +||
| 111 | +
- stop(e)+ |
||
| 378 | +112 |
- }+ #' @describeIn tm_g_quality sets up the user interface. |
|
| 379 | +113 |
- }+ #' @inheritParams module_arguments |
|
| 380 | +114 |
- )+ #' @export |
|
| 381 | -! | +||
| 115 | +
- result+ ui_g_quality <- function(id, |
||
| 382 | +116 |
- })+ data, |
|
| 383 | +117 |
-
+ mae_name, |
|
| 384 | -! | +||
| 118 | +
- time_unit <- reactive({
+ pre_output, |
||
| 385 | -! | +||
| 119 | +
- adtte_subset <- adtte_subset()+ post_output) {
|
||
| 386 | -! | +||
| 120 | +1x |
- result <- unique(as.character(adtte_subset[[adtte_vars$avalu]]))+ ns <- NS(id) |
|
| 387 | -! | +||
| 121 | +1x |
- assert_string(result)+ teal.widgets::standard_layout( |
|
| 388 | -! | +||
| 122 | +1x |
- result+ encoding = div( |
|
| 389 | +123 |
- })+ ### Reporter+ |
+ |
| 124 | +1x | +
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 390 | +125 |
-
+ ### |
|
| 391 | -! | +||
| 126 | +1x |
- list(+ tags$label("Encodings", class = "text-primary"),
|
|
| 392 | -! | +||
| 127 | +1x |
- binned_adtte_subset = binned_adtte_subset,+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|
| 393 | -! | +||
| 128 | +1x |
- gene_col = gene_col,+ experimentSpecInput(ns("experiment"), data, mae_name),
|
|
| 394 | -! | +||
| 129 | +1x |
- gene_factor = "gene_factor",+ selectInput( |
|
| 395 | -! | +||
| 130 | +1x |
- time_unit = time_unit+ ns("plot_type"),
|
|
| 396 | -+ | ||
| 131 | +1x |
- )+ "Plot Type", |
|
| 397 | -+ | ||
| 132 | +1x |
- })+ choices = c( |
|
| 398 | -+ | ||
| 133 | +1x |
- }+ "Histogram", |
| 1 | -+ | ||
| 134 | +1x |
- #' Teal Module for PCA Analysis+ "Q-Q Plot", |
|
| 2 | -+ | ||
| 135 | +1x |
- #'+ "Density", |
|
| 3 | -+ | ||
| 136 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ "Boxplot", |
|
| 4 | -+ | ||
| 137 | +1x |
- #'+ "Top Genes Plot", |
|
| 5 | -+ | ||
| 138 | +1x |
- #' This module provides an interactive principal components plot and an+ "Correlation Heatmap" |
|
| 6 | +139 |
- #' interactive heatmap with correlation of principal components with sample+ ) |
|
| 7 | +140 |
- #' variables.+ ), |
|
| 8 | -+ | ||
| 141 | +1x |
- #'+ conditionalPanel( |
|
| 9 | -+ | ||
| 142 | +1x |
- #' @inheritParams module_arguments+ condition = "input.plot_type == 'Top Genes Plot' || input.plot_type == 'Correlation Heatmap'", |
|
| 10 | -+ | ||
| 143 | +1x |
- #'+ ns = ns, |
|
| 11 | -+ | ||
| 144 | +1x |
- #' @return Shiny module to be used in the teal app.+ assaySpecInput(ns("assay"))
|
|
| 12 | +145 |
- #' @export+ ), |
|
| 13 | -+ | ||
| 146 | +1x |
- #'+ tags$label("Gene Filter Settings", class = "text-primary"),
|
|
| 14 | -+ | ||
| 147 | +1x |
- #' @examples+ shinyWidgets::switchInput( |
|
| 15 | -+ | ||
| 148 | +1x |
- #' mae <- hermes::multi_assay_experiment+ ns("filter_gene"),
|
|
| 16 | -+ | ||
| 149 | +1x |
- #' mae_data <- dataset("MAE", mae)
+ value = TRUE, |
|
| 17 | -+ | ||
| 150 | +1x |
- #' data <- teal_data(mae_data)+ size = "mini" |
|
| 18 | +151 |
- #' app <- init(+ ), |
|
| 19 | -+ | ||
| 152 | +1x |
- #' data = data,+ conditionalPanel( |
|
| 20 | -+ | ||
| 153 | +1x |
- #' modules = modules(+ condition = "input.filter_gene", |
|
| 21 | -+ | ||
| 154 | +1x |
- #' tm_g_pca(+ ns = ns, |
|
| 22 | -+ | ||
| 155 | +1x |
- #' label = "PCA plot",+ sliderInput(ns("min_cpm"), label = ("Minimum CPM"), min = 1, max = 10, value = 5),
|
|
| 23 | -+ | ||
| 156 | +1x |
- #' mae_name = "MAE"+ sliderInput(ns("min_cpm_prop"), label = ("Minimum CPM Proportion"), min = 0.01, max = 0.99, value = 0.25),
|
|
| 24 | -+ | ||
| 157 | +1x |
- #' )+ teal.widgets::optionalSelectInput( |
|
| 25 | -+ | ||
| 158 | +1x |
- #' )+ ns("annotate"),
|
|
| 26 | -+ | ||
| 159 | +1x |
- #' )+ label = "Required Annotations", |
|
| 27 | -+ | ||
| 160 | +1x |
- #' if (interactive()) {
+ choices = "", |
|
| 28 | -+ | ||
| 161 | +1x |
- #' shinyApp(app$ui, app$server)+ selected = "", |
|
| 29 | -+ | ||
| 162 | +1x |
- #' }+ multiple = TRUE |
|
| 30 | +163 |
- tm_g_pca <- function(label,+ ) |
|
| 31 | +164 |
- mae_name,+ ), |
|
| 32 | -+ | ||
| 165 | +1x |
- exclude_assays = character(),+ tags$label("Sample Filter Settings", class = "text-primary"),
|
|
| 33 | -+ | ||
| 166 | +1x |
- pre_output = NULL,+ shinyWidgets::switchInput( |
|
| 34 | -+ | ||
| 167 | +1x |
- post_output = NULL) {
+ ns("filter_sample"),
|
|
| 35 | -! | +||
| 168 | +1x |
- logger::log_info("Initializing tm_g_pca")
+ value = TRUE, |
|
| 36 | -! | +||
| 169 | +1x |
- assert_string(label)+ size = "mini" |
|
| 37 | -! | +||
| 170 | +
- assert_string(mae_name)+ ), |
||
| 38 | -! | +||
| 171 | +1x |
- assert_tag(pre_output, null.ok = TRUE)+ conditionalPanel( |
|
| 39 | -! | +||
| 172 | +1x |
- assert_tag(post_output, null.ok = TRUE)+ condition = "input.filter_sample", |
|
| 40 | -+ | ||
| 173 | +1x |
-
+ ns = ns, |
|
| 41 | -! | +||
| 174 | +1x |
- teal::module(+ sliderInput(ns("min_corr"), label = ("Minimum Correlation"), min = 0.01, max = 0.99, value = 0.5),
|
|
| 42 | -! | +||
| 175 | +1x |
- label = label,+ radioButtons( |
|
| 43 | -! | +||
| 176 | +1x |
- server = srv_g_pca,+ ns("min_depth"),
|
|
| 44 | -! | +||
| 177 | +1x |
- server_args = list(+ label = "Minimum Depth", |
|
| 45 | -! | +||
| 178 | +1x |
- mae_name = mae_name,+ choices = c("Default", "Specify"),
|
|
| 46 | -! | +||
| 179 | +1x |
- exclude_assays = exclude_assays+ selected = "Default" |
|
| 47 | +180 |
- ),+ ), |
|
| 48 | -! | +||
| 181 | +1x |
- ui = ui_g_pca,+ conditionalPanel( |
|
| 49 | -! | +||
| 182 | +1x |
- ui_args = list(+ condition = "input.min_depth == 'Specify'", |
|
| 50 | -! | +||
| 183 | +1x |
- mae_name = mae_name,+ ns = ns, |
|
| 51 | -! | +||
| 184 | +1x |
- pre_output = pre_output,+ sliderInput(ns("min_depth_continuous"), label = NULL, min = 1, max = 10, value = 1)
|
|
| 52 | -! | +||
| 185 | +
- post_output = post_output+ ) |
||
| 53 | +186 | ++ |
+ )+ |
+
| 187 |
), |
||
| 54 | -! | +||
| 188 | +1x |
- datanames = mae_name+ output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ |
+ |
| 189 | +1x | +
+ pre_output = pre_output,+ |
+ |
| 190 | +1x | +
+ post_output = post_output |
|
| 55 | +191 |
) |
|
| 56 | +192 |
} |
|
| 57 | +193 | ||
| 58 | +194 |
- #' @describeIn tm_g_pca sets up the user interface.+ #' @describeIn tm_g_quality sets up the server with reactive graphs. |
|
| 59 | +195 |
#' @inheritParams module_arguments |
|
| 60 | +196 |
#' @export |
|
| 61 | +197 |
- ui_g_pca <- function(id,+ srv_g_quality <- function(id, |
|
| 62 | +198 |
- data,+ data, |
|
| 63 | +199 |
- mae_name,+ filter_panel_api, |
|
| 64 | +200 |
- pre_output,+ reporter, |
|
| 65 | +201 |
- post_output) {
+ mae_name, |
|
| 66 | -1x | +||
| 202 | +
- ns <- NS(id)+ exclude_assays) {
|
||
| 67 | -1x | +||
| 203 | +! |
- mae <- data[[mae_name]]()+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 68 | -1x | +||
| 204 | +! |
- experiment_name_choices <- names(mae)+ assert_class(filter_panel_api, "FilterPanelAPI")+ |
+ |
| 205 | +! | +
+ assert_class(data, "tdata") |
|
| 69 | +206 | ||
| 70 | -1x | +||
| 207 | +! |
- tagList(+ moduleServer(id, function(input, output, session) {
|
|
| 71 | -1x | +||
| 208 | +! |
- teal.widgets::standard_layout(+ experiment <- experimentSpecServer( |
|
| 72 | -1x | +||
| 209 | +! |
- include_css_files(pattern = "*"),+ "experiment", |
|
| 73 | -1x | +||
| 210 | +! |
- encoding = div(+ data = data, |
|
| 74 | -+ | ||
| 211 | +! |
- ### Reporter+ filter_panel_api = filter_panel_api, |
|
| 75 | -1x | +||
| 212 | +! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ mae_name = mae_name |
|
| 76 | +213 |
- ###- |
- |
| 77 | -1x | -
- tags$label("Encodings", class = "text-primary"),
+ ) |
|
| 78 | -1x | +||
| 214 | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+
|
||
| 79 | -1x | +||
| 215 | +! |
- experimentSpecInput(ns("experiment"), data, mae_name),
+ assay <- assaySpecServer( |
|
| 80 | -1x | +||
| 216 | +! |
- assaySpecInput(ns("assay")),
+ "assay", |
|
| 81 | -1x | +||
| 217 | +! |
- conditionalPanel(+ assays = reactive({
|
|
| 82 | -1x | +||
| 218 | +! |
- condition = "input.tab_selected == 'PCA'",+ union( |
|
| 83 | -1x | +||
| 219 | +! |
- ns = ns,+ experiment$assays(), |
|
| 84 | -1x | +||
| 220 | +
- sampleVarSpecInput(ns("color"), "Optional color variable"),
+ # Add all the additional normalized assays. |
||
| 85 | -1x | +||
| 221 | +! |
- selectizeInput(ns("x_var"), "Select X-axis PC", choices = ""),
+ c("cpm", "rpkm", "tpm", "voom", "vst")
|
|
| 86 | -1x | +||
| 222 | +
- selectizeInput(ns("y_var"), "Select Y-axis PC", choices = "")
+ ) |
||
| 87 | +223 |
- ),+ }), |
|
| 88 | -1x | +||
| 224 | +! |
- teal.widgets::panel_group(+ exclude_assays = exclude_assays |
|
| 89 | -1x | +||
| 225 | +
- teal.widgets::panel_item(+ ) |
||
| 90 | -1x | +||
| 226 | +
- input_id = "settings_item",+ |
||
| 91 | -1x | +||
| 227 | +! |
- collapsed = TRUE,+ experiment_properties <- eventReactive(experiment$name(), {
|
|
| 92 | -1x | +||
| 228 | +! |
- title = "Additional Settings",+ data <- experiment$data() |
|
| 93 | -1x | +||
| 229 | +! |
- tags$label("Use only Top Variance Genes"),
+ cpm <- edgeR::cpm(hermes::counts(data)) |
|
| 94 | -1x | +||
| 230 | +! |
- shinyWidgets::switchInput(ns("filter_top"), value = FALSE, size = "mini"),
+ depth <- colSums(hermes::counts(data)) |
|
| 95 | -1x | +||
| 231 | +! |
- conditionalPanel(+ list( |
|
| 96 | -1x | +||
| 232 | +! |
- condition = "input.filter_top",+ annotations = names(hermes::annotation(data)), |
|
| 97 | -1x | +||
| 233 | +! |
- ns = ns,- |
- |
| 98 | -1x | -
- sliderInput(ns("n_top"), label = "Number of Top Genes", min = 10, max = 5000, value = 500)
+ min_cpm_calc = floor(min(cpm)), |
|
| 99 | -+ | ||
| 234 | +! |
- ),+ max_cpm_calc = floor(max(cpm)), |
|
| 100 | -1x | +||
| 235 | +! |
- conditionalPanel(+ min_depth_calc = min(depth), |
|
| 101 | -1x | +||
| 236 | +! |
- condition = "input.tab_selected == 'PCA'",+ max_depth_calc = max(depth) |
|
| 102 | -1x | +||
| 237 | +
- ns = ns,+ ) |
||
| 103 | -1x | +||
| 238 | +
- tags$label("Show Variance %"),
+ }) |
||
| 104 | -1x | +||
| 239 | +
- shinyWidgets::switchInput(ns("var_pct"), value = TRUE, size = "mini"),
+
|
||
| 105 | -1x | +||
| 240 | +! |
- tags$label("Show Label"),
+ observeEvent(experiment_properties(), {
|
|
| 106 | -1x | +||
| 241 | +! |
- shinyWidgets::switchInput(ns("label"), value = TRUE, size = "mini")
+ properties <- experiment_properties() |
|
| 107 | +242 |
- ),+ |
|
| 108 | -1x | +||
| 243 | +! |
- conditionalPanel(+ teal.widgets::updateOptionalSelectInput( |
|
| 109 | -1x | +||
| 244 | +! |
- condition = "input.tab_selected == 'PC and Sample Correlation'",+ session, |
|
| 110 | -1x | +||
| 245 | +! |
- ns = ns,+ "annotate", |
|
| 111 | -1x | +||
| 246 | +! |
- tags$label("Cluster columns"),
+ choices = properties$annotations, |
|
| 112 | -1x | +||
| 247 | +! |
- shinyWidgets::switchInput(ns("cluster_columns"), value = FALSE, size = "mini")
+ selected = "WidthBP" |
|
| 113 | +248 |
- ),- |
- |
| 114 | -1x | -
- tags$label("View Matrix"),
- |
- |
| 115 | -1x | -
- shinyWidgets::switchInput(ns("show_matrix"), value = TRUE, size = "mini")
+ ) |
|
| 116 | -+ | ||
| 249 | +! |
- )+ updateSliderInput( |
|
| 117 | -+ | ||
| 250 | +! |
- )+ session, |
|
| 118 | -+ | ||
| 251 | +! |
- ),+ "min_cpm", |
|
| 119 | -1x | +||
| 252 | +! |
- output = div(+ min = properties$min_cpm_calc, |
|
| 120 | -1x | +||
| 253 | +! |
- style = "display:flow-root",+ max = properties$max_cpm_calc, |
|
| 121 | -1x | +||
| 254 | +! |
- tabsetPanel(+ value = properties$min_cpm_calc |
|
| 122 | -1x | +||
| 255 | +
- id = ns("tab_selected"),
+ ) |
||
| 123 | -1x | +||
| 256 | +! |
- type = "tabs",+ updateSliderInput( |
|
| 124 | -1x | +||
| 257 | +! |
- tabPanel(+ session, |
|
| 125 | -1x | +||
| 258 | +! |
- "PCA",+ "min_depth_continuous", |
|
| 126 | -1x | +||
| 259 | +! |
- column(+ min = properties$min_depth_calc, |
|
| 127 | -1x | +||
| 260 | +! |
- width = 12,+ max = properties$max_depth_calc, |
|
| 128 | -1x | +||
| 261 | +! |
- div(+ value = properties$min_depth_calc |
|
| 129 | -1x | +||
| 262 | +
- class = "my-5",+ ) |
||
| 130 | -1x | +||
| 263 | +
- teal.widgets::plot_with_settings_ui(ns("plot_pca"))
+ }) |
||
| 131 | +264 |
- ),+ |
|
| 132 | -1x | +||
| 265 | +! |
- DT::DTOutput(ns("table_pca"))
+ min_depth_final <- reactive({
|
|
| 133 | -+ | ||
| 266 | +! |
- )+ min_depth <- input$min_depth |
|
| 134 | -+ | ||
| 267 | +! |
- ),+ min_depth_continuous <- input$min_depth_continuous |
|
| 135 | -1x | +||
| 268 | +! |
- tabPanel(+ if (min_depth == "Specify") {
|
|
| 136 | -1x | +||
| 269 | +! |
- "PC and Sample Correlation",+ req(min_depth_continuous) |
|
| 137 | -1x | +||
| 270 | +! |
- column(+ min_depth_continuous |
|
| 138 | -1x | +||
| 271 | +
- width = 12,+ } else {
|
||
| 139 | -1x | +||
| 272 | +! |
- div(+ NULL |
|
| 140 | -1x | +||
| 273 | +
- class = "my-5",+ } |
||
| 141 | -1x | +||
| 274 | +
- teal.widgets::plot_with_settings_ui(ns("plot_cor"))
+ }) |
||
| 142 | +275 |
- ),+ |
|
| 143 | -1x | +||
| 276 | +! | +
+ control <- reactive({
+ |
+ |
| 277 | +! |
- DT::DTOutput(ns("table_cor"))
+ min_cpm <- input$min_cpm |
|
| 144 | -+ | ||
| 278 | +! |
- )+ min_cpm_prop <- input$min_cpm_prop |
|
| 145 | -+ | ||
| 279 | +! |
- )+ min_corr <- input$min_corr |
|
| 146 | -+ | ||
| 280 | +! |
- )+ min_depth_final <- min_depth_final() |
|
| 147 | +281 |
- ),+ |
|
| 148 | -1x | +||
| 282 | +! |
- pre_output = pre_output,+ req( |
|
| 149 | -1x | +||
| 283 | +! |
- post_output = post_output+ min_cpm, |
|
| 150 | -+ | ||
| 284 | +! |
- )+ min_cpm_prop, |
|
| 151 | -+ | ||
| 285 | +! |
- )+ min_corr |
|
| 152 | +286 |
- }+ ) |
|
| 153 | +287 | ||
| 154 | -- |
- #' @describeIn tm_g_pca sets up the server with reactive graph.- |
- |
| 155 | -+ | ||
| 288 | +! |
- #' @inheritParams module_arguments+ hermes::control_quality( |
|
| 156 | -+ | ||
| 289 | +! |
- #' @export+ min_cpm = min_cpm, |
|
| 157 | -+ | ||
| 290 | +! |
- srv_g_pca <- function(id,+ min_cpm_prop = min_cpm_prop, |
|
| 158 | -+ | ||
| 291 | +! |
- data,+ min_corr = min_corr, |
|
| 159 | -+ | ||
| 292 | +! |
- filter_panel_api,+ min_depth = min_depth_final |
|
| 160 | +293 |
- reporter,+ ) |
|
| 161 | +294 |
- mae_name,+ }) |
|
| 162 | +295 |
- exclude_assays) {
+
|
|
| 163 | +296 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ object_flagged <- reactive({
|
| 164 | +297 | ! |
- assert_class(filter_panel_api, "FilterPanelAPI")+ control <- control() |
| 165 | +298 | ! |
- assert_class(data, "tdata")+ object <- experiment$data() |
| 166 | +299 | ||
| 167 | +300 | ! |
- moduleServer(id, function(input, output, session) {
+ already_added <- ("control_quality_flags" %in% names(hermes::metadata(object)))
|
| 168 | +301 | ! |
- experiment <- experimentSpecServer(+ validate(need(!already_added, "Quality flags have already been added to this experiment")) |
| 169 | +302 | ! |
- "experiment",+ if (any(c("cpm", "rpkm", "tpm", "voom", "vst") %in% SummarizedExperiment::assayNames(object))) {
|
| 170 | +303 | ! |
- data = data,+ showNotification("Original normalized assays will be overwritten", type = "warning")
+ |
+
| 304 | ++ |
+ }+ |
+ |
| 305 | ++ | + | |
| 171 | +306 | ! |
- filter_panel_api = filter_panel_api,+ hermes::add_quality_flags( |
| 172 | +307 | ! |
- mae_name = mae_name+ object,+ |
+
| 308 | +! | +
+ control = control |
|
| 173 | +309 |
- )+ )+ |
+ |
| 310 | ++ |
+ })+ |
+ |
| 311 | ++ | + | |
| 174 | +312 | ! |
- assay <- assaySpecServer(+ object_final <- reactive({
|
| 175 | +313 | ! |
- "assay",+ object_flagged <- object_flagged() |
| 176 | +314 | ! |
- assays = experiment$assays,+ filter <- input$filter |
| 177 | +315 | ! |
- exclude_assays = exclude_assays+ annotate <- input$annotate |
| 178 | +316 |
- )+ |
|
| 179 | +317 | ! |
- color <- sampleVarSpecServer(+ req(!is_blank(annotate))+ |
+
| 318 | ++ | + | |
| 180 | +319 | ! |
- "color",+ result <- hermes::filter( |
| 181 | +320 | ! |
- experiment_name = experiment$name,+ object_flagged, |
| 182 | +321 | ! |
- original_data = experiment$data+ what = filter, |
| 183 | -+ | ||
| 322 | +! |
- )+ annotation_required = annotate |
|
| 184 | +323 |
-
+ ) |
|
| 185 | +324 |
- # Total number of genes at the moment.+ |
|
| 186 | +325 | ! |
- n_genes <- reactive({
+ validate(need( |
| 187 | +326 | ! |
- experiment_data <- color$experiment_data()+ nrow(result) >= 2, |
| 188 | +327 | ! |
- nrow(experiment_data)+ "Please change gene filters to ensure that there are at least 2 genes" |
| 189 | +328 |
- })+ )) |
|
| 190 | +329 | ||
| 330 | +! | +
+ hermes::normalize(result)+ |
+ |
| 191 | +331 |
- # When the total number changes or gene filter is activated, update slider max.+ })+ |
+ |
| 332 | ++ | + | |
| 192 | +333 | ! |
- observeEvent(list(n_genes(), input$filter_top), {
+ plot_r <- reactive({
|
| 193 | +334 | ! |
- n_genes <- n_genes()+ object_final <- object_final() |
| 194 | +335 | ! |
- filter_top <- input$filter_top+ plot_type <- input$plot_type |
| 195 | +336 | ! |
- if (filter_top) {
+ assay_name <- assay()+ |
+
| 337 | ++ | + | |
| 196 | +338 | ! |
- n_top <- input$n_top+ switch(plot_type, |
| 197 | +339 | ! |
- updateSliderInput(+ "Histogram" = hermes::draw_libsize_hist(object_final), |
| 198 | +340 | ! |
- session = session,+ "Density" = hermes::draw_libsize_densities(object_final), |
| 199 | +341 | ! |
- inputId = "n_top",+ "Q-Q Plot" = hermes::draw_libsize_qq(object_final), |
| 200 | +342 | ! |
- value = min(n_top, n_genes),+ "Boxplot" = hermes::draw_nonzero_boxplot(object_final), |
| 201 | +343 | ! |
- max = n_genes+ "Top Genes Plot" = top_gene_plot(object_final, assay_name = assay_name), |
| 202 | -+ | ||
| 344 | +! |
- )+ "Correlation Heatmap" = heatmap_plot(object_final, assay_name = assay_name) |
|
| 203 | +345 |
- }+ ) |
|
| 204 | +346 |
}) |
|
| 205 | -+ | ||
| 347 | +! |
-
+ output$plot <- renderPlot(plot_r()) |
|
| 206 | +348 |
- # When the chosen experiment or assay name changes, recompute the PC.+ |
|
| 207 | +349 | ! |
- pca_result <- reactive({
+ pws <- teal.widgets::plot_with_settings_srv( |
| 208 | +350 | ! |
- experiment_data <- color$experiment_data()+ id = "plot", |
| 209 | +351 | ! |
- filter_top <- input$filter_top+ plot_r = plot_r |
| 210 | -! | +||
| 352 | +
- n_top <- input$n_top+ ) |
||
| 211 | -! | +||
| 353 | +
- assay_name <- assay()+ |
||
| 212 | +354 |
-
+ ### REPORTER |
|
| 213 | +355 | ! |
- validate(need(hermes::is_hermes_data(experiment_data), "please use HermesData() on input experiments"))+ if (with_reporter) {
|
| 214 | +356 | ! |
- req(isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)))+ card_fun <- function(comment, label) {
|
| 215 | +357 | ! |
- validate(need(+ card <- report_card_template( |
| 216 | +358 | ! |
- ncol(experiment_data) > 2,+ title = "Quality Control Plot", |
| 217 | +359 | ! |
- "Sample size is too small. PCA needs more than 2 samples."- |
-
| 218 | -- |
- ))+ label = label, |
|
| 219 | +360 | ! |
- validate(need(+ description = tools::toTitleCase(input$plot_type), |
| 220 | +361 | ! |
- nrow(experiment_data) > 1,+ with_filter = TRUE, |
| 221 | +362 | ! |
- "Number of genes is too small. PCA needs more than 1 gene."- |
-
| 222 | -- |
- ))+ filter_panel_api = filter_panel_api |
|
| 223 | +363 |
-
+ ) |
|
| 224 | +364 | ! |
- hermes::calc_pca(experiment_data, assay_name, n_top = if (filter_top) n_top else NULL)- |
-
| 225 | -- |
- })- |
- |
| 226 | -- | - - | -|
| 227 | -- |
- # When experiment or assay name changes, update choices for PCs in x_var and y_var.+ card$append_text("Selected Options", "header3")
|
|
| 228 | +365 | ! |
- observeEvent(pca_result(), {
+ encodings_list <- list( |
| 229 | +366 | ! |
- pca_result_x <- pca_result()$x+ "Experiment:", |
| 230 | +367 | ! |
- pc_choices <- seq_len(ncol(pca_result_x))+ input$`experiment-name`, |
| 231 | -+ | ||
| 368 | +! |
-
+ "\nPlot Type:", |
|
| 232 | +369 | ! |
- id_names <- c("x_var", "y_var")
+ input$plot_type, |
| 233 | +370 | ! |
- for (i in seq_along(id_names)) {
+ "\nAssay:", |
| 234 | +371 | ! |
- updateSelectizeInput(+ input$`assay-name`, |
| 235 | +372 | ! |
- session,+ "\nShow Gene Filter Settings:", |
| 236 | +373 | ! |
- id_names[i],+ input$filter_gene, |
| 237 | +374 | ! |
- choices = pc_choices,+ "\nMinimum CPM:", |
| 238 | +375 | ! |
- selected = pc_choices[i]+ input$min_cpm, |
| 239 | -+ | ||
| 376 | +! |
- )+ "\nMinimum CPM Proportion:", |
|
| 240 | -+ | ||
| 377 | +! |
- }+ input$min_cpm_prop, |
|
| 241 | -+ | ||
| 378 | +! |
- })+ "\nRequired Annotations:", |
|
| 242 | -+ | ||
| 379 | +! |
-
+ paste(input$annotate, collapse = ", "), |
|
| 243 | -+ | ||
| 380 | +! |
- # Compute correlation of PC with sample variables.+ "\nShow Sample Filter Settings:", |
|
| 244 | +381 | ! |
- cor_result <- reactive({
+ input$filter_sample, |
| 245 | +382 | ! |
- pca_result <- pca_result()+ "\nMinimum Correlation:", |
| 246 | +383 | ! |
- experiment_data <- color$experiment_data()+ input$min_corr, |
| 247 | -+ | ||
| 384 | +! |
-
+ "\nMinimum Depth:", |
|
| 248 | +385 | ! |
- hermes::correlate(pca_result, experiment_data)+ input$min_depth, |
| 249 | -+ | ||
| 386 | +! |
- })+ "\nMinimum Depth Value:", |
|
| 250 | -+ | ||
| 387 | +! |
-
+ input$min_depth_continuous |
|
| 251 | +388 |
- # Compute & display PCA matrix table if show_matrix is TRUE.- |
- |
| 252 | -! | -
- show_matrix_pca <- reactive({
+ ) |
|
| 253 | +389 | ! |
- if (input$show_matrix) {
+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
| 254 | +390 | ! |
- pca_result_x <- pca_result()$x+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
| 255 | +391 | ! |
- pca_result_x <- round(pca_result_x, 3)+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
| 256 | +392 | ! |
- as.data.frame(pca_result_x)+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
| 257 | +393 |
- } else {
+ } else {
|
|
| 258 | +394 | ! |
- NULL+ paste(encodings_list, collapse = " ") |
| 259 | +395 |
- }+ } |
|
| 260 | +396 |
- })+ |
|
| 261 | -+ | ||
| 397 | +! |
-
+ card$append_text(final_encodings, style = "verbatim") |
|
| 262 | +398 | ! |
- output$table_pca <- DT::renderDT({
+ card$append_text("Plot", "header3")
|
| 263 | +399 | ! |
- show_matrix_pca <- show_matrix_pca()+ card$append_plot(plot_r(), dim = pws$dim()) |
| 264 | +400 | ! |
- DT::datatable(+ if (!comment == "") {
|
| 265 | +401 | ! |
- show_matrix_pca,+ card$append_text("Comment", "header3")
|
| 266 | +402 | ! |
- rownames = TRUE,+ card$append_text(comment)+ |
+
| 403 | ++ |
+ } |
|
| 267 | +404 | ! |
- options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)),+ card+ |
+
| 405 | ++ |
+ } |
|
| 268 | +406 | ! |
- caption = "PCA Matrix"+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 269 | +407 |
- )+ } |
|
| 270 | +408 |
- })+ ### |
|
| 271 | +409 |
-
+ }) |
|
| 272 | +410 |
- # Compute & display correlation matrix if show_matrix is TRUE+ } |
|
| 273 | -! | +||
| 411 | +
- show_matrix_cor <- reactive({
+
|
||
| 274 | -! | +||
| 412 | +
- if (input$show_matrix) {
+ #' @describeIn tm_g_quality sample module function. |
||
| 275 | -! | +||
| 413 | +
- cor_result <- cor_result()+ #' @export |
||
| 276 | -! | +||
| 414 | +
- cor_result <- round(cor_result, 3)+ #' @examples |
||
| 277 | -! | +||
| 415 | +
- as.data.frame(cor_result)+ #' |
||
| 278 | +416 |
- } else {
+ #' # Alternatively you can run the sample module with this function call: |
|
| 279 | -! | +||
| 417 | ++ |
+ #' if (interactive()) {
+ |
+ |
| 418 | +
- NULL+ #' sample_tm_g_quality() |
||
| 280 | +419 |
- }+ #' } |
|
| 281 | +420 |
- })+ sample_tm_g_quality <- function() {
|
|
| 282 | +421 | ! |
- output$table_cor <- DT::renderDT({
+ mae <- hermes::multi_assay_experiment |
| 283 | +422 | ! |
- show_matrix_cor <- show_matrix_cor()+ mae_data <- teal.data::dataset("MAE", mae)
|
| 284 | +423 | ! |
- DT::datatable(+ data <- teal.data::teal_data(mae_data) |
| 285 | +424 | ! |
- show_matrix_cor,+ app <- teal::init( |
| 286 | +425 | ! |
- rownames = TRUE,+ data = data, |
| 287 | +426 | ! |
- options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)),+ modules = teal::modules( |
| 288 | +427 | ! |
- caption = "PC and Sample Correlation Matrix"+ tm_g_quality( |
| 289 | -+ | ||
| 428 | +! |
- )+ label = "quality", |
|
| 290 | -+ | ||
| 429 | +! |
- })+ mae_name = "MAE" |
|
| 291 | +430 |
-
+ ) |
|
| 292 | +431 |
- # Render plot PCA output.- |
- |
| 293 | -! | -
- plot_pca <- reactive({
+ ) |
|
| 294 | +432 |
- # Resolve all reactivity.- |
- |
| 295 | -! | -
- pca_result <- pca_result()- |
- |
| 296 | -! | -
- experiment_data <- color$experiment_data()- |
- |
| 297 | -! | -
- x_var <- as.numeric(input$x_var)- |
- |
| 298 | -! | -
- y_var <- as.numeric(input$y_var)+ ) |
|
| 299 | +433 | ! |
- data <- as.data.frame(SummarizedExperiment::colData(color$experiment_data()))+ shinyApp(app$ui, app$server) |
| 300 | -! | +||
| 434 | +
- color_var <- color$sample_var()+ } |
||
| 301 | -! | +
| 1 | +
- assay_name <- assay()+ #' Data Preprocessing for `ADTTE` Module |
||
| 302 | -! | +||
| 2 | +
- var_pct <- input$var_pct+ #' |
||
| 303 | -! | +||
| 3 | +
- label <- input$label+ #' @description `r lifecycle::badge("experimental")`
|
||
| 304 | +4 |
-
+ #' |
|
| 305 | +5 |
- # Require which states need to be truthy.+ #' A function to help with merging of MAE to `ADTTE`. |
|
| 306 | -! | +||
| 6 | +
- req(+ #' |
||
| 307 | -! | +||
| 7 | +
- assay_name,+ #' @inheritParams function_arguments |
||
| 308 | +8 |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ #' |
|
| 309 | -! | +||
| 9 | +
- isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)),+ #' @return A data frame containing all columns/rows from `adtte` that match |
||
| 310 | -! | +||
| 10 | +
- is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))),+ #' by subject ID with the row names of the MAE and have the gene samples available |
||
| 311 | -! | +||
| 11 | +
- cancelOutput = FALSE+ #' in the given experiment. The attribute `gene_cols` contains the column names |
||
| 312 | +12 |
- )+ #' for the gene columns. |
|
| 313 | +13 |
-
+ #' |
|
| 314 | +14 |
- # Validate and give useful messages to the user. Note: no need to duplicate here req() from above.+ #' @note The final gene column names can start with a different string than |
|
| 315 | -! | +||
| 15 | +
- validate(need(x_var != y_var, "please select two different principal components"))+ #' the original gene IDs (or labels), in particular white space and colons are removed. |
||
| 316 | +16 |
-
+ #' |
|
| 317 | -! | +||
| 17 | +
- hermes::autoplot(+ #' @export |
||
| 318 | -! | +||
| 18 | +
- object = pca_result,+ #' @examples |
||
| 319 | -! | +||
| 19 | +
- assay_name = assay_name,+ #' mae <- hermes::multi_assay_experiment |
||
| 320 | -! | +||
| 20 | +
- x = x_var,+ #' adtte <- teal.modules.hermes::rADTTE %>% |
||
| 321 | -! | +||
| 21 | +
- y = y_var,+ #' dplyr::mutate(CNSR = as.logical(CNSR)) |
||
| 322 | -! | +||
| 22 | +
- data = data,+ #' |
||
| 323 | -! | +||
| 23 | +
- colour = color_var,+ #' new_adtte <- h_km_mae_to_adtte( |
||
| 324 | -! | +||
| 24 | +
- variance_percentage = var_pct,+ #' adtte, |
||
| 325 | -! | +||
| 25 | +
- label = label,+ #' mae, |
||
| 326 | -! | +||
| 26 | +
- label.repel = label,+ #' genes = hermes::gene_spec("GeneID:1820"),
|
||
| 327 | -! | +||
| 27 | +
- label.show.legend = FALSE+ #' experiment_name = "hd2" |
||
| 328 | +28 |
- )+ #' ) |
|
| 329 | +29 |
- })+ #' new_adtte2 <- h_km_mae_to_adtte( |
|
| 330 | -! | +||
| 30 | +
- output$plot_pca <- renderPlot(plot_pca())+ #' adtte, |
||
| 331 | +31 |
-
+ #' mae, |
|
| 332 | -! | +||
| 32 | +
- pws_pca <- teal.widgets::plot_with_settings_srv(+ #' genes = hermes::gene_spec(c("GeneID:1820", "GeneID:94115"), fun = colMeans),
|
||
| 333 | -! | +||
| 33 | +
- id = "plot_pca",+ #' experiment_name = "hd2" |
||
| 334 | -! | +||
| 34 | +
- plot_r = plot_pca+ #' ) |
||
| 335 | +35 |
- )+ #' new_adtte3 <- h_km_mae_to_adtte( |
|
| 336 | +36 |
-
+ #' adtte, |
|
| 337 | +37 |
- # render correlation heatmap+ #' mae, |
|
| 338 | -! | +||
| 38 | +
- plot_cor <- reactive({
+ #' genes = hermes::gene_spec(c(A = "GeneID:1820", B = "GeneID:94115")), |
||
| 339 | +39 |
- # Resolve all reactivity.+ #' experiment_name = "hd2" |
|
| 340 | -! | +||
| 40 | +
- cor_result <- cor_result()+ #' ) |
||
| 341 | -! | +||
| 41 | +
- cluster_columns <- input$cluster_columns+ h_km_mae_to_adtte <- function(adtte, |
||
| 342 | +42 |
-
+ mae, |
|
| 343 | -! | +||
| 43 | +
- validate(need(+ genes, |
||
| 344 | -! | +||
| 44 | +
- !any(is.na(cor_result)),+ experiment_name = "hd1", |
||
| 345 | -! | +||
| 45 | +
- "Obtained NA results in the correlation matrix, therefore no plot can be produced"+ assay_name = "counts", |
||
| 346 | +46 |
- ))+ usubjid_var = "USUBJID") {
|
|
| 347 | -! | +||
| 47 | +11x |
- hermes::autoplot(+ assert_class(mae, "MultiAssayExperiment") |
|
| 348 | -! | +||
| 48 | +11x |
- object = cor_result,+ assert_string(experiment_name) |
|
| 349 | -! | +||
| 49 | +10x |
- cluster_columns = cluster_columns+ assert_string(usubjid_var) |
|
| 350 | -+ | ||
| 50 | +10x |
- )+ assert_names(names(adtte), must.include = usubjid_var) |
|
| 351 | +51 |
- })+ |
|
| 352 | +52 |
-
+ # Check subject ID across experiment, sample map, and MAE colData. |
|
| 353 | -! | +||
| 53 | +10x |
- pws_cor <- teal.widgets::plot_with_settings_srv(+ mae_samplemap <- MultiAssayExperiment::sampleMap(mae) |
|
| 354 | -! | +||
| 54 | +10x |
- id = "plot_cor",+ samplemap_experiment <- mae_samplemap[mae_samplemap$assay == experiment_name, ] |
|
| 355 | -! | +||
| 55 | +10x |
- plot_r = plot_cor+ sm_usubjid <- as.character(samplemap_experiment$primary) |
|
| 356 | +56 |
- )+ + |
+ |
| 57 | +10x | +
+ hd <- suppressWarnings(MultiAssayExperiment::getWithColData(mae, experiment_name))+ |
+ |
| 58 | +9x | +
+ assert_class(hd, "AnyHermesData")+ |
+ |
| 59 | +9x | +
+ hd_usubjid <- as.character(SummarizedExperiment::colData(hd)[[usubjid_var]]) |
|
| 357 | +60 | ||
| 358 | -+ | ||
| 61 | +9x |
- ### REPORTER+ assert_subset( |
|
| 359 | -! | +||
| 62 | +9x |
- if (with_reporter) {
+ x = hd_usubjid, |
|
| 360 | -! | +||
| 63 | +9x |
- card_fun <- function(comment) {
+ choices = sm_usubjid |
|
| 361 | -! | +||
| 64 | +
- card <- teal::TealReportCard$new()+ ) |
||
| 362 | -! | +||
| 65 | +
- card$set_name("PCA")
+
|
||
| 363 | -! | +||
| 66 | +8x |
- card$append_text("PCA", "header2")
+ mae_coldata <- MultiAssayExperiment::colData(mae) |
|
| 364 | -! | +||
| 67 | +8x |
- card$append_fs(filter_panel_api$get_filter_state())+ if (usubjid_var %in% colnames(mae_coldata)) {
|
|
| 365 | -! | +||
| 68 | +8x |
- card$append_text("Selected Options", "header3")
+ mae_usubjid <- as.character(mae_coldata[[usubjid_var]]) |
|
| 366 | -! | +||
| 69 | +8x |
- if (input$tab_selected == "PCA") {
+ assert_subset( |
|
| 367 | -! | +||
| 70 | +8x |
- encodings_list <- list(+ x = sm_usubjid, |
|
| 368 | -! | +||
| 71 | +8x |
- "Experiment:",+ choices = mae_usubjid |
|
| 369 | -! | +||
| 72 | +
- input$`experiment-name`,+ ) |
||
| 370 | -! | +||
| 73 | +
- "\nAssay:",+ } |
||
| 371 | -! | +||
| 74 | +
- input$`assay-name`,+ |
||
| 372 | -! | +||
| 75 | +7x |
- "\nOptional Color Variable:",+ gene_data <- hermes::col_data_with_genes( |
|
| 373 | -! | +||
| 76 | +7x |
- input$`color-sample_var`,+ object = hd, |
|
| 374 | -! | +||
| 77 | +7x |
- "\nX-axis PC:",+ assay_name = assay_name, |
|
| 375 | -! | +||
| 78 | +7x |
- input$x_var,+ genes = genes |
|
| 376 | -! | +||
| 79 | +
- "\nY-axis PC:",+ ) |
||
| 377 | -! | +||
| 80 | +5x |
- input$y_var,+ merged_adtte <- hermes::inner_join_cdisc( |
|
| 378 | -! | +||
| 81 | +5x |
- "\nUse Top Variance Genes:",+ gene_data = gene_data, |
|
| 379 | -! | +||
| 82 | +5x |
- input$filter_top,+ cdisc_data = adtte, |
|
| 380 | -! | +||
| 83 | +5x |
- "\nNumber of Top Genes:",+ patient_key = usubjid_var |
|
| 381 | -! | +||
| 84 | +
- input$n_top,+ ) |
||
| 382 | -! | +||
| 85 | +5x |
- "\nShow Variance %:",+ structure( |
|
| 383 | -! | +||
| 86 | +5x |
- input$var_pct,+ merged_adtte, |
|
| 384 | -! | +||
| 87 | +5x |
- "\nShow Matrix:",+ gene_cols = attr(gene_data, "gene_cols") |
|
| 385 | -! | +||
| 88 | +
- input$show_matrix,+ ) |
||
| 386 | -! | +||
| 89 | +
- "\nShow Label:",+ } |
||
| 387 | -! | +||
| 90 | +
- input$label+ |
||
| 388 | +91 |
- )+ #' Module Input for `ADTTE` Specification |
|
| 389 | -! | +||
| 92 | ++ |
+ #'+ |
+ |
| 93 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ #' @description `r lifecycle::badge("experimental")`
|
||
| 390 | -! | +||
| 94 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ #' |
||
| 391 | -! | +||
| 95 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ #' This defines the input for the `ADTTE` specification. |
||
| 392 | -! | +||
| 96 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ #' |
||
| 393 | +97 |
- } else {
+ #' @inheritParams module_arguments |
|
| 394 | -! | +||
| 98 | +
- paste(encodings_list, collapse = " ")+ #' @param label_paramcd (`string`)\cr label for the endpoint (`PARAMCD`) selection. |
||
| 395 | +99 |
- }+ #' |
|
| 396 | -! | +||
| 100 | +
- card$append_text(final_encodings, style = "verbatim")+ #' @return The UI part. |
||
| 397 | -! | +||
| 101 | +
- card$append_text("Plot", "header3")
+ #' @seealso [adtteSpecServer()] for the module server and a complete example. |
||
| 398 | -! | +||
| 102 | +
- card$append_plot(plot_pca(), dim = pws_pca$dim())+ #' @export |
||
| 399 | -! | +||
| 103 | +
- card$append_text("Table", "header3")
+ adtteSpecInput <- function(inputId, # nolint |
||
| 400 | -! | +||
| 104 | +
- card$append_table(show_matrix_pca())+ label_paramcd = "Select Endpoint") {
|
||
| 401 | -+ | ||
| 105 | +3x |
- } else {
+ assert_string(inputId) |
|
| 402 | -! | +||
| 106 | +3x |
- encodings_list <- list(+ assert_string(label_paramcd, min.chars = 1L) |
|
| 403 | -! | +||
| 107 | +
- "Experiment:",+ |
||
| 404 | -! | +||
| 108 | +3x |
- input$`experiment-name`,+ ns <- NS(inputId) |
|
| 405 | -! | +||
| 109 | +
- "\nAssay:",+ |
||
| 406 | -! | +||
| 110 | +3x |
- input$`assay-name`,+ tagList( |
|
| 407 | -! | +||
| 111 | +3x |
- "\nUse Top Variance Genes:",+ selectizeInput( |
|
| 408 | -! | +||
| 112 | +3x |
- input$filter_top,+ inputId = ns("paramcd"),
|
|
| 409 | -! | +||
| 113 | +3x |
- "\nNumber of Top Genes:",+ label = label_paramcd, |
|
| 410 | -! | +||
| 114 | +3x |
- input$top_n,+ choices = "", |
|
| 411 | -! | +||
| 115 | +3x |
- "\nCluster Columns:",+ options = list(placeholder = "- Nothing selected -") |
|
| 412 | -! | +||
| 116 | +
- paste0(input$cluster_columns, collapse = ", "),+ ), |
||
| 413 | -! | +||
| 117 | +3x |
- "\nShow Matrix:",+ include_js_files("dropdown.js")
|
|
| 414 | -! | +||
| 118 | +
- input$show_matrix+ ) |
||
| 415 | +119 |
- )+ } |
|
| 416 | -! | +||
| 120 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ |
||
| 417 | -! | +||
| 121 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ #' Module Server for `ADTTE` Specification |
||
| 418 | -! | +||
| 122 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ #' |
||
| 419 | -! | +||
| 123 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ #' @description `r lifecycle::badge("experimental")`
|
||
| 420 | +124 |
- } else {
+ #' |
|
| 421 | -! | +||
| 125 | +
- paste(encodings_list, collapse = " ")+ #' This defines the server part for the `ADTTE` specification. The resulting data |
||
| 422 | +126 |
- }+ #' set `binned_adtte_subset` contains the subset of `ADTTE` selected by the time-to-event |
|
| 423 | +127 |
-
+ #' endpoint, joined together with the gene information extracted from specified assay |
|
| 424 | -! | +||
| 128 | +
- card$append_text(final_encodings, style = "verbatim")+ #' and experiment, as numeric and factor columns. The factor column is created by binning |
||
| 425 | -! | +||
| 129 | +
- card$append_text("Plot", "header3")
+ #' the numeric column according to the quantile cutoffs specified in `probs`. |
||
| 426 | -! | +||
| 130 | +
- card$append_plot(plot_cor())+ #' |
||
| 427 | -! | +||
| 131 | +
- card$append_plot(plot_cor(), dim = pws_cor$dim())+ #' @inheritParams module_arguments |
||
| 428 | -! | +||
| 132 | +
- card$append_text("Table", "header3")
+ #' @param experiment_data (reactive `AnyHermesData`)\cr input experiment. |
||
| 429 | -! | +||
| 133 | +
- card$append_table(show_matrix_cor())+ #' @param experiment_name (reactive `string`)\cr name of the input experiment. |
||
| 430 | +134 |
- }+ #' @param assay (reactive `string`)\cr name of the assay. |
|
| 431 | -! | +||
| 135 | +
- if (!comment == "") {
+ #' @param genes (reactive `GeneSpec`)\cr gene specification. |
||
| 432 | -! | +||
| 136 | +
- card$append_text("Comment", "header3")
+ #' @param probs (reactive `numeric`)\cr probabilities to bin the gene or gene signature |
||
| 433 | -! | +||
| 137 | +
- card$append_text(comment)+ #' into. |
||
| 434 | +138 |
- }+ #' |
|
| 435 | -! | +||
| 139 | +
- card+ #' @return List with the following elements: |
||
| 436 | +140 |
- }+ #' - `binned_adtte_subset`: reactive containing the joined `ADTTE` and gene data. |
|
| 437 | -! | +||
| 141 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' - `gene_col`: reactive containing the string with the column name of the original |
||
| 438 | +142 |
- }+ #' numeric gene variable. |
|
| 439 | +143 |
- ###+ #' - `gene_factor`: string with the variable name for the binned gene data. |
|
| 440 | +144 |
- })+ #' - `time_unit`: reactive string with the time unit for the current subset. |
|
| 441 | +145 |
- }+ #' |
|
| 442 | +146 |
-
+ #' @seealso [adtteSpecInput()] for the module UI. |
|
| 443 | +147 |
- #' @describeIn tm_g_pca sample module function.+ #' |
|
| 444 | +148 |
#' @export |
|
| 445 | +149 | ++ |
+ #'+ |
+
| 150 |
#' @examples |
||
| 446 | +151 |
- #'+ #' ui <- function(id, |
|
| 447 | +152 |
- #' # Alternatively you can run the sample module with this function call:+ #' data) {
|
|
| 448 | +153 |
- #' if (interactive()) {
+ #' ns <- NS(id) |
|
| 449 | +154 |
- #' sample_tm_g_pca()+ #' |
|
| 450 | +155 |
- #' }+ #' teal.widgets::standard_layout( |
|
| 451 | +156 |
- sample_tm_g_pca <- function() {
+ #' encoding = div( |
|
| 452 | -! | +||
| 157 | +
- mae <- hermes::multi_assay_experiment+ #' experimentSpecInput(ns("experiment"), data = data, mae_name = "MAE"),
|
||
| 453 | -! | +||
| 158 | +
- mae_data <- teal.data::dataset("MAE", mae)
+ #' assaySpecInput(ns("assay")),
|
||
| 454 | -! | +||
| 159 | +
- data <- teal.data::teal_data(mae_data)+ #' geneSpecInput(ns("genes"), funs = list(Mean = colMeans)),
|
||
| 455 | -! | +||
| 160 | +
- app <- teal::init(+ #' adtteSpecInput(ns("adtte"))
|
||
| 456 | -! | +||
| 161 | +
- data = data,+ #' ), |
||
| 457 | -! | +||
| 162 | +
- modules = teal::modules(+ #' output = verbatimTextOutput(ns("summary"))
|
||
| 458 | -! | +||
| 163 | +
- tm_g_pca(+ #' ) |
||
| 459 | -! | +||
| 164 | +
- label = "pca",+ #' } |
||
| 460 | -! | +||
| 165 | +
- mae_name = "MAE"+ #' |
||
| 461 | +166 |
- )+ #' server <- function(id, data, filter_panel_api) {
|
|
| 462 | +167 |
- )+ #' moduleServer(id, function(input, output, session) {
|
|
| 463 | +168 |
- )+ #' experiment <- experimentSpecServer( |
|
| 464 | -! | +||
| 169 | +
- shinyApp(app$ui, app$server)+ #' "experiment", |
||
| 465 | +170 |
- }+ #' data = data, |
| 1 | +171 |
- #' Teal Module for Survival Forest Plot+ #' filter_panel_api = filter_panel_api, |
|
| 2 | +172 |
- #'+ #' mae_name = "MAE" |
|
| 3 | +173 |
- #' @description `r lifecycle::badge("experimental")`
+ #' ) |
|
| 4 | +174 |
- #'+ #' assay <- assaySpecServer( |
|
| 5 | +175 |
- #' This module provides an interactive survival forest plot.+ #' "assay", |
|
| 6 | +176 |
- #'+ #' assays = experiment$assays |
|
| 7 | +177 |
- #' @inheritParams module_arguments+ #' ) |
|
| 8 | +178 |
- #'+ #' genes <- geneSpecServer( |
|
| 9 | +179 |
- #' @return Shiny module to be used in the teal app.+ #' "genes", |
|
| 10 | +180 |
- #'+ #' funs = list(Mean = colMeans), |
|
| 11 | +181 |
- #' @export+ #' gene_choices = experiment$genes |
|
| 12 | +182 |
- #'+ #' ) |
|
| 13 | +183 |
- #' @examples+ #' adtte <- adtteSpecServer( |
|
| 14 | +184 |
- #' mae <- hermes::multi_assay_experiment+ #' "adtte", |
|
| 15 | +185 |
- #' adtte <- teal.modules.hermes::rADTTE %>%+ #' data = data, |
|
| 16 | +186 |
- #' dplyr::mutate(is_event = (.data$CNSR == 0))+ #' adtte_name = "ADTTE", |
|
| 17 | +187 |
- #'+ #' mae_name = "MAE", |
|
| 18 | +188 |
- #' data <- teal_data(+ #' adtte_vars = list( |
|
| 19 | +189 |
- #' dataset(+ #' aval = "AVAL", |
|
| 20 | +190 |
- #' "ADTTE",+ #' avalu = "AVALU", |
|
| 21 | +191 |
- #' adtte,+ #' is_event = "is_event", |
|
| 22 | +192 |
- #' code = "adtte <- teal.modules.hermes::rADTTE %>%+ #' paramcd = "PARAMCD", |
|
| 23 | +193 |
- #' dplyr::mutate(is_event = (.data$CNSR == 0))"+ #' usubjid = "USUBJID" |
|
| 24 | +194 |
- #' ),+ #' ), |
|
| 25 | +195 |
- #' dataset("MAE", mae)
+ #' experiment_data = experiment$data, |
|
| 26 | +196 |
- #' )+ #' experiment_name = experiment$name, |
|
| 27 | +197 |
- #' app <- init(+ #' assay = assay, |
|
| 28 | +198 |
- #' data = data,+ #' genes = genes, |
|
| 29 | +199 |
- #' modules = modules(+ #' probs = reactive({
|
|
| 30 | +200 |
- #' tm_g_forest_tte(+ #' 0.5 |
|
| 31 | +201 |
- #' label = "forestplot",+ #' }) |
|
| 32 | +202 |
- #' adtte_name = "ADTTE",+ #' ) |
|
| 33 | +203 |
- #' mae_name = "MAE"+ #' output$summary <- renderPrint({
|
|
| 34 | +204 |
- #' )+ #' binned_adtte_subset <- adtte$binned_adtte_subset() |
|
| 35 | +205 |
- #' )+ #' summary(binned_adtte_subset) |
|
| 36 | +206 |
- #' )+ #' }) |
|
| 37 | +207 |
- #' if (interactive()) {
+ #' }) |
|
| 38 | +208 |
- #' shinyApp(app$ui, app$server)+ #' } |
|
| 39 | +209 |
- #' }+ #' |
|
| 40 | +210 |
- tm_g_forest_tte <- function(label,+ #' my_app <- function() {
|
|
| 41 | +211 |
- adtte_name,+ #' mae <- hermes::multi_assay_experiment |
|
| 42 | +212 |
- mae_name,+ #' adtte <- teal.modules.hermes::rADTTE %>% |
|
| 43 | +213 |
- adtte_vars = list(+ #' dplyr::mutate(is_event = .data$CNSR == 0) |
|
| 44 | +214 |
- aval = "AVAL",+ #' |
|
| 45 | +215 |
- is_event = "is_event",+ #' data <- teal_data( |
|
| 46 | +216 |
- paramcd = "PARAMCD",+ #' dataset( |
|
| 47 | +217 |
- usubjid = "USUBJID",+ #' "ADTTE", |
|
| 48 | +218 |
- avalu = "AVALU"+ #' adtte, |
|
| 49 | +219 |
- ),+ #' code = "adtte <- teal.modules.hermes::rADTTE |
|
| 50 | +220 |
- exclude_assays = "counts",+ #' dplyr::mutate(is_event = .data$CNSR == 0)" |
|
| 51 | +221 |
- summary_funs = list(+ #' ), |
|
| 52 | +222 |
- Mean = colMeans,+ #' dataset("MAE", mae)
|
|
| 53 | +223 |
- Median = matrixStats::colMedians,+ #' ) |
|
| 54 | +224 |
- Max = matrixStats::colMaxs+ #' |
|
| 55 | +225 |
- ),+ #' app <- init( |
|
| 56 | +226 |
- pre_output = NULL,+ #' data = data, |
|
| 57 | +227 |
- post_output = NULL,+ #' modules = modules( |
|
| 58 | +228 |
- plot_height = c(600L, 200L, 2000L),+ #' module( |
|
| 59 | +229 |
- plot_width = c(1360L, 500L, 2000L)) {
+ #' label = "adtteSpec example", |
|
| 60 | -! | +||
| 230 | +
- logger::log_info("Initializing tm_g_forest_tte")
+ #' server = server, |
||
| 61 | -! | +||
| 231 | +
- assert_string(label)+ #' ui = ui, |
||
| 62 | -! | +||
| 232 | +
- assert_string(adtte_name)+ #' datanames = "all" |
||
| 63 | -! | +||
| 233 | +
- assert_string(mae_name)+ #' ) |
||
| 64 | -! | +||
| 234 | +
- assert_adtte_vars(adtte_vars)+ #' ) |
||
| 65 | -! | +||
| 235 | +
- assert_character(exclude_assays, any.missing = FALSE)+ #' ) |
||
| 66 | -! | +||
| 236 | +
- assert_summary_funs(summary_funs)+ #' shinyApp(app$ui, app$server) |
||
| 67 | -! | +||
| 237 | +
- assert_tag(pre_output, null.ok = TRUE)+ #' } |
||
| 68 | -! | +||
| 238 | +
- assert_tag(post_output, null.ok = TRUE)+ #' |
||
| 69 | +239 |
-
+ #' if (interactive()) {
|
|
| 70 | -! | +||
| 240 | +
- teal::module(+ #' my_app() |
||
| 71 | -! | +||
| 241 | +
- label = label,+ #' } |
||
| 72 | -! | +||
| 242 | +
- server = srv_g_forest_tte,+ adtteSpecServer <- function(id, # nolint |
||
| 73 | -! | +||
| 243 | +
- server_args = list(+ data, |
||
| 74 | -! | +||
| 244 | +
- adtte_name = adtte_name,+ mae_name, |
||
| 75 | -! | +||
| 245 | +
- mae_name = mae_name,+ adtte_name, |
||
| 76 | -! | +||
| 246 | +
- adtte_vars = adtte_vars,+ adtte_vars, |
||
| 77 | -! | +||
| 247 | +
- exclude_assays = exclude_assays,+ experiment_data, |
||
| 78 | -! | +||
| 248 | +
- summary_funs = summary_funs,+ experiment_name, |
||
| 79 | -! | +||
| 249 | +
- plot_height = plot_height,+ assay, |
||
| 80 | -! | +||
| 250 | +
- plot_width = plot_width+ genes, |
||
| 81 | +251 |
- ),+ probs) {
|
|
| 82 | +252 | ! |
- ui = ui_g_forest_tte,+ assert_string(id) |
| 83 | +253 | ! |
- ui_args = list(+ assert_string(mae_name) |
| 84 | +254 | ! |
- adtte_name = adtte_name,+ assert_string(adtte_name) |
| 85 | +255 | ! |
- mae_name = mae_name,+ assert_adtte_vars(adtte_vars) |
| 86 | +256 | ! |
- summary_funs = summary_funs,+ assert_reactive(experiment_data) |
| 87 | +257 | ! |
- pre_output = pre_output,+ assert_reactive(experiment_name) |
| 88 | +258 | ! |
- post_output = post_output- |
-
| 89 | -- |
- ),+ assert_reactive(assay) |
|
| 90 | +259 | ! |
- datanames = c(adtte_name, mae_name)- |
-
| 91 | -- |
- )+ assert_reactive(genes) |
|
| 92 | -+ | ||
| 260 | +! |
- }+ assert_reactive(probs) |
|
| 93 | +261 | ||
| 94 | -- |
- #' @describeIn tm_g_forest_tte sets up the user interface.- |
- |
| 95 | -- |
- #' @inheritParams module_arguments- |
- |
| 96 | -- |
- #' @export- |
- |
| 97 | -- |
- ui_g_forest_tte <- function(id,- |
- |
| 98 | -+ | ||
| 262 | +! |
- data,+ moduleServer(id, function(input, output, session) {
|
|
| 99 | +263 |
- adtte_name,+ # Join ADTTE with gene data. |
|
| 100 | -+ | ||
| 264 | +! |
- mae_name,+ adtte_joined <- reactive({
|
|
| 101 | -+ | ||
| 265 | +! |
- summary_funs,+ experiment_data <- experiment_data() |
|
| 102 | -+ | ||
| 266 | +! |
- pre_output,+ experiment_name <- experiment_name() |
|
| 103 | -+ | ||
| 267 | +! |
- post_output) {
+ assay <- assay() |
|
| 104 | -1x | +||
| 268 | +! |
- ns <- NS(id)+ genes <- genes() |
|
| 105 | -1x | +||
| 269 | +
- teal.widgets::standard_layout(+ |
||
| 106 | -1x | +||
| 270 | +! |
- encoding = div(+ validate_gene_spec(genes, rownames(experiment_data)) |
|
| 107 | +271 |
- ### Reporter+ |
|
| 108 | -1x | +||
| 272 | +! |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ req( |
|
| 109 | -+ | ||
| 273 | +! |
- ###+ genes$returns_vector(), |
|
| 110 | -1x | +||
| 274 | +! |
- tags$label("Encodings", class = "text-primary"),
+ experiment_name, |
|
| 111 | -1x | +||
| 275 | +! |
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ assay |
|
| 112 | -1x | +||
| 276 | +
- experimentSpecInput(ns("experiment"), data, mae_name),
+ ) |
||
| 113 | -1x | +||
| 277 | +
- assaySpecInput(ns("assay")),
+
|
||
| 114 | -1x | +||
| 278 | +! |
- geneSpecInput(ns("genes"), summary_funs),
+ mae <- data[[mae_name]]() |
|
| 115 | -1x | +||
| 279 | +! |
- helpText("Analysis of ADTTE:", tags$code(adtte_name)),
+ adtte <- data[[adtte_name]]() |
|
| 116 | -1x | +||
| 280 | +
- adtteSpecInput(ns("adtte")),
+
|
||
| 117 | -1x | +||
| 281 | +! |
- teal.widgets::panel_group(+ mae[[experiment_name]] <- experiment_data |
|
| 118 | -1x | +||
| 282 | +! |
- teal.widgets::panel_item(+ h_km_mae_to_adtte( |
|
| 119 | -1x | +||
| 283 | +! |
- input_id = "settings_item",+ adtte, |
|
| 120 | -1x | +||
| 284 | +! |
- collapsed = TRUE,+ mae, |
|
| 121 | -1x | +||
| 285 | +! |
- title = "Additional Settings",+ genes = genes, |
|
| 122 | -1x | +||
| 286 | +! |
- sliderInput(ns("probs"), label = ("Probability Cutoff"), min = 0.01, max = 0.99, value = 0.5),
+ experiment_name = experiment_name, |
|
| 123 | -1x | +||
| 287 | +! |
- sampleVarSpecInput(ns("subgroups"), "Select Categorical Subgroup Variable")
+ assay_name = assay, |
|
| 124 | -+ | ||
| 288 | +! |
- )+ usubjid_var = adtte_vars$usubjid |
|
| 125 | +289 |
) |
|
| 126 | +290 |
- ),- |
- |
| 127 | -1x | -
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ }) |
|
| 128 | -1x | +||
| 291 | +
- pre_output = pre_output,+ |
||
| 129 | -1x | +||
| 292 | +! |
- post_output = post_output+ gene_col <- reactive({
|
|
| 130 | -+ | ||
| 293 | +! |
- )+ attr(adtte_joined(), "gene_cols") |
|
| 131 | +294 |
- }+ }) |
|
| 132 | +295 | ||
| 133 | +296 |
- #' @describeIn tm_g_forest_tte sets up the server with reactive graph.+ # After joining, we recompute available endpoints. |
|
| 134 | -+ | ||
| 297 | +! |
- #' @inheritParams module_arguments+ paramcd_choices <- reactive({
|
|
| 135 | -+ | ||
| 298 | +! |
- #' @export+ adtte_joined <- adtte_joined() |
|
| 136 | -+ | ||
| 299 | +! |
- srv_g_forest_tte <- function(id,+ sort(unique(adtte_joined[[adtte_vars$paramcd]])) # Order should not matter. |
|
| 137 | +300 |
- data,+ }) |
|
| 138 | +301 |
- filter_panel_api,+ |
|
| 139 | +302 |
- reporter,+ # Start by disabling selection, will be overriden if there are valid choices. |
|
| 140 | -+ | ||
| 303 | +! |
- adtte_name,+ session$sendCustomMessage( |
|
| 141 | -+ | ||
| 304 | +! |
- mae_name,+ "toggle_dropdown", |
|
| 142 | -+ | ||
| 305 | +! |
- adtte_vars,+ list(input_id = session$ns("paramcd"), disabled = TRUE)
|
|
| 143 | +306 |
- exclude_assays,+ ) |
|
| 144 | +307 |
- summary_funs,+ |
|
| 145 | +308 |
- plot_height,+ # Once available endpoints change, we update choices (and also the selection |
|
| 146 | +309 |
- plot_width) {
+ # if nothing was selected earlier) and warn the user if previous endpoint is |
|
| 147 | -! | +||
| 310 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ # not available. |
||
| 148 | +311 | ! |
- assert_class(filter_panel_api, "FilterPanelAPI")+ observeEvent(paramcd_choices(), {
|
| 149 | +312 | ! |
- assert_class(data, "tdata")+ paramcd_choices <- paramcd_choices() |
| 150 | +313 | ||
| 151 | +314 | ! |
- moduleServer(id, function(input, output, session) {
+ new_selected <- if (is_blank(input$paramcd) || (input$paramcd %in% paramcd_choices)) {
|
| 152 | +315 | ! |
- experiment <- experimentSpecServer(+ input$paramcd |
| 153 | -! | +||
| 316 | +
- "experiment",+ } else {
|
||
| 154 | +317 | ! |
- data = data,+ showNotification(type = "warning", paste( |
| 155 | +318 | ! |
- filter_panel_api = filter_panel_api,+ "Endpoint", input$paramcd, "not available in this data subset, please", |
| 156 | +319 | ! |
- mae_name = mae_name+ "change filter options or select another endpoint" |
| 157 | +320 |
- )+ )) |
|
| 158 | -! | +||
| 321 | +
- assay <- assaySpecServer(+ ""+ |
+ ||
| 322 | ++ |
+ } |
|
| 159 | +323 | ! |
- "assay",+ updateSelectizeInput( |
| 160 | +324 | ! |
- assays = experiment$assays,+ "paramcd", |
| 161 | +325 | ! |
- exclude_assays = exclude_assays+ choices = paramcd_choices, |
| 162 | -+ | ||
| 326 | +! |
- )+ selected = new_selected, |
|
| 163 | +327 | ! |
- genes <- geneSpecServer(+ session = session+ |
+
| 328 | ++ |
+ ) |
|
| 164 | +329 | ! |
- "genes",+ session$sendCustomMessage( |
| 165 | +330 | ! |
- funs = summary_funs,+ "toggle_dropdown", |
| 166 | +331 | ! |
- gene_choices = experiment$genes+ list(input_id = session$ns("paramcd"), disabled = (length(paramcd_choices) == 0))
|
| 167 | +332 |
- )+ ) |
|
| 168 | -! | +||
| 333 | +
- subgroups <- sampleVarSpecServer(+ }) |
||
| 169 | -! | +||
| 334 | +
- "subgroups",+ |
||
| 170 | -! | +||
| 335 | +
- experiment_name = experiment$name,+ # Subset zooming in on a specified endpoint. |
||
| 171 | +336 | ! |
- original_data = experiment$data,+ adtte_subset <- reactive({
|
| 172 | +337 | ! |
- categorical_only = TRUE,+ endpoint <- input$paramcd |
| 173 | +338 | ! |
- explicit_na = TRUE+ adtte_joined <- adtte_joined() |
| 174 | +339 |
- )+ |
|
| 175 | +340 | ! |
- adtte <- adtteSpecServer(+ validate(need( |
| 176 | +341 | ! |
- "adtte",+ endpoint, |
| 177 | +342 | ! |
- data = data,+ "please select an endpoint" |
| 178 | -! | +||
| 343 | +
- adtte_name = adtte_name,+ )) |
||
| 179 | -! | +||
| 344 | +
- mae_name = mae_name,+ # Validate that adtte_data is not empty. |
||
| 180 | +345 | ! |
- adtte_vars = adtte_vars,+ validate(need( |
| 181 | +346 | ! |
- experiment_data = subgroups$experiment_data,+ nrow(adtte_joined) > 0, |
| 182 | +347 | ! |
- experiment_name = experiment$name,+ "Joined ADTTE is empty - please relax the filter criteria" |
| 183 | -! | +||
| 348 | +
- assay = assay,+ ))+ |
+ ||
| 349 | ++ | + | |
| 184 | +350 | ! |
- genes = genes,+ subset_rows <- adtte_joined[[adtte_vars$paramcd]] == endpoint |
| 185 | +351 | ! |
- probs = reactive({
+ result <- adtte_joined[subset_rows, , drop = FALSE] |
| 186 | +352 | ! |
- input$probs+ droplevels(result) |
| 187 | +353 |
- })+ }) |
|
| 188 | +354 |
- )+ |
|
| 189 | -+ | ||
| 355 | +! |
-
+ binned_adtte_subset <- reactive({
|
|
| 190 | +356 | ! |
- surv_subgroups <- reactive({
+ gene_col <- gene_col() |
| 191 | +357 | ! |
- binned_adtte <- adtte$binned_adtte_subset()+ probs <- probs() |
| 192 | +358 | ! |
- subgroups_var <- subgroups$sample_var()+ adtte_subset <- adtte_subset() |
| 193 | +359 | ||
| 194 | -! | -
- tern::extract_survival_subgroups(- |
- |
| 195 | +360 | ! |
- variables = list(+ result <- tryCatch( |
| 196 | +361 | ! |
- tte = adtte_vars$aval,+ expr = {
|
| 197 | +362 | ! |
- is_event = adtte_vars$is_event,+ dplyr::mutate( |
| 198 | +363 | ! |
- arm = adtte$gene_factor,+ adtte_subset, |
| 199 | +364 | ! |
- subgroups = subgroups_var- |
-
| 200 | -- |
- ),+ gene_factor = tern::cut_quantile_bins( |
|
| 201 | +365 | ! |
- label_all = "All Patients",+ adtte_subset[, gene_col], |
| 202 | +366 | ! |
- data = binned_adtte+ probs = probs |
| 203 | +367 |
- )+ ) |
|
| 204 | +368 |
- })+ ) |
|
| 205 | +369 |
-
+ }, |
|
| 206 | +370 | ! |
- result <- reactive({
+ error = function(e) {
|
| 207 | +371 | ! |
- surv_subgroups <- surv_subgroups()+ if (grepl("Contains duplicated values", e)) {
|
| 208 | +372 | ! |
- lyt <- rtables::basic_table()+ validate(paste( |
| 209 | +373 | ! |
- time_unit <- adtte$time_unit()+ "please adjust filters or select (slightly) different quantiles", |
| 210 | -+ | ||
| 374 | +! |
-
+ "to avoid duplicate quantiles" |
|
| 211 | -! | +||
| 375 | +
- tern::tabulate_survival_subgroups(+ )) |
||
| 212 | -! | +||
| 376 | +
- lyt = lyt,+ } else {
|
||
| 213 | +377 | ! |
- df = surv_subgroups,+ stop(e) |
| 214 | -! | +||
| 378 | +
- vars = c("n_tot_events", "n", "n_events", "median", "hr", "ci"),
+ } |
||
| 215 | -! | +||
| 379 | +
- time_unit = time_unit+ } |
||
| 216 | +380 |
) |
|
| 381 | +! | +
+ result+ |
+ |
| 217 | +382 |
}) |
|
| 218 | +383 | ||
| 219 | +384 | ! |
- forest_plot <- reactive({
+ time_unit <- reactive({
|
| 220 | +385 | ! |
- result <- result()+ adtte_subset <- adtte_subset() |
| 221 | +386 | ! |
- tern::g_forest(result)+ result <- unique(as.character(adtte_subset[[adtte_vars$avalu]]))+ |
+
| 387 | +! | +
+ assert_string(result)+ |
+ |
| 388 | +! | +
+ result |
|
| 222 | +389 |
}) |
|
| 223 | +390 | ||
| 224 | +391 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ list( |
| 225 | +392 | ! |
- id = "plot",+ binned_adtte_subset = binned_adtte_subset, |
| 226 | +393 | ! |
- plot_r = forest_plot,+ gene_col = gene_col, |
| 227 | +394 | ! |
- height = plot_height,+ gene_factor = "gene_factor", |
| 228 | +395 | ! |
- width = plot_width+ time_unit = time_unit |
| 229 | +396 |
) |
|
| 230 | +397 |
-
+ }) |
|
| 231 | +398 |
- ### REPORTER+ }+ |
+
| 1 | ++ |
+ #' Module Input for Gene Signature Specification+ |
+ |
| 2 | ++ |
+ #'+ |
+ |
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
|
|
| 232 | -! | +||
| 4 | +
- if (with_reporter) {
+ #' |
||
| 233 | -! | +||
| 5 | +
- card_fun <- function(comment) {
+ #' This defines the input for the gene signature specification. |
||
| 234 | -! | +||
| 6 | +
- card <- teal::TealReportCard$new()+ #' |
||
| 235 | -! | +||
| 7 | +
- card$set_name("Forest Plot")
+ #' @inheritParams module_arguments |
||
| 236 | -! | +||
| 8 | +
- card$append_text("Forest Plot", "header2")
+ #' @param funs (named `list`)\cr names of this list will be used for the function |
||
| 237 | -! | +||
| 9 | +
- card$append_fs(filter_panel_api$get_filter_state())+ #' selection drop down menu. |
||
| 238 | -! | +||
| 10 | +
- card$append_text("Selected Options", "header3")
+ #' @param label_genes (`string`)\cr label for the gene selection. |
||
| 239 | -! | +||
| 11 | +
- encodings_list <- list(+ #' @param label_funs (`string`)\cr label for the function selection. |
||
| 240 | -! | +||
| 12 | +
- "Experiment:",+ #' @param label_text_button (`string`)\cr label for the text input button. |
||
| 241 | -! | +||
| 13 | +
- input$`experiment-name`,+ #' @param label_lock_button (`string`)\cr label for the lock button. |
||
| 242 | -! | +||
| 14 | +
- "\nAssay:",+ #' @param label_select_all_button (`string`)\cr label for the selecting all genes button. |
||
| 243 | -! | +||
| 15 | +
- input$`assay-name`,+ #' @param label_select_none_button (`string`)\cr label for the selecting no genes button. |
||
| 244 | -! | +||
| 16 | +
- "\nGenes Selected:",+ #' @param max_options (`count`)\cr maximum number of gene options rendering and selected via |
||
| 245 | -! | +||
| 17 | +
- paste0(genes()$get_gene_labels(), collapse = ", "),+ #' "Select All". |
||
| 246 | -! | +||
| 18 | +
- "\nGene Summary:",+ #' @param max_selected (`count`)\cr maximum number of genes which can be selected. |
||
| 247 | -! | +||
| 19 | +
- input$`genes-fun_name`,+ #' |
||
| 248 | -! | +||
| 20 | +
- "\nEndpoint:",+ #' @return The UI part. |
||
| 249 | -! | +||
| 21 | +
- input$`adtte-paramcd`,+ #' @seealso [geneSpecServer()] for the module server and a complete example. |
||
| 250 | -! | +||
| 22 | +
- "\nProbability Cutoff:",+ #' @export |
||
| 251 | -! | +||
| 23 | +
- input$probs,+ #' |
||
| 252 | -! | +||
| 24 | +
- "\nSubgroup Variable:",+ #' @examples |
||
| 253 | -! | +||
| 25 | +
- input$`subgroups-sample_var`+ #' geneSpecInput("my_genes", list(mean = colMeans), label_funs = "Please select function")
|
||
| 254 | +26 |
- )+ geneSpecInput <- function(inputId, # nolint |
|
| 255 | -! | +||
| 27 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ funs, |
||
| 256 | -! | +||
| 28 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ label_genes = "Select Gene(s)", |
||
| 257 | -! | +||
| 29 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ label_funs = "Select Gene Summary", |
||
| 258 | -! | +||
| 30 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ label_text_button = "Enter list of genes", |
||
| 259 | +31 |
- } else {
+ label_lock_button = "Lock gene selection (so that it does not get updated when filtering)", |
|
| 260 | -! | +||
| 32 | +
- paste(encodings_list, collapse = " ")+ label_select_all_button = paste0("Select All Genes (first ", max_options, ")"),
|
||
| 261 | +33 |
- }+ label_select_none_button = "Select None", |
|
| 262 | +34 |
-
+ max_options = 200L, |
|
| 263 | -! | +||
| 35 | +
- card$append_text(final_encodings, style = "verbatim")+ max_selected = max_options) {
|
||
| 264 | -! | +||
| 36 | +7x |
- card$append_text("Plot", "header3")
+ assert_string(inputId) |
|
| 265 | -! | +||
| 37 | +7x |
- card$append_plot(forest_plot(), dim = pws$dim())+ assert_list(funs, names = "unique", min.len = 1L) |
|
| 266 | -! | +||
| 38 | +7x |
- if (!comment == "") {
+ assert_string(label_genes) |
|
| 267 | -! | +||
| 39 | +7x |
- card$append_text("Comment", "header3")
+ assert_string(label_funs) |
|
| 268 | -! | +||
| 40 | +7x |
- card$append_text(comment)+ assert_string(label_text_button) |
|
| 269 | -+ | ||
| 41 | +7x |
- }+ assert_string(label_lock_button) |
|
| 270 | -! | +||
| 42 | +7x |
- card+ assert_string(label_select_all_button) |
|
| 271 | -+ | ||
| 43 | +7x |
- }+ assert_string(label_select_none_button) |
|
| 272 | -! | +||
| 44 | +7x |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ assert_count(max_options, positive = TRUE) |
|
| 273 | -+ | ||
| 45 | +7x |
- }+ assert_count(max_selected, positive = TRUE) |
|
| 274 | +46 |
- ###+ |
|
| 275 | -+ | ||
| 47 | +7x |
- })+ ns <- NS(inputId) |
|
| 276 | -+ | ||
| 48 | +7x |
- }+ tagList( |
|
| 277 | -+ | ||
| 49 | +7x |
-
+ include_css_files(pattern = "*"), |
|
| 278 | -+ | ||
| 50 | +7x |
- #' @describeIn tm_g_forest_tte sample module function.+ div( |
|
| 279 | -+ | ||
| 51 | +7x |
- #' @export+ class = "row", |
|
| 280 | -+ | ||
| 52 | +7x |
- #' @examples+ div( |
|
| 281 | -+ | ||
| 53 | +7x |
- #'+ class = "col-sm-8", |
|
| 282 | -+ | ||
| 54 | +7x |
- #' # Alternatively you can run the sample module with this function call:+ tags$label( |
|
| 283 | -+ | ||
| 55 | +7x |
- #' if (interactive()) {
+ class = "control-label", |
|
| 284 | -+ | ||
| 56 | +7x |
- #' sample_tm_g_forest_tte()+ label_genes |
|
| 285 | +57 |
- #' }+ ) |
|
| 286 | +58 |
- sample_tm_g_forest_tte <- function() { # nolint
+ ), |
|
| 287 | -+ | ||
| 59 | +7x |
-
+ div( |
|
| 288 | -! | +||
| 60 | +7x |
- mae <- hermes::multi_assay_experiment+ class = "col-sm-2", |
|
| 289 | -! | +||
| 61 | +7x |
- adtte <- teal.modules.hermes::rADTTE %>%+ actionButton( |
|
| 290 | -! | +||
| 62 | +7x |
- dplyr::mutate(is_event = .data$CNSR == 0)+ ns("select_none_button"),
|
|
| 291 | -+ | ||
| 63 | +7x |
-
+ span(icon("remove-circle", lib = "glyphicon")),
|
|
| 292 | -! | +||
| 64 | +7x |
- data <- teal.data::teal_data(+ title = label_select_none_button, |
|
| 293 | -! | +||
| 65 | +7x |
- teal.data::dataset(+ class = "pull-right list-genes" |
|
| 294 | -! | +||
| 66 | +
- "ADTTE",+ ), |
||
| 295 | -! | +||
| 67 | +7x |
- adtte,+ actionButton( |
|
| 296 | -! | +||
| 68 | +7x |
- code = "adtte <- teal.modules.hermes::rADTTE %>%+ ns("select_all_button"),
|
|
| 297 | -! | +||
| 69 | +7x |
- dplyr::mutate(is_event = .data$CNSR == 0)"+ span(icon("ok-circle", lib = "glyphicon")),
|
|
| 298 | -+ | ||
| 70 | +7x |
- ),+ title = label_select_all_button, |
|
| 299 | -! | +||
| 71 | +7x |
- teal.data::dataset("MAE", mae)
+ class = "pull-right list-genes" |
|
| 300 | +72 |
- )+ ) |
|
| 301 | +73 | - - | -|
| 302 | -! | -
- app <- teal::init(- |
- |
| 303 | -! | -
- data = data,+ ), |
|
| 304 | -! | +||
| 74 | +7x |
- modules = teal::modules(+ div( |
|
| 305 | -! | +||
| 75 | +7x |
- tm_g_forest_tte(+ class = "col-sm-2", |
|
| 306 | -! | +||
| 76 | +7x |
- label = "forest",+ actionButton( |
|
| 307 | -! | +||
| 77 | +7x |
- adtte_name = "ADTTE",+ ns("text_button"),
|
|
| 308 | -! | +||
| 78 | +7x |
- mae_name = "MAE"+ span(icon("fas fa-font")),
|
|
| 309 | -+ | ||
| 79 | +7x |
- )+ title = label_text_button, |
|
| 310 | -+ | ||
| 80 | +7x |
- )+ class = "pull-right list-genes" |
|
| 311 | +81 |
- )+ ), |
|
| 312 | -! | +||
| 82 | +7x |
- shinyApp(app$ui, app$server)+ div( |
|
| 313 | -+ | ||
| 83 | +7x |
- }+ class = "pull-right", |
| 1 | -+ | |||
| 84 | +7x |
- #' Teal Module for `Kaplan-Meier` Plot+ title = label_lock_button, |
||
| 2 | -+ | |||
| 85 | +7x |
- #'+ shinyWidgets::prettyToggle( |
||
| 3 | -+ | |||
| 86 | +7x |
- #' @description `r lifecycle::badge("experimental")`
+ ns("lock_button"),
|
||
| 4 | -+ | |||
| 87 | +7x |
- #'+ value = FALSE, |
||
| 5 | -+ | |||
| 88 | +7x |
- #' This teal module produces a grid style `Kaplan-Meier` plot for data with+ label_on = NULL, |
||
| 6 | -+ | |||
| 89 | +7x |
- #' `ADaM` structure.+ label_off = NULL, |
||
| 7 | -+ | |||
| 90 | +7x |
- #'+ status_on = "default", |
||
| 8 | -+ | |||
| 91 | +7x |
- #' @inheritParams module_arguments+ status_off = "default", |
||
| 9 | -+ | |||
| 92 | +7x |
- #'+ outline = FALSE, |
||
| 10 | -+ | |||
| 93 | +7x |
- #' @return Shiny module to be used in the teal app.+ plain = TRUE, |
||
| 11 | -+ | |||
| 94 | +7x |
- #'+ icon_on = icon("fas fa-lock"),
|
||
| 12 | -+ | |||
| 95 | +7x |
- #' @export+ icon_off = icon("fas fa-lock-open"),
|
||
| 13 | -+ | |||
| 96 | +7x |
- #'+ animation = "pulse" |
||
| 14 | +97 |
- #' @examples+ ) |
||
| 15 | +98 |
- #' mae <- hermes::multi_assay_experiment+ ) |
||
| 16 | +99 |
- #' adtte <- teal.modules.hermes::rADTTE %>%+ ) |
||
| 17 | +100 |
- #' dplyr::mutate(is_event = (.data$CNSR == 0))+ ), |
||
| 18 | -+ | |||
| 101 | +7x |
- #'+ div( |
||
| 19 | -+ | |||
| 102 | +7x |
- #' data <- teal_data(+ class = "custom-select-input", |
||
| 20 | -+ | |||
| 103 | +7x |
- #' dataset(+ selectizeInput( |
||
| 21 | -+ | |||
| 104 | +7x |
- #' "ADTTE",+ ns("genes"),
|
||
| 22 | -+ | |||
| 105 | +7x |
- #' adtte,+ label = NULL, |
||
| 23 | -+ | |||
| 106 | +7x |
- #' code = "adtte <- teal.modules.hermes::rADTTE %>%+ choices = "", |
||
| 24 | -+ | |||
| 107 | +7x |
- #' dplyr::mutate(is_event = (.data$CNSR == 0))"+ multiple = TRUE, |
||
| 25 | -+ | |||
| 108 | +7x |
- #' ),+ selected = 1, |
||
| 26 | -+ | |||
| 109 | +7x |
- #' dataset("MAE", mae)
+ options = list( |
||
| 27 | -+ | |||
| 110 | +7x |
- #' )+ placeholder = "- Nothing selected -", |
||
| 28 | -+ | |||
| 111 | +7x |
- #'+ render = I("{
|
||
| 29 | -+ | |||
| 112 | +7x |
- #' modules <- modules(+ option: function(item, escape) {
|
||
| 30 | -+ | |||
| 113 | +7x |
- #' tm_g_km(+ return '<div> <span style=\"font-size: inherit;\">' + item.label + '</div>' + |
||
| 31 | -+ | |||
| 114 | +7x |
- #' label = "kaplan-meier",+ ' <span style=\"color: #808080; font-size: xx-small;\" >' + item.value + '</div> </div>' |
||
| 32 | +115 |
- #' adtte_name = "ADTTE",+ } |
||
| 33 | +116 |
- #' mae_name = "MAE"+ }"), |
||
| 34 | -+ | |||
| 117 | +7x |
- #' )+ searchField = c("value", "label"),
|
||
| 35 | -+ | |||
| 118 | +7x |
- #' )+ maxOptions = max_options, |
||
| 36 | -+ | |||
| 119 | +7x |
- #'+ maxItems = max_selected |
||
| 37 | +120 |
- #' app <- init(+ ) |
||
| 38 | +121 |
- #' data = data,+ ) |
||
| 39 | +122 |
- #' modules = modules+ ), |
||
| 40 | -+ | |||
| 123 | +7x |
- #' )+ conditionalPanel( |
||
| 41 | -+ | |||
| 124 | +7x |
- #'+ condition = "input.genes && input.genes.length > 1", |
||
| 42 | -+ | |||
| 125 | +7x |
- #' if (interactive()) {
+ ns = ns, |
||
| 43 | -+ | |||
| 126 | +7x |
- #' shinyApp(ui = app$ui, server = app$server)+ selectInput( |
||
| 44 | -+ | |||
| 127 | +7x |
- #' }+ ns("fun_name"),
|
||
| 45 | -+ | |||
| 128 | +7x |
- tm_g_km <- function(label,+ label_funs, |
||
| 46 | -+ | |||
| 129 | +7x |
- adtte_name,+ names(funs) |
||
| 47 | +130 |
- mae_name,+ ) |
||
| 48 | +131 |
- adtte_vars = list(+ ) |
||
| 49 | +132 |
- aval = "AVAL",+ ) |
||
| 50 | +133 |
- is_event = "is_event",+ } |
||
| 51 | +134 |
- paramcd = "PARAMCD",+ |
||
| 52 | +135 |
- usubjid = "USUBJID",+ #' Helper Function to Update Gene Selection |
||
| 53 | +136 |
- avalu = "AVALU"+ #' |
||
| 54 | +137 |
- ),+ #' @description `r lifecycle::badge("experimental")`
|
||
| 55 | +138 |
- exclude_assays = "counts",+ #' |
||
| 56 | +139 |
- summary_funs = list(+ #' This helper function takes the intersection of `selected` and |
||
| 57 | +140 |
- Mean = colMeans,+ #' `choices` for genes and updates the `inputId` accordingly. It then |
||
| 58 | +141 |
- Median = matrixStats::colMedians,+ #' shows a notification if not all `selected` genes were available. |
||
| 59 | +142 |
- Max = matrixStats::colMaxs+ #' |
||
| 60 | +143 |
- ),+ #' @inheritParams module_arguments |
||
| 61 | +144 |
- pre_output = NULL,+ #' @param session (`ShinySession`)\cr the session object. |
||
| 62 | +145 |
- post_output = NULL) {
- |
- ||
| 63 | -! | -
- logger::log_info("Initializing tm_g_km")
- |
- ||
| 64 | -! | -
- assert_string(label)+ #' @param selected (`character`)\cr currently selected gene IDs. |
||
| 65 | -! | +|||
| 146 | +
- assert_string(adtte_name)+ #' @param choices (`data.frame`)\cr containing `id` and `name` columns of the |
|||
| 66 | -! | +|||
| 147 | +
- assert_string(mae_name)+ #' new choices. |
|||
| 67 | -! | +|||
| 148 | +
- assert_adtte_vars(adtte_vars)+ #' |
|||
| 68 | -! | +|||
| 149 | +
- assert_character(exclude_assays, any.missing = FALSE)+ #' @export |
|||
| 69 | -! | +|||
| 150 | +
- assert_summary_funs(summary_funs)+ h_update_gene_selection <- function(session, |
|||
| 70 | -! | +|||
| 151 | +
- assert_tag(pre_output, null.ok = TRUE)+ inputId, # nolint |
|||
| 71 | -! | +|||
| 152 | +
- assert_tag(post_output, null.ok = TRUE)+ selected, |
|||
| 72 | +153 |
-
+ choices) {
|
||
| 73 | +154 | ! |
- teal::module(+ is_new_selected <- selected %in% choices$id |
|
| 74 | +155 | ! |
- label = label,+ is_removed <- !is_new_selected |
|
| 75 | +156 | ! |
- server = srv_g_km,+ updateSelectizeInput( |
|
| 76 | +157 | ! |
- server_args = list(+ session = session, |
|
| 77 | +158 | ! |
- adtte_name = adtte_name,+ inputId = inputId, |
|
| 78 | +159 | ! |
- mae_name = mae_name,+ selected = selected[is_new_selected], |
|
| 79 | +160 | ! |
- adtte_vars = adtte_vars,+ choices = stats::setNames(choices$id, choices$name), |
|
| 80 | +161 | ! |
- exclude_assays = exclude_assays,+ server = TRUE |
|
| 81 | -! | +|||
| 162 | +
- summary_funs = summary_funs+ ) |
|||
| 82 | +163 |
- ),+ |
||
| 83 | +164 | ! |
- ui = ui_g_km,+ n_removed <- sum(is_removed) |
|
| 84 | +165 | ! |
- ui_args = list(+ if (n_removed > 0) {
|
|
| 85 | +166 | ! |
- adtte_name = adtte_name,+ showNotification(paste( |
|
| 86 | +167 | ! |
- mae_name = mae_name,+ "Removed", n_removed, ifelse(n_removed > 1, "genes", "gene"), |
|
| 87 | +168 | ! |
- summary_funs = summary_funs,+ hermes::h_parens(hermes::h_short_list(selected[is_removed])) |
|
| 88 | -! | +|||
| 169 | +
- pre_output = pre_output,+ )) |
|||
| 89 | -! | +|||
| 170 | +
- post_output = post_output+ } |
|||
| 90 | +171 |
- ),+ } |
||
| 91 | -! | +|||
| 172 | +
- datanames = c(adtte_name, mae_name)+ |
|||
| 92 | +173 |
- )+ #' Helper Function to Parse Genes |
||
| 93 | +174 |
- }+ #' |
||
| 94 | +175 |
-
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 95 | +176 |
- #' @describeIn tm_g_km sets up the user interface.+ #' |
||
| 96 | +177 |
- #' @inheritParams module_arguments+ #' This helper function takes a vector of `words` and tries to match them |
||
| 97 | +178 |
- #' @export+ #' with the `id` and `name` columns of possible gene choices. |
||
| 98 | +179 |
- ui_g_km <- function(id,+ #' |
||
| 99 | +180 |
- data,+ #' @param words (`character`)\cr containing gene IDs or names. |
||
| 100 | +181 |
- adtte_name,+ #' @inheritParams h_update_gene_selection |
||
| 101 | +182 |
- mae_name,+ #' @return The subset of `choices` which matches `words` in ID or name. |
||
| 102 | +183 |
- summary_funs,+ #' |
||
| 103 | +184 |
- pre_output,+ #' @export |
||
| 104 | +185 |
- post_output) {
+ #' @examples |
||
| 105 | -1x | +|||
| 186 | +
- ns <- NS(id)+ #' h_parse_genes( |
|||
| 106 | +187 |
-
+ #' c("a", "2535"),
|
||
| 107 | -1x | +|||
| 188 | +
- teal.widgets::standard_layout(+ #' data.frame(id = as.character(2533:2537), name = letters[1:5]) |
|||
| 108 | -1x | +|||
| 189 | +
- encoding = div(+ #' ) |
|||
| 109 | +190 |
- ### Reporter+ h_parse_genes <- function(words, choices) {
|
||
| 110 | -1x | +191 | +2x | +
+ assert_character(words, min.len = 1L)+ |
+
| 192 | +2x | +
+ assert_data_frame(choices, types = "character")+ |
+ ||
| 193 | +2x |
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ assert_set_equal(names(choices), c("id", "name"))
|
||
| 111 | +194 |
- ###- |
- ||
| 112 | -1x | -
- tags$label("Encodings", class = "text-primary"),
+
|
||
| 113 | -1x | +195 | +2x |
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ id_matches <- choices$id %in% words |
| 114 | -1x | +196 | +2x |
- experimentSpecInput(ns("experiment"), data, mae_name),
+ name_matches <- choices$name %in% words |
| 115 | -1x | +197 | +2x |
- assaySpecInput(ns("assay")),
+ has_match <- id_matches | name_matches |
| 116 | -1x | +198 | +2x |
- geneSpecInput(ns("genes"), summary_funs),
+ choices[has_match, , drop = FALSE] |
| 117 | -1x | +|||
| 199 | +
- helpText("Analysis of ADTTE:", tags$code(adtte_name)),
+ } |
|||
| 118 | -1x | +|||
| 200 | +
- adtteSpecInput(ns("adtte")),
+
|
|||
| 119 | -1x | +|||
| 201 | +
- teal.widgets::panel_group(+ #' Module Server for Gene Signature Specification |
|||
| 120 | -1x | +|||
| 202 | +
- teal.widgets::panel_item(+ #' |
|||
| 121 | -1x | +|||
| 203 | +
- input_id = "settings_item",+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 122 | -1x | +|||
| 204 | +
- collapsed = TRUE,+ #' |
|||
| 123 | -1x | +|||
| 205 | +
- title = "Additional Settings",+ #' This defines the server part for the gene signature specification. |
|||
| 124 | -1x | +|||
| 206 | +
- sampleVarSpecInput(ns("strata"), "Select Strata"),
+ #' |
|||
| 125 | -1x | +|||
| 207 | +
- sliderInput(+ #' @inheritParams module_arguments |
|||
| 126 | -1x | +|||
| 208 | +
- ns("percentiles"),
+ #' @param funs (static named `list`)\cr names of this list will be used for the function |
|||
| 127 | -1x | +|||
| 209 | +
- "Select quantiles to be displayed",+ #' selection drop down menu. |
|||
| 128 | -1x | +|||
| 210 | +
- min = 0,+ #' @param gene_choices (reactive `data.frame`)\cr returns the possible gene choices to |
|||
| 129 | -1x | +|||
| 211 | +
- max = 1,+ #' populate in the UI, as a `data.frame` with columns `id` and `name`. |
|||
| 130 | -1x | +|||
| 212 | +
- value = c(0, 0.5)+ #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input. |
|||
| 131 | +213 |
- )+ #' @param label_modal_footer (`character`)\cr lines of text to use for the footer of the dialog. |
||
| 132 | +214 |
- )+ #' |
||
| 133 | +215 |
- )+ #' @return Reactive [`hermes::GeneSpec`] which can be used as input for the relevant |
||
| 134 | +216 |
- ),+ #' `hermes` functions. |
||
| 135 | -1x | +|||
| 217 | +
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ #' @seealso [geneSpecInput()] for the module UI. |
|||
| 136 | -1x | +|||
| 218 | +
- pre_output = pre_output,+ #' |
|||
| 137 | -1x | +|||
| 219 | +
- post_output = post_output+ #' @export |
|||
| 138 | +220 |
- )+ #' |
||
| 139 | +221 |
- }+ #' @examples |
||
| 140 | +222 |
-
+ #' ui <- function(id, |
||
| 141 | +223 |
- #' @describeIn tm_g_km sets up the user interface.+ #' data, |
||
| 142 | +224 |
- #' @inheritParams module_arguments+ #' funs) {
|
||
| 143 | +225 |
- #' @export+ #' ns <- NS(id) |
||
| 144 | +226 |
- srv_g_km <- function(id,+ #' teal.widgets::standard_layout( |
||
| 145 | +227 |
- data,+ #' encoding = div( |
||
| 146 | +228 |
- filter_panel_api,+ #' geneSpecInput( |
||
| 147 | +229 |
- reporter,+ #' ns("my_genes"),
|
||
| 148 | +230 |
- adtte_name,+ #' funs = funs, |
||
| 149 | +231 |
- mae_name,+ #' label_funs = "Please select function" |
||
| 150 | +232 |
- adtte_vars,+ #' ) |
||
| 151 | +233 |
- summary_funs,+ #' ), |
||
| 152 | +234 |
- exclude_assays) {
+ #' output = textOutput(ns("result"))
|
||
| 153 | -! | +|||
| 235 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' ) |
|||
| 154 | -! | +|||
| 236 | +
- assert_class(filter_panel_api, "FilterPanelAPI")+ #' } |
|||
| 155 | -! | +|||
| 237 | +
- assert_class(data, "tdata")+ #' server <- function(id, |
|||
| 156 | +238 |
-
+ #' data, |
||
| 157 | -! | +|||
| 239 | +
- moduleServer(id, function(input, output, session) {
+ #' funs) {
|
|||
| 158 | -! | +|||
| 240 | +
- experiment <- experimentSpecServer(+ #' moduleServer(id, function(input, output, session) {
|
|||
| 159 | -! | +|||
| 241 | +
- "experiment",+ #' gene_choices <- reactive({
|
|||
| 160 | -! | +|||
| 242 | +
- data = data,+ #' mae <- data[["MAE"]]() |
|||
| 161 | -! | +|||
| 243 | +
- filter_panel_api = filter_panel_api,+ #' object <- mae[[1]] |
|||
| 162 | -! | +|||
| 244 | +
- mae_name = mae_name,+ #' gene_ids <- rownames(object) |
|||
| 163 | -! | +|||
| 245 | +
- sample_vars_as_factors = FALSE # To avoid converting logical `event` to factor.+ #' gene_names <- SummarizedExperiment::rowData(object)$symbol |
|||
| 164 | +246 |
- )+ #' gene_data <- data.frame( |
||
| 165 | -! | +|||
| 247 | +
- assay <- assaySpecServer(+ #' id = gene_ids, |
|||
| 166 | -! | +|||
| 248 | +
- "assay",+ #' name = gene_names |
|||
| 167 | -! | +|||
| 249 | +
- assays = experiment$assays,+ #' ) |
|||
| 168 | -! | +|||
| 250 | +
- exclude_assays = exclude_assays+ #' gene_data[order(gene_data$name), ] |
|||
| 169 | +251 |
- )+ #' }) |
||
| 170 | -! | +|||
| 252 | +
- genes <- geneSpecServer(+ #' gene_spec <- geneSpecServer( |
|||
| 171 | -! | +|||
| 253 | +
- "genes",+ #' "my_genes", |
|||
| 172 | -! | +|||
| 254 | +
- funs = summary_funs,+ #' funs = funs, |
|||
| 173 | -! | +|||
| 255 | +
- gene_choices = experiment$genes+ #' gene_choices = gene_choices |
|||
| 174 | +256 |
- )+ #' ) |
||
| 175 | -! | +|||
| 257 | +
- strata <- sampleVarSpecServer(+ #' output$result <- renderText({
|
|||
| 176 | -! | +|||
| 258 | +
- "strata",+ #' validate_gene_spec( |
|||
| 177 | -! | +|||
| 259 | +
- experiment_name = experiment$name,+ #' gene_spec(), |
|||
| 178 | -! | +|||
| 260 | +
- original_data = experiment$data+ #' gene_choices()$id |
|||
| 179 | +261 |
- )+ #' ) |
||
| 180 | -! | +|||
| 262 | +
- percentiles_without_borders <- reactive({
+ #' gene_spec <- gene_spec() |
|||
| 181 | -! | +|||
| 263 | +
- percentiles <- input$percentiles+ #' gene_spec$get_label() |
|||
| 182 | +264 |
-
+ #' }) |
||
| 183 | -! | +|||
| 265 | +
- result <- setdiff(percentiles, c(0, 1))+ #' }) |
|||
| 184 | -! | +|||
| 266 | +
- validate(need(+ #' } |
|||
| 185 | -! | +|||
| 267 | +
- length(result) > 0,+ #' funs <- list(mean = colMeans) |
|||
| 186 | -! | +|||
| 268 | +
- "Please select at least one quantile other than 0 and 1"+ #' my_app <- function() {
|
|||
| 187 | +269 |
- ))+ #' mae <- hermes::multi_assay_experiment |
||
| 188 | -! | +|||
| 270 | +
- result+ #' mae_data <- dataset("MAE", mae)
|
|||
| 189 | +271 |
- })+ #' data <- teal_data(mae_data) |
||
| 190 | -! | +|||
| 272 | +
- adtte <- adtteSpecServer(+ #' app <- init( |
|||
| 191 | -! | +|||
| 273 | +
- "adtte",+ #' data = data, |
|||
| 192 | -! | +|||
| 274 | +
- data = data,+ #' modules = modules( |
|||
| 193 | -! | +|||
| 275 | +
- adtte_name = adtte_name,+ #' module( |
|||
| 194 | -! | +|||
| 276 | +
- mae_name = mae_name,+ #' label = "GeneSpec example", |
|||
| 195 | -! | +|||
| 277 | +
- adtte_vars = adtte_vars,+ #' server = server, |
|||
| 196 | -! | +|||
| 278 | +
- experiment_data = strata$experiment_data,+ #' server_args = list(funs = funs), |
|||
| 197 | -! | +|||
| 279 | +
- experiment_name = experiment$name,+ #' ui = ui, |
|||
| 198 | -! | +|||
| 280 | +
- assay = assay,+ #' ui_args = list(funs = funs), |
|||
| 199 | -! | +|||
| 281 | +
- genes = genes,+ #' datanames = "all" |
|||
| 200 | -! | +|||
| 282 | +
- probs = percentiles_without_borders+ #' ) |
|||
| 201 | +283 |
- )+ #' ) |
||
| 202 | +284 |
-
+ #' ) |
||
| 203 | -! | +|||
| 285 | +
- km_plot <- reactive({
+ #' shinyApp(app$ui, app$server) |
|||
| 204 | -! | +|||
| 286 | +
- strata_var <- strata$sample_var()+ #' } |
|||
| 205 | -! | +|||
| 287 | +
- binned_adtte <- adtte$binned_adtte_subset()+ #' if (interactive()) {
|
|||
| 206 | +288 |
-
+ #' my_app() |
||
| 207 | -! | +|||
| 289 | +
- variables <- list(+ #' } |
|||
| 208 | -! | +|||
| 290 | +
- tte = adtte_vars$aval,+ geneSpecServer <- function(id, # nolint |
|||
| 209 | -! | +|||
| 291 | +
- is_event = adtte_vars$is_event,+ funs, |
|||
| 210 | -! | +|||
| 292 | +
- arm = adtte$gene_factor,+ gene_choices, |
|||
| 211 | -! | +|||
| 293 | +
- strat = strata_var+ label_modal_title = "Enter list of genes", |
|||
| 212 | +294 |
- )+ label_modal_footer = c( |
||
| 213 | -! | +|||
| 295 | +
- tern::g_km(binned_adtte, variables = variables, annot_coxph = TRUE)+ "Please enter a comma-separated list of gene IDs and/or names.", |
|||
| 214 | +296 |
- })+ "(Note that genes not included in current choices will be removed)" |
||
| 215 | +297 |
-
+ )) {
|
||
| 216 | +298 | ! |
- output$km_plot <- renderPlot(km_plot())+ assert_string(id) |
|
| 217 | -+ | |||
| 299 | +! |
-
+ assert_list(funs, names = "unique", min.len = 1L) |
||
| 218 | +300 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ assert_reactive(gene_choices) |
|
| 219 | +301 | ! |
- id = "plot",+ assert_string(label_modal_title) |
|
| 220 | +302 | ! |
- plot_r = km_plot+ assert_character(label_modal_footer) |
|
| 221 | +303 |
- )+ + |
+ ||
| 304 | +! | +
+ moduleServer(id, function(input, output, session) {
|
||
| 222 | +305 |
-
+ # The `reactiveValues` object for storing current gene text input. |
||
| 223 | +306 |
- ### REPORTER+ # This will also be a data frame with id and name columns. |
||
| 224 | +307 | ! |
- if (with_reporter) {
+ parsed_genes <- reactiveVal(NULL, label = "Parsed genes") |
|
| 225 | -! | +|||
| 308 | +
- card_fun <- function(comment) {
+
|
|||
| 226 | -! | +|||
| 309 | +
- card <- teal::TealReportCard$new()+ # If the parsed genes are entered via text, update gene selection. |
|||
| 227 | +310 | ! |
- card$set_name("Kaplan-Meier Plot")
+ observeEvent(parsed_genes(), ignoreNULL = TRUE, {
|
|
| 228 | +311 | ! |
- card$append_text("Kaplan-Meier Plot", "header2")
+ gene_choices <- gene_choices() |
|
| 229 | +312 | ! |
- card$append_fs(filter_panel_api$get_filter_state())+ parsed_genes <- parsed_genes()+ |
+ |
| 313 | ++ | + | ||
| 230 | +314 | ! |
- card$append_text("Selected Options", "header3")
+ h_update_gene_selection( |
|
| 231 | +315 | ! |
- encodings_list <- list(+ session, |
|
| 232 | +316 | ! |
- "Experiment:",+ inputId = "genes", |
|
| 233 | +317 | ! |
- input$`experiment-name`,+ selected = parsed_genes$id, |
|
| 234 | +318 | ! |
- "\nAssay:",+ choices = gene_choices |
|
| 235 | -! | +|||
| 319 | +
- input$`assay-name`,+ ) |
|||
| 236 | -! | +|||
| 320 | +
- "\nGenes Selected:",+ }) |
|||
| 237 | -! | +|||
| 321 | +
- paste0(genes()$get_gene_labels(), collapse = ", "),+ |
|||
| 238 | -! | +|||
| 322 | +
- "\nGene Summary:",+ # When |
|||
| 239 | -! | +|||
| 323 | +
- input$`genes-fun_name`,+ # 1) the gene choices are recomputed, |
|||
| 240 | -! | +|||
| 324 | +
- "\nEndpoint:",+ # 2) the lock is pressed and then switched off, |
|||
| 241 | -! | +|||
| 325 | +
- input$`adtte-paramcd`,+ # then update gene selection. |
|||
| 242 | +326 | ! |
- "\nStrata Selected:",+ observeEvent(list(gene_choices(), input$lock_button), {
|
|
| 243 | +327 | ! |
- input$`strata-sample_var`,+ gene_choices <- gene_choices() |
|
| 244 | +328 | ! |
- "\nQuantiles Displayed:",+ lock_button <- input$lock_button |
|
| 245 | +329 | ! |
- paste0(input$percentiles, collapse = "-")+ old_selected <- input$genes |
|
| 246 | +330 |
- )+ |
||
| 247 | +331 | ! |
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ if (isFALSE(lock_button)) {
|
|
| 248 | +332 | ! |
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ h_update_gene_selection( |
|
| 249 | +333 | ! |
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ session, |
|
| 250 | +334 | ! |
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ inputId = "genes", |
|
| 251 | -+ | |||
| 335 | +! |
- } else {
+ selected = old_selected, |
||
| 252 | +336 | ! |
- paste(encodings_list, collapse = " ")+ choices = gene_choices |
|
| 253 | +337 |
- }+ ) |
||
| 254 | +338 |
-
+ } |
||
| 255 | -! | +|||
| 339 | +
- card$append_text(final_encodings, style = "verbatim")+ }) |
|||
| 256 | -! | +|||
| 340 | +
- card$append_text("Plot", "header3")
+
|
|||
| 257 | -! | +|||
| 341 | +
- card$append_plot(km_plot(), dim = pws$dim())+ # When the Select All button is pressed and not locked, select all genes. |
|||
| 258 | +342 | ! |
- if (!comment == "") {
+ observeEvent(input$select_all_button, {
|
|
| 259 | +343 | ! |
- card$append_text("Comment", "header3")
+ gene_choices <- gene_choices() |
|
| 260 | +344 | ! |
- card$append_text(comment)+ lock_button <- input$lock_button |
|
| 261 | +345 |
- }+ |
||
| 262 | +346 | ! |
- card- |
- |
| 263 | -- |
- }+ if (isFALSE(lock_button)) {
|
||
| 264 | +347 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
- |
- |
| 265 | -- |
- }+ h_update_gene_selection( |
||
| 266 | -+ | |||
| 348 | +! |
- ###+ session, |
||
| 267 | -+ | |||
| 349 | +! |
- })+ inputId = "genes", |
||
| 268 | -+ | |||
| 350 | +! |
- }+ selected = gene_choices$id, |
||
| 269 | -+ | |||
| 351 | +! |
-
+ choices = gene_choices |
||
| 270 | +352 |
- #' @describeIn tm_g_km sample module function.+ ) |
||
| 271 | +353 |
- #' @export+ } else {
|
||
| 272 | -+ | |||
| 354 | +! |
- #' @examples+ showNotification( |
||
| 273 | -+ | |||
| 355 | +! |
- #'+ "Please unlock if you would like to select all genes", |
||
| 274 | -+ | |||
| 356 | +! |
- #' # Alternatively you can run the sample module with this function call:+ type = "warning" |
||
| 275 | +357 |
- #' if (interactive()) {
+ ) |
||
| 276 | +358 |
- #' sample_tm_g_km()+ } |
||
| 277 | +359 |
- #' }+ }) |
||
| 278 | +360 |
- sample_tm_g_km <- function() { # nolint
+
|
||
| 279 | +361 |
-
+ # When the Select None button is pressed and not locked, select none. |
||
| 280 | +362 | ! |
- mae <- hermes::multi_assay_experiment+ observeEvent(input$select_none_button, {
|
|
| 281 | +363 | ! |
- adtte <- teal.modules.hermes::rADTTE %>%+ gene_choices <- gene_choices() |
|
| 282 | +364 | ! |
- dplyr::mutate(is_event = (.data$CNSR == 0))+ lock_button <- input$lock_button |
|
| 283 | +365 | |||
| 284 | -! | -
- data <- teal.data::teal_data(- |
- ||
| 285 | +366 | ! |
- teal.data::dataset(+ if (isFALSE(lock_button)) {
|
|
| 286 | +367 | ! |
- "ADTTE",+ h_update_gene_selection( |
|
| 287 | +368 | ! |
- adtte,+ session, |
|
| 288 | +369 | ! |
- code = "adtte <- teal.modules.hermes::rADTTE %>%+ inputId = "genes", |
|
| 289 | +370 | ! |
- dplyr::mutate(is_event = (.data$CNSR == 0))"- |
- |
| 290 | -- |
- ),+ selected = character(), |
||
| 291 | +371 | ! |
- teal.data::dataset("MAE", mae)
+ choices = gene_choices |
|
| 292 | +372 |
- )+ ) |
||
| 293 | +373 |
-
+ } else {
|
||
| 294 | +374 | ! |
- modules <- teal::modules(+ showNotification( |
|
| 295 | +375 | ! |
- tm_g_km(+ "Please unlock if you would like to select none", |
|
| 296 | +376 | ! |
- label = "kaplan-meier",+ type = "warning" |
|
| 297 | -! | +|||
| 377 | +
- adtte_name = "ADTTE",+ ) |
|||
| 298 | -! | +|||
| 378 | +
- mae_name = "MAE"+ } |
|||
| 299 | +379 |
- )+ }) |
||
| 300 | +380 |
- )+ |
||
| 301 | +381 |
-
+ # Return the UI for a modal dialog with gene text input, showing examples. |
||
| 302 | +382 | ! |
- app <- teal::init(+ dataModal <- function(example_list) { # nolint
|
|
| 303 | +383 | ! |
- data = data,+ modalDialog( |
|
| 304 | +384 | ! |
- modules = modules+ textInput( |
|
| 305 | -+ | |||
| 385 | +! |
- )+ session$ns("gene_text"),
|
||
| 306 | -+ | |||
| 386 | +! |
-
+ label = label_modal_title, |
||
| 307 | +387 | ! |
- shinyApp(ui = app$ui, server = app$server)+ placeholder = example_list |
|
| 308 | +388 |
- }+ ), |
| 1 | -+ | ||
| 389 | +! |
- #' Teal Module for RNA-seq Scatterplot+ do.call("span", as.list(label_modal_footer)),
|
|
| 2 | -+ | ||
| 390 | +! |
- #'+ footer = tagList( |
|
| 3 | -+ | ||
| 391 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ modalButton("Cancel"),
|
|
| 4 | -+ | ||
| 392 | +! |
- #'+ actionButton(session$ns("ok_button"), "OK")
|
|
| 5 | +393 |
- #' This module provides an interactive scatterplot for RNA-seq gene expression+ ) |
|
| 6 | +394 |
- #' analysis.+ ) |
|
| 7 | +395 |
- #'+ } |
|
| 8 | +396 |
- #' @inheritParams module_arguments+ |
|
| 9 | +397 |
- #'+ # Show modal when the text button is clicked. |
|
| 10 | -+ | ||
| 398 | +! |
- #' @return Shiny module to be used in the teal app.+ observeEvent(input$text_button, {
|
|
| 11 | -+ | ||
| 399 | +! |
- #'+ gene_choices <- gene_choices() |
|
| 12 | -+ | ||
| 400 | +! |
- #' @export+ example_list <- hermes::h_short_list(utils::head(setdiff(gene_choices$name, "")))+ |
+ |
| 401 | +! | +
+ showModal(dataModal(example_list)) |
|
| 13 | +402 |
- #'+ }) |
|
| 14 | +403 |
- #' @examples+ |
|
| 15 | +404 |
- #' mae <- hermes::multi_assay_experiment+ # When OK button is pressed, attempt to parse the genes from the text. |
|
| 16 | +405 |
- #' mae_data <- dataset("MAE", mae)
+ # This can be IDs and/or names of genes. |
|
| 17 | +406 |
- #' data <- teal_data(mae_data)+ # Remove the modal and display notification message. |
|
| 18 | -+ | ||
| 407 | +! |
- #' app <- init(+ observeEvent(input$ok_button, {
|
|
| 19 | -+ | ||
| 408 | +! |
- #' data = data,+ gene_text <- input$gene_text |
|
| 20 | -+ | ||
| 409 | +! |
- #' modules = modules(+ gene_choices <- gene_choices() |
|
| 21 | +410 |
- #' tm_g_scatterplot(+ |
|
| 22 | -+ | ||
| 411 | +! |
- #' label = "scatterplot",+ if (!nzchar(gene_text)) {
|
|
| 23 | -+ | ||
| 412 | +! |
- #' mae_name = "MAE"+ showNotification( |
|
| 24 | -+ | ||
| 413 | +! |
- #' )+ "Please enter at least one full gene ID.", |
|
| 25 | -+ | ||
| 414 | +! |
- #' )+ type = "error" |
|
| 26 | +415 |
- #' )+ ) |
|
| 27 | +416 |
- #' if (interactive()) {
+ } else {
|
|
| 28 | -+ | ||
| 417 | +! |
- #' shinyApp(app$ui, app$server)+ words <- h_extract_words(gene_text) |
|
| 29 | -+ | ||
| 418 | +! |
- #' }+ parse_result <- h_parse_genes(words, choices = gene_choices) |
|
| 30 | -+ | ||
| 419 | +! |
- tm_g_scatterplot <- function(label,+ showNotification(paste( |
|
| 31 | -+ | ||
| 420 | +! |
- mae_name,+ "Parsed total", nrow(parse_result), "genes from", length(words), "words" |
|
| 32 | +421 |
- exclude_assays = "counts",+ )) |
|
| 33 | -+ | ||
| 422 | +! |
- summary_funs = list(+ parsed_genes(parse_result) |
|
| 34 | -+ | ||
| 423 | +! |
- Mean = colMeans,+ removeModal() |
|
| 35 | +424 |
- Median = matrixStats::colMedians,+ } |
|
| 36 | +425 |
- Max = matrixStats::colMaxs+ }) |
|
| 37 | +426 |
- ),+ |
|
| 38 | +427 |
- pre_output = NULL,+ # When the gene choice is updated, then also set the names |
|
| 39 | +428 |
- post_output = NULL) {
+ # correctly by looking up in current choices. |
|
| 40 | +429 | ! |
- logger::log_info("Initializing tm_g_scatterplot")
+ named_genes <- eventReactive(input$genes, ignoreNULL = FALSE, {
|
| 41 | +430 | ! |
- assert_string(label)+ genes <- input$genes |
| 42 | +431 | ! |
- assert_string(mae_name)+ gene_choices <- gene_choices() |
| 43 | +432 | ! |
- assert_character(exclude_assays, any.missing = FALSE)+ ret <- if (!is.null(genes)) {
|
| 44 | +433 | ! |
- assert_summary_funs(summary_funs)+ which_id <- match(genes, gene_choices$id) |
| 45 | +434 | ! |
- assert_tag(pre_output, null.ok = TRUE)+ gene_names <- gene_choices$name[which_id] |
| 46 | +435 | ! |
- assert_tag(post_output, null.ok = TRUE)+ stats::setNames(genes, gene_names) |
| 47 | +436 | - - | -|
| 48 | -! | -
- teal::module(- |
- |
| 49 | -! | -
- label = label,- |
- |
| 50 | -! | -
- server = srv_g_scatterplot,- |
- |
| 51 | -! | -
- server_args = list(+ } else {
|
|
| 52 | +437 | ! |
- mae_name = mae_name,+ NULL |
| 53 | -! | +||
| 438 | +
- summary_funs = summary_funs,+ } |
||
| 54 | +439 | ! |
- exclude_assays = exclude_assays+ ret |
| 55 | +440 |
- ),+ }) |
|
| 56 | -! | +||
| 441 | +
- ui = ui_g_scatterplot,+ |
||
| 57 | +442 | ! |
- ui_args = list(+ reactive({
|
| 58 | +443 | ! |
- mae_name = mae_name,+ hermes::gene_spec( |
| 59 | +444 | ! |
- summary_funs = summary_funs,+ genes = named_genes(), |
| 60 | +445 | ! |
- pre_output = pre_output,+ fun = funs[[input$fun_name]], |
| 61 | +446 | ! |
- post_output = post_output+ fun_name = input$fun_name |
| 62 | +447 |
- ),+ ) |
|
| 63 | -! | +||
| 448 | +
- datanames = mae_name+ }) |
||
| 64 | +449 |
- )+ }) |
|
| 65 | +450 |
} |
|
| 66 | +451 | ||
| 67 | +452 |
- #' @describeIn tm_g_scatterplot sets up the user interface.+ #' Validation of Gene Specification |
|
| 68 | +453 |
- #' @inheritParams module_arguments+ #' |
|
| 69 | +454 |
- #' @export+ #' @description `r lifecycle::badge("experimental")`
|
|
| 70 | +455 |
- ui_g_scatterplot <- function(id,+ #' |
|
| 71 | +456 |
- data,+ #' This validation function checks that a given [`hermes::GeneSpec`] has at least |
|
| 72 | +457 |
- mae_name,+ #' one gene selected and that all genes are included in possible choices. |
|
| 73 | +458 |
- summary_funs,+ #' |
|
| 74 | +459 |
- pre_output,+ #' @param gene_spec (`GeneSpec`)\cr gene specification. |
|
| 75 | +460 |
- post_output) {
+ #' @param gene_choices (`character`)\cr all possible gene choices. |
|
| 76 | -1x | +||
| 461 | +
- ns <- NS(id)+ #' |
||
| 77 | +462 |
-
+ #' @export |
|
| 78 | -1x | +||
| 463 | +
- smooth_method_choices <- c(+ validate_gene_spec <- function(gene_spec, |
||
| 79 | -1x | +||
| 464 | +
- Linear = "lm",+ gene_choices) {
|
||
| 80 | -1x | +||
| 465 | +! |
- Loess = "loess",+ assert_r6(gene_spec, "GeneSpec") |
|
| 81 | -1x | +||
| 466 | +! |
- None = "none"+ assert_character(gene_choices) |
|
| 82 | +467 |
- )+ |
|
| 83 | -+ | ||
| 468 | +! |
-
+ validate(need( |
|
| 84 | -1x | +||
| 469 | +! |
- teal.widgets::standard_layout(+ !is.null(gene_spec$get_genes()), |
|
| 85 | -1x | +||
| 470 | +! |
- encoding = div(+ "please select at least one gene" |
|
| 86 | +471 |
- ### Reporter- |
- |
| 87 | -1x | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ )) |
|
| 88 | -+ | ||
| 472 | +! |
- ###+ genes_not_included <- setdiff(gene_spec$get_genes(), gene_choices) |
|
| 89 | -1x | +||
| 473 | +! |
- tags$label("Encodings", class = "text-primary"),
+ n_not_incl <- length(genes_not_included) |
|
| 90 | -1x | +||
| 474 | +! |
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ validate(need( |
|
| 91 | -1x | +||
| 475 | +! |
- experimentSpecInput(ns("experiment"), data, mae_name),
+ identical(n_not_incl, 0L), |
|
| 92 | -1x | +||
| 476 | +! |
- assaySpecInput(ns("assay")),
+ paste( |
|
| 93 | -1x | +||
| 477 | +! |
- geneSpecInput(ns("x_spec"), summary_funs, label_genes = "Select x Gene(s)"),
+ n_not_incl, |
|
| 94 | -1x | +||
| 478 | +! |
- geneSpecInput(ns("y_spec"), summary_funs, label_genes = "Select y Gene(s)"),
+ ifelse(n_not_incl > 1, "genes", "gene"), |
|
| 95 | -1x | +||
| 479 | +! |
- teal.widgets::panel_group(+ hermes::h_parens(hermes::h_short_list(genes_not_included)), |
|
| 96 | -1x | +||
| 480 | +! |
- teal.widgets::panel_item(+ "not included, please unlock or change filters" |
|
| 97 | -1x | +||
| 481 | +
- input_id = "settings_item",+ ) |
||
| 98 | -1x | +||
| 482 | +
- collapsed = TRUE,+ )) |
||
| 99 | -1x | +||
| 483 | +
- title = "Additional Settings",+ } |
||
| 100 | -1x | +
| 1 | +
- sampleVarSpecInput(ns("color_var"), "Optional color variable"),
+ #' Teal Module for RNA-seq Volcano Plot |
||
| 101 | -1x | +||
| 2 | +
- sampleVarSpecInput(ns("facet_var"), "Optional facet variable"),
+ #' |
||
| 102 | -1x | +||
| 3 | +
- selectInput(ns("smooth_method"), "Select smoother", smooth_method_choices)
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 103 | +4 |
- )+ #' |
|
| 104 | +5 |
- )+ #' This module provides an interactive volcano plot for RNA-seq gene expression |
|
| 105 | +6 |
- ),+ #' analysis. |
|
| 106 | -1x | +||
| 7 | +
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ #' |
||
| 107 | -1x | +||
| 8 | +
- pre_output = pre_output,+ #' @inheritParams module_arguments |
||
| 108 | -1x | +||
| 9 | +
- post_output = post_output+ #' |
||
| 109 | +10 |
- )+ #' @return Shiny module to be used in the teal app. |
|
| 110 | +11 |
- }+ #' |
|
| 111 | +12 |
-
+ #' @export |
|
| 112 | +13 |
- #' @describeIn tm_g_scatterplot sets up the server with reactive graph.+ #' |
|
| 113 | +14 |
- #' @inheritParams module_arguments+ #' @examples |
|
| 114 | +15 |
- #' @export+ #' mae <- hermes::multi_assay_experiment |
|
| 115 | +16 |
- srv_g_scatterplot <- function(id,+ #' mae_data <- dataset("MAE", mae)
|
|
| 116 | +17 |
- data,+ #' data <- teal_data(mae_data) |
|
| 117 | +18 |
- filter_panel_api,+ #' app <- init( |
|
| 118 | +19 |
- reporter,+ #' data = data, |
|
| 119 | +20 |
- mae_name,+ #' modules = modules( |
|
| 120 | +21 |
- exclude_assays,+ #' tm_g_volcanoplot( |
|
| 121 | +22 |
- summary_funs) {
+ #' label = "volcanoplot", |
|
| 122 | -! | +||
| 23 | +
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ #' mae_name = "MAE" |
||
| 123 | -! | +||
| 24 | +
- assert_class(filter_panel_api, "FilterPanelAPI")+ #' ) |
||
| 124 | -! | +||
| 25 | +
- assert_class(data, "tdata")+ #' ) |
||
| 125 | +26 |
-
+ #' ) |
|
| 126 | -! | +||
| 27 | +
- moduleServer(id, function(input, output, session) {
+ #' if (interactive()) {
|
||
| 127 | -! | +||
| 28 | +
- experiment <- experimentSpecServer(+ #' shinyApp(app$ui, app$server) |
||
| 128 | -! | +||
| 29 | +
- "experiment",+ #' } |
||
| 129 | -! | +||
| 30 | +
- data = data,+ tm_g_volcanoplot <- function(label, |
||
| 130 | -! | +||
| 31 | +
- filter_panel_api = filter_panel_api,+ mae_name, |
||
| 131 | -! | +||
| 32 | +
- mae_name = mae_name+ exclude_assays = character(), |
||
| 132 | +33 |
- )+ pre_output = NULL, |
|
| 133 | -! | +||
| 34 | +
- assay <- assaySpecServer(+ post_output = NULL) {
|
||
| 134 | +35 | ! |
- "assay",+ logger::log_info("Initializing tm_g_volcanoplot")
|
| 135 | +36 | ! |
- assays = experiment$assays,+ assert_string(label) |
| 136 | +37 | ! |
- exclude_assays = exclude_assays+ assert_string(mae_name) |
| 137 | -+ | ||
| 38 | +! |
- )+ assert_character(exclude_assays) |
|
| 138 | +39 | ! |
- sample_var_specs <- multiSampleVarSpecServer(+ assert_tag(pre_output, null.ok = TRUE) |
| 139 | +40 | ! |
- inputIds = c("facet_var", "color_var"),
+ assert_tag(post_output, null.ok = TRUE) |
| 140 | -! | +||
| 41 | +
- experiment_name = experiment$name,+ |
||
| 141 | +42 | ! |
- original_data = experiment$data+ teal::module( |
| 142 | -+ | ||
| 43 | +! |
- )+ label = label, |
|
| 143 | +44 | ! |
- x_spec <- geneSpecServer("x_spec", summary_funs, experiment$genes)
+ server = srv_g_volcanoplot, |
| 144 | +45 | ! |
- y_spec <- geneSpecServer("y_spec", summary_funs, experiment$genes)
+ server_args = list( |
| 145 | -+ | ||
| 46 | +! |
-
+ mae_name = mae_name, |
|
| 146 | +47 | ! |
- plot_r <- reactive({
+ exclude_assays = exclude_assays |
| 147 | +48 |
- # Resolve all reactivity.+ ), |
|
| 148 | +49 | ! |
- experiment_data <- sample_var_specs$experiment_data()+ ui = ui_g_volcanoplot, |
| 149 | +50 | ! |
- x_spec <- x_spec()+ ui_args = list( |
| 150 | +51 | ! |
- y_spec <- y_spec()+ mae_name = mae_name, |
| 151 | +52 | ! |
- facet_var <- sample_var_specs$vars$facet_var()+ pre_output = pre_output, |
| 152 | +53 | ! |
- color_var <- sample_var_specs$vars$color_var()+ post_output = post_output |
| 153 | -! | +||
| 54 | +
- assay_name <- assay()+ ), |
||
| 154 | +55 | ! |
- smooth_method <- input$smooth_method+ datanames = mae_name |
| 155 | +56 |
-
+ ) |
|
| 156 | -! | +||
| 57 | +
- validate_gene_spec(x_spec, rownames(experiment_data))+ } |
||
| 157 | -! | +||
| 58 | +
- validate_gene_spec(y_spec, rownames(experiment_data))+ |
||
| 158 | +59 |
-
+ #' @describeIn tm_g_volcanoplot sets up the user interface. |
|
| 159 | +60 |
- # Require which states need to be truthy.+ #' @inheritParams module_arguments |
|
| 160 | -! | +||
| 61 | +
- req(+ #' @export |
||
| 161 | -! | +||
| 62 | +
- smooth_method,+ ui_g_volcanoplot <- function(id, |
||
| 162 | +63 |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ data, |
|
| 163 | -! | +||
| 64 | +
- isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)),+ mae_name, |
||
| 164 | -! | +||
| 65 | +
- is.null(facet_var) || isTRUE(facet_var %in% names(SummarizedExperiment::colData(experiment_data))),+ pre_output, |
||
| 165 | -! | +||
| 66 | +
- is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))),+ post_output) {
|
||
| 166 | -! | +||
| 67 | +1x |
- cancelOutput = FALSE+ ns <- NS(id) |
|
| 167 | -+ | ||
| 68 | +1x |
- )+ mae <- data[[mae_name]] |
|
| 168 | +69 | ||
| 169 | -! | +||
| 70 | +1x |
- hermes::draw_scatterplot(+ teal.widgets::standard_layout( |
|
| 170 | -! | +||
| 71 | +1x |
- object = experiment_data,+ output = div( |
|
| 171 | -! | +||
| 72 | +1x |
- assay_name = assay_name,+ teal.widgets::plot_with_settings_ui(ns("plot")),
|
|
| 172 | -! | +||
| 73 | +1x |
- x_spec = x_spec,+ DT::DTOutput(ns("table"))
|
|
| 173 | -! | +||
| 74 | +
- y_spec = y_spec,+ ), |
||
| 174 | -! | +||
| 75 | +1x |
- facet_var = facet_var,+ pre_output = pre_output, |
|
| 175 | -! | +||
| 76 | +1x |
- color_var = color_var,+ post_output = post_output, |
|
| 176 | -! | +||
| 77 | +1x |
- smooth_method = smooth_method+ encoding = div( |
|
| 177 | +78 |
- )+ ### Reporter |
|
| 178 | -+ | ||
| 79 | +1x |
- })+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 179 | -! | +||
| 80 | +
- output$plot <- renderPlot(plot_r())+ ### |
||
| 180 | -+ | ||
| 81 | +1x |
-
+ tags$label("Encodings", class = "text-primary"),
|
|
| 181 | -! | +||
| 82 | +1x |
- pws <- teal.widgets::plot_with_settings_srv(+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|
| 182 | -! | +||
| 83 | +1x |
- id = "plot",+ experimentSpecInput(ns("experiment"), data, mae_name),
|
|
| 183 | -! | +||
| 84 | +1x |
- plot_r = plot_r+ assaySpecInput(ns("assay")),
|
|
| 184 | -+ | ||
| 85 | +1x |
- )+ sampleVarSpecInput(ns("compare_group"), "Compare Groups", "Please group here into 2 levels"),
|
|
| 185 | -+ | ||
| 86 | +1x |
-
+ tags$label("Show Top Differentiated Genes"),
|
|
| 186 | -+ | ||
| 87 | +1x |
- ### REPORTER+ shinyWidgets::switchInput(ns("show_top_gene"), value = FALSE, size = "mini"),
|
|
| 187 | -! | +||
| 88 | +1x |
- if (with_reporter) {
+ teal.widgets::panel_group( |
|
| 188 | -! | +||
| 89 | +1x |
- card_fun <- function(comment) {
+ teal.widgets::panel_item( |
|
| 189 | -! | +||
| 90 | +1x |
- card <- teal::TealReportCard$new()+ input_id = "settings_item", |
|
| 190 | -! | +||
| 91 | +1x |
- card$set_name("Scatter Plot")
+ collapsed = TRUE, |
|
| 191 | -! | +||
| 92 | +1x |
- card$append_text("Scatter Plot", "header2")
+ title = "Additional Settings", |
|
| 192 | -! | +||
| 93 | +1x |
- card$append_fs(filter_panel_api$get_filter_state())+ selectInput(ns("method"), "Method", choices = c("voom", "deseq2")),
|
|
| 193 | -! | +||
| 94 | +1x |
- card$append_text("Selected Options", "header3")
+ sliderInput(ns("log2_fc_thresh"), "Log2 fold change threshold", value = 2.5, min = 0.1, max = 10),
|
|
| 194 | -! | +||
| 95 | +1x |
- encodings_list <- list(+ sliderInput(ns("adj_p_val_thresh"), "Adjusted p-value threshold", value = 0.05, min = 0.001, max = 1)
|
|
| 195 | -! | +||
| 96 | +
- "Experiment:",+ ) |
||
| 196 | -! | +||
| 97 | +
- input$`experiment-name`,+ ) |
||
| 197 | -! | +||
| 98 | +
- "\nAssay:",+ ) |
||
| 198 | -! | +||
| 99 | +
- input$`assay-name`,+ ) |
||
| 199 | -! | +||
| 100 | +
- "\nX Genes Selected:",+ } |
||
| 200 | -! | +||
| 101 | +
- paste0(x_spec()$get_gene_labels(), collapse = ", "),+ |
||
| 201 | -! | +||
| 102 | +
- "\nX Genes Summary:",+ #' @describeIn tm_g_volcanoplot sets up the server with reactive graph. |
||
| 202 | -! | +||
| 103 | +
- input$`x_spec-fun_name`,+ #' @inheritParams module_arguments |
||
| 203 | -! | +||
| 104 | +
- "\nY Genes Selected:",+ #' @export |
||
| 204 | -! | +||
| 105 | +
- paste0(y_spec()$get_gene_labels(), collapse = ", "),+ srv_g_volcanoplot <- function(id, |
||
| 205 | -! | +||
| 106 | +
- "\nY Genes Summary:",+ data, |
||
| 206 | -! | +||
| 107 | +
- input$`y_spec-fun_name`,+ filter_panel_api, |
||
| 207 | -! | +||
| 108 | +
- "\nOptional Color Variable:",+ reporter, |
||
| 208 | -! | +||
| 109 | +
- input$`color_var-sample_var`,+ mae_name, |
||
| 209 | -! | +||
| 110 | +
- "\nOptional Facetting Variable:",+ exclude_assays) {
|
||
| 210 | +111 | ! |
- input$`facet_var-sample_var`,+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
| 211 | +112 | ! |
- "\nSmoother:",+ assert_class(filter_panel_api, "FilterPanelAPI") |
| 212 | +113 | ! |
- input$smooth_method+ assert_class(data, "tdata") |
| 213 | +114 |
- )+ |
|
| 214 | +115 | ! |
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ moduleServer(id, function(input, output, session) {
|
| 215 | +116 | ! |
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ experiment_data <- experimentSpecServer( |
| 216 | +117 | ! |
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ "experiment", |
| 217 | +118 | ! |
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")- |
-
| 218 | -- |
- } else {
+ data = data, |
|
| 219 | +119 | ! |
- paste(encodings_list, collapse = " ")- |
-
| 220 | -- |
- }+ mae_name = mae_name |
|
| 221 | +120 | - - | -|
| 222 | -! | -
- card$append_text(final_encodings, style = "verbatim")+ ) |
|
| 223 | +121 | ! |
- card$append_text("Plot", "header3")
+ assay <- assaySpecServer( |
| 224 | +122 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ "assay", |
| 225 | +123 | ! |
- if (!comment == "") {
+ assays = experiment_data$assays, |
| 226 | +124 | ! |
- card$append_text("Comment", "header3")
+ exclude_assays = exclude_assays+ |
+
| 125 | ++ |
+ ) |
|
| 227 | +126 | ! |
- card$append_text(comment)+ compare_group <- sampleVarSpecServer( |
| 228 | -+ | ||
| 127 | +! |
- }+ "compare_group", |
|
| 229 | +128 | ! |
- card+ experiment_name = experiment_data$name, |
| 230 | -+ | ||
| 129 | +! |
- }+ original_data = experiment_data$data, |
|
| 231 | +130 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ num_levels = 2L, |
| 232 | -+ | ||
| 131 | +! |
- }+ label_modal_title = "Please click to group into exactly 2 levels, first level is reference" |
|
| 233 | +132 |
- ###+ ) |
|
| 234 | +133 |
- })+ |
|
| 235 | +134 |
- }+ # When the filtered data set or the chosen experiment changes, update |
|
| 236 | +135 |
-
+ # the differential expression results. |
|
| 237 | -+ | ||
| 136 | +! |
- #' @describeIn tm_g_scatterplot sample module function.+ diff_expr <- reactive({
|
|
| 238 | -+ | ||
| 137 | +! |
- #' @export+ object <- compare_group$experiment_data() |
|
| 239 | -+ | ||
| 138 | +! |
- #' @examples+ compare_group <- compare_group$sample_var() |
|
| 240 | -+ | ||
| 139 | +! |
- #'+ method <- input$method |
|
| 241 | +140 |
- #' # Alternatively you can run the sample module with this function call:+ |
|
| 242 | -+ | ||
| 141 | +! |
- #' if (interactive()) {
+ req( |
|
| 243 | -+ | ||
| 142 | +! |
- #' sample_tm_g_scatterplot()+ object, |
|
| 244 | -+ | ||
| 143 | +! |
- #' }+ method |
|
| 245 | +144 |
- sample_tm_g_scatterplot <- function() {
+ ) |
|
| 246 | +145 | ! |
- mae <- hermes::multi_assay_experiment+ validate(need( |
| 247 | +146 | ! |
- mae_data <- teal.data::dataset("MAE", mae)
+ !is.null(compare_group), |
| 248 | +147 | ! |
- data <- teal.data::teal_data(mae_data)+ "Please select a group variable" |
| 249 | -! | +||
| 148 | +
- app <- teal::init(+ )) |
||
| 250 | -! | +||
| 149 | +
- data = data,+ |
||
| 251 | +150 | ! |
- modules = teal::modules(+ hermes::diff_expression( |
| 252 | +151 | ! |
- tm_g_scatterplot(+ object, |
| 253 | +152 | ! |
- label = "scatterplot",+ group = compare_group, |
| 254 | +153 | ! |
- mae_name = "MAE"+ method = method |
| 255 | +154 |
) |
|
| 256 | +155 |
- )+ }) |
|
| 257 | +156 |
- )+ |
|
| 258 | +157 | ! |
- shinyApp(app$ui, app$server)+ plot_r <- reactive({
|
| 259 | -+ | ||
| 158 | +! |
- }+ diff_expr_result <- diff_expr() |
| 1 | -+ | ||
| 159 | +! |
- #' Module Input for Sample Variable Specification+ log2_fc_thresh <- input$log2_fc_thresh |
|
| 2 | -+ | ||
| 160 | +! |
- #'+ adj_p_val_thresh <- input$adj_p_val_thresh |
|
| 3 | +161 |
- #' @description `r lifecycle::badge("experimental")`
+
+ |
+ |
| 162 | +! | +
+ req(+ |
+ |
| 163 | +! | +
+ log2_fc_thresh,+ |
+ |
| 164 | +! | +
+ adj_p_val_thresh |
|
| 4 | +165 |
- #'+ ) |
|
| 5 | +166 |
- #' This defines the input for the sample variable specification.+ |
|
| 6 | -+ | ||
| 167 | +! |
- #'+ hermes::autoplot( |
|
| 7 | -+ | ||
| 168 | +! |
- #' @inheritParams module_arguments+ diff_expr_result, |
|
| 8 | -+ | ||
| 169 | +! |
- #' @param label_vars (`string`)\cr label for the sample variable selection.+ adj_p_val_thresh = adj_p_val_thresh, |
|
| 9 | -+ | ||
| 170 | +! |
- #' @param label_levels_button (`string`)\cr label for the levels combination button.+ log2_fc_thresh = log2_fc_thresh |
|
| 10 | +171 |
- #'+ ) |
|
| 11 | +172 |
- #' @return The UI part.+ }) |
|
| 12 | -+ | ||
| 173 | +! |
- #' @seealso [sampleVarSpecServer()] for the module server and a complete example.+ output$plot <- renderPlot(plot_r()) |
|
| 13 | +174 |
- #' @export+ |
|
| 14 | -+ | ||
| 175 | +! |
- #'+ pws_p <- teal.widgets::plot_with_settings_srv( |
|
| 15 | -+ | ||
| 176 | +! |
- #' @examples+ id = "plot", |
|
| 16 | -+ | ||
| 177 | +! |
- #' sampleVarSpecInput("my_vars", label_vars = "Select faceting variable")
+ plot_r = plot_r |
|
| 17 | +178 |
- sampleVarSpecInput <- function(inputId, # nolint+ ) |
|
| 18 | +179 |
- label_vars = "Select sample variable",+ |
|
| 19 | +180 |
- label_levels_button = "Combine factor levels") {
+ # Display top genes if switched on. |
|
| 20 | -4x | +||
| 181 | +! |
- assert_string(inputId)+ show_top_gene_diffexpr <- reactive({
|
|
| 21 | -4x | +||
| 182 | +! |
- assert_string(label_vars)+ if (input$show_top_gene) {
|
|
| 22 | -4x | +||
| 183 | +! |
- assert_string(label_levels_button)+ result <- diff_expr() |
|
| 23 | -+ | ||
| 184 | +! |
-
+ with( |
|
| 24 | -4x | +||
| 185 | +! |
- ns <- NS(inputId)+ result, |
|
| 25 | -4x | +||
| 186 | +! |
- tagList(+ data.frame( |
|
| 26 | -4x | +||
| 187 | +! |
- include_css_files(pattern = "*"),+ log2_fc = round(log2_fc, 2), |
|
| 27 | -4x | +||
| 188 | +! |
- div(+ stat = round(stat, 2), |
|
| 28 | -4x | +||
| 189 | +! |
- class = "row",+ p_val = format.pval(p_val), |
|
| 29 | -4x | +||
| 190 | +! |
- div(+ adj_p_val = format.pval(adj_p_val), |
|
| 30 | -4x | +||
| 191 | +! |
- class = "col-sm-8",+ row.names = rownames(result) |
|
| 31 | -4x | +||
| 192 | +
- tags$label(+ ) |
||
| 32 | -4x | +||
| 193 | +
- class = "control-label",+ ) |
||
| 33 | -4x | +||
| 194 | +
- label_vars+ } else {
+ |
+ ||
| 195 | +! | +
+ NULL |
|
| 34 | +196 |
- )+ } |
|
| 35 | +197 |
- ),+ }) |
|
| 36 | -4x | +||
| 198 | +
- div(+ |
||
| 37 | -4x | +||
| 199 | +! |
- class = "col-sm-4",+ output$table <- DT::renderDT({
|
|
| 38 | -4x | +||
| 200 | +! |
- actionButton(+ DT::datatable( |
|
| 39 | -4x | +||
| 201 | +! |
- ns("levels_button"),
+ show_top_gene_diffexpr(), |
|
| 40 | -4x | +||
| 202 | +! |
- span(icon("fas fa-table")),
+ rownames = TRUE, |
|
| 41 | -4x | +||
| 203 | +! |
- title = label_levels_button,+ options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)), |
|
| 42 | -4x | +||
| 204 | +! |
- class = "pull-right list-genes"+ caption = "Top Differentiated Genes" |
|
| 43 | +205 |
- )+ ) |
|
| 44 | +206 |
- )+ }) |
|
| 45 | +207 |
- ),+ |
|
| 46 | -4x | +||
| 208 | +
- div(+ ### REPORTER |
||
| 47 | -4x | +||
| 209 | +! |
- class = "custom-select-input",+ if (with_reporter) {
|
|
| 48 | -4x | +||
| 210 | +! |
- teal.widgets::optionalSelectInput(+ card_fun <- function(comment, label) {
|
|
| 49 | -4x | +||
| 211 | +! |
- ns("sample_var"),
+ card <- report_card_template( |
|
| 50 | -4x | +||
| 212 | +! |
- label = NULL,+ title = "Volcano Plot", |
|
| 51 | -4x | +||
| 213 | +! |
- choices = "",+ label = label, |
|
| 52 | -4x | +||
| 214 | +! |
- multiple = FALSE+ with_filter = TRUE, |
|
| 53 | -+ | ||
| 215 | +! |
- )+ filter_panel_api = filter_panel_api |
|
| 54 | +216 |
- )+ ) |
|
| 55 | -+ | ||
| 217 | +! |
- )+ card$append_text("Selected Options", "header3")
|
|
| 56 | -+ | ||
| 218 | +! |
- }+ encodings_list <- list( |
|
| 57 | -+ | ||
| 219 | +! |
-
+ "Experiment:", |
|
| 58 | -+ | ||
| 220 | +! |
- #' Helper Function For Group List Creation+ input$`experiment-name`, |
|
| 59 | -+ | ||
| 221 | +! |
- #'+ "\nAssay:", |
|
| 60 | -+ | ||
| 222 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ input$`assay-name`, |
|
| 61 | -+ | ||
| 223 | +! |
- #'+ "\nCompare Groups:", |
|
| 62 | -+ | ||
| 224 | +! |
- #' This helper function takes an assignment list and converts it to a+ input$`compare_group-sample_var`, |
|
| 63 | -+ | ||
| 225 | +! |
- #' group list.+ "\nShow Top Differentiated Genes:", |
|
| 64 | -+ | ||
| 226 | +! |
- #'+ input$show_top_gene, |
|
| 65 | -+ | ||
| 227 | +! |
- #' @param x (named `list` of `character`)\cr input assignment list.+ "\nMethod:", |
|
| 66 | -+ | ||
| 228 | +! |
- #' @return A combination list.+ input$method, |
|
| 67 | -+ | ||
| 229 | +! |
- #'+ "\nLog2fold Change Threshold:", |
|
| 68 | -+ | ||
| 230 | +! |
- #' @export+ input$log2_fc_thresh, |
|
| 69 | -+ | ||
| 231 | +! |
- #'+ "\nAdjusted P-value Threshold:", |
|
| 70 | -+ | ||
| 232 | +! |
- #' @examples+ input$adj_p_val_thresh |
|
| 71 | +233 |
- #' assign_list <- list(+ ) |
|
| 72 | -+ | ||
| 234 | +! |
- #' "ASIAN" = "1",+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 73 | -+ | ||
| 235 | +! |
- #' "BLACK OR AFRICAN AMERICAN" = "1",+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 74 | -+ | ||
| 236 | +! |
- #' "MULTIPLE" = "2",+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 75 | -+ | ||
| 237 | +! |
- #' "UNKNOWN" = "2",+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|
| 76 | +238 |
- #' "WHITE" = "4"+ } else {
|
|
| 77 | -+ | ||
| 239 | +! |
- #' )+ paste(encodings_list, collapse = " ") |
|
| 78 | +240 |
- #' objective_list <- list(+ } |
|
| 79 | +241 |
- #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
+
|
|
| 80 | -+ | ||
| 242 | +! |
- #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
+ card$append_text(final_encodings, style = "verbatim") |
|
| 81 | -+ | ||
| 243 | +! |
- #' "WHITE" = "WHITE"+ card$append_text("Plot", "header3")
|
|
| 82 | -+ | ||
| 244 | +! |
- #' )+ card$append_plot(plot_r(), dim = pws_p$dim()) |
|
| 83 | -+ | ||
| 245 | +! |
- #' result_list <- h_assign_to_group_list(assign_list)+ if (isTRUE(input$show_top_gene)) {
|
|
| 84 | -+ | ||
| 246 | +! |
- #' stopifnot(identical(result_list, objective_list))+ card$append_text("Table", "header3")
|
|
| 85 | -+ | ||
| 247 | +! |
- h_assign_to_group_list <- function(x) {
+ card$append_table(show_top_gene_diffexpr()) |
|
| 86 | -2x | +||
| 248 | +
- assert_list(+ } |
||
| 87 | -2x | +||
| 249 | +! |
- x,+ if (!comment == "") {
|
|
| 88 | -2x | +||
| 250 | +! |
- types = "character",+ card$append_text("Comment", "header3")
|
|
| 89 | -2x | +||
| 251 | +! |
- any.missing = FALSE,+ card$append_text(comment) |
|
| 90 | -2x | +||
| 252 | +
- names = "unique",+ } |
||
| 91 | -2x | +||
| 253 | +! |
- unique = FALSE+ card |
|
| 92 | +254 |
- )+ } |
|
| 93 | -2x | +||
| 255 | +! |
- x_vec <- unlist(x)+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 94 | -2x | +||
| 256 | +
- x_split <- split(names(x_vec), x_vec)+ } |
||
| 95 | -2x | +||
| 257 | +
- new_levels <- sapply(x_split, hermes::h_short_list, sep = "/")+ ### |
||
| 96 | -2x | +||
| 258 | +
- stats::setNames(x_split, new_levels)+ }) |
||
| 97 | +259 |
} |
|
| 98 | +260 | ||
| 99 | +261 |
- #' Helper Function for Collapsing of Factor Levels+ #' @describeIn tm_g_volcanoplot sample module function. |
|
| 100 | +262 |
- #'+ #' @export |
|
| 101 | +263 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @examples |
|
| 102 | +264 |
#' |
|
| 103 | +265 |
- #' Given a group list and a factor, this helper function collapses the+ #' # Alternatively you can run the sample module with this function call: |
|
| 104 | +266 |
- #' levels in the factor accordingly and also ensures that the resulting+ #' if (interactive()) {
|
|
| 105 | +267 |
- #' levels are in the order given in the group list.+ #' sample_tm_g_volcanoplot() |
|
| 106 | +268 |
- #'+ #' } |
|
| 107 | +269 |
- #' @param x (`factor`)\cr original factor.+ sample_tm_g_volcanoplot <- function() {
|
|
| 108 | -+ | ||
| 270 | +! |
- #' @param group_list (named `list` of `character`)\cr includes the collapsing+ mae <- hermes::multi_assay_experiment |
|
| 109 | -+ | ||
| 271 | +! |
- #' specification.+ mae_data <- teal.data::dataset("MAE", mae)
+ |
+ |
| 272 | +! | +
+ data <- teal.data::teal_data(mae_data)+ |
+ |
| 273 | +! | +
+ app <- teal::init(+ |
+ |
| 274 | +! | +
+ data = data,+ |
+ |
| 275 | +! | +
+ modules = teal::modules(+ |
+ |
| 276 | +! | +
+ tm_g_volcanoplot(+ |
+ |
| 277 | +! | +
+ label = "volcanoplot",+ |
+ |
| 278 | +! | +
+ mae_name = "MAE" |
|
| 110 | +279 |
- #'+ ) |
|
| 111 | +280 |
- #' @return The transformed factor `x` with new levels.+ ) |
|
| 112 | +281 |
- #' @export+ ) |
|
| 113 | -+ | ||
| 282 | +! |
- #'+ shinyApp(app$ui, app$server) |
|
| 114 | +283 |
- #' @examples+ } |
| 115 | +1 |
- #' set.seed(123)+ #' Module Input for Sample Variable Specification |
||
| 116 | +2 |
- #' x <- factor(sample(+ #' |
||
| 117 | +3 |
- #' c("ASIAN", "BLACK OR AFRICAN AMERICAN", "MULTIPLE", "UNKNOWN", "WHITE"),
+ #' @description `r lifecycle::badge("experimental")`
|
||
| 118 | +4 |
- #' size = 30L,+ #' |
||
| 119 | +5 |
- #' replace = TRUE+ #' This defines the input for the sample variable specification. |
||
| 120 | +6 |
- #' ))+ #' |
||
| 121 | +7 |
- #' group_list <- list(+ #' @inheritParams module_arguments |
||
| 122 | +8 |
- #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
+ #' @param label_vars (`string`)\cr label for the sample variable selection. |
||
| 123 | +9 |
- #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
+ #' @param label_levels_button (`string`)\cr label for the levels combination button. |
||
| 124 | +10 |
- #' "WHITE" = "WHITE"+ #' |
||
| 125 | +11 |
- #' )+ #' @return The UI part. |
||
| 126 | +12 |
- #' x_collapsed <- h_collapse_levels(x, group_list)+ #' @seealso [sampleVarSpecServer()] for the module server and a complete example. |
||
| 127 | +13 |
- #' stopifnot(identical(levels(x_collapsed), names(group_list)))+ #' @export |
||
| 128 | +14 |
- h_collapse_levels <- function(x, group_list) {
- |
- ||
| 129 | -3x | -
- assert_factor(x)- |
- ||
| 130 | -2x | -
- assert_list(group_list, names = "unique", types = "character")- |
- ||
| 131 | -1x | -
- x_collapsed <- do.call(- |
- ||
| 132 | -1x | -
- forcats::fct_collapse,- |
- ||
| 133 | -1x | -
- args = c(- |
- ||
| 134 | -1x | -
- list(.f = x),- |
- ||
| 135 | -1x | -
- group_list+ #' |
||
| 136 | +15 |
- )+ #' @examples |
||
| 137 | +16 |
- )- |
- ||
| 138 | -1x | -
- factor(x_collapsed, levels = names(group_list))+ #' sampleVarSpecInput("my_vars", label_vars = "Select faceting variable")
|
||
| 139 | +17 |
- }+ sampleVarSpecInput <- function(inputId, # nolint |
||
| 140 | +18 |
-
+ label_vars = "Select sample variable", |
||
| 141 | +19 |
- #' Validation of Number of Levels+ label_levels_button = "Combine factor levels") {
|
||
| 142 | -+ | |||
| 20 | +4x |
- #'+ assert_string(inputId) |
||
| 143 | -+ | |||
| 21 | +4x |
- #' @description `r lifecycle::badge("experimental")`
+ assert_string(label_vars) |
||
| 144 | -+ | |||
| 22 | +4x |
- #'+ assert_string(label_levels_button) |
||
| 145 | +23 |
- #' This validation function checks that a given vector `x` is a factor with+ |
||
| 146 | -+ | |||
| 24 | +4x |
- #' the specified number of levels.+ ns <- NS(inputId) |
||
| 147 | -+ | |||
| 25 | +4x |
- #'+ tagList( |
||
| 148 | -+ | |||
| 26 | +4x |
- #' @param x (`factor`)\cr factor to validate.+ include_css_files(pattern = "*"), |
||
| 149 | -+ | |||
| 27 | +4x |
- #' @param name (`string`)\cr name of `x` in the app.+ div( |
||
| 150 | -+ | |||
| 28 | +4x |
- #' @param n_levels (`count`)\cr required number of factor levels in `x`.+ class = "row", |
||
| 151 | -+ | |||
| 29 | +4x |
- #'+ div( |
||
| 152 | -+ | |||
| 30 | +4x |
- #' @export+ class = "col-sm-8", |
||
| 153 | -+ | |||
| 31 | +4x |
- validate_n_levels <- function(x, name, n_levels) {
+ tags$label( |
||
| 154 | -3x | +32 | +4x |
- validate(need(+ class = "control-label", |
| 155 | -3x | +33 | +4x |
- is.factor(x),+ label_vars |
| 156 | -3x | +|||
| 34 | +
- paste("Variable", name, "is not a factor but a", class(x))
+ ) |
|||
| 157 | +35 |
- ))+ ), |
||
| 158 | -2x | +36 | +4x |
- assert_string(name, min.chars = 1L)+ div( |
| 159 | -2x | +37 | +4x |
- assert_count(n_levels, positive = TRUE)+ class = "col-sm-4", |
| 160 | -2x | +38 | +4x |
- validate(need(+ actionButton( |
| 161 | -2x | +39 | +4x |
- identical(n_levels, nlevels(x)),+ ns("levels_button"),
|
| 162 | -2x | +40 | +4x |
- paste(+ span(icon("fas fa-table")),
|
| 163 | -2x | +41 | +4x |
- "Please combine the original levels of", name,+ title = label_levels_button, |
| 164 | -2x | +42 | +4x |
- "into exactly", n_levels, "levels"+ class = "pull-right list-genes" |
| 165 | +43 |
- )+ ) |
||
| 166 | +44 |
- ))+ ) |
||
| 167 | +45 |
- }+ ), |
||
| 168 | -+ | |||
| 46 | +4x |
-
+ div( |
||
| 169 | -+ | |||
| 47 | +4x |
- #' Module Server for Sample Variable Specification+ class = "custom-select-input", |
||
| 170 | -+ | |||
| 48 | +4x |
- #'+ teal.widgets::optionalSelectInput( |
||
| 171 | -+ | |||
| 49 | +4x |
- #' @description `r lifecycle::badge("experimental")`
+ ns("sample_var"),
|
||
| 172 | -+ | |||
| 50 | +4x |
- #'+ label = NULL, |
||
| 173 | -+ | |||
| 51 | +4x |
- #' This defines the server part for the sample variable specification.+ choices = "", |
||
| 174 | -+ | |||
| 52 | +4x |
- #'+ multiple = FALSE |
||
| 175 | +53 |
- #' @inheritParams module_arguments+ ) |
||
| 176 | +54 |
- #' @param experiment_name (reactive `string`)\cr name of the input experiment.+ ) |
||
| 177 | +55 |
- #' @param original_data (reactive `SummarizedExperiment`)\cr input experiment where the+ ) |
||
| 178 | +56 |
- #' sample variables extracted via [SummarizedExperiment::colData()] should be eligible for+ } |
||
| 179 | +57 |
- #' selection.+ |
||
| 180 | +58 |
- #' @param transformed_data (reactive `SummarizedExperiment`)\cr used when multiple sample+ #' Helper Function For Group List Creation |
||
| 181 | +59 |
- #' variables can be selected in the app. In that case, pass here the pre-transformed data.+ #' |
||
| 182 | +60 |
- #' @param assign_lists (`reactivevalues`)\cr object to share factor level groupings across multiple+ #' @description `r lifecycle::badge("experimental")`
|
||
| 183 | +61 |
- #' sample variables.+ #' |
||
| 184 | +62 |
- #' @param num_levels (`count` or `NULL`)\cr required number of levels after combining original levels.+ #' This helper function takes an assignment list and converts it to a |
||
| 185 | +63 |
- #' If `NULL` then all numbers of levels are allowed.+ #' group list. |
||
| 186 | +64 |
- #' @param categorical_only (`flag`)\cr whether only categorical variables should be selected+ #' |
||
| 187 | +65 |
- #' from.+ #' @param x (named `list` of `character`)\cr input assignment list. |
||
| 188 | +66 |
- #' @param explicit_na (`flag`)\cr whether the `colData` of `original_data` will be transformed with+ #' @return A combination list. |
||
| 189 | +67 |
- #' [hermes::h_df_factors_with_explicit_na] before further processing. That means also that+ #' |
||
| 190 | +68 |
- #' `NA` will be made an explicit factor level and counted for `num_levels`.+ #' @export |
||
| 191 | +69 |
- #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input.+ #' |
||
| 192 | +70 |
- #'+ #' @examples |
||
| 193 | +71 |
- #' @return Reactive [`SummarizedExperiment::SummarizedExperiment`] which can be used as+ #' assign_list <- list( |
||
| 194 | +72 |
- #' input for the relevant `hermes` functions.+ #' "ASIAN" = "1", |
||
| 195 | +73 |
- #' @seealso [sampleVarSpecInput()] for the module UI.+ #' "BLACK OR AFRICAN AMERICAN" = "1", |
||
| 196 | +74 |
- #'+ #' "MULTIPLE" = "2", |
||
| 197 | +75 |
- #' @note Only atomic columns (e.g. not `DataFrame` columns) of the `colData`+ #' "UNKNOWN" = "2", |
||
| 198 | +76 |
- #' which are not completely missing (`NA`) will be shown for selection.+ #' "WHITE" = "4" |
||
| 199 | +77 |
- #' If `num_levels` is specified then only factor columns will be available.+ #' ) |
||
| 200 | +78 |
- #'+ #' objective_list <- list( |
||
| 201 | +79 |
- #' @export+ #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
|
||
| 202 | +80 |
- #'+ #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
|
||
| 203 | +81 |
- #' @examples+ #' "WHITE" = "WHITE" |
||
| 204 | +82 |
- #' ui <- function(id,+ #' ) |
||
| 205 | +83 |
- #' data) {
+ #' result_list <- h_assign_to_group_list(assign_list) |
||
| 206 | +84 |
- #' ns <- NS(id)+ #' stopifnot(identical(result_list, objective_list)) |
||
| 207 | +85 |
- #' mae <- data[["MAE"]]()+ h_assign_to_group_list <- function(x) {
|
||
| 208 | -+ | |||
| 86 | +2x |
- #' experiment_name_choices <- names(mae)+ assert_list( |
||
| 209 | -+ | |||
| 87 | +2x |
- #' teal.widgets::standard_layout(+ x, |
||
| 210 | -+ | |||
| 88 | +2x |
- #' encoding = div(+ types = "character", |
||
| 211 | -+ | |||
| 89 | +2x |
- #' selectInput(ns("experiment_name"), "Select experiment", experiment_name_choices),
+ any.missing = FALSE, |
||
| 212 | -+ | |||
| 90 | +2x |
- #' sampleVarSpecInput(ns("facet_var"), "Select faceting variable")
+ names = "unique", |
||
| 213 | -+ | |||
| 91 | +2x |
- #' ),+ unique = FALSE |
||
| 214 | +92 |
- #' output = plotOutput(ns("plot"))
+ ) |
||
| 215 | -+ | |||
| 93 | +2x |
- #' )+ x_vec <- unlist(x) |
||
| 216 | -+ | |||
| 94 | +2x |
- #' }+ x_split <- split(names(x_vec), x_vec) |
||
| 217 | -+ | |||
| 95 | +2x |
- #' server <- function(id,+ new_levels <- sapply(x_split, hermes::h_short_list, sep = "/") |
||
| 218 | -+ | |||
| 96 | +2x |
- #' data) {
+ stats::setNames(x_split, new_levels) |
||
| 219 | +97 |
- #' moduleServer(id, function(input, output, session) {
+ } |
||
| 220 | +98 |
- #' experiment_data <- reactive({
+
|
||
| 221 | +99 |
- #' req(input$experiment_name)+ #' Helper Function for Collapsing of Factor Levels |
||
| 222 | +100 |
- #' mae <- data[["MAE"]]()+ #' |
||
| 223 | +101 |
- #' object <- mae[[input$experiment_name]]+ #' @description `r lifecycle::badge("experimental")`
|
||
| 224 | +102 |
- #' SummarizedExperiment::colData(object) <-+ #' |
||
| 225 | +103 |
- #' hermes::df_cols_to_factor(SummarizedExperiment::colData(object))+ #' Given a group list and a factor, this helper function collapses the |
||
| 226 | +104 |
- #' object+ #' levels in the factor accordingly and also ensures that the resulting |
||
| 227 | +105 |
- #' })+ #' levels are in the order given in the group list. |
||
| 228 | +106 |
- #' facet_var_spec <- sampleVarSpecServer(+ #' |
||
| 229 | +107 |
- #' "facet_var",+ #' @param x (`factor`)\cr original factor. |
||
| 230 | +108 |
- #' experiment_name = reactive({
+ #' @param group_list (named `list` of `character`)\cr includes the collapsing |
||
| 231 | +109 |
- #' input$experiment_name+ #' specification. |
||
| 232 | +110 |
- #' }),+ #' |
||
| 233 | +111 |
- #' original_data = experiment_data+ #' @return The transformed factor `x` with new levels. |
||
| 234 | +112 |
- #' )+ #' @export |
||
| 235 | +113 |
- #' output$plot <- renderPlot({
+ #' |
||
| 236 | +114 |
- #' experiment_data_final <- facet_var_spec$experiment_data()+ #' @examples |
||
| 237 | +115 |
- #' facet_var <- facet_var_spec$sample_var()+ #' set.seed(123) |
||
| 238 | +116 |
- #' hermes::draw_boxplot(+ #' x <- factor(sample( |
||
| 239 | +117 |
- #' experiment_data_final,+ #' c("ASIAN", "BLACK OR AFRICAN AMERICAN", "MULTIPLE", "UNKNOWN", "WHITE"),
|
||
| 240 | +118 |
- #' assay_name = "counts",+ #' size = 30L, |
||
| 241 | +119 |
- #' genes = hermes::gene_spec(hermes::genes(experiment_data_final)[1]),+ #' replace = TRUE |
||
| 242 | +120 |
- #' facet_var = facet_var+ #' )) |
||
| 243 | +121 |
- #' )+ #' group_list <- list( |
||
| 244 | +122 |
- #' })+ #' "ASIAN/BLACK OR AFRICAN AMERICAN" = c("ASIAN", "BLACK OR AFRICAN AMERICAN"),
|
||
| 245 | +123 |
- #' })+ #' "MULTIPLE/UNKNOWN" = c("MULTIPLE", "UNKNOWN"),
|
||
| 246 | +124 |
- #' }+ #' "WHITE" = "WHITE" |
||
| 247 | +125 |
- #' my_app <- function() {
+ #' ) |
||
| 248 | +126 |
- #' mae <- hermes::multi_assay_experiment+ #' x_collapsed <- h_collapse_levels(x, group_list) |
||
| 249 | +127 |
- #' mae_data <- dataset("MAE", mae)
+ #' stopifnot(identical(levels(x_collapsed), names(group_list))) |
||
| 250 | +128 |
- #' data <- teal_data(mae_data)+ h_collapse_levels <- function(x, group_list) {
|
||
| 251 | -+ | |||
| 129 | +3x |
- #' app <- init(+ assert_factor(x) |
||
| 252 | -+ | |||
| 130 | +2x |
- #' data = data,+ assert_list(group_list, names = "unique", types = "character") |
||
| 253 | -+ | |||
| 131 | +1x |
- #' modules = modules(+ x_collapsed <- do.call( |
||
| 254 | -+ | |||
| 132 | +1x |
- #' module(+ forcats::fct_collapse, |
||
| 255 | -+ | |||
| 133 | +1x |
- #' label = "sampleVarSpec example",+ args = c( |
||
| 256 | -+ | |||
| 134 | +1x |
- #' server = server,+ list(.f = x), |
||
| 257 | -+ | |||
| 135 | +1x |
- #' ui = ui,+ group_list |
||
| 258 | +136 |
- #' datanames = "all"+ ) |
||
| 259 | +137 |
- #' )+ ) |
||
| 260 | -+ | |||
| 138 | +1x |
- #' )+ factor(x_collapsed, levels = names(group_list)) |
||
| 261 | +139 |
- #' )+ } |
||
| 262 | +140 |
- #' shinyApp(app$ui, app$server)+ |
||
| 263 | +141 |
- #' }+ #' Validation of Number of Levels |
||
| 264 | +142 |
- #' if (interactive()) {
+ #' |
||
| 265 | +143 |
- #' my_app()+ #' @description `r lifecycle::badge("experimental")`
|
||
| 266 | +144 |
- #' }+ #' |
||
| 267 | +145 |
- sampleVarSpecServer <- function(id, # nolint+ #' This validation function checks that a given vector `x` is a factor with |
||
| 268 | +146 |
- experiment_name,+ #' the specified number of levels. |
||
| 269 | +147 |
- original_data,+ #' |
||
| 270 | +148 |
- transformed_data = original_data,+ #' @param x (`factor`)\cr factor to validate. |
||
| 271 | +149 |
- assign_lists = reactiveValues(),+ #' @param name (`string`)\cr name of `x` in the app. |
||
| 272 | +150 |
- num_levels = NULL,+ #' @param n_levels (`count`)\cr required number of factor levels in `x`. |
||
| 273 | +151 |
- categorical_only = !is.null(num_levels),+ #' |
||
| 274 | +152 |
- explicit_na = FALSE,+ #' @export |
||
| 275 | +153 |
- label_modal_title = "Please click to group the original factor levels") {
- |
- ||
| 276 | -2x | -
- assert_string(id)+ validate_n_levels <- function(x, name, n_levels) {
|
||
| 277 | -2x | +154 | +3x |
- assert_reactive(experiment_name)+ validate(need( |
| 278 | -2x | +155 | +3x |
- assert_reactive(original_data)+ is.factor(x), |
| 279 | -2x | +156 | +3x |
- assert_reactive(transformed_data)+ paste("Variable", name, "is not a factor but a", class(x))
|
| 280 | -2x | +|||
| 157 | +
- assert_class(assign_lists, "reactivevalues")+ )) |
|||
| 281 | +158 | 2x |
- assert_count(num_levels, null.ok = TRUE, positive = TRUE)+ assert_string(name, min.chars = 1L) |
|
| 282 | +159 | 2x |
- assert_flag(categorical_only)+ assert_count(n_levels, positive = TRUE) |
|
| 283 | +160 | 2x |
- assert_flag(explicit_na)+ validate(need( |
|
| 284 | +161 | 2x |
- assert_string(label_modal_title)- |
- |
| 285 | -- |
-
+ identical(n_levels, nlevels(x)), |
||
| 286 | +162 | 2x |
- moduleServer(id, function(input, output, session) {
+ paste( |
|
| 287 | +163 | 2x |
- to_observe <- reactive({
+ "Please combine the original levels of", name, |
|
| 288 | +164 | 2x |
- list(experiment_name(), original_data())+ "into exactly", n_levels, "levels" |
|
| 289 | +165 |
- })+ ) |
||
| 290 | +166 | - - | -||
| 291 | -2x | -
- start_col_data <- eventReactive(to_observe(), {
- |
- ||
| 292 | -2x | -
- object <- original_data()- |
- ||
| 293 | -2x | -
- col_data <- SummarizedExperiment::colData(object)- |
- ||
| 294 | -2x | -
- if (explicit_na) {
+ )) |
||
| 295 | -! | +|||
| 167 | +
- hermes::df_cols_to_factor(col_data)+ } |
|||
| 296 | +168 |
- } else {
+
|
||
| 297 | -2x | +|||
| 169 | +
- col_data+ #' Module Server for Sample Variable Specification |
|||
| 298 | +170 |
- }+ #' |
||
| 299 | +171 |
- })+ #' @description `r lifecycle::badge("experimental")`
|
||
| 300 | +172 |
-
+ #' |
||
| 301 | +173 |
- # The colData variables to choose the sample variable from.+ #' This defines the server part for the sample variable specification. |
||
| 302 | -2x | +|||
| 174 | +
- col_data_vars <- reactive({
+ #' |
|||
| 303 | -2x | +|||
| 175 | +
- col_data <- start_col_data()+ #' @inheritParams module_arguments |
|||
| 304 | -2x | +|||
| 176 | +
- can_be_used <- vapply(col_data, FUN = function(x) is.atomic(x) && !allMissing(x), FUN.VALUE = logical(1))+ #' @param experiment_name (reactive `string`)\cr name of the input experiment. |
|||
| 305 | -2x | +|||
| 177 | +
- if (categorical_only) {
+ #' @param original_data (reactive `SummarizedExperiment`)\cr input experiment where the |
|||
| 306 | -1x | +|||
| 178 | +
- col_is_factor <- vapply(col_data, FUN = is.factor, FUN.VALUE = logical(1))+ #' sample variables extracted via [SummarizedExperiment::colData()] should be eligible for |
|||
| 307 | -1x | +|||
| 179 | +
- can_be_used <- can_be_used & col_is_factor+ #' selection. |
|||
| 308 | +180 |
- }+ #' @param transformed_data (reactive `SummarizedExperiment`)\cr used when multiple sample |
||
| 309 | -2x | +|||
| 181 | +
- names(col_data)[can_be_used]+ #' variables can be selected in the app. In that case, pass here the pre-transformed data. |
|||
| 310 | +182 |
- })+ #' @param assign_lists (`reactivevalues`)\cr object to share factor level groupings across multiple |
||
| 311 | +183 |
-
+ #' sample variables. |
||
| 312 | +184 |
- # When the colData variables change, update the choices for sample_var.+ #' @param num_levels (`count` or `NULL`)\cr required number of levels after combining original levels. |
||
| 313 | -2x | +|||
| 185 | +
- observeEvent(col_data_vars(), {
+ #' If `NULL` then all numbers of levels are allowed. |
|||
| 314 | -! | +|||
| 186 | +
- col_data_vars <- col_data_vars()+ #' @param categorical_only (`flag`)\cr whether only categorical variables should be selected |
|||
| 315 | +187 |
-
+ #' from. |
||
| 316 | -! | +|||
| 188 | +
- sel <- intersect(input$sample_var, col_data_vars)+ #' @param explicit_na (`flag`)\cr whether the `colData` of `original_data` will be transformed with |
|||
| 317 | +189 |
-
+ #' [hermes::h_df_factors_with_explicit_na] before further processing. That means also that |
||
| 318 | -! | +|||
| 190 | +
- teal.widgets::updateOptionalSelectInput(+ #' `NA` will be made an explicit factor level and counted for `num_levels`. |
|||
| 319 | -! | +|||
| 191 | +
- session,+ #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input. |
|||
| 320 | -! | +|||
| 192 | +
- "sample_var",+ #' |
|||
| 321 | -! | +|||
| 193 | +
- choices = col_data_vars,+ #' @return Reactive [`SummarizedExperiment::SummarizedExperiment`] which can be used as |
|||
| 322 | -! | +|||
| 194 | +
- selected = sel+ #' input for the relevant `hermes` functions. |
|||
| 323 | +195 |
- )+ #' @seealso [sampleVarSpecInput()] for the module UI. |
||
| 324 | +196 |
- })+ #' |
||
| 325 | +197 |
-
+ #' @note Only atomic columns (e.g. not `DataFrame` columns) of the `colData` |
||
| 326 | +198 |
- # Reactive for the current combination. Takes the assignment list if available+ #' which are not completely missing (`NA`) will be shown for selection. |
||
| 327 | +199 |
- # and converts to combination list.+ #' If `num_levels` is specified then only factor columns will be available. |
||
| 328 | -2x | +|||
| 200 | +
- current_combination <- reactive({
+ #' |
|||
| 329 | -! | +|||
| 201 | +
- experiment_name <- experiment_name()+ #' @export |
|||
| 330 | -! | +|||
| 202 | +
- sample_var <- input$sample_var+ #' |
|||
| 331 | -! | +|||
| 203 | +
- req(experiment_name)+ #' @examples |
|||
| 332 | +204 |
-
+ #' ui <- function(id, |
||
| 333 | -! | +|||
| 205 | +
- if (!is.null(sample_var)) {
+ #' data) {
|
|||
| 334 | -! | +|||
| 206 | +
- assign_list <- assign_lists[[experiment_name]][[sample_var]]+ #' ns <- NS(id) |
|||
| 335 | -! | +|||
| 207 | +
- if (!is.null(assign_list)) {
+ #' mae <- data[["MAE"]]() |
|||
| 336 | -! | +|||
| 208 | +
- h_assign_to_group_list(assign_list)+ #' experiment_name_choices <- names(mae) |
|||
| 337 | +209 |
- } else {
+ #' teal.widgets::standard_layout( |
||
| 338 | -! | +|||
| 210 | +
- NULL+ #' encoding = div( |
|||
| 339 | +211 |
- }+ #' selectInput(ns("experiment_name"), "Select experiment", experiment_name_choices),
|
||
| 340 | +212 |
- }+ #' sampleVarSpecInput(ns("facet_var"), "Select faceting variable")
|
||
| 341 | +213 |
- })+ #' ), |
||
| 342 | +214 |
-
+ #' output = plotOutput(ns("plot"))
|
||
| 343 | +215 |
- # Here we produce the final object by checking+ #' ) |
||
| 344 | +216 |
- # if we should combine for this sample var.+ #' } |
||
| 345 | -2x | +|||
| 217 | +
- final_data <- reactive({
+ #' server <- function(id, |
|||
| 346 | -! | +|||
| 218 | +
- sample_var <- input$sample_var+ #' data) {
|
|||
| 347 | -! | +|||
| 219 | +
- original_data <- original_data()+ #' moduleServer(id, function(input, output, session) {
|
|||
| 348 | -! | +|||
| 220 | +
- start_col_data <- start_col_data()+ #' experiment_data <- reactive({
|
|||
| 349 | -! | +|||
| 221 | +
- transformed_data <- transformed_data()+ #' req(input$experiment_name) |
|||
| 350 | -! | +|||
| 222 | +
- current_combination <- current_combination()+ #' mae <- data[["MAE"]]() |
|||
| 351 | +223 |
-
+ #' object <- mae[[input$experiment_name]] |
||
| 352 | -! | +|||
| 224 | +
- if (!is.null(sample_var)) {
+ #' SummarizedExperiment::colData(object) <- |
|||
| 353 | -! | +|||
| 225 | +
- sample_var_vector <- start_col_data[[sample_var]]+ #' hermes::df_cols_to_factor(SummarizedExperiment::colData(object)) |
|||
| 354 | -! | +|||
| 226 | +
- if (!is.null(current_combination)) {
+ #' object |
|||
| 355 | -! | +|||
| 227 | +
- sample_var_vector <- h_collapse_levels(+ #' }) |
|||
| 356 | -! | +|||
| 228 | +
- sample_var_vector,+ #' facet_var_spec <- sampleVarSpecServer( |
|||
| 357 | -! | +|||
| 229 | +
- current_combination+ #' "facet_var", |
|||
| 358 | +230 |
- )+ #' experiment_name = reactive({
|
||
| 359 | +231 |
- }+ #' input$experiment_name |
||
| 360 | -! | +|||
| 232 | +
- if (!is.null(num_levels)) {
+ #' }), |
|||
| 361 | -! | +|||
| 233 | +
- validate_n_levels(sample_var_vector, sample_var, num_levels)+ #' original_data = experiment_data |
|||
| 362 | +234 |
- }+ #' ) |
||
| 363 | -! | +|||
| 235 | +
- SummarizedExperiment::colData(transformed_data)[[sample_var]] <- sample_var_vector+ #' output$plot <- renderPlot({
|
|||
| 364 | +236 |
- }+ #' experiment_data_final <- facet_var_spec$experiment_data() |
||
| 365 | +237 |
-
+ #' facet_var <- facet_var_spec$sample_var() |
||
| 366 | -! | +|||
| 238 | +
- transformed_data+ #' hermes::draw_boxplot( |
|||
| 367 | +239 |
- })+ #' experiment_data_final, |
||
| 368 | +240 |
-
+ #' assay_name = "counts", |
||
| 369 | +241 |
- # Function to return the UI for a modal dialog with matrix input for combination+ #' genes = hermes::gene_spec(hermes::genes(experiment_data_final)[1]), |
||
| 370 | +242 |
- # assignment.+ #' facet_var = facet_var |
||
| 371 | -2x | +|||
| 243 | +
- combModal <- function(sample_var_levels, # nolint+ #' ) |
|||
| 372 | -2x | +|||
| 244 | +
- n_max_groups,+ #' }) |
|||
| 373 | -2x | +|||
| 245 | +
- selected_groups) {
+ #' }) |
|||
| 374 | -! | +|||
| 246 | +
- if (is.null(selected_groups)) {
+ #' } |
|||
| 375 | -! | +|||
| 247 | +
- selected_groups <- pmin(+ #' my_app <- function() {
|
|||
| 376 | -! | +|||
| 248 | +
- seq_along(sample_var_levels),+ #' mae <- hermes::multi_assay_experiment |
|||
| 377 | -! | +|||
| 249 | +
- n_max_groups+ #' mae_data <- dataset("MAE", mae)
|
|||
| 378 | +250 |
- )+ #' data <- teal_data(mae_data) |
||
| 379 | +251 |
- }+ #' app <- init( |
||
| 380 | -! | +|||
| 252 | +
- modalDialog(+ #' data = data, |
|||
| 381 | -! | +|||
| 253 | +
- shinyRadioMatrix::radioMatrixInput(+ #' modules = modules( |
|||
| 382 | -! | +|||
| 254 | +
- session$ns("comb_assignment"),
+ #' module( |
|||
| 383 | -! | +|||
| 255 | ++ |
+ #' label = "sampleVarSpec example",+ |
+ ||
| 256 | +
- rowIDs = sample_var_levels,+ #' server = server, |
|||
| 384 | -! | +|||
| 257 | +
- rowIDsName = "Original levels",+ #' ui = ui, |
|||
| 385 | -! | +|||
| 258 | +
- rowLLabels = rep("", length = length(sample_var_levels)),
+ #' datanames = "all" |
|||
| 386 | -! | +|||
| 259 | +
- choices = seq_len(n_max_groups),+ #' ) |
|||
| 387 | -! | +|||
| 260 | +
- selected = selected_groups+ #' ) |
|||
| 388 | +261 |
- ),+ #' ) |
||
| 389 | -! | +|||
| 262 | +
- span(label_modal_title),+ #' shinyApp(app$ui, app$server) |
|||
| 390 | -! | +|||
| 263 | +
- footer = tagList(+ #' } |
|||
| 391 | -! | +|||
| 264 | +
- modalButton("Cancel"),
+ #' if (interactive()) {
|
|||
| 392 | -! | +|||
| 265 | +
- actionButton(session$ns("ok"), "OK")
+ #' my_app() |
|||
| 393 | +266 |
- ),+ #' } |
||
| 394 | -! | +|||
| 267 | +
- include_js_files("checkbox.js")
+ sampleVarSpecServer <- function(id, # nolint |
|||
| 395 | +268 |
- )+ experiment_name, |
||
| 396 | +269 |
- }+ original_data, |
||
| 397 | +270 |
-
+ transformed_data = original_data, |
||
| 398 | +271 |
- # Show modal when button is clicked and the current variable is a factor variable.+ assign_lists = reactiveValues(), |
||
| 399 | -2x | +|||
| 272 | +
- observeEvent(input$levels_button, {
+ num_levels = NULL, |
|||
| 400 | -! | +|||
| 273 | +
- sample_var <- input$sample_var+ categorical_only = !is.null(num_levels), |
|||
| 401 | -! | +|||
| 274 | +
- original_data <- original_data()+ explicit_na = FALSE, |
|||
| 402 | -! | +|||
| 275 | +
- start_col_data <- start_col_data()+ label_modal_title = "Please click to group the original factor levels") {
|
|||
| 403 | -! | +|||
| 276 | +2x |
- experiment_name <- experiment_name()+ assert_string(id) |
||
| 404 | -+ | |||
| 277 | +2x |
-
+ assert_reactive(experiment_name) |
||
| 405 | -! | +|||
| 278 | +2x |
- req(experiment_name)+ assert_reactive(original_data) |
||
| 406 | -+ | |||
| 279 | +2x |
-
+ assert_reactive(transformed_data) |
||
| 407 | -! | +|||
| 280 | +2x |
- if (!is.null(sample_var)) {
+ assert_class(assign_lists, "reactivevalues") |
||
| 408 | -! | +|||
| 281 | +2x |
- current_sample_var <- start_col_data[[sample_var]]+ assert_count(num_levels, null.ok = TRUE, positive = TRUE) |
||
| 409 | -+ | |||
| 282 | +2x |
-
+ assert_flag(categorical_only) |
||
| 410 | -! | +|||
| 283 | +2x |
- if (is.factor(current_sample_var)) {
+ assert_flag(explicit_na) |
||
| 411 | -! | +|||
| 284 | +2x |
- sample_var_levels <- levels(current_sample_var)+ assert_string(label_modal_title) |
||
| 412 | +285 | |||
| 413 | -+ | |||
| 286 | +2x |
- # Note: here we make sure we load with previous choice so the user+ moduleServer(id, function(input, output, session) {
|
||
| 414 | -+ | |||
| 287 | +2x |
- # does not constantly need to start from scratch again.+ to_observe <- reactive({
|
||
| 415 | -+ | |||
| 288 | +2x |
- # although we do not do this if the levels do not match (i.e. if+ list(experiment_name(), original_data()) |
||
| 416 | +289 |
- # some levels have been filtered out)+ }) |
||
| 417 | +290 | |||
| 418 | -! | +|||
| 291 | +2x |
- selected_groups <- NULL+ start_col_data <- eventReactive(to_observe(), {
|
||
| 419 | -+ | |||
| 292 | +2x | +
+ object <- original_data()+ |
+ ||
| 293 | +2x |
-
+ col_data <- SummarizedExperiment::colData(object) |
||
| 420 | -! | +|||
| 294 | +2x |
- old_values <- names(assign_lists[[experiment_name]][[sample_var]])+ if (explicit_na) {
|
||
| 421 | +295 | ! |
- if (!is.null(old_values) &&+ hermes::df_cols_to_factor(col_data) |
|
| 422 | -! | +|||
| 296 | +
- length(old_values) == length(sample_var_levels) &&+ } else {
|
|||
| 423 | -! | +|||
| 297 | +2x |
- all(sort(old_values) == sort(sample_var_levels))) {
+ col_data |
||
| 424 | -! | +|||
| 298 | +
- selected_groups <- assign_lists[[experiment_name]][[sample_var]]+ } |
|||
| 425 | +299 |
- }+ }) |
||
| 426 | +300 | |||
| 427 | -! | +|||
| 301 | +
- showModal(combModal(+ # The colData variables to choose the sample variable from. |
|||
| 428 | -! | +|||
| 302 | +2x |
- sample_var_levels = sample_var_levels,+ col_data_vars <- reactive({
|
||
| 429 | -! | +|||
| 303 | +2x |
- n_max_groups = `if`(!is.null(num_levels), num_levels, length(sample_var_levels)),+ col_data <- start_col_data() |
||
| 430 | -! | +|||
| 304 | +2x |
- selected_groups = selected_groups+ can_be_used <- vapply(col_data, FUN = function(x) is.atomic(x) && !allMissing(x), FUN.VALUE = logical(1)) |
||
| 431 | -+ | |||
| 305 | +2x |
- ))+ if (categorical_only) {
|
||
| 432 | -+ | |||
| 306 | +1x |
- } else {
+ col_is_factor <- vapply(col_data, FUN = is.factor, FUN.VALUE = logical(1)) |
||
| 433 | -! | +|||
| 307 | +1x |
- showNotification("Can only group levels for factor variables", type = "message")
+ can_be_used <- can_be_used & col_is_factor |
||
| 434 | +308 |
- }+ } |
||
| 435 | -+ | |||
| 309 | +2x |
- }+ names(col_data)[can_be_used] |
||
| 436 | +310 |
}) |
||
| 437 | +311 | |||
| 438 | +312 |
- # When OK button is pressed, save the settings, and remove the modal.+ # When the colData variables change, update the choices for sample_var. |
||
| 439 | +313 | 2x |
- observeEvent(input$ok, {
+ observeEvent(col_data_vars(), {
|
|
| 440 | +314 | ! |
- experiment_name <- experiment_name()+ col_data_vars <- col_data_vars() |
|
| 441 | -! | +|||
| 315 | +
- sample_var <- input$sample_var+ |
|||
| 442 | +316 | ! |
- comb_assignment <- input$comb_assignment+ sel <- intersect(input$sample_var, col_data_vars) |
|
| 443 | +317 | |||
| 444 | +318 | ! |
- req(experiment_name, sample_var, comb_assignment)- |
- |
| 445 | -- |
-
+ teal.widgets::updateOptionalSelectInput( |
||
| 446 | +319 | ! |
- if (!is.null(num_levels) && !identical(length(unique(unlist(comb_assignment))), num_levels)) {
+ session, |
|
| 447 | +320 | ! |
- showNotification(+ "sample_var", |
|
| 448 | +321 | ! |
- paste("Please group the original levels into exactly", num_levels, "levels"),
+ choices = col_data_vars, |
|
| 449 | +322 | ! |
- type = "error"+ selected = sel |
|
| 450 | +323 |
- )+ ) |
||
| 451 | +324 |
- } else {
+ }) |
||
| 452 | -! | +|||
| 325 | +
- assign_lists[[experiment_name]][[sample_var]] <- comb_assignment+ |
|||
| 453 | -! | +|||
| 326 | +
- removeModal()+ # Reactive for the current combination. Takes the assignment list if available |
|||
| 454 | +327 |
- }+ # and converts to combination list. |
||
| 455 | -+ | |||
| 328 | +2x |
- })+ current_combination <- reactive({
|
||
| 456 | -+ | |||
| 329 | +! |
-
+ experiment_name <- experiment_name() |
||
| 457 | -+ | |||
| 330 | +! |
- # Return both the reactives with the experiment data as well as the sample variable.+ sample_var <- input$sample_var |
||
| 458 | -2x | +|||
| 331 | +! |
- list(+ req(experiment_name) |
||
| 459 | -2x | +|||
| 332 | +
- experiment_data = final_data,+ |
|||
| 460 | -2x | +|||
| 333 | +! | +
+ if (!is.null(sample_var)) {
+ |
+ ||
| 334 | +! | +
+ assign_list <- assign_lists[[experiment_name]][[sample_var]]+ |
+ ||
| 335 | +! |
- sample_var = reactive({
+ if (!is.null(assign_list)) {
|
||
| 461 | +336 | ! |
- input$sample_var+ h_assign_to_group_list(assign_list) |
|
| 462 | +337 |
- })+ } else {
+ |
+ ||
| 338 | +! | +
+ NULL |
||
| 463 | +339 |
- )+ } |
||
| 464 | +340 |
- })+ } |
||
| 465 | +341 |
- }+ }) |
||
| 466 | +342 | |||
| 467 | +343 |
- #' Module Server for Specification of Multiple Sample Variables+ # Here we produce the final object by checking |
||
| 468 | +344 |
- #'+ # if we should combine for this sample var. |
||
| 469 | -+ | |||
| 345 | +2x |
- #' @description `r lifecycle::badge("experimental")`
+ final_data <- reactive({
|
||
| 470 | -+ | |||
| 346 | +! |
- #'+ sample_var <- input$sample_var |
||
| 471 | -+ | |||
| 347 | +! |
- #' When multiple sample variables are used in a given module, then this+ original_data <- original_data() |
||
| 472 | -+ | |||
| 348 | +! |
- #' wrapper makes it much easier to specify in the server function.+ start_col_data <- start_col_data() |
||
| 473 | -+ | |||
| 349 | +! |
- #'+ transformed_data <- transformed_data() |
||
| 474 | -+ | |||
| 350 | +! |
- #' @param inputIds (`character`)\cr multiple input IDs corresponding to the+ current_combination <- current_combination() |
||
| 475 | +351 |
- #' different sample variables specified in the UI function.+ |
||
| 476 | -+ | |||
| 352 | +! |
- #' @inheritParams sampleVarSpecServer+ if (!is.null(sample_var)) {
|
||
| 477 | -+ | |||
| 353 | +! |
- #' @param ... additional arguments as documented in [sampleVarSpecServer()],+ sample_var_vector <- start_col_data[[sample_var]] |
||
| 478 | -+ | |||
| 354 | +! |
- #' namely the mandatory `experiment_name` and the optional `categorical_only`,+ if (!is.null(current_combination)) {
|
||
| 479 | -+ | |||
| 355 | +! |
- #' `num_levels` and `label_modal_title`.+ sample_var_vector <- h_collapse_levels( |
||
| 480 | -+ | |||
| 356 | +! |
- #' `transformed_data` and `assign_lists` should not be+ sample_var_vector, |
||
| 481 | -+ | |||
| 357 | +! |
- #' specified as they are already specified internally here.+ current_combination |
||
| 482 | +358 |
- #'+ ) |
||
| 483 | +359 |
- #' @return List with the final transformed `experiment_data` reactive and a+ } |
||
| 484 | -+ | |||
| 360 | +! |
- #' list `vars` which contains the selected sample variables as reactives+ if (!is.null(num_levels)) {
|
||
| 485 | -+ | |||
| 361 | +! |
- #' under their input ID.+ validate_n_levels(sample_var_vector, sample_var, num_levels) |
||
| 486 | +362 |
- #'+ } |
||
| 487 | -+ | |||
| 363 | +! |
- #' @export+ SummarizedExperiment::colData(transformed_data)[[sample_var]] <- sample_var_vector |
||
| 488 | +364 |
- #' @examples+ } |
||
| 489 | +365 |
- #' \dontrun{
+
|
||
| 490 | -+ | |||
| 366 | +! |
- #' # In the server use:+ transformed_data |
||
| 491 | +367 |
- #' sample_var_specs <- multiSampleVarSpecServer(+ }) |
||
| 492 | +368 |
- #' inputIds = c("facet_var", "color_var"),
+
|
||
| 493 | +369 |
- #' experiment_name = reactive({
+ # Function to return the UI for a modal dialog with matrix input for combination |
||
| 494 | +370 |
- #' input$experiment_name+ # assignment. |
||
| 495 | -+ | |||
| 371 | +2x |
- #' }),+ combModal <- function(sample_var_levels, # nolint |
||
| 496 | -+ | |||
| 372 | +2x |
- #' original_data = ori_data # nolint Please update the <ori_data>+ n_max_groups, |
||
| 497 | -+ | |||
| 373 | +2x |
- #' )+ selected_groups) {
|
||
| 498 | -+ | |||
| 374 | +! | +
+ if (is.null(selected_groups)) {
+ |
+ ||
| 375 | +! | +
+ selected_groups <- pmin(+ |
+ ||
| 376 | +! |
- #' # Then can extract the transformed data and selected variables later:+ seq_along(sample_var_levels), |
||
| 499 | -+ | |||
| 377 | +! |
- #' experiment_data <- sample_var_specs$experiment_data()+ n_max_groups |
||
| 500 | +378 |
- #' facet_var <- sample_var_specs$vars$facet_var()+ ) |
||
| 501 | +379 |
- #' color_var <- sample_var_specs$vars$color_var()+ } |
||
| 502 | -+ | |||
| 380 | +! |
- #' }+ modalDialog( |
||
| 503 | -+ | |||
| 381 | +! |
- multiSampleVarSpecServer <- function(inputIds, # nolint+ shinyRadioMatrix::radioMatrixInput( |
||
| 504 | -+ | |||
| 382 | +! |
- original_data,+ session$ns("comb_assignment"),
|
||
| 505 | -+ | |||
| 383 | +! |
- ...) {
+ rowIDs = sample_var_levels, |
||
| 506 | +384 | ! |
- assert_character(inputIds, any.missing = FALSE, unique = TRUE)+ rowIDsName = "Original levels", |
|
| 507 | +385 | ! |
- assign_lists <- reactiveValues()+ rowLLabels = rep("", length = length(sample_var_levels)),
|
|
| 508 | +386 | ! |
- spec_list <- list()+ choices = seq_len(n_max_groups), |
|
| 509 | +387 | ! |
- transformed_data <- original_data+ selected = selected_groups |
|
| 510 | -! | +|||
| 388 | +
- for (id in inputIds) {
+ ), |
|||
| 511 | +389 | ! |
- spec_list[[id]] <- sampleVarSpecServer(+ span(label_modal_title), |
|
| 512 | +390 | ! |
- id,+ footer = tagList( |
|
| 513 | +391 | ! |
- original_data = original_data,+ modalButton("Cancel"),
|
|
| 514 | +392 | ! |
- transformed_data = transformed_data,+ actionButton(session$ns("ok"), "OK")
+ |
+ |
| 393 | ++ |
+ ), |
||
| 515 | +394 | ! |
- assign_lists = assign_lists,+ include_js_files("checkbox.js")
|
|
| 516 | +395 |
- ...+ ) |
||
| 517 | +396 |
- )+ } |
||
| 518 | -! | +|||
| 397 | +
- transformed_data <- spec_list[[id]]$experiment_data+ |
|||
| 519 | +398 |
- }+ # Show modal when button is clicked and the current variable is a factor variable.+ |
+ ||
| 399 | +2x | +
+ observeEvent(input$levels_button, {
|
||
| 520 | +400 | ! |
- list(+ sample_var <- input$sample_var |
|
| 521 | +401 | ! |
- experiment_data = transformed_data,+ original_data <- original_data() |
|
| 522 | +402 | ! |
- vars = lapply(spec_list, "[[", "sample_var")+ start_col_data <- start_col_data() |
|
| 523 | -+ | |||
| 403 | +! |
- )+ experiment_name <- experiment_name() |
||
| 524 | +404 |
- }+ |
| 1 | -+ | |||
| 405 | +! |
- #' Module Input for Gene Signature Specification+ req(experiment_name) |
||
| 2 | +406 |
- #'+ |
||
| 3 | -+ | |||
| 407 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ if (!is.null(sample_var)) {
|
||
| 4 | -+ | |||
| 408 | +! |
- #'+ current_sample_var <- start_col_data[[sample_var]] |
||
| 5 | +409 |
- #' This defines the input for the gene signature specification.+ |
||
| 6 | -+ | |||
| 410 | +! |
- #'+ if (is.factor(current_sample_var)) {
|
||
| 7 | -+ | |||
| 411 | +! |
- #' @inheritParams module_arguments+ sample_var_levels <- levels(current_sample_var) |
||
| 8 | +412 |
- #' @param funs (named `list`)\cr names of this list will be used for the function+ |
||
| 9 | +413 |
- #' selection drop down menu.+ # Note: here we make sure we load with previous choice so the user |
||
| 10 | +414 |
- #' @param label_genes (`string`)\cr label for the gene selection.+ # does not constantly need to start from scratch again. |
||
| 11 | +415 |
- #' @param label_funs (`string`)\cr label for the function selection.+ # although we do not do this if the levels do not match (i.e. if |
||
| 12 | +416 |
- #' @param label_text_button (`string`)\cr label for the text input button.+ # some levels have been filtered out) |
||
| 13 | +417 |
- #' @param label_lock_button (`string`)\cr label for the lock button.+ |
||
| 14 | -+ | |||
| 418 | +! |
- #' @param label_select_all_button (`string`)\cr label for the selecting all genes button.+ selected_groups <- NULL |
||
| 15 | +419 |
- #' @param label_select_none_button (`string`)\cr label for the selecting no genes button.+ |
||
| 16 | -+ | |||
| 420 | +! |
- #' @param max_options (`count`)\cr maximum number of gene options rendering and selected via+ old_values <- names(assign_lists[[experiment_name]][[sample_var]])+ |
+ ||
| 421 | +! | +
+ if (!is.null(old_values) && |
||
| 17 | -+ | |||
| 422 | +! |
- #' "Select All".+ length(old_values) == length(sample_var_levels) && |
||
| 18 | -+ | |||
| 423 | +! |
- #' @param max_selected (`count`)\cr maximum number of genes which can be selected.+ all(sort(old_values) == sort(sample_var_levels))) {
|
||
| 19 | -+ | |||
| 424 | +! |
- #'+ selected_groups <- assign_lists[[experiment_name]][[sample_var]] |
||
| 20 | +425 |
- #' @return The UI part.+ } |
||
| 21 | +426 |
- #' @seealso [geneSpecServer()] for the module server and a complete example.+ |
||
| 22 | -+ | |||
| 427 | +! |
- #' @export+ showModal(combModal( |
||
| 23 | -+ | |||
| 428 | +! |
- #'+ sample_var_levels = sample_var_levels, |
||
| 24 | -+ | |||
| 429 | +! |
- #' @examples+ n_max_groups = `if`(!is.null(num_levels), num_levels, length(sample_var_levels)), |
||
| 25 | -+ | |||
| 430 | +! |
- #' geneSpecInput("my_genes", list(mean = colMeans), label_funs = "Please select function")
+ selected_groups = selected_groups |
||
| 26 | +431 |
- geneSpecInput <- function(inputId, # nolint+ )) |
||
| 27 | +432 |
- funs,+ } else {
|
||
| 28 | -+ | |||
| 433 | +! |
- label_genes = "Select Gene(s)",+ showNotification("Can only group levels for factor variables", type = "message")
|
||
| 29 | +434 |
- label_funs = "Select Gene Summary",+ } |
||
| 30 | +435 |
- label_text_button = "Enter list of genes",+ } |
||
| 31 | +436 |
- label_lock_button = "Lock gene selection (so that it does not get updated when filtering)",+ }) |
||
| 32 | +437 |
- label_select_all_button = paste0("Select All Genes (first ", max_options, ")"),
+
|
||
| 33 | +438 |
- label_select_none_button = "Select None",+ # When OK button is pressed, save the settings, and remove the modal. |
||
| 34 | -+ | |||
| 439 | +2x |
- max_options = 200L,+ observeEvent(input$ok, {
|
||
| 35 | -+ | |||
| 440 | +! |
- max_selected = max_options) {
+ experiment_name <- experiment_name() |
||
| 36 | -7x | +|||
| 441 | +! |
- assert_string(inputId)+ sample_var <- input$sample_var |
||
| 37 | -7x | +|||
| 442 | +! |
- assert_list(funs, names = "unique", min.len = 1L)+ comb_assignment <- input$comb_assignment |
||
| 38 | -7x | +|||
| 443 | +
- assert_string(label_genes)+ |
|||
| 39 | -7x | +|||
| 444 | +! |
- assert_string(label_funs)+ req(experiment_name, sample_var, comb_assignment) |
||
| 40 | -7x | +|||
| 445 | +
- assert_string(label_text_button)+ |
|||
| 41 | -7x | +|||
| 446 | +! |
- assert_string(label_lock_button)+ if (!is.null(num_levels) && !identical(length(unique(unlist(comb_assignment))), num_levels)) {
|
||
| 42 | -7x | +|||
| 447 | +! |
- assert_string(label_select_all_button)+ showNotification( |
||
| 43 | -7x | +|||
| 448 | +! |
- assert_string(label_select_none_button)+ paste("Please group the original levels into exactly", num_levels, "levels"),
|
||
| 44 | -7x | +|||
| 449 | +! |
- assert_count(max_options, positive = TRUE)+ type = "error" |
||
| 45 | -7x | +|||
| 450 | +
- assert_count(max_selected, positive = TRUE)+ ) |
|||
| 46 | +451 |
-
+ } else {
|
||
| 47 | -7x | +|||
| 452 | +! |
- ns <- NS(inputId)+ assign_lists[[experiment_name]][[sample_var]] <- comb_assignment |
||
| 48 | -7x | +|||
| 453 | +! |
- tagList(+ removeModal() |
||
| 49 | -7x | +|||
| 454 | +
- include_css_files(pattern = "*"),+ } |
|||
| 50 | -7x | +|||
| 455 | +
- div(+ }) |
|||
| 51 | -7x | +|||
| 456 | +
- class = "row",+ + |
+ |||
| 457 | ++ |
+ # Return both the reactives with the experiment data as well as the sample variable. |
||
| 52 | -7x | +458 | +2x |
- div(+ list( |
| 53 | -7x | +459 | +2x |
- class = "col-sm-8",+ experiment_data = final_data, |
| 54 | -7x | +460 | +2x |
- tags$label(+ sample_var = reactive({
|
| 55 | -7x | +|||
| 461 | +! |
- class = "control-label",+ input$sample_var |
||
| 56 | -7x | +|||
| 462 | +
- label_genes+ }) |
|||
| 57 | +463 |
- )+ ) |
||
| 58 | +464 |
- ),+ }) |
||
| 59 | -7x | +|||
| 465 | +
- div(+ } |
|||
| 60 | -7x | +|||
| 466 | +
- class = "col-sm-2",+ |
|||
| 61 | -7x | +|||
| 467 | +
- actionButton(+ #' Module Server for Specification of Multiple Sample Variables |
|||
| 62 | -7x | +|||
| 468 | +
- ns("select_none_button"),
+ #' |
|||
| 63 | -7x | +|||
| 469 | +
- span(icon("remove-circle", lib = "glyphicon")),
+ #' @description `r lifecycle::badge("experimental")`
|
|||
| 64 | -7x | +|||
| 470 | +
- title = label_select_none_button,+ #' |
|||
| 65 | -7x | +|||
| 471 | +
- class = "pull-right list-genes"+ #' When multiple sample variables are used in a given module, then this |
|||
| 66 | +472 |
- ),+ #' wrapper makes it much easier to specify in the server function. |
||
| 67 | -7x | +|||
| 473 | +
- actionButton(+ #' |
|||
| 68 | -7x | +|||
| 474 | +
- ns("select_all_button"),
+ #' @param inputIds (`character`)\cr multiple input IDs corresponding to the |
|||
| 69 | -7x | +|||
| 475 | +
- span(icon("ok-circle", lib = "glyphicon")),
+ #' different sample variables specified in the UI function. |
|||
| 70 | -7x | +|||
| 476 | +
- title = label_select_all_button,+ #' @inheritParams sampleVarSpecServer |
|||
| 71 | -7x | +|||
| 477 | +
- class = "pull-right list-genes"+ #' @param ... additional arguments as documented in [sampleVarSpecServer()], |
|||
| 72 | +478 |
- )+ #' namely the mandatory `experiment_name` and the optional `categorical_only`, |
||
| 73 | +479 |
- ),+ #' `num_levels` and `label_modal_title`. |
||
| 74 | -7x | +|||
| 480 | +
- div(+ #' `transformed_data` and `assign_lists` should not be |
|||
| 75 | -7x | +|||
| 481 | +
- class = "col-sm-2",+ #' specified as they are already specified internally here. |
|||
| 76 | -7x | +|||
| 482 | +
- actionButton(+ #' |
|||
| 77 | -7x | +|||
| 483 | +
- ns("text_button"),
+ #' @return List with the final transformed `experiment_data` reactive and a |
|||
| 78 | -7x | +|||
| 484 | +
- span(icon("fas fa-font")),
+ #' list `vars` which contains the selected sample variables as reactives |
|||
| 79 | -7x | +|||
| 485 | +
- title = label_text_button,+ #' under their input ID. |
|||
| 80 | -7x | +|||
| 486 | +
- class = "pull-right list-genes"+ #' |
|||
| 81 | +487 |
- ),+ #' @export |
||
| 82 | -7x | +|||
| 488 | +
- div(+ #' @examples |
|||
| 83 | -7x | +|||
| 489 | +
- class = "pull-right",+ #' \dontrun{
|
|||
| 84 | -7x | +|||
| 490 | +
- title = label_lock_button,+ #' # In the server use: |
|||
| 85 | -7x | +|||
| 491 | +
- shinyWidgets::prettyToggle(+ #' sample_var_specs <- multiSampleVarSpecServer( |
|||
| 86 | -7x | +|||
| 492 | +
- ns("lock_button"),
+ #' inputIds = c("facet_var", "color_var"),
|
|||
| 87 | -7x | +|||
| 493 | +
- value = FALSE,+ #' experiment_name = reactive({
|
|||
| 88 | -7x | +|||
| 494 | +
- label_on = NULL,+ #' input$experiment_name |
|||
| 89 | -7x | +|||
| 495 | +
- label_off = NULL,+ #' }), |
|||
| 90 | -7x | +|||
| 496 | +
- status_on = "default",+ #' original_data = ori_data # nolint Please update the <ori_data> |
|||
| 91 | -7x | +|||
| 497 | +
- status_off = "default",+ #' ) |
|||
| 92 | -7x | +|||
| 498 | +
- outline = FALSE,+ #' # Then can extract the transformed data and selected variables later: |
|||
| 93 | -7x | +|||
| 499 | +
- plain = TRUE,+ #' experiment_data <- sample_var_specs$experiment_data() |
|||
| 94 | -7x | +|||
| 500 | +
- icon_on = icon("fas fa-lock"),
+ #' facet_var <- sample_var_specs$vars$facet_var() |
|||
| 95 | -7x | +|||
| 501 | +
- icon_off = icon("fas fa-lock-open"),
+ #' color_var <- sample_var_specs$vars$color_var() |
|||
| 96 | -7x | +|||
| 502 | +
- animation = "pulse"+ #' } |
|||
| 97 | +503 |
- )+ multiSampleVarSpecServer <- function(inputIds, # nolint |
||
| 98 | +504 |
- )+ original_data, |
||
| 99 | +505 |
- )+ ...) {
|
||
| 100 | -+ | |||
| 506 | +! |
- ),+ assert_character(inputIds, any.missing = FALSE, unique = TRUE) |
||
| 101 | -7x | +|||
| 507 | +! |
- div(+ assign_lists <- reactiveValues() |
||
| 102 | -7x | +|||
| 508 | +! |
- class = "custom-select-input",+ spec_list <- list() |
||
| 103 | -7x | +|||
| 509 | +! |
- selectizeInput(+ transformed_data <- original_data |
||
| 104 | -7x | +|||
| 510 | +! |
- ns("genes"),
+ for (id in inputIds) {
|
||
| 105 | -7x | +|||
| 511 | +! |
- label = NULL,+ spec_list[[id]] <- sampleVarSpecServer( |
||
| 106 | -7x | +|||
| 512 | +! |
- choices = "",+ id, |
||
| 107 | -7x | +|||
| 513 | +! |
- multiple = TRUE,+ original_data = original_data, |
||
| 108 | -7x | +|||
| 514 | +! |
- selected = 1,+ transformed_data = transformed_data, |
||
| 109 | -7x | +|||
| 515 | +! |
- options = list(+ assign_lists = assign_lists, |
||
| 110 | -7x | +|||
| 516 | +
- placeholder = "- Nothing selected -",+ ... |
|||
| 111 | -7x | +|||
| 517 | +
- render = I("{
+ ) |
|||
| 112 | -7x | +|||
| 518 | +! |
- option: function(item, escape) {
+ transformed_data <- spec_list[[id]]$experiment_data |
||
| 113 | -7x | +|||
| 519 | +
- return '<div> <span style=\"font-size: inherit;\">' + item.label + '</div>' ++ } |
|||
| 114 | -7x | +|||
| 520 | +! |
- ' <span style=\"color: #808080; font-size: xx-small;\" >' + item.value + '</div> </div>'+ list(+ |
+ ||
| 521 | +! | +
+ experiment_data = transformed_data,+ |
+ ||
| 522 | +! | +
+ vars = lapply(spec_list, "[[", "sample_var") |
||
| 115 | +523 |
- }+ ) |
||
| 116 | +524 |
- }"),+ } |
||
| 117 | -7x | +
| 1 | +
- searchField = c("value", "label"),
+ #' Teal Module for RNA-seq Scatterplot |
|||
| 118 | -7x | +|||
| 2 | +
- maxOptions = max_options,+ #' |
|||
| 119 | -7x | +|||
| 3 | +
- maxItems = max_selected+ #' @description `r lifecycle::badge("experimental")`
+ |
+ |||
| 4 | ++ |
+ #' |
||
| 120 | +5 |
- )+ #' This module provides an interactive scatterplot for RNA-seq gene expression |
||
| 121 | +6 |
- )+ #' analysis. |
||
| 122 | +7 |
- ),+ #' |
||
| 123 | -7x | +|||
| 8 | +
- conditionalPanel(+ #' @inheritParams module_arguments |
|||
| 124 | -7x | +|||
| 9 | +
- condition = "input.genes && input.genes.length > 1",+ #' |
|||
| 125 | -7x | +|||
| 10 | +
- ns = ns,+ #' @return Shiny module to be used in the teal app. |
|||
| 126 | -7x | +|||
| 11 | +
- selectInput(+ #' |
|||
| 127 | -7x | +|||
| 12 | +
- ns("fun_name"),
+ #' @export |
|||
| 128 | -7x | +|||
| 13 | +
- label_funs,+ #' |
|||
| 129 | -7x | +|||
| 14 | +
- names(funs)+ #' @examples |
|||
| 130 | +15 |
- )+ #' mae <- hermes::multi_assay_experiment |
||
| 131 | +16 |
- )+ #' mae_data <- dataset("MAE", mae)
|
||
| 132 | +17 |
- )+ #' data <- teal_data(mae_data) |
||
| 133 | +18 |
- }+ #' app <- init( |
||
| 134 | +19 |
-
+ #' data = data, |
||
| 135 | +20 |
- #' Helper Function to Update Gene Selection+ #' modules = modules( |
||
| 136 | +21 |
- #'+ #' tm_g_scatterplot( |
||
| 137 | +22 |
- #' @description `r lifecycle::badge("experimental")`
+ #' label = "scatterplot", |
||
| 138 | +23 |
- #'+ #' mae_name = "MAE" |
||
| 139 | +24 |
- #' This helper function takes the intersection of `selected` and+ #' ) |
||
| 140 | +25 |
- #' `choices` for genes and updates the `inputId` accordingly. It then+ #' ) |
||
| 141 | +26 |
- #' shows a notification if not all `selected` genes were available.+ #' ) |
||
| 142 | +27 |
- #'+ #' if (interactive()) {
|
||
| 143 | +28 |
- #' @inheritParams module_arguments+ #' shinyApp(app$ui, app$server) |
||
| 144 | +29 |
- #' @param session (`ShinySession`)\cr the session object.+ #' } |
||
| 145 | +30 |
- #' @param selected (`character`)\cr currently selected gene IDs.+ tm_g_scatterplot <- function(label, |
||
| 146 | +31 |
- #' @param choices (`data.frame`)\cr containing `id` and `name` columns of the+ mae_name, |
||
| 147 | +32 |
- #' new choices.+ exclude_assays = "counts", |
||
| 148 | +33 |
- #'+ summary_funs = list( |
||
| 149 | +34 |
- #' @export+ Mean = colMeans, |
||
| 150 | +35 |
- h_update_gene_selection <- function(session,+ Median = matrixStats::colMedians, |
||
| 151 | +36 |
- inputId, # nolint+ Max = matrixStats::colMaxs |
||
| 152 | +37 |
- selected,+ ), |
||
| 153 | +38 |
- choices) {
+ pre_output = NULL, |
||
| 154 | -! | +|||
| 39 | +
- is_new_selected <- selected %in% choices$id+ post_output = NULL) {
|
|||
| 155 | +40 | ! |
- is_removed <- !is_new_selected+ logger::log_info("Initializing tm_g_scatterplot")
|
|
| 156 | +41 | ! |
- updateSelectizeInput(+ assert_string(label) |
|
| 157 | +42 | ! |
- session = session,+ assert_string(mae_name) |
|
| 158 | +43 | ! |
- inputId = inputId,+ assert_character(exclude_assays, any.missing = FALSE) |
|
| 159 | +44 | ! |
- selected = selected[is_new_selected],+ assert_summary_funs(summary_funs) |
|
| 160 | +45 | ! |
- choices = stats::setNames(choices$id, choices$name),+ assert_tag(pre_output, null.ok = TRUE) |
|
| 161 | +46 | ! |
- server = TRUE+ assert_tag(post_output, null.ok = TRUE) |
|
| 162 | +47 |
- )+ |
||
| 163 | -+ | |||
| 48 | +! |
-
+ teal::module( |
||
| 164 | +49 | ! |
- n_removed <- sum(is_removed)+ label = label, |
|
| 165 | +50 | ! |
- if (n_removed > 0) {
+ server = srv_g_scatterplot, |
|
| 166 | +51 | ! |
- showNotification(paste(+ server_args = list( |
|
| 167 | +52 | ! |
- "Removed", n_removed, ifelse(n_removed > 1, "genes", "gene"),+ mae_name = mae_name, |
|
| 168 | +53 | ! |
- hermes::h_parens(hermes::h_short_list(selected[is_removed]))+ summary_funs = summary_funs, |
|
| 169 | -+ | |||
| 54 | +! |
- ))+ exclude_assays = exclude_assays |
||
| 170 | +55 |
- }+ ), |
||
| 171 | -+ | |||
| 56 | +! |
- }+ ui = ui_g_scatterplot, |
||
| 172 | -+ | |||
| 57 | +! |
-
+ ui_args = list( |
||
| 173 | -+ | |||
| 58 | +! |
- #' Helper Function to Parse Genes+ mae_name = mae_name, |
||
| 174 | -+ | |||
| 59 | +! |
- #'+ summary_funs = summary_funs, |
||
| 175 | -+ | |||
| 60 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ pre_output = pre_output, |
||
| 176 | -+ | |||
| 61 | +! |
- #'+ post_output = post_output |
||
| 177 | +62 |
- #' This helper function takes a vector of `words` and tries to match them+ ), |
||
| 178 | -+ | |||
| 63 | +! |
- #' with the `id` and `name` columns of possible gene choices.+ datanames = mae_name |
||
| 179 | +64 |
- #'+ ) |
||
| 180 | +65 |
- #' @param words (`character`)\cr containing gene IDs or names.+ } |
||
| 181 | +66 |
- #' @inheritParams h_update_gene_selection+ |
||
| 182 | +67 |
- #' @return The subset of `choices` which matches `words` in ID or name.+ #' @describeIn tm_g_scatterplot sets up the user interface. |
||
| 183 | +68 |
- #'+ #' @inheritParams module_arguments |
||
| 184 | +69 |
#' @export |
||
| 185 | +70 |
- #' @examples+ ui_g_scatterplot <- function(id, |
||
| 186 | +71 |
- #' h_parse_genes(+ data, |
||
| 187 | +72 |
- #' c("a", "2535"),
+ mae_name, |
||
| 188 | +73 |
- #' data.frame(id = as.character(2533:2537), name = letters[1:5])+ summary_funs, |
||
| 189 | +74 |
- #' )+ pre_output, |
||
| 190 | +75 |
- h_parse_genes <- function(words, choices) {
- |
- ||
| 191 | -2x | -
- assert_character(words, min.len = 1L)- |
- ||
| 192 | -2x | -
- assert_data_frame(choices, types = "character")+ post_output) {
|
||
| 193 | -2x | +76 | +1x |
- assert_set_equal(names(choices), c("id", "name"))
+ ns <- NS(id) |
| 194 | +77 | |||
| 195 | -2x | +78 | +1x |
- id_matches <- choices$id %in% words+ smooth_method_choices <- c( |
| 196 | -2x | +79 | +1x |
- name_matches <- choices$name %in% words+ Linear = "lm", |
| 197 | -2x | +80 | +1x |
- has_match <- id_matches | name_matches+ Loess = "loess", |
| 198 | -2x | +81 | +1x |
- choices[has_match, , drop = FALSE]+ None = "none" |
| 199 | +82 |
- }+ ) |
||
| 200 | +83 | |||
| 201 | -- |
- #' Module Server for Gene Signature Specification- |
- ||
| 202 | -- |
- #'- |
- ||
| 203 | -+ | |||
| 84 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ teal.widgets::standard_layout( |
||
| 204 | -+ | |||
| 85 | +1x |
- #'+ encoding = div( |
||
| 205 | +86 |
- #' This defines the server part for the gene signature specification.+ ### Reporter |
||
| 206 | -+ | |||
| 87 | +1x |
- #'+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
||
| 207 | +88 |
- #' @inheritParams module_arguments+ ### |
||
| 208 | -+ | |||
| 89 | +1x |
- #' @param funs (static named `list`)\cr names of this list will be used for the function+ tags$label("Encodings", class = "text-primary"),
|
||
| 209 | -+ | |||
| 90 | +1x |
- #' selection drop down menu.+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
||
| 210 | -+ | |||
| 91 | +1x |
- #' @param gene_choices (reactive `data.frame`)\cr returns the possible gene choices to+ experimentSpecInput(ns("experiment"), data, mae_name),
|
||
| 211 | -+ | |||
| 92 | +1x |
- #' populate in the UI, as a `data.frame` with columns `id` and `name`.+ assaySpecInput(ns("assay")),
|
||
| 212 | -+ | |||
| 93 | +1x |
- #' @param label_modal_title (`string`)\cr title for the dialog that asks for the text input.+ geneSpecInput(ns("x_spec"), summary_funs, label_genes = "Select x Gene(s)"),
|
||
| 213 | -+ | |||
| 94 | +1x |
- #' @param label_modal_footer (`character`)\cr lines of text to use for the footer of the dialog.+ geneSpecInput(ns("y_spec"), summary_funs, label_genes = "Select y Gene(s)"),
|
||
| 214 | -+ | |||
| 95 | +1x |
- #'+ teal.widgets::panel_group( |
||
| 215 | -+ | |||
| 96 | +1x |
- #' @return Reactive [`hermes::GeneSpec`] which can be used as input for the relevant+ teal.widgets::panel_item( |
||
| 216 | -+ | |||
| 97 | +1x |
- #' `hermes` functions.+ input_id = "settings_item", |
||
| 217 | -+ | |||
| 98 | +1x |
- #' @seealso [geneSpecInput()] for the module UI.+ collapsed = TRUE, |
||
| 218 | -+ | |||
| 99 | +1x |
- #'+ title = "Additional Settings", |
||
| 219 | -+ | |||
| 100 | +1x |
- #' @export+ sampleVarSpecInput(ns("color_var"), "Optional color variable"),
|
||
| 220 | -+ | |||
| 101 | +1x |
- #'+ sampleVarSpecInput(ns("facet_var"), "Optional facet variable"),
|
||
| 221 | -+ | |||
| 102 | +1x |
- #' @examples+ selectInput(ns("smooth_method"), "Select smoother", smooth_method_choices)
|
||
| 222 | +103 |
- #' ui <- function(id,+ ) |
||
| 223 | +104 |
- #' data,+ ) |
||
| 224 | +105 |
- #' funs) {
+ ), |
||
| 225 | -+ | |||
| 106 | +1x |
- #' ns <- NS(id)+ output = teal.widgets::plot_with_settings_ui(ns("plot")),
|
||
| 226 | -+ | |||
| 107 | +1x |
- #' teal.widgets::standard_layout(+ pre_output = pre_output, |
||
| 227 | -+ | |||
| 108 | +1x |
- #' encoding = div(+ post_output = post_output |
||
| 228 | +109 |
- #' geneSpecInput(+ ) |
||
| 229 | +110 |
- #' ns("my_genes"),
+ } |
||
| 230 | +111 |
- #' funs = funs,+ |
||
| 231 | +112 |
- #' label_funs = "Please select function"+ #' @describeIn tm_g_scatterplot sets up the server with reactive graph. |
||
| 232 | +113 |
- #' )+ #' @inheritParams module_arguments |
||
| 233 | +114 |
- #' ),+ #' @export |
||
| 234 | +115 |
- #' output = textOutput(ns("result"))
+ srv_g_scatterplot <- function(id, |
||
| 235 | +116 |
- #' )+ data, |
||
| 236 | +117 |
- #' }+ filter_panel_api, |
||
| 237 | +118 |
- #' server <- function(id,+ reporter, |
||
| 238 | +119 |
- #' data,+ mae_name, |
||
| 239 | +120 |
- #' funs) {
+ exclude_assays, |
||
| 240 | +121 |
- #' moduleServer(id, function(input, output, session) {
+ summary_funs) {
|
||
| 241 | -+ | |||
| 122 | +! |
- #' gene_choices <- reactive({
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
||
| 242 | -+ | |||
| 123 | +! |
- #' mae <- data[["MAE"]]()+ assert_class(filter_panel_api, "FilterPanelAPI") |
||
| 243 | -+ | |||
| 124 | +! |
- #' object <- mae[[1]]+ assert_class(data, "tdata") |
||
| 244 | +125 |
- #' gene_ids <- rownames(object)+ |
||
| 245 | -+ | |||
| 126 | +! |
- #' gene_names <- SummarizedExperiment::rowData(object)$symbol+ moduleServer(id, function(input, output, session) {
|
||
| 246 | -+ | |||
| 127 | +! |
- #' gene_data <- data.frame(+ experiment <- experimentSpecServer( |
||
| 247 | -+ | |||
| 128 | +! |
- #' id = gene_ids,+ "experiment", |
||
| 248 | -+ | |||
| 129 | +! |
- #' name = gene_names+ data = data, |
||
| 249 | -+ | |||
| 130 | +! |
- #' )+ filter_panel_api = filter_panel_api, |
||
| 250 | -+ | |||
| 131 | +! |
- #' gene_data[order(gene_data$name), ]+ mae_name = mae_name |
||
| 251 | +132 |
- #' })+ ) |
||
| 252 | -+ | |||
| 133 | +! |
- #' gene_spec <- geneSpecServer(+ assay <- assaySpecServer( |
||
| 253 | -+ | |||
| 134 | +! |
- #' "my_genes",+ "assay", |
||
| 254 | -+ | |||
| 135 | +! |
- #' funs = funs,+ assays = experiment$assays, |
||
| 255 | -+ | |||
| 136 | +! |
- #' gene_choices = gene_choices+ exclude_assays = exclude_assays |
||
| 256 | +137 |
- #' )+ ) |
||
| 257 | -+ | |||
| 138 | +! |
- #' output$result <- renderText({
+ sample_var_specs <- multiSampleVarSpecServer( |
||
| 258 | -+ | |||
| 139 | +! |
- #' validate_gene_spec(+ inputIds = c("facet_var", "color_var"),
|
||
| 259 | -+ | |||
| 140 | +! |
- #' gene_spec(),+ experiment_name = experiment$name, |
||
| 260 | -+ | |||
| 141 | +! |
- #' gene_choices()$id+ original_data = experiment$data |
||
| 261 | +142 |
- #' )+ ) |
||
| 262 | -+ | |||
| 143 | +! |
- #' gene_spec <- gene_spec()+ x_spec <- geneSpecServer("x_spec", summary_funs, experiment$genes)
|
||
| 263 | -+ | |||
| 144 | +! |
- #' gene_spec$get_label()+ y_spec <- geneSpecServer("y_spec", summary_funs, experiment$genes)
|
||
| 264 | +145 |
- #' })+ |
||
| 265 | -+ | |||
| 146 | +! |
- #' })+ plot_r <- reactive({
|
||
| 266 | +147 |
- #' }+ # Resolve all reactivity. |
||
| 267 | -+ | |||
| 148 | +! |
- #' funs <- list(mean = colMeans)+ experiment_data <- sample_var_specs$experiment_data() |
||
| 268 | -+ | |||
| 149 | +! |
- #' my_app <- function() {
+ x_spec <- x_spec() |
||
| 269 | -+ | |||
| 150 | +! |
- #' mae <- hermes::multi_assay_experiment+ y_spec <- y_spec() |
||
| 270 | -+ | |||
| 151 | +! |
- #' mae_data <- dataset("MAE", mae)
+ facet_var <- sample_var_specs$vars$facet_var() |
||
| 271 | -+ | |||
| 152 | +! |
- #' data <- teal_data(mae_data)+ color_var <- sample_var_specs$vars$color_var() |
||
| 272 | -+ | |||
| 153 | +! |
- #' app <- init(+ assay_name <- assay() |
||
| 273 | -+ | |||
| 154 | +! |
- #' data = data,+ smooth_method <- input$smooth_method |
||
| 274 | +155 |
- #' modules = modules(+ |
||
| 275 | -+ | |||
| 156 | +! |
- #' module(+ validate_gene_spec(x_spec, rownames(experiment_data)) |
||
| 276 | -+ | |||
| 157 | +! |
- #' label = "GeneSpec example",+ validate_gene_spec(y_spec, rownames(experiment_data)) |
||
| 277 | +158 |
- #' server = server,+ |
||
| 278 | +159 |
- #' server_args = list(funs = funs),+ # Require which states need to be truthy. |
||
| 279 | -+ | |||
| 160 | +! |
- #' ui = ui,+ req( |
||
| 280 | -+ | |||
| 161 | +! |
- #' ui_args = list(funs = funs),+ smooth_method, |
||
| 281 | +162 |
- #' datanames = "all"+ # Note: The following statements are important to make sure the UI inputs have been updated. |
||
| 282 | -+ | |||
| 163 | +! |
- #' )+ isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)), |
||
| 283 | -+ | |||
| 164 | +! |
- #' )+ is.null(facet_var) || isTRUE(facet_var %in% names(SummarizedExperiment::colData(experiment_data))), |
||
| 284 | -+ | |||
| 165 | +! |
- #' )+ is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))), |
||
| 285 | -+ | |||
| 166 | +! |
- #' shinyApp(app$ui, app$server)+ cancelOutput = FALSE |
||
| 286 | +167 |
- #' }+ ) |
||
| 287 | +168 |
- #' if (interactive()) {
+
|
||
| 288 | -+ | |||
| 169 | +! |
- #' my_app()+ hermes::draw_scatterplot( |
||
| 289 | -+ | |||
| 170 | +! |
- #' }+ object = experiment_data, |
||
| 290 | -+ | |||
| 171 | +! |
- geneSpecServer <- function(id, # nolint+ assay_name = assay_name, |
||
| 291 | -+ | |||
| 172 | +! |
- funs,+ x_spec = x_spec, |
||
| 292 | -+ | |||
| 173 | +! |
- gene_choices,+ y_spec = y_spec, |
||
| 293 | -+ | |||
| 174 | +! |
- label_modal_title = "Enter list of genes",+ facet_var = facet_var, |
||
| 294 | -+ | |||
| 175 | +! |
- label_modal_footer = c(+ color_var = color_var, |
||
| 295 | -+ | |||
| 176 | +! |
- "Please enter a comma-separated list of gene IDs and/or names.",+ smooth_method = smooth_method |
||
| 296 | +177 |
- "(Note that genes not included in current choices will be removed)"+ ) |
||
| 297 | +178 |
- )) {
+ }) |
||
| 298 | +179 | ! |
- assert_string(id)+ output$plot <- renderPlot(plot_r()) |
|
| 299 | -! | +|||
| 180 | +
- assert_list(funs, names = "unique", min.len = 1L)+ |
|||
| 300 | +181 | ! |
- assert_reactive(gene_choices)+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 301 | +182 | ! |
- assert_string(label_modal_title)+ id = "plot", |
|
| 302 | +183 | ! |
- assert_character(label_modal_footer)+ plot_r = plot_r |
|
| 303 | +184 |
-
+ ) |
||
| 304 | -! | +|||
| 185 | +
- moduleServer(id, function(input, output, session) {
+
|
|||
| 305 | +186 |
- # The `reactiveValues` object for storing current gene text input.+ ### REPORTER |
||
| 306 | -+ | |||
| 187 | +! |
- # This will also be a data frame with id and name columns.+ if (with_reporter) {
|
||
| 307 | +188 | ! |
- parsed_genes <- reactiveVal(NULL, label = "Parsed genes")+ card_fun <- function(comment, label) {
|
|
| 308 | -+ | |||
| 189 | +! |
-
+ card <- report_card_template( |
||
| 309 | -+ | |||
| 190 | +! |
- # If the parsed genes are entered via text, update gene selection.+ title = "Scatter Plot", |
||
| 310 | +191 | ! |
- observeEvent(parsed_genes(), ignoreNULL = TRUE, {
+ label = label, |
|
| 311 | +192 | ! |
- gene_choices <- gene_choices()+ with_filter = TRUE, |
|
| 312 | +193 | ! |
- parsed_genes <- parsed_genes()+ filter_panel_api = filter_panel_api |
|
| 313 | +194 |
-
+ ) |
||
| 314 | +195 | ! |
- h_update_gene_selection(+ card$append_text("Selected Options", "header3")
|
|
| 315 | +196 | ! |
- session,+ encodings_list <- list( |
|
| 316 | +197 | ! |
- inputId = "genes",+ "Experiment:", |
|
| 317 | +198 | ! |
- selected = parsed_genes$id,+ input$`experiment-name`, |
|
| 318 | +199 | ! |
- choices = gene_choices+ "\nAssay:", |
|
| 319 | -+ | |||
| 200 | +! |
- )+ input$`assay-name`, |
||
| 320 | -+ | |||
| 201 | +! |
- })+ "\nX Genes Selected:", |
||
| 321 | -+ | |||
| 202 | +! |
-
+ paste0(x_spec()$get_gene_labels(), collapse = ", "), |
||
| 322 | -+ | |||
| 203 | +! |
- # When+ "\nX Genes Summary:", |
||
| 323 | -+ | |||
| 204 | +! |
- # 1) the gene choices are recomputed,+ input$`x_spec-fun_name`, |
||
| 324 | -+ | |||
| 205 | +! |
- # 2) the lock is pressed and then switched off,+ "\nY Genes Selected:", |
||
| 325 | -+ | |||
| 206 | +! |
- # then update gene selection.+ paste0(y_spec()$get_gene_labels(), collapse = ", "), |
||
| 326 | +207 | ! |
- observeEvent(list(gene_choices(), input$lock_button), {
+ "\nY Genes Summary:", |
|
| 327 | +208 | ! |
- gene_choices <- gene_choices()+ input$`y_spec-fun_name`, |
|
| 328 | +209 | ! |
- lock_button <- input$lock_button+ "\nOptional Color Variable:", |
|
| 329 | +210 | ! |
- old_selected <- input$genes+ input$`color_var-sample_var`, |
|
| 330 | -+ | |||
| 211 | +! |
-
+ "\nOptional Facetting Variable:", |
||
| 331 | +212 | ! |
- if (isFALSE(lock_button)) {
+ input$`facet_var-sample_var`, |
|
| 332 | +213 | ! |
- h_update_gene_selection(+ "\nSmoother:", |
|
| 333 | +214 | ! |
- session,+ input$smooth_method+ |
+ |
| 215 | ++ |
+ ) |
||
| 334 | +216 | ! |
- inputId = "genes",+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 335 | +217 | ! |
- selected = old_selected,+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 336 | +218 | ! |
- choices = gene_choices+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 337 | -+ | |||
| 219 | +! |
- )+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
||
| 338 | +220 |
- }+ } else {
|
||
| 339 | -+ | |||
| 221 | +! |
- })+ paste(encodings_list, collapse = " ") |
||
| 340 | +222 |
-
+ } |
||
| 341 | +223 |
- # When the Select All button is pressed and not locked, select all genes.+ |
||
| 342 | +224 | ! |
- observeEvent(input$select_all_button, {
+ card$append_text(final_encodings, style = "verbatim") |
|
| 343 | +225 | ! |
- gene_choices <- gene_choices()+ card$append_text("Plot", "header3")
|
|
| 344 | +226 | ! |
- lock_button <- input$lock_button+ card$append_plot(plot_r(), dim = pws$dim()) |
|
| 345 | -+ | |||
| 227 | +! |
-
+ if (!comment == "") {
|
||
| 346 | +228 | ! |
- if (isFALSE(lock_button)) {
+ card$append_text("Comment", "header3")
|
|
| 347 | +229 | ! |
- h_update_gene_selection(+ card$append_text(comment) |
|
| 348 | -! | +|||
| 230 | +
- session,+ } |
|||
| 349 | +231 | ! |
- inputId = "genes",+ card |
|
| 350 | -! | +|||
| 232 | +
- selected = gene_choices$id,+ } |
|||
| 351 | +233 | ! |
- choices = gene_choices+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 352 | +234 |
- )+ } |
||
| 353 | +235 |
- } else {
+ ### |
||
| 354 | -! | +|||
| 236 | +
- showNotification(+ }) |
|||
| 355 | -! | +|||
| 237 | +
- "Please unlock if you would like to select all genes",+ } |
|||
| 356 | -! | +|||
| 238 | +
- type = "warning"+ |
|||
| 357 | +239 |
- )+ #' @describeIn tm_g_scatterplot sample module function. |
||
| 358 | +240 |
- }+ #' @export |
||
| 359 | +241 |
- })+ #' @examples |
||
| 360 | +242 |
-
+ #' |
||
| 361 | +243 |
- # When the Select None button is pressed and not locked, select none.+ #' # Alternatively you can run the sample module with this function call: |
||
| 362 | -! | +|||
| 244 | +
- observeEvent(input$select_none_button, {
+ #' if (interactive()) {
+ |
+ |||
| 245 | ++ |
+ #' sample_tm_g_scatterplot()+ |
+ ||
| 246 | ++ |
+ #' }+ |
+ ||
| 247 | ++ |
+ sample_tm_g_scatterplot <- function() {
|
||
| 363 | +248 | ! |
- gene_choices <- gene_choices()+ mae <- hermes::multi_assay_experiment |
|
| 364 | +249 | ! |
- lock_button <- input$lock_button+ mae_data <- teal.data::dataset("MAE", mae)
|
|
| 365 | -+ | |||
| 250 | +! |
-
+ data <- teal.data::teal_data(mae_data) |
||
| 366 | +251 | ! |
- if (isFALSE(lock_button)) {
+ app <- teal::init( |
|
| 367 | +252 | ! |
- h_update_gene_selection(+ data = data, |
|
| 368 | +253 | ! |
- session,+ modules = teal::modules( |
|
| 369 | +254 | ! |
- inputId = "genes",+ tm_g_scatterplot( |
|
| 370 | +255 | ! |
- selected = character(),+ label = "scatterplot", |
|
| 371 | +256 | ! |
- choices = gene_choices+ mae_name = "MAE" |
|
| 372 | +257 |
- )+ ) |
||
| 373 | +258 |
- } else {
+ ) |
||
| 374 | -! | +|||
| 259 | +
- showNotification(+ ) |
|||
| 375 | +260 | ! |
- "Please unlock if you would like to select none",+ shinyApp(app$ui, app$server) |
|
| 376 | -! | +|||
| 261 | +
- type = "warning"+ } |
| 377 | +1 |
- )+ #' Teal Module for PCA Analysis |
|
| 378 | +2 |
- }+ #'+ |
+ |
| 3 | ++ |
+ #' @description `r lifecycle::badge("experimental")`
+ |
+ |
| 4 | ++ |
+ #'+ |
+ |
| 5 | ++ |
+ #' This module provides an interactive principal components plot and an+ |
+ |
| 6 | ++ |
+ #' interactive heatmap with correlation of principal components with sample+ |
+ |
| 7 | ++ |
+ #' variables. |
|
| 379 | +8 |
- })+ #' |
|
| 380 | +9 |
-
+ #' @inheritParams module_arguments |
|
| 381 | +10 |
- # Return the UI for a modal dialog with gene text input, showing examples.+ #' |
|
| 382 | -! | +||
| 11 | +
- dataModal <- function(example_list) { # nolint
+ #' @return Shiny module to be used in the teal app. |
||
| 383 | -! | +||
| 12 | +
- modalDialog(+ #' @export |
||
| 384 | -! | +||
| 13 | +
- textInput(+ #' |
||
| 385 | -! | +||
| 14 | +
- session$ns("gene_text"),
+ #' @examples |
||
| 386 | -! | +||
| 15 | +
- label = label_modal_title,+ #' mae <- hermes::multi_assay_experiment |
||
| 387 | -! | +||
| 16 | +
- placeholder = example_list+ #' mae_data <- dataset("MAE", mae)
|
||
| 388 | +17 |
- ),+ #' data <- teal_data(mae_data) |
|
| 389 | -! | +||
| 18 | +
- do.call("span", as.list(label_modal_footer)),
+ #' app <- init( |
||
| 390 | -! | +||
| 19 | +
- footer = tagList(+ #' data = data, |
||
| 391 | -! | +||
| 20 | +
- modalButton("Cancel"),
+ #' modules = modules( |
||
| 392 | -! | +||
| 21 | +
- actionButton(session$ns("ok_button"), "OK")
+ #' tm_g_pca( |
||
| 393 | +22 |
- )+ #' label = "PCA plot", |
|
| 394 | +23 |
- )+ #' mae_name = "MAE" |
|
| 395 | +24 |
- }+ #' ) |
|
| 396 | +25 |
-
+ #' ) |
|
| 397 | +26 |
- # Show modal when the text button is clicked.+ #' ) |
|
| 398 | -! | +||
| 27 | +
- observeEvent(input$text_button, {
+ #' if (interactive()) {
|
||
| 399 | -! | +||
| 28 | +
- gene_choices <- gene_choices()+ #' shinyApp(app$ui, app$server) |
||
| 400 | -! | +||
| 29 | +
- example_list <- hermes::h_short_list(utils::head(setdiff(gene_choices$name, "")))+ #' } |
||
| 401 | -! | +||
| 30 | +
- showModal(dataModal(example_list))+ tm_g_pca <- function(label, |
||
| 402 | +31 |
- })+ mae_name, |
|
| 403 | +32 |
-
+ exclude_assays = character(), |
|
| 404 | +33 |
- # When OK button is pressed, attempt to parse the genes from the text.+ pre_output = NULL, |
|
| 405 | +34 |
- # This can be IDs and/or names of genes.+ post_output = NULL) {
|
|
| 406 | -+ | ||
| 35 | +! |
- # Remove the modal and display notification message.+ logger::log_info("Initializing tm_g_pca")
|
|
| 407 | +36 | ! |
- observeEvent(input$ok_button, {
+ assert_string(label) |
| 408 | +37 | ! |
- gene_text <- input$gene_text+ assert_string(mae_name) |
| 409 | +38 | ! |
- gene_choices <- gene_choices()+ assert_tag(pre_output, null.ok = TRUE)+ |
+
| 39 | +! | +
+ assert_tag(post_output, null.ok = TRUE) |
|
| 410 | +40 | ||
| 411 | +41 | ! |
- if (!nzchar(gene_text)) {
+ teal::module( |
| 412 | +42 | ! |
- showNotification(+ label = label, |
| 413 | +43 | ! |
- "Please enter at least one full gene ID.",+ server = srv_g_pca, |
| 414 | +44 | ! |
- type = "error"+ server_args = list( |
| 415 | -+ | ||
| 45 | +! |
- )+ mae_name = mae_name,+ |
+ |
| 46 | +! | +
+ exclude_assays = exclude_assays |
|
| 416 | +47 |
- } else {
+ ), |
|
| 417 | +48 | ! |
- words <- h_extract_words(gene_text)+ ui = ui_g_pca, |
| 418 | +49 | ! |
- parse_result <- h_parse_genes(words, choices = gene_choices)+ ui_args = list( |
| 419 | +50 | ! |
- showNotification(paste(+ mae_name = mae_name, |
| 420 | +51 | ! |
- "Parsed total", nrow(parse_result), "genes from", length(words), "words"+ pre_output = pre_output, |
| 421 | -+ | ||
| 52 | +! |
- ))+ post_output = post_output |
|
| 422 | -! | +||
| 53 | +
- parsed_genes(parse_result)+ ), |
||
| 423 | +54 | ! |
- removeModal()+ datanames = mae_name |
| 424 | +55 |
- }+ ) |
|
| 425 | +56 |
- })+ } |
|
| 426 | +57 | ||
| 427 | +58 |
- # When the gene choice is updated, then also set the names+ #' @describeIn tm_g_pca sets up the user interface. |
|
| 428 | +59 |
- # correctly by looking up in current choices.+ #' @inheritParams module_arguments |
|
| 429 | -! | +||
| 60 | +
- named_genes <- eventReactive(input$genes, ignoreNULL = FALSE, {
+ #' @export |
||
| 430 | -! | +||
| 61 | +
- genes <- input$genes+ ui_g_pca <- function(id, |
||
| 431 | -! | +||
| 62 | +
- gene_choices <- gene_choices()+ data, |
||
| 432 | -! | +||
| 63 | +
- ret <- if (!is.null(genes)) {
+ mae_name, |
||
| 433 | -! | +||
| 64 | +
- which_id <- match(genes, gene_choices$id)+ pre_output, |
||
| 434 | -! | +||
| 65 | +
- gene_names <- gene_choices$name[which_id]+ post_output) {
|
||
| 435 | -! | +||
| 66 | +1x |
- stats::setNames(genes, gene_names)+ ns <- NS(id) |
|
| 436 | -+ | ||
| 67 | +1x |
- } else {
+ mae <- data[[mae_name]]() |
|
| 437 | -! | +||
| 68 | +1x |
- NULL+ experiment_name_choices <- names(mae) |
|
| 438 | +69 |
- }+ |
|
| 439 | -! | +||
| 70 | +1x |
- ret+ tagList( |
|
| 440 | -+ | ||
| 71 | +1x |
- })+ teal.widgets::standard_layout( |
|
| 441 | -+ | ||
| 72 | +1x |
-
+ include_css_files(pattern = "*"), |
|
| 442 | -! | +||
| 73 | +1x |
- reactive({
+ encoding = div( |
|
| 443 | -! | +||
| 74 | +
- hermes::gene_spec(+ ### Reporter |
||
| 444 | -! | +||
| 75 | +1x |
- genes = named_genes(),+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 445 | -! | +||
| 76 | +
- fun = funs[[input$fun_name]],+ ### |
||
| 446 | -! | +||
| 77 | +1x |
- fun_name = input$fun_name+ tags$label("Encodings", class = "text-primary"),
|
|
| 447 | -+ | ||
| 78 | +1x |
- )+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|
| 448 | -+ | ||
| 79 | +1x |
- })+ experimentSpecInput(ns("experiment"), data, mae_name),
|
|
| 449 | -+ | ||
| 80 | +1x |
- })+ assaySpecInput(ns("assay")),
|
|
| 450 | -+ | ||
| 81 | +1x |
- }+ conditionalPanel( |
|
| 451 | -+ | ||
| 82 | +1x |
-
+ condition = "input.tab_selected == 'PCA'", |
|
| 452 | -+ | ||
| 83 | +1x |
- #' Validation of Gene Specification+ ns = ns, |
|
| 453 | -+ | ||
| 84 | +1x |
- #'+ sampleVarSpecInput(ns("color"), "Optional color variable"),
|
|
| 454 | -+ | ||
| 85 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ selectizeInput(ns("x_var"), "Select X-axis PC", choices = ""),
|
|
| 455 | -+ | ||
| 86 | +1x |
- #'+ selectizeInput(ns("y_var"), "Select Y-axis PC", choices = "")
|
|
| 456 | +87 |
- #' This validation function checks that a given [`hermes::GeneSpec`] has at least+ ), |
|
| 457 | -+ | ||
| 88 | +1x |
- #' one gene selected and that all genes are included in possible choices.+ teal.widgets::panel_group(+ |
+ |
| 89 | +1x | +
+ teal.widgets::panel_item( |
|
| 458 | -+ | ||
| 90 | +1x |
- #'+ input_id = "settings_item", |
|
| 459 | -+ | ||
| 91 | +1x |
- #' @param gene_spec (`GeneSpec`)\cr gene specification.+ collapsed = TRUE, |
|
| 460 | -+ | ||
| 92 | +1x |
- #' @param gene_choices (`character`)\cr all possible gene choices.+ title = "Additional Settings", |
|
| 461 | -+ | ||
| 93 | +1x |
- #'+ tags$label("Use only Top Variance Genes"),
|
|
| 462 | -+ | ||
| 94 | +1x |
- #' @export+ shinyWidgets::switchInput(ns("filter_top"), value = FALSE, size = "mini"),
|
|
| 463 | -+ | ||
| 95 | +1x |
- validate_gene_spec <- function(gene_spec,+ conditionalPanel( |
|
| 464 | -+ | ||
| 96 | +1x |
- gene_choices) {
+ condition = "input.filter_top", |
|
| 465 | -! | +||
| 97 | +1x |
- assert_r6(gene_spec, "GeneSpec")+ ns = ns, |
|
| 466 | -! | +||
| 98 | +1x |
- assert_character(gene_choices)+ sliderInput(ns("n_top"), label = "Number of Top Genes", min = 10, max = 5000, value = 500)
|
|
| 467 | +99 |
-
+ ), |
|
| 468 | -! | +||
| 100 | +1x |
- validate(need(+ conditionalPanel( |
|
| 469 | -! | +||
| 101 | +1x |
- !is.null(gene_spec$get_genes()),+ condition = "input.tab_selected == 'PCA'", |
|
| 470 | -! | +||
| 102 | +1x |
- "please select at least one gene"+ ns = ns, |
|
| 471 | -+ | ||
| 103 | +1x |
- ))+ tags$label("Show Variance %"),
|
|
| 472 | -! | +||
| 104 | +1x |
- genes_not_included <- setdiff(gene_spec$get_genes(), gene_choices)+ shinyWidgets::switchInput(ns("var_pct"), value = TRUE, size = "mini"),
|
|
| 473 | -! | +||
| 105 | +1x |
- n_not_incl <- length(genes_not_included)+ tags$label("Show Label"),
|
|
| 474 | -! | +||
| 106 | +1x |
- validate(need(+ shinyWidgets::switchInput(ns("label"), value = TRUE, size = "mini")
|
|
| 475 | -! | +||
| 107 | +
- identical(n_not_incl, 0L),+ ), |
||
| 476 | -! | +||
| 108 | +1x |
- paste(+ conditionalPanel( |
|
| 477 | -! | +||
| 109 | +1x |
- n_not_incl,+ condition = "input.tab_selected == 'PC and Sample Correlation'", |
|
| 478 | -! | +||
| 110 | +1x |
- ifelse(n_not_incl > 1, "genes", "gene"),+ ns = ns, |
|
| 479 | -! | +||
| 111 | +1x |
- hermes::h_parens(hermes::h_short_list(genes_not_included)),+ tags$label("Cluster columns"),
|
|
| 480 | -! | +||
| 112 | +1x |
- "not included, please unlock or change filters"+ shinyWidgets::switchInput(ns("cluster_columns"), value = FALSE, size = "mini")
|
|
| 481 | +113 |
- )+ ), |
|
| 482 | -+ | ||
| 114 | +1x |
- ))+ tags$label("View Matrix"),
|
|
| 483 | -+ | ||
| 115 | +1x |
- }+ shinyWidgets::switchInput(ns("show_matrix"), value = TRUE, size = "mini")
|
| 1 | +116 |
- #' Most Expressed Genes Plot+ ) |
|
| 2 | +117 |
- #'+ ) |
|
| 3 | +118 |
- #' @description `r lifecycle::badge("experimental")`
+ ), |
|
| 4 | -+ | ||
| 119 | +1x |
- #'+ output = div( |
|
| 5 | -+ | ||
| 120 | +1x |
- #' This function plots the most expressed genes.+ style = "display:flow-root", |
|
| 6 | -+ | ||
| 121 | +1x |
- #'+ tabsetPanel(+ |
+ |
| 122 | +1x | +
+ id = ns("tab_selected"),
+ |
+ |
| 123 | +1x | +
+ type = "tabs", |
|
| 7 | -+ | ||
| 124 | +1x |
- #' @inheritParams function_arguments+ tabPanel( |
|
| 8 | -+ | ||
| 125 | +1x |
- #'+ "PCA", |
|
| 9 | -+ | ||
| 126 | +1x |
- #' @return Plot to be displayed in the teal app.+ column( |
|
| 10 | -+ | ||
| 127 | +1x |
- #'+ width = 12, |
|
| 11 | -+ | ||
| 128 | +1x |
- #' @export+ div( |
|
| 12 | -+ | ||
| 129 | +1x |
- #'+ class = "my-5", |
|
| 13 | -+ | ||
| 130 | +1x |
- #' @examples+ teal.widgets::plot_with_settings_ui(ns("plot_pca"))
|
|
| 14 | +131 |
- #' library(hermes)+ ), |
|
| 15 | -+ | ||
| 132 | +1x |
- #' object <- HermesData(summarized_experiment)+ DT::DTOutput(ns("table_pca"))
|
|
| 16 | +133 |
- #' result <- top_gene_plot(object, assay_name = "counts")+ ) |
|
| 17 | +134 |
- top_gene_plot <- function(object, assay_name) {
+ ), |
|
| 18 | -! | +||
| 135 | +1x |
- top_gene <- hermes::top_genes(+ tabPanel( |
|
| 19 | -! | +||
| 136 | +1x |
- object = object,+ "PC and Sample Correlation", |
|
| 20 | -! | +||
| 137 | +1x |
- assay_name = assay_name,+ column( |
|
| 21 | -! | +||
| 138 | +1x |
- summary_fun = rowMeans+ width = 12, |
|
| 22 | -+ | ||
| 139 | +1x |
- )+ div( |
|
| 23 | -! | +||
| 140 | +1x |
- hermes::autoplot(+ class = "my-5", |
|
| 24 | -! | +||
| 141 | +1x |
- top_gene,+ teal.widgets::plot_with_settings_ui(ns("plot_cor"))
|
|
| 25 | -! | +||
| 142 | +
- x_lab = "Gene",+ ), |
||
| 26 | -! | +||
| 143 | +1x |
- y_lab = paste("Mean", assay_name, "across samples")
+ DT::DTOutput(ns("table_cor"))
|
|
| 27 | +144 |
- )+ ) |
|
| 28 | +145 |
- }+ ) |
|
| 29 | +146 |
-
+ ) |
|
| 30 | +147 |
- #' Correlation Heatmap Plot+ ), |
|
| 31 | -+ | ||
| 148 | +1x |
- #'+ pre_output = pre_output, |
|
| 32 | -+ | ||
| 149 | +1x |
- #' @description `r lifecycle::badge("experimental")`
+ post_output = post_output |
|
| 33 | +150 |
- #'+ ) |
|
| 34 | +151 |
- #' This function plots the correlation heatmap.+ ) |
|
| 35 | +152 |
- #'+ } |
|
| 36 | +153 |
- #' @inheritParams function_arguments+ |
|
| 37 | +154 |
- #'+ #' @describeIn tm_g_pca sets up the server with reactive graph. |
|
| 38 | +155 |
- #' @return Plot to be displayed in the teal app.+ #' @inheritParams module_arguments |
|
| 39 | +156 |
- #'+ #' @export |
|
| 40 | +157 |
- #' @export+ srv_g_pca <- function(id, |
|
| 41 | +158 |
- #'+ data, |
|
| 42 | +159 |
- #' @examples+ filter_panel_api, |
|
| 43 | +160 |
- #' library(hermes)+ reporter, |
|
| 44 | +161 |
- #' object <- HermesData(summarized_experiment)+ mae_name, |
|
| 45 | +162 |
- #' result <- heatmap_plot(object, assay_name = "counts")+ exclude_assays) {
+ |
+ |
| 163 | +! | +
+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ |
+ |
| 164 | +! | +
+ assert_class(filter_panel_api, "FilterPanelAPI")+ |
+ |
| 165 | +! | +
+ assert_class(data, "tdata") |
|
| 46 | +166 |
- heatmap_plot <- function(object, assay_name) {
+
|
|
| 47 | +167 | ! |
- heatmap <- hermes::correlate(+ moduleServer(id, function(input, output, session) {
|
| 48 | +168 | ! |
- object = object,+ experiment <- experimentSpecServer( |
| 49 | +169 | ! |
- assay_name = assay_name- |
-
| 50 | -- |
- )+ "experiment", |
|
| 51 | +170 | ! |
- hermes::autoplot(heatmap)- |
-
| 52 | -- |
- }+ data = data, |
|
| 53 | -+ | ||
| 171 | +! |
-
+ filter_panel_api = filter_panel_api, |
|
| 54 | -+ | ||
| 172 | +! |
- #' Teal Module for RNA-seq Quality Control+ mae_name = mae_name |
|
| 55 | +173 |
- #'+ ) |
|
| 56 | -+ | ||
| 174 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ assay <- assaySpecServer( |
|
| 57 | -+ | ||
| 175 | +! |
- #'+ "assay", |
|
| 58 | -+ | ||
| 176 | +! |
- #' This module adds quality flags, filters by genes and/or samples,+ assays = experiment$assays, |
|
| 59 | -+ | ||
| 177 | +! |
- #' normalizes `AnyHermesData` objects and provides interactive plots+ exclude_assays = exclude_assays |
|
| 60 | +178 |
- #' for RNA-seq gene expression quality control.+ ) |
|
| 61 | -+ | ||
| 179 | +! |
- #'+ color <- sampleVarSpecServer( |
|
| 62 | -+ | ||
| 180 | +! |
- #' @inheritParams module_arguments+ "color", |
|
| 63 | -+ | ||
| 181 | +! |
- #'+ experiment_name = experiment$name, |
|
| 64 | -+ | ||
| 182 | +! |
- #' @return Shiny module to be used in the teal app.+ original_data = experiment$data |
|
| 65 | +183 |
- #'+ ) |
|
| 66 | +184 |
- #' @export+ |
|
| 67 | +185 |
- #'+ # Total number of genes at the moment. |
|
| 68 | -+ | ||
| 186 | +! |
- #' @examples+ n_genes <- reactive({
|
|
| 69 | -+ | ||
| 187 | +! |
- #' mae <- hermes::multi_assay_experiment+ experiment_data <- color$experiment_data() |
|
| 70 | -+ | ||
| 188 | +! |
- #' mae_data <- dataset("MAE", mae)
+ nrow(experiment_data) |
|
| 71 | +189 |
- #' data <- teal_data(mae_data)+ }) |
|
| 72 | +190 |
- #' app <- init(+ |
|
| 73 | +191 |
- #' data = data,+ # When the total number changes or gene filter is activated, update slider max. |
|
| 74 | -+ | ||
| 192 | +! |
- #' modules = modules(+ observeEvent(list(n_genes(), input$filter_top), {
|
|
| 75 | -+ | ||
| 193 | +! |
- #' tm_g_quality(+ n_genes <- n_genes() |
|
| 76 | -+ | ||
| 194 | +! |
- #' label = "Quality Control",+ filter_top <- input$filter_top |
|
| 77 | -+ | ||
| 195 | +! |
- #' mae_name = "MAE"+ if (filter_top) {
|
|
| 78 | -+ | ||
| 196 | +! |
- #' )+ n_top <- input$n_top |
|
| 79 | -+ | ||
| 197 | +! |
- #' )+ updateSliderInput( |
|
| 80 | -+ | ||
| 198 | +! |
- #' )+ session = session, |
|
| 81 | -+ | ||
| 199 | +! |
- #' if (interactive()) {
+ inputId = "n_top", |
|
| 82 | -+ | ||
| 200 | +! |
- #' shinyApp(app$ui, app$server)+ value = min(n_top, n_genes), |
|
| 83 | -+ | ||
| 201 | +! |
- #' }+ max = n_genes |
|
| 84 | +202 |
- tm_g_quality <- function(label,+ ) |
|
| 85 | +203 |
- mae_name,+ } |
|
| 86 | +204 |
- exclude_assays = character(),+ }) |
|
| 87 | +205 |
- pre_output = NULL,+ |
|
| 88 | +206 |
- post_output = NULL) {
+ # When the chosen experiment or assay name changes, recompute the PC. |
|
| 89 | +207 | ! |
- assert_string(label)+ pca_result <- reactive({
|
| 90 | +208 | ! |
- assert_string(mae_name)+ experiment_data <- color$experiment_data() |
| 91 | +209 | ! |
- assert_character(exclude_assays, any.missing = FALSE)+ filter_top <- input$filter_top |
| 92 | +210 | ! |
- assert_tag(pre_output, null.ok = TRUE)+ n_top <- input$n_top |
| 93 | +211 | ! |
- assert_tag(post_output, null.ok = TRUE)+ assay_name <- assay() |
| 94 | +212 | ||
| 95 | -! | -
- teal::module(- |
- |
| 96 | +213 | ! |
- label = label,+ validate(need(hermes::is_hermes_data(experiment_data), "please use HermesData() on input experiments")) |
| 97 | +214 | ! |
- server = srv_g_quality,+ req(isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data))) |
| 98 | +215 | ! |
- server_args = list(+ validate(need( |
| 99 | +216 | ! |
- mae_name = mae_name,+ ncol(experiment_data) > 2, |
| 100 | +217 | ! |
- exclude_assays = exclude_assays+ "Sample size is too small. PCA needs more than 2 samples." |
| 101 | +218 |
- ),- |
- |
| 102 | -! | -
- ui = ui_g_quality,+ )) |
|
| 103 | +219 | ! |
- ui_args = list(+ validate(need( |
| 104 | +220 | ! |
- mae_name = mae_name,+ nrow(experiment_data) > 1, |
| 105 | +221 | ! |
- pre_output = pre_output,+ "Number of genes is too small. PCA needs more than 1 gene." |
| 106 | -! | +||
| 222 | +
- post_output = post_output+ )) |
||
| 107 | +223 |
- ),+ |
|
| 108 | +224 | ! |
- datanames = mae_name+ hermes::calc_pca(experiment_data, assay_name, n_top = if (filter_top) n_top else NULL) |
| 109 | +225 |
- )+ }) |
|
| 110 | +226 |
- }+ |
|
| 111 | +227 |
-
+ # When experiment or assay name changes, update choices for PCs in x_var and y_var. |
|
| 112 | -+ | ||
| 228 | +! |
- #' @describeIn tm_g_quality sets up the user interface.+ observeEvent(pca_result(), {
|
|
| 113 | -+ | ||
| 229 | +! |
- #' @inheritParams module_arguments+ pca_result_x <- pca_result()$x |
|
| 114 | -+ | ||
| 230 | +! |
- #' @export+ pc_choices <- seq_len(ncol(pca_result_x)) |
|
| 115 | +231 |
- ui_g_quality <- function(id,+ |
|
| 116 | -+ | ||
| 232 | +! |
- data,+ id_names <- c("x_var", "y_var")
|
|
| 117 | -+ | ||
| 233 | +! |
- mae_name,+ for (i in seq_along(id_names)) {
|
|
| 118 | -+ | ||
| 234 | +! |
- pre_output,+ updateSelectizeInput( |
|
| 119 | -+ | ||
| 235 | +! |
- post_output) {
+ session, |
|
| 120 | -1x | +||
| 236 | +! |
- ns <- NS(id)+ id_names[i], |
|
| 121 | -1x | +||
| 237 | +! |
- teal.widgets::standard_layout(+ choices = pc_choices, |
|
| 122 | -1x | +||
| 238 | +! |
- encoding = div(+ selected = pc_choices[i] |
|
| 123 | +239 |
- ### Reporter- |
- |
| 124 | -1x | -
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ) |
|
| 125 | +240 |
- ###- |
- |
| 126 | -1x | -
- tags$label("Encodings", class = "text-primary"),
+ } |
|
| 127 | -1x | +||
| 241 | +
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ }) |
||
| 128 | -1x | +||
| 242 | +
- experimentSpecInput(ns("experiment"), data, mae_name),
+
|
||
| 129 | -1x | +||
| 243 | +
- selectInput(+ # Compute correlation of PC with sample variables. |
||
| 130 | -1x | +||
| 244 | +! |
- ns("plot_type"),
+ cor_result <- reactive({
|
|
| 131 | -1x | +||
| 245 | +! |
- "Plot Type",+ pca_result <- pca_result() |
|
| 132 | -1x | +||
| 246 | +! |
- choices = c(+ experiment_data <- color$experiment_data() |
|
| 133 | -1x | +||
| 247 | +
- "Histogram",+ |
||
| 134 | -1x | +||
| 248 | +! |
- "Q-Q Plot",+ hermes::correlate(pca_result, experiment_data) |
|
| 135 | -1x | +||
| 249 | +
- "Density",+ }) |
||
| 136 | -1x | +||
| 250 | +
- "Boxplot",+ |
||
| 137 | -1x | +||
| 251 | +
- "Top Genes Plot",+ # Compute & display PCA matrix table if show_matrix is TRUE. |
||
| 138 | -1x | +||
| 252 | +! |
- "Correlation Heatmap"+ show_matrix_pca <- reactive({
|
|
| 139 | -+ | ||
| 253 | +! |
- )+ if (input$show_matrix) {
|
|
| 140 | -+ | ||
| 254 | +! |
- ),+ pca_result_x <- pca_result()$x |
|
| 141 | -1x | +||
| 255 | +! |
- conditionalPanel(+ pca_result_x <- round(pca_result_x, 3) |
|
| 142 | -1x | +||
| 256 | +! |
- condition = "input.plot_type == 'Top Genes Plot' || input.plot_type == 'Correlation Heatmap'",+ as.data.frame(pca_result_x) |
|
| 143 | -1x | +||
| 257 | +
- ns = ns,+ } else {
|
||
| 144 | -1x | +||
| 258 | +! |
- assaySpecInput(ns("assay"))
+ NULL |
|
| 145 | +259 |
- ),+ } |
|
| 146 | -1x | +||
| 260 | +
- tags$label("Gene Filter Settings", class = "text-primary"),
+ }) |
||
| 147 | -1x | +||
| 261 | +
- shinyWidgets::switchInput(+ |
||
| 148 | -1x | +||
| 262 | +! |
- ns("filter_gene"),
+ output$table_pca <- DT::renderDT({
|
|
| 149 | -1x | +||
| 263 | +! |
- value = TRUE,+ show_matrix_pca <- show_matrix_pca() |
|
| 150 | -1x | +||
| 264 | +! |
- size = "mini"+ DT::datatable( |
|
| 151 | -+ | ||
| 265 | +! |
- ),+ show_matrix_pca, |
|
| 152 | -1x | +||
| 266 | +! |
- conditionalPanel(+ rownames = TRUE, |
|
| 153 | -1x | +||
| 267 | +! |
- condition = "input.filter_gene",+ options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)), |
|
| 154 | -1x | +||
| 268 | +! |
- ns = ns,+ caption = "PCA Matrix" |
|
| 155 | -1x | +||
| 269 | +
- sliderInput(ns("min_cpm"), label = ("Minimum CPM"), min = 1, max = 10, value = 5),
+ ) |
||
| 156 | -1x | +||
| 270 | +
- sliderInput(ns("min_cpm_prop"), label = ("Minimum CPM Proportion"), min = 0.01, max = 0.99, value = 0.25),
+ }) |
||
| 157 | -1x | +||
| 271 | +
- teal.widgets::optionalSelectInput(+ |
||
| 158 | -1x | +||
| 272 | +
- ns("annotate"),
+ # Compute & display correlation matrix if show_matrix is TRUE |
||
| 159 | -1x | +||
| 273 | +! |
- label = "Required Annotations",+ show_matrix_cor <- reactive({
|
|
| 160 | -1x | +||
| 274 | +! |
- choices = "",+ if (input$show_matrix) {
|
|
| 161 | -1x | +||
| 275 | +! |
- selected = "",+ cor_result <- cor_result() |
|
| 162 | -1x | +||
| 276 | +! |
- multiple = TRUE+ cor_result <- round(cor_result, 3) |
|
| 163 | -+ | ||
| 277 | +! |
- )+ as.data.frame(cor_result) |
|
| 164 | +278 |
- ),+ } else {
|
|
| 165 | -1x | +||
| 279 | +! |
- tags$label("Sample Filter Settings", class = "text-primary"),
+ NULL |
|
| 166 | -1x | +||
| 280 | +
- shinyWidgets::switchInput(+ } |
||
| 167 | -1x | +||
| 281 | +
- ns("filter_sample"),
+ }) |
||
| 168 | -1x | +||
| 282 | +! |
- value = TRUE,+ output$table_cor <- DT::renderDT({
|
|
| 169 | -1x | +||
| 283 | +! |
- size = "mini"+ show_matrix_cor <- show_matrix_cor() |
|
| 170 | -+ | ||
| 284 | +! |
- ),+ DT::datatable( |
|
| 171 | -1x | +||
| 285 | +! |
- conditionalPanel(+ show_matrix_cor, |
|
| 172 | -1x | +||
| 286 | +! |
- condition = "input.filter_sample",+ rownames = TRUE, |
|
| 173 | -1x | +||
| 287 | +! |
- ns = ns,+ options = list(scrollX = TRUE, pageLength = 30, lengthMenu = c(5, 15, 30, 100)), |
|
| 174 | -1x | +||
| 288 | +! |
- sliderInput(ns("min_corr"), label = ("Minimum Correlation"), min = 0.01, max = 0.99, value = 0.5),
+ caption = "PC and Sample Correlation Matrix" |
|
| 175 | -1x | +||
| 289 | +
- radioButtons(+ ) |
||
| 176 | -1x | +||
| 290 | +
- ns("min_depth"),
+ }) |
||
| 177 | -1x | +||
| 291 | +
- label = "Minimum Depth",+ |
||
| 178 | -1x | +||
| 292 | +
- choices = c("Default", "Specify"),
+ # Render plot PCA output. |
||
| 179 | -1x | +||
| 293 | +! |
- selected = "Default"+ plot_pca <- reactive({
|
|
| 180 | +294 |
- ),+ # Resolve all reactivity. |
|
| 181 | -1x | +||
| 295 | +! |
- conditionalPanel(+ pca_result <- pca_result() |
|
| 182 | -1x | +||
| 296 | +! |
- condition = "input.min_depth == 'Specify'",+ experiment_data <- color$experiment_data() |
|
| 183 | -1x | +||
| 297 | +! |
- ns = ns,+ x_var <- as.numeric(input$x_var) |
|
| 184 | -1x | +||
| 298 | +! |
- sliderInput(ns("min_depth_continuous"), label = NULL, min = 1, max = 10, value = 1)
+ y_var <- as.numeric(input$y_var) |
|
| 185 | -+ | ||
| 299 | +! |
- )+ data <- as.data.frame(SummarizedExperiment::colData(color$experiment_data())) |
|
| 186 | -+ | ||
| 300 | +! |
- )+ color_var <- color$sample_var() |
|
| 187 | -+ | ||
| 301 | +! |
- ),+ assay_name <- assay() |
|
| 188 | -1x | +||
| 302 | +! |
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ var_pct <- input$var_pct |
|
| 189 | -1x | +||
| 303 | +! |
- pre_output = pre_output,+ label <- input$label |
|
| 190 | -1x | +||
| 304 | +
- post_output = post_output+ |
||
| 191 | +305 |
- )+ # Require which states need to be truthy. |
|
| 192 | -+ | ||
| 306 | +! |
- }+ req( |
|
| 193 | -+ | ||
| 307 | +! |
-
+ assay_name, |
|
| 194 | +308 |
- #' @describeIn tm_g_quality sets up the server with reactive graphs.+ # Note: The following statements are important to make sure the UI inputs have been updated. |
|
| 195 | -+ | ||
| 309 | +! |
- #' @inheritParams module_arguments+ isTRUE(assay_name %in% SummarizedExperiment::assayNames(experiment_data)), |
|
| 196 | -+ | ||
| 310 | +! |
- #' @export+ is.null(color_var) || isTRUE(color_var %in% names(SummarizedExperiment::colData(experiment_data))),+ |
+ |
| 311 | +! | +
+ cancelOutput = FALSE |
|
| 197 | +312 |
- srv_g_quality <- function(id,+ ) |
|
| 198 | +313 |
- data,+ |
|
| 199 | +314 |
- filter_panel_api,+ # Validate and give useful messages to the user. Note: no need to duplicate here req() from above. |
|
| 200 | -+ | ||
| 315 | +! |
- reporter,+ validate(need(x_var != y_var, "please select two different principal components")) |
|
| 201 | +316 |
- mae_name,+ |
|
| 202 | -+ | ||
| 317 | +! |
- exclude_assays) {
+ hermes::autoplot( |
|
| 203 | +318 | ! |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ object = pca_result, |
| 204 | +319 | ! |
- assert_class(filter_panel_api, "FilterPanelAPI")+ assay_name = assay_name, |
| 205 | +320 | ! |
- assert_class(data, "tdata")+ x = x_var, |
| 206 | -+ | ||
| 321 | +! |
-
+ y = y_var, |
|
| 207 | +322 | ! |
- moduleServer(id, function(input, output, session) {
+ data = data, |
| 208 | +323 | ! |
- experiment <- experimentSpecServer(+ colour = color_var, |
| 209 | +324 | ! |
- "experiment",+ variance_percentage = var_pct, |
| 210 | +325 | ! |
- data = data,+ label = label, |
| 211 | +326 | ! |
- filter_panel_api = filter_panel_api,+ label.repel = label, |
| 212 | +327 | ! |
- mae_name = mae_name+ label.show.legend = FALSE |
| 213 | +328 |
- )+ ) |
|
| 214 | +329 |
-
+ }) |
|
| 215 | +330 | ! |
- assay <- assaySpecServer(+ output$plot_pca <- renderPlot(plot_pca()) |
| 216 | -! | +||
| 331 | +
- "assay",+ |
||
| 217 | +332 | ! |
- assays = reactive({
+ pws_pca <- teal.widgets::plot_with_settings_srv( |
| 218 | +333 | ! |
- union(+ id = "plot_pca", |
| 219 | +334 | ! |
- experiment$assays(),+ plot_r = plot_pca |
| 220 | +335 |
- # Add all the additional normalized assays.- |
- |
| 221 | -! | -
- c("cpm", "rpkm", "tpm", "voom", "vst")
+ ) |
|
| 222 | +336 |
- )+ |
|
| 223 | +337 |
- }),+ # render correlation heatmap |
|
| 224 | +338 | ! |
- exclude_assays = exclude_assays- |
-
| 225 | -- |
- )+ plot_cor <- reactive({
|
|
| 226 | +339 |
-
+ # Resolve all reactivity. |
|
| 227 | +340 | ! |
- experiment_properties <- eventReactive(experiment$name(), {
+ cor_result <- cor_result() |
| 228 | +341 | ! |
- data <- experiment$data()+ cluster_columns <- input$cluster_columns |
| 229 | -! | +||
| 342 | +
- cpm <- edgeR::cpm(hermes::counts(data))+ |
||
| 230 | +343 | ! |
- depth <- colSums(hermes::counts(data))+ validate(need( |
| 231 | +344 | ! |
- list(+ !any(is.na(cor_result)), |
| 232 | +345 | ! |
- annotations = names(hermes::annotation(data)),+ "Obtained NA results in the correlation matrix, therefore no plot can be produced" |
| 233 | -! | +||
| 346 | +
- min_cpm_calc = floor(min(cpm)),+ )) |
||
| 234 | +347 | ! |
- max_cpm_calc = floor(max(cpm)),+ hermes::autoplot( |
| 235 | +348 | ! |
- min_depth_calc = min(depth),+ object = cor_result, |
| 236 | +349 | ! |
- max_depth_calc = max(depth)+ cluster_columns = cluster_columns |
| 237 | +350 |
) |
|
| 238 | +351 |
}) |
|
| 239 | +352 | ||
| 240 | +353 | ! |
- observeEvent(experiment_properties(), {
+ pws_cor <- teal.widgets::plot_with_settings_srv( |
| 241 | +354 | ! |
- properties <- experiment_properties()+ id = "plot_cor",+ |
+
| 355 | +! | +
+ plot_r = plot_cor |
|
| 242 | +356 | ++ |
+ )+ |
+
| 357 | |||
| 358 | ++ |
+ ### REPORTER+ |
+ |
| 243 | +359 | ! |
- teal.widgets::updateOptionalSelectInput(+ if (with_reporter) {
|
| 244 | +360 | ! |
- session,+ card_fun <- function(comment, label) {
|
| 245 | +361 | ! |
- "annotate",+ card <- report_card_template( |
| 246 | +362 | ! |
- choices = properties$annotations,+ title = "PCA", |
| 247 | +363 | ! |
- selected = "WidthBP"+ label = label, |
| 248 | -+ | ||
| 364 | +! |
- )+ with_filter = TRUE, |
|
| 249 | +365 | ! |
- updateSliderInput(+ filter_panel_api = filter_panel_api+ |
+
| 366 | ++ |
+ ) |
|
| 250 | +367 | ! |
- session,+ card$append_text("Selected Options", "header3")
|
| 251 | +368 | ! |
- "min_cpm",+ if (input$tab_selected == "PCA") {
|
| 252 | +369 | ! |
- min = properties$min_cpm_calc,+ encodings_list <- list( |
| 253 | +370 | ! |
- max = properties$max_cpm_calc,+ "Experiment:", |
| 254 | +371 | ! |
- value = properties$min_cpm_calc- |
-
| 255 | -- |
- )+ input$`experiment-name`, |
|
| 256 | +372 | ! |
- updateSliderInput(+ "\nAssay:", |
| 257 | +373 | ! |
- session,+ input$`assay-name`, |
| 258 | +374 | ! |
- "min_depth_continuous",+ "\nOptional Color Variable:", |
| 259 | +375 | ! |
- min = properties$min_depth_calc,+ input$`color-sample_var`, |
| 260 | +376 | ! |
- max = properties$max_depth_calc,+ "\nX-axis PC:", |
| 261 | +377 | ! |
- value = properties$min_depth_calc+ input$x_var, |
| 262 | -+ | ||
| 378 | +! |
- )+ "\nY-axis PC:", |
|
| 263 | -+ | ||
| 379 | +! |
- })+ input$y_var, |
|
| 264 | -+ | ||
| 380 | +! |
-
+ "\nUse Top Variance Genes:", |
|
| 265 | +381 | ! |
- min_depth_final <- reactive({
+ input$filter_top, |
| 266 | +382 | ! |
- min_depth <- input$min_depth+ "\nNumber of Top Genes:", |
| 267 | +383 | ! |
- min_depth_continuous <- input$min_depth_continuous+ input$n_top, |
| 268 | +384 | ! |
- if (min_depth == "Specify") {
+ "\nShow Variance %:", |
| 269 | +385 | ! |
- req(min_depth_continuous)+ input$var_pct, |
| 270 | +386 | ! |
- min_depth_continuous+ "\nShow Matrix:", |
| 271 | -+ | ||
| 387 | +! |
- } else {
+ input$show_matrix, |
|
| 272 | +388 | ! |
- NULL+ "\nShow Label:", |
| 273 | -+ | ||
| 389 | +! |
- }+ input$label |
|
| 274 | +390 |
- })+ ) |
|
| 275 | -+ | ||
| 391 | +! |
-
+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 276 | +392 | ! |
- control <- reactive({
+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
| 277 | +393 | ! |
- min_cpm <- input$min_cpm+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
| 278 | +394 | ! |
- min_cpm_prop <- input$min_cpm_prop+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
| 279 | -! | +||
| 395 | +
- min_corr <- input$min_corr+ } else {
|
||
| 280 | +396 | ! |
- min_depth_final <- min_depth_final()+ paste(encodings_list, collapse = " ") |
| 281 | +397 |
-
+ } |
|
| 282 | +398 | ! |
- req(+ card$append_text(final_encodings, style = "verbatim") |
| 283 | +399 | ! |
- min_cpm,+ card$append_text("Plot", "header3")
|
| 284 | +400 | ! |
- min_cpm_prop,+ card$append_plot(plot_pca(), dim = pws_pca$dim()) |
| 285 | +401 | ! |
- min_corr+ card$append_text("Table", "header3")
|
| 286 | -+ | ||
| 402 | +! |
- )+ card$append_table(show_matrix_pca()) |
|
| 287 | +403 |
-
+ } else {
|
|
| 288 | +404 | ! |
- hermes::control_quality(+ encodings_list <- list( |
| 289 | +405 | ! |
- min_cpm = min_cpm,+ "Experiment:", |
| 290 | +406 | ! |
- min_cpm_prop = min_cpm_prop,+ input$`experiment-name`, |
| 291 | +407 | ! |
- min_corr = min_corr,+ "\nAssay:", |
| 292 | +408 | ! |
- min_depth = min_depth_final- |
-
| 293 | -- |
- )- |
- |
| 294 | -- |
- })- |
- |
| 295 | -- |
-
+ input$`assay-name`, |
|
| 296 | +409 | ! |
- object_flagged <- reactive({
+ "\nUse Top Variance Genes:", |
| 297 | +410 | ! |
- control <- control()+ input$filter_top, |
| 298 | +411 | ! |
- object <- experiment$data()+ "\nNumber of Top Genes:", |
| 299 | -+ | ||
| 412 | +! |
-
+ input$top_n, |
|
| 300 | +413 | ! |
- already_added <- ("control_quality_flags" %in% names(hermes::metadata(object)))
+ "\nCluster Columns:", |
| 301 | +414 | ! |
- validate(need(!already_added, "Quality flags have already been added to this experiment"))+ paste0(input$cluster_columns, collapse = ", "), |
| 302 | +415 | ! |
- if (any(c("cpm", "rpkm", "tpm", "voom", "vst") %in% SummarizedExperiment::assayNames(object))) {
+ "\nShow Matrix:", |
| 303 | +416 | ! |
- showNotification("Original normalized assays will be overwritten", type = "warning")
+ input$show_matrix |
| 304 | +417 |
- }+ ) |
|
| 305 | -+ | ||
| 418 | +! |
-
+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 306 | +419 | ! |
- hermes::add_quality_flags(+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
| 307 | +420 | ! |
- object,+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
| 308 | +421 | ! |
- control = control+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
| 309 | +422 |
- )+ } else {
+ |
+ |
| 423 | +! | +
+ paste(encodings_list, collapse = " ") |
|
| 310 | +424 |
- })+ } |
|
| 311 | +425 | ||
| 312 | +426 | ! |
- object_final <- reactive({
+ card$append_text(final_encodings, style = "verbatim") |
| 313 | +427 | ! |
- object_flagged <- object_flagged()+ card$append_text("Plot", "header3")
|
| 314 | +428 | ! |
- filter <- input$filter+ card$append_plot(plot_cor()) |
| 315 | +429 | ! |
- annotate <- input$annotate+ card$append_plot(plot_cor(), dim = pws_cor$dim()) |
| 316 | -+ | ||
| 430 | +! |
-
+ card$append_text("Table", "header3")
|
|
| 317 | +431 | ! |
- req(!is_blank(annotate))+ card$append_table(show_matrix_cor()) |
| 318 | +432 |
-
+ } |
|
| 319 | +433 | ! |
- result <- hermes::filter(+ if (!comment == "") {
|
| 320 | +434 | ! |
- object_flagged,+ card$append_text("Comment", "header3")
|
| 321 | +435 | ! |
- what = filter,+ card$append_text(comment) |
| 322 | -! | +||
| 436 | +
- annotation_required = annotate+ } |
||
| 323 | -+ | ||
| 437 | +! |
- )+ card |
|
| 324 | +438 |
-
+ } |
|
| 325 | +439 | ! |
- validate(need(+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 326 | -! | +||
| 440 | +
- nrow(result) >= 2,+ } |
||
| 327 | -! | +||
| 441 | +
- "Please change gene filters to ensure that there are at least 2 genes"+ ### |
||
| 328 | +442 |
- ))+ }) |
|
| 329 | +443 |
-
+ } |
|
| 330 | -! | +||
| 444 | +
- hermes::normalize(result)+ |
||
| 331 | +445 |
- })+ #' @describeIn tm_g_pca sample module function. |
|
| 332 | +446 |
-
+ #' @export |
|
| 333 | -! | +||
| 447 | +
- plot_r <- reactive({
+ #' @examples |
||
| 334 | -! | +||
| 448 | +
- object_final <- object_final()+ #' |
||
| 335 | -! | +||
| 449 | +
- plot_type <- input$plot_type+ #' # Alternatively you can run the sample module with this function call: |
||
| 336 | -! | +||
| 450 | +
- assay_name <- assay()+ #' if (interactive()) {
|
||
| 337 | +451 |
-
+ #' sample_tm_g_pca() |
|
| 338 | -! | +||
| 452 | +
- switch(plot_type,+ #' } |
||
| 339 | -! | +||
| 453 | +
- "Histogram" = hermes::draw_libsize_hist(object_final),+ sample_tm_g_pca <- function() {
|
||
| 340 | +454 | ! |
- "Density" = hermes::draw_libsize_densities(object_final),+ mae <- hermes::multi_assay_experiment |
| 341 | +455 | ! |
- "Q-Q Plot" = hermes::draw_libsize_qq(object_final),+ mae_data <- teal.data::dataset("MAE", mae)
|
| 342 | +456 | ! |
- "Boxplot" = hermes::draw_nonzero_boxplot(object_final),+ data <- teal.data::teal_data(mae_data) |
| 343 | +457 | ! |
- "Top Genes Plot" = top_gene_plot(object_final, assay_name = assay_name),+ app <- teal::init( |
| 344 | +458 | ! |
- "Correlation Heatmap" = heatmap_plot(object_final, assay_name = assay_name)- |
-
| 345 | -- |
- )- |
- |
| 346 | -- |
- })+ data = data, |
|
| 347 | +459 | ! |
- output$plot <- renderPlot(plot_r())- |
-
| 348 | -- |
-
+ modules = teal::modules( |
|
| 349 | +460 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ tm_g_pca( |
| 350 | +461 | ! |
- id = "plot",+ label = "pca", |
| 351 | +462 | ! |
- plot_r = plot_r+ mae_name = "MAE" |
| 352 | +463 |
- )+ ) |
|
| 353 | +464 |
-
+ ) |
|
| 354 | +465 |
- ### REPORTER- |
- |
| 355 | -! | -
- if (with_reporter) {
+ ) |
|
| 356 | +466 | ! |
- card_fun <- function(comment) {
+ shinyApp(app$ui, app$server) |
| 357 | -! | +||
| 467 | +
- card <- teal::TealReportCard$new()+ } |
||
| 358 | -! | +
| 1 | +
- card$set_name("Quality Control Plot")
+ #' Checking for Empty String |
|||||
| 359 | -! | +|||||
| 2 | +
- card$append_text("Quality Control Plot", "header2")
+ #' |
|||||
| 360 | -! | +|||||
| 3 | +
- card$append_text(tools::toTitleCase(input$plot_type), "header3")+ #' @description `r lifecycle::badge('experimental')`
|
|||||
| 361 | -! | +|||||
| 4 | +
- card$append_fs(filter_panel_api$get_filter_state())+ #' |
|||||
| 362 | -! | +|||||
| 5 | +
- card$append_text("Selected Options", "header3")
+ #' This predicate function is helpful for functions where arguments could |
|||||
| 363 | -! | +|||||
| 6 | +
- encodings_list <- list(+ #' not yet be initialized from the teal module. |
|||||
| 364 | -! | +|||||
| 7 | +
- "Experiment:",+ #' |
|||||
| 365 | -! | +|||||
| 8 | +
- input$`experiment-name`,+ #' @param x object to check. |
|||||
| 366 | -! | +|||||
| 9 | +
- "\nPlot Type:",+ #' |
|||||
| 367 | -! | +|||||
| 10 | +
- input$plot_type,+ #' @return Flag whether `x` is identical to an empty string, i.e. `""`. |
|||||
| 368 | -! | +|||||
| 11 | +
- "\nAssay:",+ #' @export |
|||||
| 369 | -! | +|||||
| 12 | +
- input$`assay-name`,+ #' |
|||||
| 370 | -! | +|||||
| 13 | +
- "\nShow Gene Filter Settings:",+ #' @examples |
|||||
| 371 | -! | +|||||
| 14 | +
- input$filter_gene,+ #' is_blank("")
|
|||||
| 372 | -! | +|||||
| 15 | +
- "\nMinimum CPM:",+ #' is_blank(" ")
|
|||||
| 373 | -! | +|||||
| 16 | +
- input$min_cpm,+ is_blank <- function(x) {
|
|||||
| 374 | -! | +|||||
| 17 | +3x |
- "\nMinimum CPM Proportion:",+ identical(x, "") |
||||
| 375 | -! | +|||||
| 18 | +
- input$min_cpm_prop,+ } |
|||||
| 376 | -! | +|||||
| 19 | +
- "\nRequired Annotations:",+ |
|||||
| 377 | -! | +|||||
| 20 | +
- paste(input$annotate, collapse = ", "),+ #' Helper Function to Extract Words |
|||||
| 378 | -! | +|||||
| 21 | +
- "\nShow Sample Filter Settings:",+ #' |
|||||
| 379 | -! | +|||||
| 22 | +
- input$filter_sample,+ #' @description `r lifecycle::badge("experimental")`
|
|||||
| 380 | -! | +|||||
| 23 | +
- "\nMinimum Correlation:",+ #' |
|||||
| 381 | -! | +|||||
| 24 | +
- input$min_corr,+ #' This helper function extracts words from a string. Here words are defined |
|||||
| 382 | -! | +|||||
| 25 | +
- "\nMinimum Depth:",+ #' as containing lower or upper case letters, colons and dots. All other |
|||||
| 383 | -! | +|||||
| 26 | +
- input$min_depth,+ #' characters are considered separators. |
|||||
| 384 | -! | +|||||
| 27 | +
- "\nMinimum Depth Value:",+ #' |
|||||
| 385 | -! | +|||||
| 28 | +
- input$min_depth_continuous+ #' @param x (`string`)\cr input. |
|||||
| 386 | +29 |
- )+ #' |
||||
| 387 | -! | +|||||
| 30 | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ #' @return Character vector with the extracted words. |
|||||
| 388 | -! | +|||||
| 31 | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ #' @export |
|||||
| 389 | -! | +|||||
| 32 | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ #' |
|||||
| 390 | -! | +|||||
| 33 | +
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ #' @examples |
|||||
| 391 | +34 |
- } else {
+ #' h_extract_words("a, b, , c, 234; 34562 - GeneID:bla")
|
||||
| 392 | -! | +|||||
| 35 | +
- paste(encodings_list, collapse = " ")+ #' h_extract_words("GeneID:1820, sdf.393; 32596")
|
|||||
| 393 | +36 |
- }+ h_extract_words <- function(x) {
|
||||
| 394 | -+ | |||||
| 37 | +3x |
-
+ assert_string(x, min.chars = 1L) |
||||
| 395 | -! | +|||||
| 38 | +2x |
- card$append_text(final_encodings, style = "verbatim")+ stringr::str_extract_all( |
||||
| 396 | -! | +|||||
| 39 | +2x |
- card$append_text("Plot", "header3")
+ x, |
||||
| 397 | -! | +|||||
| 40 | +2x |
- card$append_plot(plot_r(), dim = pws$dim())+ "[a-zA-Z0-9:\\.]+" |
||||
| 398 | -! | +|||||
| 41 | +2x |
- if (!comment == "") {
+ )[[1]] |
||||
| 399 | -! | +|||||
| 42 | +
- card$append_text("Comment", "header3")
+ } |
|||||
| 400 | -! | +|||||
| 43 | +
- card$append_text(comment)+ |
|||||
| 401 | +44 |
- }+ #' Include `CSS` files from `/inst/css/` package directory to application header |
||||
| 402 | -! | +|||||
| 45 | +
- card+ #' |
|||||
| 403 | +46 |
- }+ #' `system.file` should not be used to access files in other packages, it does |
||||
| 404 | -! | +|||||
| 47 | +
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
|||||
| 405 | +48 |
- }+ #' as needed. Thus, we do not export this method |
||||
| 406 | +49 |
- ###+ #' |
||||
| 407 | +50 |
- })+ #' @param pattern (`character`) pattern of files to be included |
||||
| 408 | +51 |
- }+ #' |
||||
| 409 | +52 |
-
+ #' @return HTML code that includes `CSS` files |
||||
| 410 | +53 |
- #' @describeIn tm_g_quality sample module function.+ #' @keywords internal |
||||
| 411 | +54 |
- #' @export+ include_css_files <- function(pattern = "*") { # nolint
+ |
+ ||||
| 55 | +12x | +
+ css_files <- list.files(+ |
+ ||||
| 56 | +12x | +
+ system.file("css", package = "teal.modules.hermes", mustWork = TRUE),
+ |
+ ||||
| 57 | +12x | +
+ pattern = pattern, full.names = TRUE |
||||
| 412 | +58 |
- #' @examples+ )+ |
+ ||||
| 59 | +12x | +
+ return(shiny::singleton(shiny::tags$head(lapply(css_files, includeCSS)))) |
||||
| 413 | +60 |
- #'+ } |
||||
| 414 | +61 |
- #' # Alternatively you can run the sample module with this function call:+ |
||||
| 415 | +62 |
- #' if (interactive()) {
+ #' Include `JS` files from `/inst/js/` package directory to application header |
||||
| 416 | +63 |
- #' sample_tm_g_quality()+ #' |
||||
| 417 | +64 |
- #' }+ #' `system.file` should not be used to access files in other packages, it does |
||||
| 418 | +65 |
- sample_tm_g_quality <- function() {
+ #' not work with `devtools`. Therefore, we redefine this method in each package |
||||
| 419 | -! | +|||||
| 66 | +
- mae <- hermes::multi_assay_experiment+ #' as needed. Thus, we do not export this method |
|||||
| 420 | -! | +|||||
| 67 | +
- mae_data <- teal.data::dataset("MAE", mae)
+ #' |
|||||
| 421 | -! | +|||||
| 68 | +
- data <- teal.data::teal_data(mae_data)+ #' @param pattern (`character`) pattern of files to be included, passed to `system.file` |
|||||
| 422 | -! | +|||||
| 69 | +
- app <- teal::init(+ #' @param except (`character`) vector of basename filenames to be excluded |
|||||
| 423 | -! | +|||||
| 70 | +
- data = data,+ #' |
|||||
| 424 | -! | +|||||
| 71 | +
- modules = teal::modules(+ #' @return HTML code that includes `JS` files |
|||||
| 425 | -! | +|||||
| 72 | +
- tm_g_quality(+ #' @keywords internal |
|||||
| 426 | -! | +|||||
| 73 | +
- label = "quality",+ include_js_files <- function(pattern = "*") { # nolint
|
|||||
| 427 | -! | +|||||
| 74 | +12x |
- mae_name = "MAE"+ js_files <- list.files( |
||||
| 428 | -+ | |||||
| 75 | +12x |
- )+ system.file("js", package = "teal.modules.hermes", mustWork = TRUE),
|
||||
| 429 | -+ | |||||
| 76 | +12x |
- )+ pattern = pattern, full.names = TRUE |
||||
| 430 | +77 |
) |
||||
| 431 | -! | +|||||
| 78 | +12x |
- shinyApp(app$ui, app$server)+ return(singleton(lapply(js_files, includeScript))) |
||||
| 432 | +79 |
}@@ -25757,473 +25847,487 @@ teal.modules.hermes coverage - 26.54% | 193 | ! |
- card_fun <- function(comment) {
+ card_fun <- function(comment, label) {
|
|
| 194 | ! |
- card <- teal::TealReportCard$new()+ card <- report_card_template( |
||||
| 195 | ! |
- card$set_name("Barplot")
+ title = "Barplot", |
||||
| 196 | ! |
- card$append_text("Barplot", "header2")
+ label = label, |
||||
| 197 | ! |
- card$append_fs(filter_panel_api$get_filter_state())+ with_filter = TRUE, |
||||
| 198 | ! | +
+ filter_panel_api = filter_panel_api+ |
+ ||||
| 199 | ++ |
+ )+ |
+ ||||
| 200 | +! |
card$append_text("Selected Options", "header3")
|
||||
| 199 | +201 | ! |
encodings_list <- list( |
|||
| 200 | +202 | ! |
"Experiment:", |
|||
| 201 | +203 | ! |
input$`experiment-name`, |
|||
| 202 | +204 | ! |
"\nAssay:", |
|||
| 203 | +205 | ! |
input$`assay-name`, |
|||
| 204 | +206 | ! |
"\nFacetting Variable:", |
|||
| 205 | +207 | ! |
input$`facet-sample_var`, |
|||
| 206 | +208 | ! |
"\nGenes Selected:", |
|||
| 207 | +209 | ! |
paste0(x()$get_gene_labels(), collapse = ", "), |
|||
| 208 | +210 | ! |
"\nGene Summary:", |
|||
| 209 | +211 | ! |
input$`x-fun_name`, |
|||
| 210 | +212 | ! |
"\nQuantiles:", |
|||
| 211 | +213 | ! |
paste0(input$percentiles, collapse = ", "), |
|||
| 212 | +214 | ! |
"\nOptional Fill Variable:", |
|||
| 213 | +215 | ! |
input$`fill-sample_var` |
|||
| 214 | +216 |
) |
||||
| 215 | +217 | ! |
null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|||
| 216 | +218 | ! |
final_encodings <- if (length(null_encodings_indices) > 0) {
|
|||
| 217 | +219 | ! |
null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|||
| 218 | +220 | ! |
paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|||
| 219 | +221 |
} else {
|
||||
| 220 | +222 | ! |
paste(encodings_list, collapse = " ") |
|||
| 221 | +223 |
} |
||||
| 222 | +224 | |||||
| 223 | +225 | ! |
card$append_text(final_encodings, style = "verbatim") |
|||
| 224 | +226 | ! |
card$append_text("Plot", "header3")
|
|||
| 225 | +227 | ! |
card$append_plot(plot_r(), dim = pws$dim()) |
|||
| 226 | +228 | ! |
if (!comment == "") {
|
|||
| 227 | +229 | ! |
card$append_text("Comment", "header3")
|
|||
| 228 | +230 | ! |
card$append_text(comment) |
|||
| 229 | +231 |
} |
||||
| 230 | +232 | ! |
card |
|||
| 231 | +233 |
} |
||||
| 232 | +234 | ! |
teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|||
| 233 | +235 |
} |
||||
| 234 | +236 |
### |
||||
| 235 | +237 |
}) |
||||
| 236 | +238 |
} |
||||
| 237 | +239 | |||||
| 238 | +240 |
#' @describeIn tm_g_barplot sample module function. |
||||
| 239 | +241 |
#' @export |
||||
| 240 | +242 |
#' @examples |
||||
| 241 | +243 |
#' |
||||
| 242 | +244 |
#' # Alternatively you can run the sample module with this function call: |
||||
| 243 | +245 |
#' if (interactive()) {
|
||||
| 244 | +246 |
#' sample_tm_g_barplot() |
||||
| 245 | +247 |
#' } |
||||
| 246 | +248 |
sample_tm_g_barplot <- function() {
|
||||
| 247 | +249 | ! |
mae <- hermes::multi_assay_experiment |
|||
| 248 | +250 | ! |
mae_data <- teal.data::dataset("MAE", mae)
|
|||
| 249 | +251 | ! |
data <- teal.data::teal_data(mae_data) |
|||
| 250 | +252 | ! |
app <- teal::init( |
|||
| 251 | +253 | ! |
data = data, |
|||
| 252 | +254 | ! |
modules = teal::modules( |
|||
| 253 | +255 | ! |
tm_g_barplot( |
|||
| 254 | +256 | ! |
label = "barplot", |
|||
| 255 | +257 | ! |
mae_name = "MAE" |
|||
| 256 | +258 |
) |
||||
| 257 | +259 |
) |
||||
| 258 | +260 |
) |
||||
| 259 | +261 | ! |
shinyApp(app$ui, app$server) |
|||
| 260 | +262 |
}@@ -26232,14 +26336,14 @@ teal.modules.hermes coverage - 26.54% |
| 1 |
- #' Teal Module for RNA-seq Boxplot+ #' Teal Module for Survival Forest Plot |
||
| 5 |
- #' This module provides an interactive boxplot for RNA-seq gene expression+ #' This module provides an interactive survival forest plot. |
||
| 6 |
- #' analysis.+ #' |
||
| 7 |
- #'+ #' @inheritParams module_arguments |
||
| 8 |
- #' @inheritParams module_arguments+ #' |
||
| 9 |
- #'+ #' @return Shiny module to be used in the teal app. |
||
| 10 |
- #' @return Shiny module to be used in the teal app.+ #' |
||
| 11 |
- #'+ #' @export |
||
| 12 |
- #' @export+ #' |
||
| 13 |
- #'+ #' @examples |
||
| 14 |
- #' @examples+ #' mae <- hermes::multi_assay_experiment |
||
| 15 |
- #' mae <- hermes::multi_assay_experiment+ #' adtte <- teal.modules.hermes::rADTTE %>% |
||
| 16 |
- #' mae_data <- dataset("MAE", mae)
+ #' dplyr::mutate(is_event = (.data$CNSR == 0)) |
||
| 17 |
- #' data <- teal_data(mae_data)+ #' |
||
| 18 |
- #' app <- init(+ #' data <- teal_data( |
||
| 19 |
- #' data = data,+ #' dataset( |
||
| 20 |
- #' modules = modules(+ #' "ADTTE", |
||
| 21 |
- #' tm_g_boxplot(+ #' adtte, |
||
| 22 |
- #' label = "boxplot",+ #' code = "adtte <- teal.modules.hermes::rADTTE %>% |
||
| 23 |
- #' mae_name = "MAE"+ #' dplyr::mutate(is_event = (.data$CNSR == 0))" |
||
| 24 |
- #' )+ #' ), |
||
| 25 |
- #' )+ #' dataset("MAE", mae)
|
||
| 27 |
- #' if (interactive()) {
+ #' app <- init( |
||
| 28 |
- #' shinyApp(app$ui, app$server)+ #' data = data, |
||
| 29 |
- #' }+ #' modules = modules( |
||
| 30 |
- tm_g_boxplot <- function(label,+ #' tm_g_forest_tte( |
||
| 31 |
- mae_name,+ #' label = "forestplot", |
||
| 32 |
- exclude_assays = character(),+ #' adtte_name = "ADTTE", |
||
| 33 |
- summary_funs = list(+ #' mae_name = "MAE" |
||
| 34 |
- None = NULL,+ #' ) |
||
| 35 |
- Mean = colMeans,+ #' ) |
||
| 36 |
- Median = matrixStats::colMedians,+ #' ) |
||
| 37 |
- Max = matrixStats::colMaxs+ #' if (interactive()) {
|
||
| 38 |
- ),+ #' shinyApp(app$ui, app$server) |
||
| 39 |
- pre_output = NULL,+ #' } |
||
| 40 |
- post_output = NULL) {
+ tm_g_forest_tte <- function(label, |
||
| 41 | -! | +
- logger::log_info("Initializing tm_g_boxplot")
+ adtte_name, |
|
| 42 | -! | +
- assert_string(label)+ mae_name, |
|
| 43 | -! | +
- assert_string(mae_name)+ adtte_vars = list( |
|
| 44 | -! | +
- assert_character(exclude_assays, any.missing = FALSE)+ aval = "AVAL", |
|
| 45 | -! | +
- assert_summary_funs(summary_funs, null.ok = TRUE)+ is_event = "is_event", |
|
| 46 | -! | +
- assert_tag(pre_output, null.ok = TRUE)+ paramcd = "PARAMCD", |
|
| 47 | -! | +
- assert_tag(post_output, null.ok = TRUE)+ usubjid = "USUBJID", |
|
| 48 |
-
+ avalu = "AVALU" |
||
| 49 | -! | +
- teal::module(+ ), |
|
| 50 | -! | +
- label = label,+ exclude_assays = "counts", |
|
| 51 | -! | +
- server = srv_g_boxplot,+ summary_funs = list( |
|
| 52 | -! | +
- server_args = list(+ Mean = colMeans, |
|
| 53 | -! | +
- mae_name = mae_name,+ Median = matrixStats::colMedians, |
|
| 54 | -! | +
- summary_funs = summary_funs,+ Max = matrixStats::colMaxs |
|
| 55 | -! | +
- exclude_assays = exclude_assays+ ), |
|
| 56 |
- ),+ pre_output = NULL, |
||
| 57 | -! | +
- ui = ui_g_boxplot,+ post_output = NULL, |
|
| 58 | -! | +
- ui_args = list(+ plot_height = c(600L, 200L, 2000L), |
|
| 59 | -! | +
- mae_name = mae_name,+ plot_width = c(1360L, 500L, 2000L)) {
|
|
| 60 | ! |
- summary_funs = summary_funs,+ logger::log_info("Initializing tm_g_forest_tte")
|
|
| 61 | ! |
- pre_output = pre_output,+ assert_string(label) |
|
| 62 | ! |
- post_output = post_output+ assert_string(adtte_name) |
|
| 63 | -+ | ! |
- ),+ assert_string(mae_name) |
| 64 | ! |
- datanames = mae_name+ assert_adtte_vars(adtte_vars) |
|
| 65 | -+ | ! |
- )+ assert_character(exclude_assays, any.missing = FALSE) |
| 66 | -+ | ! |
- }+ assert_summary_funs(summary_funs) |
| 67 | -+ | ! |
-
+ assert_tag(pre_output, null.ok = TRUE) |
| 68 | -+ | ! |
- #' @describeIn tm_g_boxplot sets up the user interface.+ assert_tag(post_output, null.ok = TRUE) |
| 69 |
- #' @inheritParams module_arguments+ |
||
| 70 | -+ | ! |
- #' @export+ teal::module( |
| 71 | -+ | ! |
- ui_g_boxplot <- function(id,+ label = label, |
| 72 | -+ | ! |
- data,+ server = srv_g_forest_tte, |
| 73 | -+ | ! |
- mae_name,+ server_args = list( |
| 74 | -+ | ! |
- summary_funs,+ adtte_name = adtte_name, |
| 75 | -+ | ! |
- pre_output,+ mae_name = mae_name, |
| 76 | -+ | ! |
- post_output) {
+ adtte_vars = adtte_vars, |
| 77 | -1x | +! |
- ns <- NS(id)+ exclude_assays = exclude_assays, |
| 78 | -1x | +! |
- teal.widgets::standard_layout(+ summary_funs = summary_funs, |
| 79 | -1x | +! |
- encoding = div(+ plot_height = plot_height, |
| 80 | -+ | ! |
- ### Reporter+ plot_width = plot_width |
| 81 | -1x | +
- teal.reporter::simple_reporter_ui(ns("simple_reporter")),
+ ), |
|
| 82 | -+ | ! |
- ###+ ui = ui_g_forest_tte, |
| 83 | -1x | +! |
- tags$label("Encodings", class = "text-primary"),
+ ui_args = list( |
| 84 | -1x | +! |
- helpText("Analysis of MAE:", tags$code(mae_name)),
+ adtte_name = adtte_name, |
| 85 | -1x | +! |
- experimentSpecInput(ns("experiment"), data, mae_name),
+ mae_name = mae_name, |
| 86 | -1x | +! |
- assaySpecInput(ns("assay")),
+ summary_funs = summary_funs, |
| 87 | -1x | +! |
- geneSpecInput(ns("genes"), summary_funs),
+ pre_output = pre_output, |
| 88 | -1x | +! |
- tags$label("Jitter"),
+ post_output = post_output |
| 89 | -1x | +
- shinyWidgets::switchInput(ns("jitter"), value = FALSE, size = "mini"),
+ ), |
|
| 90 | -1x | +! |
- tags$label("Violin Plot"),
+ datanames = c(adtte_name, mae_name) |
| 91 | -1x | +
- shinyWidgets::switchInput(ns("violin"), value = FALSE, size = "mini"),
+ ) |
|
| 92 | -1x | +
- teal.widgets::panel_group(+ } |
|
| 93 | -1x | +
- teal.widgets::panel_item(+ |
|
| 94 | -1x | +
- input_id = "settings_item",+ #' @describeIn tm_g_forest_tte sets up the user interface. |
|
| 95 | -1x | +
- collapsed = TRUE,+ #' @inheritParams module_arguments |
|
| 96 | -1x | +
- title = "Additional Settings",+ #' @export |
|
| 97 | -1x | +
- sampleVarSpecInput(ns("strat"), "Optional stratifying variable"),
+ ui_g_forest_tte <- function(id, |
|
| 98 | -1x | +
- sampleVarSpecInput(ns("color"), "Optional color variable"),
+ data, |
|
| 99 | -1x | +
- sampleVarSpecInput(ns("facet"), "Optional facet variable")
+ adtte_name, |
|
| 100 |
- )+ mae_name, |
||
| 101 |
- )+ summary_funs, |
||
| 102 |
- ),+ pre_output, |
||
| 103 | -1x | +
- output = teal.widgets::plot_with_settings_ui(ns("plot")),
+ post_output) {
|
|
| 104 | 1x |
- pre_output = pre_output,+ ns <- NS(id) |
|
| 105 | 1x |
- post_output = post_output+ teal.widgets::standard_layout( |
|
| 106 | -+ | 1x |
- )+ encoding = div( |
| 107 |
- }+ ### Reporter |
||
| 108 | -+ | 1x |
-
+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
| 109 |
- #' @describeIn tm_g_boxplot sets up the server with reactive graph.+ ### |
||
| 110 | -+ | 1x |
- #' @inheritParams module_arguments+ tags$label("Encodings", class = "text-primary"),
|
| 111 | -+ | 1x |
- #' @export+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
| 112 | -+ | 1x |
- srv_g_boxplot <- function(id,+ experimentSpecInput(ns("experiment"), data, mae_name),
|
| 113 | -+ | 1x |
- data,+ assaySpecInput(ns("assay")),
|
| 114 | -+ | 1x |
- filter_panel_api,+ geneSpecInput(ns("genes"), summary_funs),
|
| 115 | -+ | 1x |
- reporter,+ helpText("Analysis of ADTTE:", tags$code(adtte_name)),
|
| 116 | -+ | 1x |
- mae_name,+ adtteSpecInput(ns("adtte")),
|
| 117 | -+ | 1x |
- exclude_assays,+ teal.widgets::panel_group( |
| 118 | -+ | 1x |
- summary_funs) {
+ teal.widgets::panel_item( |
| 119 | -! | +1x |
- with_reporter <- !missing(reporter) && inherits(reporter, "Reporter")+ input_id = "settings_item", |
| 120 | -! | +1x |
- assert_class(filter_panel_api, "FilterPanelAPI")+ collapsed = TRUE, |
| 121 | -! | +1x |
- assert_class(data, "tdata")+ title = "Additional Settings", |
| 122 | -+ | 1x |
-
+ sliderInput(ns("probs"), label = ("Probability Cutoff"), min = 0.01, max = 0.99, value = 0.5),
|
| 123 | -! | +1x |
- moduleServer(id, function(input, output, session) {
+ sampleVarSpecInput(ns("subgroups"), "Select Categorical Subgroup Variable")
|
| 124 | -! | +
- experiment <- experimentSpecServer(+ ) |
|
| 125 | -! | +
- "experiment",+ ) |
|
| 126 | -! | +
- data = data,+ ), |
|
| 127 | -! | +1x |
- filter_panel_api = filter_panel_api,+ output = teal.widgets::plot_with_settings_ui(ns("plot")),
|
| 128 | -! | +1x |
- mae_name = mae_name+ pre_output = pre_output, |
| 129 | -+ | 1x |
- )+ post_output = post_output |
| 130 | -! | +
- assay <- assaySpecServer(+ ) |
|
| 131 | -! | +
- "assay",+ } |
|
| 132 | -! | +
- assays = experiment$assays,+ |
|
| 133 | -! | +
- exclude_assays = exclude_assays+ #' @describeIn tm_g_forest_tte sets up the server with reactive graph. |
|
| 134 |
- )+ #' @inheritParams module_arguments |
||
| 135 | -! | +
- multi <- multiSampleVarSpecServer(+ #' @export |
|
| 136 | -! | +
- inputIds = c("strat", "color", "facet"),
+ srv_g_forest_tte <- function(id, |
|
| 137 | -! | +
- experiment_name = experiment$name,+ data, |
|
| 138 | -! | +
- original_data = experiment$data+ filter_panel_api, |
|
| 139 |
- )+ reporter, |
||
| 140 | -! | +
- genes <- geneSpecServer(+ adtte_name, |
|
| 141 | -! | +
- "genes",+ mae_name, |
|
| 142 | -! | +
- funs = summary_funs,+ adtte_vars, |
|
| 143 | -! | +
- gene_choices = experiment$genes+ exclude_assays, |
|
| 144 |
- )+ summary_funs, |
||
| 145 | -! | +
- plot_r <- reactive({
+ plot_height, |
|
| 146 |
- # Resolve all reactivity.+ plot_width) {
|
||
| 147 | ! |
- experiment_data <- multi$experiment_data()+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 148 | ! |
- strat <- multi$vars$strat()+ assert_class(filter_panel_api, "FilterPanelAPI") |
|
| 149 | ! |
- genes <- genes()+ assert_class(data, "tdata") |
|
| 150 | -! | +
- facet <- multi$vars$facet()+ |
|
| 151 | ! |
- color <- multi$vars$color()+ moduleServer(id, function(input, output, session) {
|
|
| 152 | ! |
- assay <- assay()+ experiment <- experimentSpecServer( |
|
| 153 | ! |
- jitter <- input$jitter+ "experiment", |
|
| 154 | ! |
- violin <- input$violin+ data = data, |
|
| 155 | -+ | ! |
-
+ filter_panel_api = filter_panel_api, |
| 156 | ! |
- req(+ mae_name = mae_name |
|
| 157 | -! | +
- assay,+ ) |
|
| 158 | -+ | ! |
- # Note: The following statements are important to make sure the UI inputs have been updated.+ assay <- assaySpecServer( |
| 159 | ! |
- isTRUE(assay %in% SummarizedExperiment::assayNames(experiment_data)),+ "assay", |
|
| 160 | ! |
- is.null(facet) || isTRUE(facet %in% names(SummarizedExperiment::colData(experiment_data))),+ assays = experiment$assays, |
|
| 161 | ! |
- is.null(color) || isTRUE(color %in% names(SummarizedExperiment::colData(experiment_data))),+ exclude_assays = exclude_assays |
|
| 162 | -! | +
- is.null(strat) || isTRUE(strat %in% names(SummarizedExperiment::colData(experiment_data))),+ ) |
|
| 163 | ! |
- cancelOutput = FALSE+ genes <- geneSpecServer( |
|
| 164 | -+ | ! |
- )+ "genes", |
| 165 | -+ | ! |
-
+ funs = summary_funs, |
| 166 | ! |
- validate_gene_spec(genes, rownames(experiment_data))+ gene_choices = experiment$genes |
|
| 167 |
-
+ ) |
||
| 168 | ! |
- hermes::draw_boxplot(+ subgroups <- sampleVarSpecServer( |
|
| 169 | ! |
- object = experiment_data,+ "subgroups", |
|
| 170 | ! |
- assay_name = assay,+ experiment_name = experiment$name, |
|
| 171 | ! |
- genes = genes,+ original_data = experiment$data, |
|
| 172 | ! |
- x_var = strat,+ categorical_only = TRUE, |
|
| 173 | ! |
- facet_var = facet,+ explicit_na = TRUE |
|
| 174 | -! | +
- color_var = color,+ ) |
|
| 175 | ! |
- jitter = jitter,+ adtte <- adtteSpecServer( |
|
| 176 | ! |
- violin = violin+ "adtte", |
|
| 177 | -+ | ! |
- )+ data = data, |
| 178 | -+ | ! |
- })+ adtte_name = adtte_name, |
| 179 | ! |
- output$plot <- renderPlot(plot_r())+ mae_name = mae_name, |
|
| 180 | -+ | ! |
-
+ adtte_vars = adtte_vars, |
| 181 | ! |
- pws <- teal.widgets::plot_with_settings_srv(+ experiment_data = subgroups$experiment_data, |
|
| 182 | ! |
- id = "plot",+ experiment_name = experiment$name, |
|
| 183 | ! |
- plot_r = plot_r+ assay = assay, |
|
| 184 | -+ | ! |
- )+ genes = genes, |
| 185 | -+ | ! |
-
+ probs = reactive({
|
| 186 | -+ | ! |
- ### REPORTER+ input$probs |
| 187 | -! | +
- if (with_reporter) {
+ }) |
|
| 188 | -! | +
- card_fun <- function(comment) {
+ ) |
|
| 189 | -! | +
- card <- teal::TealReportCard$new()+ |
|
| 190 | ! |
- card$set_name("Boxplot")
+ surv_subgroups <- reactive({
|
|
| 191 | ! |
- card$append_text("Boxplot", "header2")
+ binned_adtte <- adtte$binned_adtte_subset() |
|
| 192 | ! |
- card$append_fs(filter_panel_api$get_filter_state())+ subgroups_var <- subgroups$sample_var() |
|
| 193 | -! | +
- card$append_text("Selected Options", "header3")
+
|
|
| 194 | ! |
- encodings_list <- list(+ tern::extract_survival_subgroups( |
|
| 195 | ! |
- "Experiment:",+ variables = list( |
|
| 196 | ! |
- input$`experiment-name`,+ tte = adtte_vars$aval, |
|
| 197 | ! |
- "\nAssay:",+ is_event = adtte_vars$is_event, |
|
| 198 | ! |
- input$`assay-name`,+ arm = adtte$gene_factor, |
|
| 199 | ! |
- "\nFacetting Variable:",+ subgroups = subgroups_var |
|
| 200 | -! | +
- input$`facet-sample_var`,+ ), |
|
| 201 | ! |
- "\nGenes Selected:",+ label_all = "All Patients", |
|
| 202 | ! |
- paste0(genes()$get_gene_labels(), collapse = ", "),+ data = binned_adtte |
|
| 203 | -! | +
- "\nGene Summary:",+ ) |
|
| 204 | -! | +
- input$`genes-fun_name`,+ }) |
|
| 205 | -! | +
- "\nJitter:",+ |
|
| 206 | ! |
- input$jitter,+ result <- reactive({
|
|
| 207 | ! |
- "\nViolin:",+ surv_subgroups <- surv_subgroups() |
|
| 208 | ! |
- input$violin,+ lyt <- rtables::basic_table() |
|
| 209 | ! |
- "\nOptional Stratifying Variable:",+ time_unit <- adtte$time_unit() |
|
| 210 | -! | +
- input$`strat-sample_var`,+ |
|
| 211 | ! |
- "\nOptional Color Variable:",+ tern::tabulate_survival_subgroups( |
|
| 212 | ! |
- input$`color-sample_var`,+ lyt = lyt, |
|
| 213 | ! |
- "\nOptional Facet Variable:",+ df = surv_subgroups, |
|
| 214 | ! |
- input$`facet-sample_var`+ vars = c("n_tot_events", "n", "n_events", "median", "hr", "ci"),
|
|
| 215 | -+ | ! |
- )+ time_unit = time_unit |
| 216 | -! | +
- null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == ""))+ ) |
|
| 217 | -! | +
- final_encodings <- if (length(null_encodings_indices) > 0) {
+ }) |
|
| 218 | -! | +
- null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1)+ |
|
| 219 | ! |
- paste(encodings_list[-null_encodings_indices_1], collapse = " ")+ forest_plot <- reactive({
|
|
| 220 | -+ | ! |
- } else {
+ result <- result() |
| 221 | ! |
- paste(encodings_list, collapse = " ")+ tern::g_forest(result) |
|
| 222 |
- }+ }) |
||
| 224 | ! |
- card$append_text(final_encodings, style = "verbatim")+ pws <- teal.widgets::plot_with_settings_srv( |
|
| 225 | ! |
- card$append_text("Plot", "header3")
+ id = "plot", |
|
| 226 | ! |
- card$append_plot(plot_r(), dim = pws$dim())+ plot_r = forest_plot, |
|
| 227 | ! |
- if (!comment == "") {
+ height = plot_height, |
|
| 228 | ! |
- card$append_text("Comment", "header3")
+ width = plot_width |
|
| 229 | -! | +
- card$append_text(comment)+ ) |
|
| 230 |
- }+ |
||
| 231 | -! | +
- card+ ### REPORTER |
|
| 232 | -+ | ! |
- }+ if (with_reporter) {
|
| 233 | ! |
- teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
+ card_fun <- function(comment, label) {
|
|
| 234 | -+ | ! |
- }+ card <- report_card_template( |
| 235 | -+ | ! |
- ###+ title = "Forest Plot", |
| 236 | -+ | ! |
- })+ label = label, |
| 237 | -+ | ! |
- }+ with_filter = TRUE, |
| 238 | -+ | ! |
-
+ filter_panel_api = filter_panel_api |
| 239 |
- #' @describeIn tm_g_boxplot sample module function.+ ) |
||
| 240 | +! | +
+ card$append_text("Selected Options", "header3")
+ |
+ |
| 241 | +! | +
+ encodings_list <- list(+ |
+ |
| 242 | +! | +
+ "Experiment:",+ |
+ |
| 243 | +! | +
+ input$`experiment-name`,+ |
+ |
| 244 | +! | +
+ "\nAssay:",+ |
+ |
| 245 | +! | +
+ input$`assay-name`,+ |
+ |
| 246 | +! | +
+ "\nGenes Selected:",+ |
+ |
| 247 | +! | +
+ paste0(genes()$get_gene_labels(), collapse = ", "),+ |
+ |
| 248 | +! | +
+ "\nGene Summary:",+ |
+ |
| 249 | +! | +
+ input$`genes-fun_name`,+ |
+ |
| 250 | +! | +
+ "\nEndpoint:",+ |
+ |
| 251 | +! | +
+ input$`adtte-paramcd`,+ |
+ |
| 252 | +! | +
+ "\nProbability Cutoff:",+ |
+ |
| 253 | +! | +
+ input$probs,+ |
+ |
| 254 | +! | +
+ "\nSubgroup Variable:",+ |
+ |
| 255 | +! | +
+ input$`subgroups-sample_var`+ |
+ |
| 256 |
- #' @export+ )+ |
+ ||
| 257 | +! | +
+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 241 | -+ | ||
| 258 | +! |
- #' @examples+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 242 | -+ | ||
| 259 | +! |
- #'+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 243 | -+ | ||
| 260 | +! |
- #' # Alternatively you can run the sample module with this function call:+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|
| 244 | +261 |
- #' if (interactive()) {
+ } else {
|
|
| 245 | -+ | ||
| 262 | +! |
- #' sample_tm_g_boxplot()+ paste(encodings_list, collapse = " ") |
|
| 246 | +263 |
- #' }+ } |
|
| 247 | +264 |
- sample_tm_g_boxplot <- function() {
+
|
|
| 248 | +265 | ! |
- mae <- hermes::multi_assay_experiment+ card$append_text(final_encodings, style = "verbatim") |
| 249 | +266 | ! |
- mae_data <- teal.data::dataset("MAE", mae)
+ card$append_text("Plot", "header3")
|
| 250 | +267 | ! |
- data <- teal.data::teal_data(mae_data)+ card$append_plot(forest_plot(), dim = pws$dim()) |
| 251 | +268 | ! |
- app <- teal::init(+ if (!comment == "") {
|
| 252 | +269 | ! |
- data = data,+ card$append_text("Comment", "header3")
|
| 253 | +270 | ! |
- modules = teal::modules(+ card$append_text(comment) |
| 254 | -! | +||
| 271 | +
- tm_g_boxplot(+ } |
||
| 255 | +272 | ! |
- label = "boxplot",+ card+ |
+
| 273 | ++ |
+ } |
|
| 256 | +274 | ! |
- mae_name = "MAE"+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
| 257 | +275 |
- )+ } |
|
| 258 | +276 |
- )+ ### |
|
| 259 | +277 |
- )+ }) |
|
| 260 | -! | +||
| 278 | +
- shinyApp(app$ui, app$server)+ } |
||
| 261 | +279 |
- }+ |
| 1 | +280 |
- #' Module Input for Experiment Specification+ #' @describeIn tm_g_forest_tte sample module function. |
|
| 2 | +281 |
- #'+ #' @export |
|
| 3 | +282 |
- #' @description `r lifecycle::badge("experimental")`
+ #' @examples |
|
| 4 | +283 |
#' |
|
| 5 | +284 |
- #' This defines the input for the experiment specification.+ #' # Alternatively you can run the sample module with this function call: |
|
| 6 | +285 |
- #'+ #' if (interactive()) {
|
|
| 7 | +286 |
- #' @inheritParams module_arguments+ #' sample_tm_g_forest_tte() |
|
| 8 | +287 |
- #' @param label_experiments (`string`)\cr label for the experiment selection.+ #' } |
|
| 9 | +288 |
- #'+ sample_tm_g_forest_tte <- function() { # nolint
|
|
| 10 | +289 |
- #' @return The UI part.+ |
|
| 11 | -+ | ||
| 290 | +! |
- #' @seealso [experimentSpecServer()] for the module server and a complete example.+ mae <- hermes::multi_assay_experiment |
|
| 12 | -+ | ||
| 291 | +! |
- #' @export+ adtte <- teal.modules.hermes::rADTTE %>% |
|
| 13 | -+ | ||
| 292 | +! |
- experimentSpecInput <- function(inputId, # nolint+ dplyr::mutate(is_event = .data$CNSR == 0) |
|
| 14 | +293 |
- data,+ |
|
| 15 | -+ | ||
| 294 | +! |
- mae_name,+ data <- teal.data::teal_data( |
|
| 16 | -+ | ||
| 295 | +! |
- label_experiments = "Select Experiment") {
+ teal.data::dataset( |
|
| 17 | -9x | +||
| 296 | +! |
- assert_string(inputId)+ "ADTTE", |
|
| 18 | -9x | +||
| 297 | +! |
- assert_string(mae_name, min.chars = 1L)+ adtte, |
|
| 19 | -9x | +||
| 298 | +! |
- assert_string(label_experiments, min.chars = 1L)+ code = "adtte <- teal.modules.hermes::rADTTE %>% |
|
| 20 | -9x | +||
| 299 | +! |
- mae <- data[[mae_name]]()+ dplyr::mutate(is_event = .data$CNSR == 0)" |
|
| 21 | -9x | +||
| 300 | ++ |
+ ),+ |
+ |
| 301 | +! | +
+ teal.data::dataset("MAE", mae)
+ |
+ |
| 302 | +
- name_choices <- names(mae)+ ) |
||
| 22 | +303 | ||
| 23 | -9x | +||
| 304 | +! |
- ns <- NS(inputId)+ app <- teal::init( |
|
| 24 | -9x | +||
| 305 | +! |
- selectInput(+ data = data, |
|
| 25 | -9x | +||
| 306 | +! |
- inputId = ns("name"),
+ modules = teal::modules( |
|
| 26 | -9x | +||
| 307 | +! |
- label = label_experiments,+ tm_g_forest_tte( |
|
| 27 | -9x | +||
| 308 | +! |
- choices = name_choices+ label = "forest", |
|
| 28 | -+ | ||
| 309 | +! |
- )+ adtte_name = "ADTTE", |
|
| 29 | -+ | ||
| 310 | +! |
- }+ mae_name = "MAE" |
|
| 30 | +311 |
-
+ ) |
|
| 31 | +312 |
- #' Helper Function to Order Gene Choices+ ) |
|
| 32 | +313 |
- #'+ ) |
|
| 33 | -+ | ||
| 314 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ shinyApp(app$ui, app$server) |
|
| 34 | +315 |
- #'+ } |
| 35 | +1 |
- #' The possible gene choices are ordered as follows. First come all genes which+ #' Module Input for Assay Specification |
||
| 36 | +2 |
- #' have a non-empty name, ordered by their name alphabetically. Last come+ #' |
||
| 37 | +3 |
- #' all genes with an empty name, ordered by their ID alphabetically.+ #' @description `r lifecycle::badge("experimental")`
|
||
| 38 | +4 |
#' |
||
| 39 | +5 |
- #' @param genes (`data.frame`)\cr containing `id` and `name` columns of the+ #' This defines the input for the assay specification. |
||
| 40 | +6 |
- #' gene choices. Note that no missing values are allowed.+ #' |
||
| 41 | +7 |
- #'+ #' @inheritParams module_arguments |
||
| 42 | +8 |
- #' @return The ordered `data.frame`.+ #' @param label_assays (`string`)\cr label for the assay selection. |
||
| 43 | +9 |
- #' @export+ #' |
||
| 44 | +10 |
- #'+ #' @return The UI part. |
||
| 45 | +11 |
- #' @examples+ #' @seealso [assaySpecServer()] for the module server and a complete example. |
||
| 46 | +12 |
- #' genes <- data.frame(+ #' @export |
||
| 47 | +13 |
- #' id = c("7", "1", "2", "345346", "0"),
+ assaySpecInput <- function(inputId, # nolint |
||
| 48 | +14 |
- #' name = c("e", "", "c", "", "a")
+ label_assays = "Select Assay") {
|
||
| 49 | -+ | |||
| 15 | +9x |
- #' )+ assert_string(inputId) |
||
| 50 | -+ | |||
| 16 | +9x |
- #' h_order_genes(genes)+ assert_string(label_assays, min.chars = 1L) |
||
| 51 | +17 |
- h_order_genes <- function(genes) {
+
|
||
| 52 | -4x | +18 | +9x |
- assert_data_frame(genes, types = "character", any.missing = FALSE)+ ns <- NS(inputId) |
| 53 | -4x | -
- assert_set_equal(names(genes), c("id", "name"))
- |
- ||
| 54 | -+ | 19 | +9x |
-
+ tagList( |
| 55 | -4x | +20 | +9x |
- has_empty_name <- genes$name == ""+ selectizeInput( |
| 56 | -4x | +21 | +9x |
- first_genes <- which(!has_empty_name)[order(genes[!has_empty_name, ]$name)]+ inputId = ns("name"),
|
| 57 | -4x | +22 | +9x |
- last_genes <- which(has_empty_name)[order(genes[has_empty_name, ]$id)]+ label = label_assays, |
| 58 | -4x | +23 | +9x |
- genes[c(first_genes, last_genes), ]+ choices = character(0), |
| 59 | -+ | |||
| 24 | +9x |
- }+ options = list( |
||
| 60 | -+ | |||
| 25 | +9x |
-
+ placeholder = "- Nothing selected -" |
||
| 61 | +26 |
- #' Helper Function to Format Gene Choices+ ) |
||
| 62 | +27 |
- #'+ ), |
||
| 63 | -+ | |||
| 28 | +9x |
- #' @description `r lifecycle::badge("experimental")`
+ include_js_files("dropdown.js")
|
||
| 64 | +29 |
- #'+ ) |
||
| 65 | +30 |
- #' Given a [`hermes::AnyHermesData`] data object, as well as the annotation+ } |
||
| 66 | +31 |
- #' column name to use as gene name, this function formats the contained genes+ |
||
| 67 | +32 |
- #' as a `data.frame` ready for consumption in [h_order_genes()] e.g.+ #' Module Server for Assay Specification |
||
| 68 | +33 |
#' |
||
| 69 | +34 |
- #' @details+ #' @description `r lifecycle::badge("experimental")`
|
||
| 70 | +35 |
- #' Note that missing names or names that only contain whitespace+ #' |
||
| 71 | +36 |
- #' are replaced by empty strings for consistency and better labeling in the+ #' This defines the server part for the assay specification. |
||
| 72 | +37 |
- #' UI downstream+ #' |
||
| 73 | +38 |
- #'+ #' @inheritParams module_arguments |
||
| 74 | +39 |
- #' @inheritParams function_arguments+ #' @param assays (reactive `character`)\cr available assays in the currently selected experiment. |
||
| 75 | +40 |
- #' @inheritParams experimentSpecServer+ #' @return The chosen assay as a reactive string. |
||
| 76 | +41 |
#' |
||
| 77 | +42 |
- #' @return A `data.frame` with `id` and `name` columns containing all genes from+ #' @seealso [assaySpecInput()] for the module UI. |
||
| 78 | +43 |
- #' `object`.+ #' |
||
| 79 | +44 |
#' @export |
||
| 80 | +45 |
#' |
||
| 81 | +46 |
#' @examples |
||
| 82 | +47 |
- #' object <- hermes::hermes_data[1:10, ]+ #' ui <- function(id, |
||
| 83 | +48 |
- #' h_gene_data(object, "symbol")+ #' data) {
|
||
| 84 | +49 |
- h_gene_data <- function(object, name_annotation) {
- |
- ||
| 85 | -2x | -
- assert_true(hermes::is_hermes_data(object))+ #' ns <- NS(id) |
||
| 86 | -2x | +|||
| 50 | +
- assert_string(name_annotation, null.ok = TRUE)+ #' teal.widgets::standard_layout( |
|||
| 87 | +51 |
-
+ #' encoding = div( |
||
| 88 | -2x | +|||
| 52 | +
- gene_ids <- hermes::genes(object)+ #' experimentSpecInput( |
|||
| 89 | -2x | +|||
| 53 | +
- gene_names <- if (!is.null(name_annotation)) {
+ #' ns("experiment"),
|
|||
| 90 | -2x | +|||
| 54 | +
- annotation_data <- hermes::annotation(object)+ #' data, |
|||
| 91 | -2x | +|||
| 55 | +
- assert_subset(name_annotation, names(annotation_data))+ #' "MAE" |
|||
| 92 | -2x | +|||
| 56 | +
- annotation_vector <- annotation_data[[name_annotation]]+ #' ), |
|||
| 93 | -2x | +|||
| 57 | +
- annotation_missing <- is.na(annotation_vector) | grepl("^\\s+$", annotation_vector)
+ #' assaySpecInput( |
|||
| 94 | -2x | +|||
| 58 | +
- annotation_vector[annotation_missing] <- ""+ #' ns("assay"),
|
|||
| 95 | -2x | +|||
| 59 | +
- annotation_vector+ #' label_assays = "Please choose assay" |
|||
| 96 | +60 |
- } else {
+ #' ) |
||
| 97 | +61 |
- ""+ #' ), |
||
| 98 | +62 |
- }+ #' output = textOutput(ns("result"))
|
||
| 99 | -2x | +|||
| 63 | +
- data.frame(+ #' ) |
|||
| 100 | -2x | +|||
| 64 | +
- id = gene_ids,+ #' } |
|||
| 101 | -2x | +|||
| 65 | +
- name = gene_names+ #' |
|||
| 102 | +66 |
- )+ #' server <- function(id, data, filter_panel_api) {
|
||
| 103 | +67 |
- }+ #' moduleServer(id, module = function(input, output, session) {
|
||
| 104 | +68 |
-
+ #' experiment <- experimentSpecServer( |
||
| 105 | +69 |
- #' Module Server for Experiment Specification+ #' id = "experiment", |
||
| 106 | +70 |
- #'+ #' data = data, |
||
| 107 | +71 |
- #' @description `r lifecycle::badge("experimental")`
+ #' filter_panel_api = filter_panel_api, |
||
| 108 | +72 |
- #'+ #' mae_name = "MAE" |
||
| 109 | +73 |
- #' This defines the server part for the experiment specification.+ #' ) |
||
| 110 | +74 |
- #'+ #' assay <- assaySpecServer( |
||
| 111 | +75 |
- #' @inheritParams module_arguments+ #' "assay", |
||
| 112 | +76 |
- #' @param name_annotation (`string` or `NULL`)\cr which annotation column to use as name+ #' experiment$assays, |
||
| 113 | +77 |
- #' to return in the `genes` data. If `NULL`, then the `name` column will be set to empty+ #' exclude_assays = c("counts", "cpm", "tpm", "bla")
|
||
| 114 | +78 |
- #' strings.+ #' ) |
||
| 115 | +79 |
- #' @param sample_vars_as_factors (`flag`)\cr whether to convert the sample variables+ #' output$result <- renderPrint({
|
||
| 116 | +80 |
- #' (columns in `colData()` of the experiment) from character to factor variables.+ #' assay() |
||
| 117 | +81 |
- #' @param with_mae_col_data (`flag`)\cr whether to include the `colData()` of the+ #' }) |
||
| 118 | +82 |
- #' MAE into the experiment `colData()`.+ #' }) |
||
| 119 | +83 |
- #' @return List with the following reactive objects:+ #' } |
||
| 120 | +84 |
- #' - `data`: the [`hermes::AnyHermesData`] experiment.+ #' |
||
| 121 | +85 |
- #' - `name`: the name of the experiment as selected by the user.+ #' my_app <- function() {
|
||
| 122 | +86 |
- #' - `genes`: a `data.frame` with the genes in `data`, with columns `id` and `name`.+ #' mae <- hermes::multi_assay_experiment |
||
| 123 | +87 |
- #' - `assays`: the names of the assays in `data`.+ #' mae_name <- "MAE" |
||
| 124 | +88 |
- #'+ #' mae_data <- dataset(mae_name, mae) |
||
| 125 | +89 |
- #' @seealso [experimentSpecInput()] for the module UI.+ #' data <- teal_data(mae_data) |
||
| 126 | +90 |
- #'+ #' app <- init( |
||
| 127 | +91 |
- #' @export+ #' data = data, |
||
| 128 | +92 |
- #'+ #' modules = modules( |
||
| 129 | +93 |
- #' @examples+ #' module( |
||
| 130 | +94 |
- #' ui <- function(id,+ #' label = "assaySpec example", |
||
| 131 | +95 |
- #' data,+ #' server = server, |
||
| 132 | +96 |
- #' mae_name) {
+ #' ui = ui, |
||
| 133 | +97 |
- #' ns <- NS(id)+ #' datanames = "all" |
||
| 134 | +98 |
- #' teal.widgets::standard_layout(+ #' ) |
||
| 135 | +99 |
- #' encoding = div(+ #' ) |
||
| 136 | +100 |
- #' experimentSpecInput(+ #' ) |
||
| 137 | +101 |
- #' ns("my_experiment"),
+ #' shinyApp(app$ui, app$server) |
||
| 138 | +102 |
- #' data,+ #' } |
||
| 139 | +103 |
- #' mae_name,+ #' if (interactive()) {
|
||
| 140 | +104 |
- #' label_experiments = "Please choose experiment"+ #' my_app() |
||
| 141 | +105 |
- #' ),+ #' } |
||
| 142 | +106 |
- #' selectInput(+ assaySpecServer <- function(id, # nolint |
||
| 143 | +107 |
- #' ns("property"),
+ assays, |
||
| 144 | +108 |
- #' "Please choose property",+ exclude_assays = character()) {
|
||
| 145 | -+ | |||
| 109 | +! |
- #' c("data", "name", "genes", "assays")
+ assert_string(id) |
||
| 146 | -+ | |||
| 110 | +! |
- #' )+ assert_reactive(assays) |
||
| 147 | -+ | |||
| 111 | +! |
- #' ),+ assert_character(exclude_assays, any.missing = FALSE) |
||
| 148 | +112 |
- #' output = div(+ |
||
| 149 | -+ | |||
| 113 | +! |
- #' verbatimTextOutput(ns("summary")),
+ moduleServer(id, function(input, output, session) {
|
||
| 150 | +114 |
- #' verbatimTextOutput(ns("head"))
+ # When the assay names change, update the choices for assay. |
||
| 151 | -+ | |||
| 115 | +! |
- #' )+ choices <- reactive({
|
||
| 152 | -+ | |||
| 116 | +! |
- #' )+ assays <- assays() |
||
| 153 | -+ | |||
| 117 | +! |
- #' }+ remaining_assays <- setdiff( |
||
| 154 | -+ | |||
| 118 | +! |
- #'+ assays, |
||
| 155 | -+ | |||
| 119 | +! |
- #' server <- function(id,+ exclude_assays |
||
| 156 | +120 |
- #' data,+ ) |
||
| 157 | -+ | |||
| 121 | +! |
- #' filter_panel_api,+ removed_assays <- setdiff(assays, remaining_assays) |
||
| 158 | -+ | |||
| 122 | +! |
- #' mae_name) {
+ if (length(removed_assays) > 0) {
|
||
| 159 | -+ | |||
| 123 | +! |
- #' moduleServer(id, function(input, output, session) {
+ showNotification(type = "warning", paste( |
||
| 160 | -+ | |||
| 124 | +! |
- #' experiment <- experimentSpecServer(+ "Excluded", ifelse(length(removed_assays) > 1, "assays", "assay"), |
||
| 161 | -+ | |||
| 125 | +! |
- #' "my_experiment",+ hermes::h_short_list(removed_assays), "as per app specifications" |
||
| 162 | +126 |
- #' data,+ )) |
||
| 163 | +127 |
- #' filter_panel_api,+ } |
||
| 164 | -+ | |||
| 128 | +! |
- #' mae_name+ if (length(remaining_assays) == 0) {
|
||
| 165 | -+ | |||
| 129 | +! |
- #' )+ remaining_assays <- character(0) |
||
| 166 | +130 |
- #' result <- reactive({
+ } |
||
| 167 | -+ | |||
| 131 | +! |
- #' switch(input$property,+ remaining_assays |
||
| 168 | +132 |
- #' data = experiment$data(),+ }) |
||
| 169 | +133 |
- #' name = experiment$name(),+ |
||
| 170 | -+ | |||
| 134 | +! |
- #' genes = experiment$genes(),+ observeEvent(choices(), {
|
||
| 171 | -+ | |||
| 135 | +! |
- #' assays = experiment$assays()+ choices <- choices() |
||
| 172 | -+ | |||
| 136 | +! |
- #' )+ updateSelectizeInput(session, "name", choices = choices) |
||
| 173 | -+ | |||
| 137 | +! |
- #' })+ session$sendCustomMessage( |
||
| 174 | -+ | |||
| 138 | +! |
- #' output$summary <- renderPrint({
+ "toggle_dropdown", |
||
| 175 | -+ | |||
| 139 | +! |
- #' result <- result()+ list(input_id = session$ns("name"), disabled = (length(choices) == 0))
|
||
| 176 | +140 |
- #' hermes::summary(result)+ ) |
||
| 177 | +141 |
- #' })+ }) |
||
| 178 | +142 |
- #' output$head <- renderPrint({
+
|
||
| 179 | -+ | |||
| 143 | +! |
- #' result <- result()+ reactive({
|
||
| 180 | -+ | |||
| 144 | +! |
- #' utils::head(result)+ choices <- choices() |
||
| 181 | -+ | |||
| 145 | +! |
- #' })+ validate(need( |
||
| 182 | -+ | |||
| 146 | +! |
- #' })+ length(choices) > 0, |
||
| 183 | -+ | |||
| 147 | +! |
- #' }+ "No assays eligible for this experiment, please make sure to add normalized assays" |
||
| 184 | +148 |
- #'+ )) |
||
| 185 | -+ | |||
| 149 | +! |
- #' my_app <- function() {
+ input$name |
||
| 186 | +150 |
- #' mae <- hermes::multi_assay_experiment+ }) |
||
| 187 | +151 |
- #' mae_name <- "MAE"+ }) |
||
| 188 | +152 |
- #' mae_data <- dataset(mae_name, mae)+ } |
| 189 | +1 |
- #' data <- teal_data(mae_data)+ #' Additional Assertions for `checkmate` |
|
| 190 | +2 |
- #' app <- init(+ #' |
|
| 191 | +3 |
- #' data = data,+ #' @description `r lifecycle::badge("experimental")`
|
|
| 192 | +4 |
- #' modules = modules(+ #' |
|
| 193 | +5 |
- #' module(+ #' We provide additional assertion functions which can be used together with |
|
| 194 | +6 |
- #' label = "experimentSpec example",+ #' the `checkmate` functions. These are described in individual help pages |
|
| 195 | +7 |
- #' server = server,+ #' linked below. |
|
| 196 | +8 |
- #' server_args = list(mae_name = mae_name),+ #' |
|
| 197 | +9 |
- #' ui = ui,+ #' @return Depending on the function prefix. |
|
| 198 | +10 |
- #' ui_args = list(mae_name = mae_name),+ #' - `assert_` functions return the object invisibly if successful, and otherwise |
|
| 199 | +11 |
- #' datanames = "all"+ #' throw an error message. |
|
| 200 | +12 |
- #' )+ #' - `check_` functions return `TRUE` if successful, otherwise a string with the |
|
| 201 | +13 |
- #' )+ #' error message. |
|
| 202 | +14 |
- #' )+ #' - `test_` functions just return `TRUE` or `FALSE`. |
|
| 203 | +15 |
- #' shinyApp(app$ui, app$server)+ #' |
|
| 204 | +16 |
- #' }+ #' @seealso [assert_tag()], [assert_reactive()], [assert_summary_funs()], [assert_adtte_vars()] |
|
| 205 | +17 |
- #' if (interactive()) {
+ #' |
|
| 206 | +18 |
- #' my_app()+ #' @name assertions |
|
| 207 | +19 |
- #' }+ #' @import checkmate |
|
| 208 | +20 |
- experimentSpecServer <- function(id, # nolint+ #' @keywords internal |
|
| 209 | +21 |
- data,+ #' |
|
| 210 | +22 |
- filter_panel_api,+ NULL |
|
| 211 | +23 |
- mae_name,+ |
|
| 212 | +24 |
- name_annotation = "symbol",+ # assert_tag ---- |
|
| 213 | +25 |
- sample_vars_as_factors = TRUE,+ |
|
| 214 | +26 |
- with_mae_col_data = TRUE) {
+ #' Check for Shiny Tag |
|
| 215 | -! | +||
| 27 | +
- assert_string(id)+ #' |
||
| 216 | -! | +||
| 28 | +
- assert_class(data, "tdata")+ #' @description `r lifecycle::badge("experimental")`
|
||
| 217 | -! | +||
| 29 | +
- assert_string(mae_name, min.chars = 1L)+ #' |
||
| 218 | -! | +||
| 30 | +
- assert_string(name_annotation, min.chars = 1L, null.ok = TRUE)+ #' Check whether `x` is a shiny tag. |
||
| 219 | -! | +||
| 31 | +
- assert_flag(sample_vars_as_factors)+ #' |
||
| 220 | -! | +||
| 32 | +
- assert_flag(with_mae_col_data)+ #' @inheritParams assertion_arguments |
||
| 221 | +33 |
-
+ #' @seealso [`assertions`] for more details. |
|
| 222 | -! | +||
| 34 | +
- moduleServer(id, function(input, output, session) {
+ #' |
||
| 223 | +35 |
- # When the filtered data set of the chosen experiment changes, update the+ #' @export |
|
| 224 | +36 |
- # experiment data object.+ #' |
|
| 225 | -! | +||
| 37 | +
- data_return <- reactive({
+ #' @examples |
||
| 226 | -! | +||
| 38 | +
- name <- input$name+ #' check_tag("bla")
|
||
| 227 | -! | +||
| 39 | +
- req(name)+ #' check_tag(NULL, null.ok = TRUE) |
||
| 228 | -! | +||
| 40 | +
- mae <- data[[mae_name]]()+ check_tag <- function(x, null.ok = FALSE) { # nolint
|
||
| 229 | -! | +||
| 41 | +16x |
- orig_object <- mae[[name]]+ assert_flag(null.ok) |
|
| 230 | -! | +||
| 42 | +15x |
- validate(need(+ ok <- (null.ok && test_null(x)) || test_class(x, "shiny.tag") |
|
| 231 | -! | +||
| 43 | +15x |
- hermes::is_hermes_data(orig_object),+ if (!ok) {
|
|
| 232 | -! | +||
| 44 | +1x |
- "Please first convert your experiment to HermesData class"+ return("Must be a 'shiny.tag' or NULL")
|
|
| 233 | +45 |
- ))+ } |
|
| 234 | -! | +||
| 46 | +14x |
- validate(need(+ return(TRUE) |
|
| 235 | -! | +||
| 47 | +
- !hermes::isEmpty(orig_object),+ } |
||
| 236 | -! | +||
| 48 | +
- "No genes or samples included in this experiment, please adjust filters"+ |
||
| 237 | +49 |
- ))+ #' @rdname check_tag |
|
| 238 | -! | +||
| 50 | +
- object <- if (with_mae_col_data) {
+ #' @inheritParams assertion_arguments |
||
| 239 | -! | +||
| 51 | +
- MultiAssayExperiment::getWithColData(mae, name)+ #' @export |
||
| 240 | +52 |
- } else {
+ assert_tag <- makeAssertionFunction(check_tag) |
|
| 241 | -! | +||
| 53 | +
- orig_object+ |
||
| 242 | +54 |
- }+ #' @rdname check_tag |
|
| 243 | -! | +||
| 55 | +
- if (sample_vars_as_factors) {
+ #' @export |
||
| 244 | -! | +||
| 56 | +
- SummarizedExperiment::colData(object) <-+ test_tag <- makeTestFunction(check_tag) |
||
| 245 | -! | +||
| 57 | +
- hermes::df_cols_to_factor(SummarizedExperiment::colData(object))+ |
||
| 246 | +58 |
- }+ #' @rdname check_tag |
|
| 247 | -! | +||
| 59 | +
- object+ #' @inheritParams assertion_arguments |
||
| 248 | +60 |
- })+ #' @export |
|
| 249 | +61 |
-
+ expect_tag <- makeExpectationFunction(check_tag) |
|
| 250 | +62 |
- # When the filtered data set or the chosen experiment changes, update+ |
|
| 251 | +63 |
- # the calls that subset the genes of the chosen experiment data object.+ # assert_reactive ---- |
|
| 252 | -! | +||
| 64 | +
- subset_calls <- reactive({
+
|
||
| 253 | -! | +||
| 65 | +
- name <- input$name+ #' Check for Reactive Input |
||
| 254 | -! | +||
| 66 | +
- req(name)+ #' |
||
| 255 | +67 |
-
+ #' @description `r lifecycle::badge("experimental")`
|
|
| 256 | -! | +||
| 68 | +
- filter_states <- filter_panel_api$get_filter_state()[[mae_name]][[name]]["subset"]+ #' |
||
| 257 | -! | +||
| 69 | +
- filter_states+ #' Check whether `x` is a reactive input. |
||
| 258 | +70 |
- })+ #' |
|
| 259 | +71 |
-
+ #' @inheritParams assertion_arguments |
|
| 260 | +72 |
- # Only when the chosen gene subset changes, we recompute gene choices+ #' @seealso [`assertions`] for more details. |
|
| 261 | -! | +||
| 73 | +
- genes <- eventReactive(subset_calls(), ignoreNULL = FALSE, {
+ #' |
||
| 262 | -! | +||
| 74 | +
- data_return <- data_return()+ #' @export |
||
| 263 | -! | +||
| 75 | +
- genes <- h_gene_data(data_return, name_annotation)+ #' |
||
| 264 | -! | +||
| 76 | +
- h_order_genes(genes)+ #' @examples |
||
| 265 | +77 |
- })+ #' check_reactive("bla")
|
|
| 266 | +78 |
-
+ #' check_reactive(reactive("bla"))
|
|
| 267 | +79 |
- # When the chosen experiment changes, recompute the assay names.+ check_reactive <- function(x) {
|
|
| 268 | -! | +||
| 80 | +6x |
- assays <- eventReactive(input$name, ignoreNULL = TRUE, {
+ inherits(x, "reactive") |
|
| 269 | -! | +||
| 81 | +
- data_return <- data_return()+ } |
||
| 270 | -! | +||
| 82 | +
- SummarizedExperiment::assayNames(data_return)+ |
||
| 271 | +83 |
- })+ #' @rdname check_reactive |
|
| 272 | +84 |
-
+ #' @inheritParams assertion_arguments |
|
| 273 | +85 |
-
+ #' @export |
|
| 274 | -! | +||
| 86 | +
- list(+ assert_reactive <- makeAssertionFunction(check_reactive) |
||
| 275 | -! | +||
| 87 | +
- data = data_return,+ |
||
| 276 | -! | +||
| 88 | +
- name = reactive({
+ #' @rdname check_reactive |
||
| 277 | -! | +||
| 89 | +
- input$name+ #' @export |
||
| 278 | -! | +||
| 90 | +
- }), # nolint+ test_reactive <- makeTestFunction(check_reactive) |
||
| 279 | -! | +||
| 91 | +
- genes = genes,+ |
||
| 280 | -! | +||
| 92 | +
- assays = assays+ # assert_summary_funs ---- |
||
| 281 | +93 |
- )+ |
|
| 282 | +94 |
- })+ #' Check for List of Summary Functions |
|
| 283 | +95 |
- }+ #' |
| 1 | +96 |
- #' Additional Assertions for `checkmate`+ #' @description `r lifecycle::badge("experimental")`
|
||
| 2 | +97 |
#' |
||
| 3 | +98 |
- #' @description `r lifecycle::badge("experimental")`
+ #' Check whether `x` is a list of summary functions. |
||
| 4 | +99 |
#' |
||
| 5 | +100 |
- #' We provide additional assertion functions which can be used together with+ #' @inheritParams assertion_arguments |
||
| 6 | +101 |
- #' the `checkmate` functions. These are described in individual help pages+ #' @param null.ok (`flag`)\cr whether `x` may also contain `NULL`, meaning that |
||
| 7 | +102 |
- #' linked below.+ #' a user choice is possible where no summary function should be applied. |
||
| 8 | +103 |
- #'+ #' @seealso [`assertions`] for more details. |
||
| 9 | +104 |
- #' @return Depending on the function prefix.+ #' |
||
| 10 | +105 |
- #' - `assert_` functions return the object invisibly if successful, and otherwise+ #' @export |
||
| 11 | +106 |
- #' throw an error message.+ #' |
||
| 12 | +107 |
- #' - `check_` functions return `TRUE` if successful, otherwise a string with the+ #' @examples |
||
| 13 | +108 |
- #' error message.+ #' assert_summary_funs(list(mean = colMeans, raw = NULL), null.ok = TRUE) |
||
| 14 | +109 |
- #' - `test_` functions just return `TRUE` or `FALSE`.+ assert_summary_funs <- function(x, null.ok = FALSE) { # nolint
|
||
| 15 | -+ | |||
| 110 | +! | +
+ assert_flag(null.ok)+ |
+ ||
| 111 | +! | +
+ assert_list(+ |
+ ||
| 112 | +! |
- #'+ x, |
||
| 16 | -+ | |||
| 113 | +! |
- #' @seealso [assert_tag()], [assert_reactive()], [assert_summary_funs()], [assert_adtte_vars()]+ types = c("function", `if`(null.ok, "null", NULL)),
|
||
| 17 | -+ | |||
| 114 | +! |
- #'+ min.len = 1L, |
||
| 18 | -+ | |||
| 115 | +! |
- #' @name assertions+ unique = TRUE, |
||
| 19 | -+ | |||
| 116 | +! |
- #' @import checkmate+ names = "unique" |
||
| 20 | +117 |
- #' @keywords internal+ ) |
||
| 21 | -+ | |||
| 118 | +! |
- #'+ invisible(x) |
||
| 22 | +119 |
- NULL+ } |
||
| 23 | +120 | |||
| 24 | +121 |
- # assert_tag ----+ # assert_adtte_vars ---- |
||
| 25 | +122 | |||
| 26 | +123 |
- #' Check for Shiny Tag+ #' Check for `ADTTE` Variables |
||
| 27 | +124 |
#' |
||
| 28 | +125 |
#' @description `r lifecycle::badge("experimental")`
|
||
| 29 | +126 |
#' |
||
| 30 | +127 |
- #' Check whether `x` is a shiny tag.+ #' Check whether `x` is a list of `ADTTE` variables. |
||
| 31 | +128 |
#' |
||
| 32 | +129 |
#' @inheritParams assertion_arguments |
||
| 33 | +130 |
#' @seealso [`assertions`] for more details. |
||
| 34 | +131 |
#' |
||
| 35 | +132 |
#' @export |
||
| 36 | +133 |
#' |
||
| 37 | +134 |
#' @examples |
||
| 38 | -- |
- #' check_tag("bla")
- |
- ||
| 39 | +135 |
- #' check_tag(NULL, null.ok = TRUE)+ #' assert_adtte_vars(list(aval = "AV", is_event = "EV", paramcd = "PC", usubjid = "ID", avalu = "u")) |
||
| 40 | +136 |
- check_tag <- function(x, null.ok = FALSE) { # nolint
- |
- ||
| 41 | -16x | -
- assert_flag(null.ok)+ assert_adtte_vars <- function(x) {
|
||
| 42 | -15x | +137 | +3x |
- ok <- (null.ok && test_null(x)) || test_class(x, "shiny.tag")+ assert_list(x, types = "character", names = "unique", unique = TRUE) |
| 43 | -15x | +138 | +2x |
- if (!ok) {
+ assert_names(names(x), permutation.of = c("aval", "is_event", "paramcd", "usubjid", "avalu"))
|
| 44 | +139 | 1x |
- return("Must be a 'shiny.tag' or NULL")
- |
- |
| 45 | -- |
- }- |
- ||
| 46 | -14x | -
- return(TRUE)+ invisible(x) |
||
| 47 | +140 |
} |
| 48 | +1 |
-
+ #' Teal Module for `Kaplan-Meier` Plot |
|
| 49 | +2 |
- #' @rdname check_tag+ #' |
|
| 50 | +3 |
- #' @inheritParams assertion_arguments+ #' @description `r lifecycle::badge("experimental")`
|
|
| 51 | +4 |
- #' @export+ #' |
|
| 52 | +5 |
- assert_tag <- makeAssertionFunction(check_tag)+ #' This teal module produces a grid style `Kaplan-Meier` plot for data with |
|
| 53 | +6 |
-
+ #' `ADaM` structure. |
|
| 54 | +7 |
- #' @rdname check_tag+ #' |
|
| 55 | +8 |
- #' @export+ #' @inheritParams module_arguments |
|
| 56 | +9 |
- test_tag <- makeTestFunction(check_tag)+ #' |
|
| 57 | +10 |
-
+ #' @return Shiny module to be used in the teal app. |
|
| 58 | +11 |
- #' @rdname check_tag+ #' |
|
| 59 | +12 |
- #' @inheritParams assertion_arguments+ #' @export |
|
| 60 | +13 |
- #' @export+ #' |
|
| 61 | +14 |
- expect_tag <- makeExpectationFunction(check_tag)+ #' @examples |
|
| 62 | +15 |
-
+ #' mae <- hermes::multi_assay_experiment |
|
| 63 | +16 |
- # assert_reactive ----+ #' adtte <- teal.modules.hermes::rADTTE %>% |
|
| 64 | +17 |
-
+ #' dplyr::mutate(is_event = (.data$CNSR == 0)) |
|
| 65 | +18 |
- #' Check for Reactive Input+ #' |
|
| 66 | +19 |
- #'+ #' data <- teal_data( |
|
| 67 | +20 |
- #' @description `r lifecycle::badge("experimental")`
+ #' dataset( |
|
| 68 | +21 |
- #'+ #' "ADTTE", |
|
| 69 | +22 |
- #' Check whether `x` is a reactive input.+ #' adtte, |
|
| 70 | +23 |
- #'+ #' code = "adtte <- teal.modules.hermes::rADTTE %>% |
|
| 71 | +24 |
- #' @inheritParams assertion_arguments+ #' dplyr::mutate(is_event = (.data$CNSR == 0))" |
|
| 72 | +25 |
- #' @seealso [`assertions`] for more details.+ #' ), |
|
| 73 | +26 |
- #'+ #' dataset("MAE", mae)
|
|
| 74 | +27 |
- #' @export+ #' ) |
|
| 75 | +28 |
#' |
|
| 76 | +29 |
- #' @examples+ #' modules <- modules( |
|
| 77 | +30 |
- #' check_reactive("bla")
+ #' tm_g_km( |
|
| 78 | +31 |
- #' check_reactive(reactive("bla"))
+ #' label = "kaplan-meier", |
|
| 79 | +32 |
- check_reactive <- function(x) {
+ #' adtte_name = "ADTTE", |
|
| 80 | -6x | +||
| 33 | +
- inherits(x, "reactive")+ #' mae_name = "MAE" |
||
| 81 | +34 |
- }+ #' ) |
|
| 82 | +35 |
-
+ #' ) |
|
| 83 | +36 |
- #' @rdname check_reactive+ #' |
|
| 84 | +37 |
- #' @inheritParams assertion_arguments+ #' app <- init( |
|
| 85 | +38 |
- #' @export+ #' data = data, |
|
| 86 | +39 |
- assert_reactive <- makeAssertionFunction(check_reactive)+ #' modules = modules |
|
| 87 | +40 |
-
+ #' ) |
|
| 88 | +41 |
- #' @rdname check_reactive+ #' |
|
| 89 | +42 |
- #' @export+ #' if (interactive()) {
|
|
| 90 | +43 |
- test_reactive <- makeTestFunction(check_reactive)+ #' shinyApp(ui = app$ui, server = app$server) |
|
| 91 | +44 |
-
+ #' } |
|
| 92 | +45 |
- # assert_summary_funs ----+ tm_g_km <- function(label, |
|
| 93 | +46 |
-
+ adtte_name, |
|
| 94 | +47 |
- #' Check for List of Summary Functions+ mae_name, |
|
| 95 | +48 |
- #'+ adtte_vars = list( |
|
| 96 | +49 |
- #' @description `r lifecycle::badge("experimental")`
+ aval = "AVAL", |
|
| 97 | +50 |
- #'+ is_event = "is_event", |
|
| 98 | +51 |
- #' Check whether `x` is a list of summary functions.+ paramcd = "PARAMCD", |
|
| 99 | +52 |
- #'+ usubjid = "USUBJID", |
|
| 100 | +53 |
- #' @inheritParams assertion_arguments+ avalu = "AVALU" |
|
| 101 | +54 |
- #' @param null.ok (`flag`)\cr whether `x` may also contain `NULL`, meaning that+ ), |
|
| 102 | +55 |
- #' a user choice is possible where no summary function should be applied.+ exclude_assays = "counts", |
|
| 103 | +56 |
- #' @seealso [`assertions`] for more details.+ summary_funs = list( |
|
| 104 | +57 |
- #'+ Mean = colMeans, |
|
| 105 | +58 |
- #' @export+ Median = matrixStats::colMedians, |
|
| 106 | +59 |
- #'+ Max = matrixStats::colMaxs |
|
| 107 | +60 |
- #' @examples+ ), |
|
| 108 | +61 |
- #' assert_summary_funs(list(mean = colMeans, raw = NULL), null.ok = TRUE)+ pre_output = NULL, |
|
| 109 | +62 |
- assert_summary_funs <- function(x, null.ok = FALSE) { # nolint
+ post_output = NULL) {
|
|
| 110 | +63 | ! |
- assert_flag(null.ok)+ logger::log_info("Initializing tm_g_km")
|
| 111 | +64 | ! |
- assert_list(+ assert_string(label) |
| 112 | +65 | ! |
- x,+ assert_string(adtte_name) |
| 113 | +66 | ! |
- types = c("function", `if`(null.ok, "null", NULL)),
+ assert_string(mae_name) |
| 114 | +67 | ! |
- min.len = 1L,+ assert_adtte_vars(adtte_vars) |
| 115 | +68 | ! |
- unique = TRUE,+ assert_character(exclude_assays, any.missing = FALSE) |
| 116 | +69 | ! |
- names = "unique"- |
-
| 117 | -- |
- )+ assert_summary_funs(summary_funs) |
|
| 118 | +70 | ! |
- invisible(x)- |
-
| 119 | -- |
- }- |
- |
| 120 | -- |
-
+ assert_tag(pre_output, null.ok = TRUE) |
|
| 121 | -+ | ||
| 71 | +! |
- # assert_adtte_vars ----+ assert_tag(post_output, null.ok = TRUE) |
|
| 122 | +72 | ||
| 123 | -- |
- #' Check for `ADTTE` Variables- |
- |
| 124 | -- |
- #'- |
- |
| 125 | -- |
- #' @description `r lifecycle::badge("experimental")`
- |
- |
| 126 | -- |
- #'- |
- |
| 127 | -+ | ||
| 73 | +! |
- #' Check whether `x` is a list of `ADTTE` variables.+ teal::module( |
|
| 128 | -+ | ||
| 74 | +! |
- #'+ label = label, |
|
| 129 | -+ | ||
| 75 | +! |
- #' @inheritParams assertion_arguments+ server = srv_g_km, |
|
| 130 | -+ | ||
| 76 | +! |
- #' @seealso [`assertions`] for more details.+ server_args = list( |
|
| 131 | -+ | ||
| 77 | +! |
- #'+ adtte_name = adtte_name, |
|
| 132 | -+ | ||
| 78 | +! |
- #' @export+ mae_name = mae_name, |
|
| 133 | -+ | ||
| 79 | +! |
- #'+ adtte_vars = adtte_vars, |
|
| 134 | -+ | ||
| 80 | +! |
- #' @examples+ exclude_assays = exclude_assays, |
|
| 135 | -+ | ||
| 81 | +! |
- #' assert_adtte_vars(list(aval = "AV", is_event = "EV", paramcd = "PC", usubjid = "ID", avalu = "u"))+ summary_funs = summary_funs |
|
| 136 | +82 |
- assert_adtte_vars <- function(x) {
+ ), |
|
| 137 | -3x | +||
| 83 | +! |
- assert_list(x, types = "character", names = "unique", unique = TRUE)+ ui = ui_g_km, |
|
| 138 | -2x | +||
| 84 | +! |
- assert_names(names(x), permutation.of = c("aval", "is_event", "paramcd", "usubjid", "avalu"))
+ ui_args = list( |
|
| 139 | -1x | +||
| 85 | +! |
- invisible(x)+ adtte_name = adtte_name, |
|
| 140 | -+ | ||
| 86 | +! |
- }+ mae_name = mae_name, |
| 1 | -+ | ||
| 87 | +! |
- #' Module Input for Assay Specification+ summary_funs = summary_funs, |
|
| 2 | -+ | ||
| 88 | +! |
- #'+ pre_output = pre_output, |
|
| 3 | -+ | ||
| 89 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ post_output = post_output |
|
| 4 | +90 |
- #'+ ), |
|
| 5 | -+ | ||
| 91 | +! |
- #' This defines the input for the assay specification.+ datanames = c(adtte_name, mae_name) |
|
| 6 | +92 |
- #'+ ) |
|
| 7 | +93 |
- #' @inheritParams module_arguments+ } |
|
| 8 | +94 |
- #' @param label_assays (`string`)\cr label for the assay selection.+ |
|
| 9 | +95 |
- #'+ #' @describeIn tm_g_km sets up the user interface. |
|
| 10 | +96 |
- #' @return The UI part.+ #' @inheritParams module_arguments |
|
| 11 | +97 |
- #' @seealso [assaySpecServer()] for the module server and a complete example.+ #' @export |
|
| 12 | +98 |
- #' @export+ ui_g_km <- function(id, |
|
| 13 | +99 |
- assaySpecInput <- function(inputId, # nolint+ data, |
|
| 14 | +100 |
- label_assays = "Select Assay") {
- |
- |
| 15 | -9x | -
- assert_string(inputId)- |
- |
| 16 | -9x | -
- assert_string(label_assays, min.chars = 1L)+ adtte_name, |
|
| 17 | +101 | - - | -|
| 18 | -9x | -
- ns <- NS(inputId)- |
- |
| 19 | -9x | -
- tagList(- |
- |
| 20 | -9x | -
- selectizeInput(- |
- |
| 21 | -9x | -
- inputId = ns("name"),
- |
- |
| 22 | -9x | -
- label = label_assays,- |
- |
| 23 | -9x | -
- choices = character(0),- |
- |
| 24 | -9x | -
- options = list(- |
- |
| 25 | -9x | -
- placeholder = "- Nothing selected -"+ mae_name, |
|
| 26 | +102 |
- )+ summary_funs, |
|
| 27 | +103 |
- ),- |
- |
| 28 | -9x | -
- include_js_files("dropdown.js")
+ pre_output, |
|
| 29 | +104 |
- )+ post_output) {
|
|
| 30 | -+ | ||
| 105 | +1x |
- }+ ns <- NS(id) |
|
| 31 | +106 | ||
| 32 | -+ | ||
| 107 | +1x |
- #' Module Server for Assay Specification+ teal.widgets::standard_layout( |
|
| 33 | -+ | ||
| 108 | +1x |
- #'+ encoding = div( |
|
| 34 | +109 |
- #' @description `r lifecycle::badge("experimental")`
+ ### Reporter |
|
| 35 | -+ | ||
| 110 | +1x |
- #'+ teal.reporter::simple_reporter_ui(ns("simple_reporter")),
|
|
| 36 | +111 |
- #' This defines the server part for the assay specification.+ ### |
|
| 37 | -+ | ||
| 112 | +1x |
- #'+ tags$label("Encodings", class = "text-primary"),
|
|
| 38 | -+ | ||
| 113 | +1x |
- #' @inheritParams module_arguments+ helpText("Analysis of MAE:", tags$code(mae_name)),
|
|
| 39 | -+ | ||
| 114 | +1x |
- #' @param assays (reactive `character`)\cr available assays in the currently selected experiment.+ experimentSpecInput(ns("experiment"), data, mae_name),
|
|
| 40 | -+ | ||
| 115 | +1x |
- #' @return The chosen assay as a reactive string.+ assaySpecInput(ns("assay")),
|
|
| 41 | -+ | ||
| 116 | +1x |
- #'+ geneSpecInput(ns("genes"), summary_funs),
|
|
| 42 | -+ | ||
| 117 | +1x |
- #' @seealso [assaySpecInput()] for the module UI.+ helpText("Analysis of ADTTE:", tags$code(adtte_name)),
|
|
| 43 | -+ | ||
| 118 | +1x |
- #'+ adtteSpecInput(ns("adtte")),
|
|
| 44 | -+ | ||
| 119 | +1x |
- #' @export+ teal.widgets::panel_group( |
|
| 45 | -+ | ||
| 120 | +1x |
- #'+ teal.widgets::panel_item( |
|
| 46 | -+ | ||
| 121 | +1x |
- #' @examples+ input_id = "settings_item", |
|
| 47 | -+ | ||
| 122 | +1x |
- #' ui <- function(id,+ collapsed = TRUE, |
|
| 48 | -+ | ||
| 123 | +1x |
- #' data) {
+ title = "Additional Settings", |
|
| 49 | -+ | ||
| 124 | +1x |
- #' ns <- NS(id)+ sampleVarSpecInput(ns("strata"), "Select Strata"),
|
|
| 50 | -+ | ||
| 125 | +1x |
- #' teal.widgets::standard_layout(+ sliderInput( |
|
| 51 | -+ | ||
| 126 | +1x |
- #' encoding = div(+ ns("percentiles"),
|
|
| 52 | -+ | ||
| 127 | +1x |
- #' experimentSpecInput(+ "Select quantiles to be displayed", |
|
| 53 | -+ | ||
| 128 | +1x |
- #' ns("experiment"),
+ min = 0, |
|
| 54 | -+ | ||
| 129 | +1x |
- #' data,+ max = 1, |
|
| 55 | -+ | ||
| 130 | +1x |
- #' "MAE"+ value = c(0, 0.5) |
|
| 56 | +131 |
- #' ),+ ) |
|
| 57 | +132 |
- #' assaySpecInput(+ ) |
|
| 58 | +133 |
- #' ns("assay"),
+ ) |
|
| 59 | +134 |
- #' label_assays = "Please choose assay"+ ), |
|
| 60 | -+ | ||
| 135 | +1x |
- #' )+ output = teal.widgets::plot_with_settings_ui(ns("plot")),
|
|
| 61 | -+ | ||
| 136 | +1x |
- #' ),+ pre_output = pre_output, |
|
| 62 | -+ | ||
| 137 | +1x |
- #' output = textOutput(ns("result"))
+ post_output = post_output |
|
| 63 | +138 |
- #' )+ ) |
|
| 64 | +139 |
- #' }+ } |
|
| 65 | +140 |
- #'+ |
|
| 66 | +141 |
- #' server <- function(id, data, filter_panel_api) {
+ #' @describeIn tm_g_km sets up the user interface. |
|
| 67 | +142 |
- #' moduleServer(id, module = function(input, output, session) {
+ #' @inheritParams module_arguments |
|
| 68 | +143 |
- #' experiment <- experimentSpecServer(+ #' @export |
|
| 69 | +144 |
- #' id = "experiment",+ srv_g_km <- function(id, |
|
| 70 | +145 |
- #' data = data,+ data, |
|
| 71 | +146 |
- #' filter_panel_api = filter_panel_api,+ filter_panel_api, |
|
| 72 | +147 |
- #' mae_name = "MAE"+ reporter, |
|
| 73 | +148 |
- #' )+ adtte_name, |
|
| 74 | +149 |
- #' assay <- assaySpecServer(+ mae_name, |
|
| 75 | +150 |
- #' "assay",+ adtte_vars, |
|
| 76 | +151 |
- #' experiment$assays,+ summary_funs, |
|
| 77 | +152 |
- #' exclude_assays = c("counts", "cpm", "tpm", "bla")
+ exclude_assays) {
|
|
| 78 | -+ | ||
| 153 | +! |
- #' )+ with_reporter <- !missing(reporter) && inherits(reporter, "Reporter") |
|
| 79 | -+ | ||
| 154 | +! |
- #' output$result <- renderPrint({
+ assert_class(filter_panel_api, "FilterPanelAPI") |
|
| 80 | -+ | ||
| 155 | +! |
- #' assay()+ assert_class(data, "tdata") |
|
| 81 | +156 |
- #' })+ |
|
| 82 | -+ | ||
| 157 | +! |
- #' })+ moduleServer(id, function(input, output, session) {
|
|
| 83 | -+ | ||
| 158 | +! |
- #' }+ experiment <- experimentSpecServer( |
|
| 84 | -+ | ||
| 159 | +! |
- #'+ "experiment", |
|
| 85 | -+ | ||
| 160 | +! |
- #' my_app <- function() {
+ data = data, |
|
| 86 | -+ | ||
| 161 | +! |
- #' mae <- hermes::multi_assay_experiment+ filter_panel_api = filter_panel_api, |
|
| 87 | -+ | ||
| 162 | +! |
- #' mae_name <- "MAE"+ mae_name = mae_name, |
|
| 88 | -+ | ||
| 163 | +! |
- #' mae_data <- dataset(mae_name, mae)+ sample_vars_as_factors = FALSE # To avoid converting logical `event` to factor. |
|
| 89 | +164 |
- #' data <- teal_data(mae_data)+ ) |
|
| 90 | -+ | ||
| 165 | +! |
- #' app <- init(+ assay <- assaySpecServer( |
|
| 91 | -+ | ||
| 166 | +! |
- #' data = data,+ "assay", |
|
| 92 | -+ | ||
| 167 | +! |
- #' modules = modules(+ assays = experiment$assays, |
|
| 93 | -+ | ||
| 168 | +! |
- #' module(+ exclude_assays = exclude_assays |
|
| 94 | +169 |
- #' label = "assaySpec example",+ ) |
|
| 95 | -+ | ||
| 170 | +! |
- #' server = server,+ genes <- geneSpecServer( |
|
| 96 | -+ | ||
| 171 | +! |
- #' ui = ui,+ "genes", |
|
| 97 | -+ | ||
| 172 | +! |
- #' datanames = "all"+ funs = summary_funs, |
|
| 98 | -+ | ||
| 173 | +! |
- #' )+ gene_choices = experiment$genes |
|
| 99 | +174 |
- #' )+ ) |
|
| 100 | -+ | ||
| 175 | +! |
- #' )+ strata <- sampleVarSpecServer( |
|
| 101 | -+ | ||
| 176 | +! |
- #' shinyApp(app$ui, app$server)+ "strata", |
|
| 102 | -+ | ||
| 177 | +! |
- #' }+ experiment_name = experiment$name, |
|
| 103 | -+ | ||
| 178 | +! |
- #' if (interactive()) {
+ original_data = experiment$data |
|
| 104 | +179 |
- #' my_app()+ ) |
|
| 105 | -+ | ||
| 180 | +! |
- #' }+ percentiles_without_borders <- reactive({
|
|
| 106 | -+ | ||
| 181 | +! |
- assaySpecServer <- function(id, # nolint+ percentiles <- input$percentiles |
|
| 107 | +182 |
- assays,+ |
|
| 108 | -+ | ||
| 183 | +! |
- exclude_assays = character()) {
+ result <- setdiff(percentiles, c(0, 1)) |
|
| 109 | +184 | ! |
- assert_string(id)+ validate(need( |
| 110 | +185 | ! |
- assert_reactive(assays)+ length(result) > 0, |
| 111 | +186 | ! |
- assert_character(exclude_assays, any.missing = FALSE)+ "Please select at least one quantile other than 0 and 1" |
| 112 | +187 |
-
+ )) |
|
| 113 | +188 | ! |
- moduleServer(id, function(input, output, session) {
+ result |
| 114 | +189 |
- # When the assay names change, update the choices for assay.+ }) |
|
| 115 | +190 | ! |
- choices <- reactive({
+ adtte <- adtteSpecServer( |
| 116 | +191 | ! |
- assays <- assays()+ "adtte", |
| 117 | +192 | ! |
- remaining_assays <- setdiff(+ data = data, |
| 118 | +193 | ! |
- assays,+ adtte_name = adtte_name, |
| 119 | +194 | ! |
- exclude_assays+ mae_name = mae_name, |
| 120 | -+ | ||
| 195 | +! |
- )+ adtte_vars = adtte_vars, |
|
| 121 | +196 | ! |
- removed_assays <- setdiff(assays, remaining_assays)+ experiment_data = strata$experiment_data, |
| 122 | +197 | ! |
- if (length(removed_assays) > 0) {
+ experiment_name = experiment$name, |
| 123 | +198 | ! |
- showNotification(type = "warning", paste(+ assay = assay, |
| 124 | +199 | ! |
- "Excluded", ifelse(length(removed_assays) > 1, "assays", "assay"),+ genes = genes, |
| 125 | +200 | ! |
- hermes::h_short_list(removed_assays), "as per app specifications"+ probs = percentiles_without_borders |
| 126 | +201 |
- ))+ ) |
|
| 127 | +202 |
- }+ |
|
| 128 | +203 | ! |
- if (length(remaining_assays) == 0) {
+ km_plot <- reactive({
|
| 129 | +204 | ! |
- remaining_assays <- character(0)- |
-
| 130 | -- |
- }+ strata_var <- strata$sample_var() |
|
| 131 | +205 | ! |
- remaining_assays- |
-
| 132 | -- |
- })+ binned_adtte <- adtte$binned_adtte_subset() |
|
| 133 | +206 | ||
| 134 | +207 | ! |
- observeEvent(choices(), {
+ variables <- list( |
| 135 | +208 | ! |
- choices <- choices()+ tte = adtte_vars$aval, |
| 136 | +209 | ! |
- updateSelectizeInput(session, "name", choices = choices)+ is_event = adtte_vars$is_event, |
| 137 | +210 | ! |
- session$sendCustomMessage(+ arm = adtte$gene_factor, |
| 138 | +211 | ! |
- "toggle_dropdown",+ strat = strata_var+ |
+
| 212 | ++ |
+ ) |
|
| 139 | +213 | ! |
- list(input_id = session$ns("name"), disabled = (length(choices) == 0))
+ tern::g_km(binned_adtte, variables = variables, annot_coxph = TRUE) |
| 140 | +214 |
- )+ }) |
|
| 141 | +215 |
- })+ + |
+ |
| 216 | +! | +
+ output$km_plot <- renderPlot(km_plot()) |
|
| 142 | +217 | ||
| 143 | +218 | ! |
- reactive({
+ pws <- teal.widgets::plot_with_settings_srv( |
| 144 | +219 | ! |
- choices <- choices()+ id = "plot", |
| 145 | +220 | ! |
- validate(need(+ plot_r = km_plot |
| 146 | -! | +||
| 221 | +
- length(choices) > 0,+ ) |
||
| 147 | -! | +||
| 222 | +
- "No assays eligible for this experiment, please make sure to add normalized assays"+ |
||
| 148 | +223 |
- ))+ ### REPORTER |
|
| 149 | +224 | ! |
- input$name+ if (with_reporter) {
|
| 150 | -+ | ||
| 225 | +! |
- })+ card_fun <- function(comment, label) {
|
|
| 151 | -+ | ||
| 226 | +! |
- })+ card <- report_card_template( |
|
| 152 | -+ | ||
| 227 | +! |
- }+ title = "Kaplan-Meier Plot", |
| 1 | -+ | ||
| 228 | +! |
- #' Checking for Empty String+ label = label, |
|
| 2 | -+ | ||
| 229 | +! |
- #'+ with_filter = TRUE, |
|
| 3 | -+ | ||
| 230 | +! |
- #' @description `r lifecycle::badge('experimental')`
+ filter_panel_api = filter_panel_api |
|
| 4 | +231 |
- #'+ ) |
|
| 5 | -+ | ||
| 232 | +! |
- #' This predicate function is helpful for functions where arguments could+ card$append_text("Selected Options", "header3")
|
|
| 6 | -+ | ||
| 233 | +! |
- #' not yet be initialized from the teal module.+ encodings_list <- list( |
|
| 7 | -+ | ||
| 234 | +! |
- #'+ "Experiment:", |
|
| 8 | -+ | ||
| 235 | +! |
- #' @param x object to check.+ input$`experiment-name`, |
|
| 9 | -+ | ||
| 236 | +! |
- #'+ "\nAssay:", |
|
| 10 | -+ | ||
| 237 | +! |
- #' @return Flag whether `x` is identical to an empty string, i.e. `""`.+ input$`assay-name`, |
|
| 11 | -+ | ||
| 238 | +! |
- #' @export+ "\nGenes Selected:", |
|
| 12 | -+ | ||
| 239 | +! |
- #'+ paste0(genes()$get_gene_labels(), collapse = ", "), |
|
| 13 | -+ | ||
| 240 | +! |
- #' @examples+ "\nGene Summary:", |
|
| 14 | -+ | ||
| 241 | +! |
- #' is_blank("")
+ input$`genes-fun_name`, |
|
| 15 | -+ | ||
| 242 | +! |
- #' is_blank(" ")
+ "\nEndpoint:", |
|
| 16 | -+ | ||
| 243 | +! |
- is_blank <- function(x) {
+ input$`adtte-paramcd`, |
|
| 17 | -3x | +||
| 244 | +! |
- identical(x, "")+ "\nStrata Selected:", |
|
| 18 | -+ | ||
| 245 | +! |
- }+ input$`strata-sample_var`, |
|
| 19 | -+ | ||
| 246 | +! |
-
+ "\nQuantiles Displayed:", |
|
| 20 | -+ | ||
| 247 | +! |
- #' Helper Function to Extract Words+ paste0(input$percentiles, collapse = "-") |
|
| 21 | +248 |
- #'+ ) |
|
| 22 | -+ | ||
| 249 | +! |
- #' @description `r lifecycle::badge("experimental")`
+ null_encodings_indices <- which(sapply(encodings_list, function(x) is.null(x) || x == "")) |
|
| 23 | -+ | ||
| 250 | +! |
- #'+ final_encodings <- if (length(null_encodings_indices) > 0) {
|
|
| 24 | -+ | ||
| 251 | +! |
- #' This helper function extracts words from a string. Here words are defined+ null_encodings_indices_1 <- c(null_encodings_indices, null_encodings_indices - 1) |
|
| 25 | -+ | ||
| 252 | +! |
- #' as containing lower or upper case letters, colons and dots. All other+ paste(encodings_list[-null_encodings_indices_1], collapse = " ") |
|
| 26 | +253 |
- #' characters are considered separators.+ } else {
|
|
| 27 | -+ | ||
| 254 | +! |
- #'+ paste(encodings_list, collapse = " ") |
|
| 28 | +255 |
- #' @param x (`string`)\cr input.+ } |
|
| 29 | +256 |
- #'+ |
|
| 30 | -+ | ||
| 257 | +! |
- #' @return Character vector with the extracted words.+ card$append_text(final_encodings, style = "verbatim") |
|
| 31 | -+ | ||
| 258 | +! |
- #' @export+ card$append_text("Plot", "header3")
|
|
| 32 | -+ | ||
| 259 | +! |
- #'+ card$append_plot(km_plot(), dim = pws$dim()) |
|
| 33 | -+ | ||
| 260 | +! |
- #' @examples+ if (!comment == "") {
|
|
| 34 | -+ | ||
| 261 | +! |
- #' h_extract_words("a, b, , c, 234; 34562 - GeneID:bla")
+ card$append_text("Comment", "header3")
|
|
| 35 | -+ | ||
| 262 | +! |
- #' h_extract_words("GeneID:1820, sdf.393; 32596")
+ card$append_text(comment) |
|
| 36 | +263 |
- h_extract_words <- function(x) {
+ } |
|
| 37 | -3x | +||
| 264 | +! |
- assert_string(x, min.chars = 1L)+ card |
|
| 38 | -2x | +||
| 265 | +
- stringr::str_extract_all(+ } |
||
| 39 | -2x | +||
| 266 | +! |
- x,+ teal.reporter::simple_reporter_srv("simple_reporter", reporter = reporter, card_fun = card_fun)
|
|
| 40 | -2x | +||
| 267 | +
- "[a-zA-Z0-9:\\.]+"+ } |
||
| 41 | -2x | +||
| 268 | +
- )[[1]]+ ### |
||
| 42 | +269 |
- }+ }) |
|
| 43 | +270 |
-
+ } |
|
| 44 | +271 |
- #' Include `CSS` files from `/inst/css/` package directory to application header+ |
|
| 45 | +272 |
- #'+ #' @describeIn tm_g_km sample module function. |
|
| 46 | +273 |
- #' `system.file` should not be used to access files in other packages, it does+ #' @export |
|
| 47 | +274 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ #' @examples |
|
| 48 | +275 |
- #' as needed. Thus, we do not export this method+ #' |
|
| 49 | +276 |
- #'+ #' # Alternatively you can run the sample module with this function call: |
|
| 50 | +277 |
- #' @param pattern (`character`) pattern of files to be included+ #' if (interactive()) {
|
|
| 51 | +278 |
- #'+ #' sample_tm_g_km() |
|
| 52 | +279 |
- #' @return HTML code that includes `CSS` files+ #' } |
|
| 53 | +280 |
- #' @keywords internal+ sample_tm_g_km <- function() { # nolint
|
|
| 54 | +281 |
- include_css_files <- function(pattern = "*") { # nolint
+
|
|
| 55 | -12x | +||
| 282 | +! |
- css_files <- list.files(+ mae <- hermes::multi_assay_experiment |
|
| 56 | -12x | +||
| 283 | +! |
- system.file("css", package = "teal.modules.hermes", mustWork = TRUE),
+ adtte <- teal.modules.hermes::rADTTE %>% |
|
| 57 | -12x | +||
| 284 | +! |
- pattern = pattern, full.names = TRUE+ dplyr::mutate(is_event = (.data$CNSR == 0)) |
|
| 58 | +285 |
- )+ |
|
| 59 | -12x | +||
| 286 | +! |
- return(shiny::singleton(shiny::tags$head(lapply(css_files, includeCSS))))+ data <- teal.data::teal_data( |
|
| 60 | -+ | ||
| 287 | +! |
- }+ teal.data::dataset( |
|
| 61 | -+ | ||
| 288 | +! |
-
+ "ADTTE", |
|
| 62 | -+ | ||
| 289 | +! |
- #' Include `JS` files from `/inst/js/` package directory to application header+ adtte, |
|
| 63 | -+ | ||
| 290 | +! |
- #'+ code = "adtte <- teal.modules.hermes::rADTTE %>% |
|
| 64 | -+ | ||
| 291 | +! |
- #' `system.file` should not be used to access files in other packages, it does+ dplyr::mutate(is_event = (.data$CNSR == 0))" |
|
| 65 | +292 |
- #' not work with `devtools`. Therefore, we redefine this method in each package+ ), |
|
| 66 | -+ | ||
| 293 | +! |
- #' as needed. Thus, we do not export this method+ teal.data::dataset("MAE", mae)
|
|
| 67 | +294 |
- #'+ ) |
|
| 68 | +295 |
- #' @param pattern (`character`) pattern of files to be included, passed to `system.file`+ |
|
| 69 | -+ | ||
| 296 | +! |
- #' @param except (`character`) vector of basename filenames to be excluded+ modules <- teal::modules( |
|
| 70 | -+ | ||
| 297 | +! |
- #'+ tm_g_km(+ |
+ |
| 298 | +! | +
+ label = "kaplan-meier",+ |
+ |
| 299 | +! | +
+ adtte_name = "ADTTE",+ |
+ |
| 300 | +! | +
+ mae_name = "MAE" |
|
| 71 | +301 |
- #' @return HTML code that includes `JS` files+ ) |
|
| 72 | +302 |
- #' @keywords internal+ ) |
|
| 73 | +303 |
- include_js_files <- function(pattern = "*") { # nolint
+
|
|
| 74 | -12x | +||
| 304 | +! |
- js_files <- list.files(+ app <- teal::init( |
|
| 75 | -12x | +||
| 305 | +! |
- system.file("js", package = "teal.modules.hermes", mustWork = TRUE),
+ data = data, |
|
| 76 | -12x | +||
| 306 | +! |
- pattern = pattern, full.names = TRUE+ modules = modules |
|
| 77 | +307 |
) |
|
| 78 | -12x | +||
| 308 | +
- return(singleton(lapply(js_files, includeScript)))+ + |
+ ||
| 309 | +! | +
+ shinyApp(ui = app$ui, server = app$server) |
|
| 79 | +310 |
} |