From 8798103b89ec5dda72941f088cedef9496e3b696 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Thu, 16 Feb 2023 16:05:50 +0100 Subject: [PATCH 01/49] feat: new table module follows the structure of `PlotModule` in the sense of user experience and not using `renderUI` stuff --- components/base/R/TableModule2.R | 234 +++++++++++++++++++++++++++++++ 1 file changed, 234 insertions(+) create mode 100644 components/base/R/TableModule2.R diff --git a/components/base/R/TableModule2.R b/components/base/R/TableModule2.R new file mode 100644 index 000000000..bce8aac84 --- /dev/null +++ b/components/base/R/TableModule2.R @@ -0,0 +1,234 @@ +TableModuleUI <- function(id, + height = c(400,800), + width = c("auto","100%"), + info.text="Figure", + title="", + options = NULL, + label="", + caption="", + caption2=info.text, + just.info=FALSE, + show.maximize = TRUE) { + ns <- shiny::NS(id) + + if(length(height)==1) height <- c(height,800) + if(length(width)==1) width <- c(width,1200) + + ifnotchar.int <- function(s) suppressWarnings( + ifelse(!is.na(as.integer(s)), paste0(as.integer(s),"px"), s)) + width.1 <- ifnotchar.int(width[1]) + width.2 <- ifnotchar.int(width[2]) + height.1 <- ifnotchar.int(height[1]) + height.2 <- ifnotchar.int(height[2]) + + options.button <- "" + + if(!just.info && !is.null(options) && length(options)>0) { + options.button <- DropdowMenu( + options, + size = "xs", + icon = shiny::icon("bars"), + status = "default" + ) + } + + dload.button <- DropdowMenu( + div( + style = "width: 150px;", + shiny::a("Download table data", + style = "text-align: center;"), + shiny::br(), + shiny::hr(), + div(style = "text-align: center;", + shiny::downloadButton( + outputId = ns("download"), + label = "Download", + ) + ) + ), + size = "xs", + icon = shiny::icon("download"), + status = "default" + ) + + if(!is.null(label) && label!="") label <- paste0(" (",label,")") + label <- shiny::div(class = "plotmodule-title", shiny::HTML(label)) + + zoom.button <- NULL + if(show.maximize) { + zoom.button <- modalTrigger(ns("zoombutton"), + ns("datatablePopup"), + icon("window-maximize"), + class="btn-circle-xs" + ) + } + + header <- shiny::fillRow( + flex = c(NA,1,NA,NA,NA,NA), + shiny::div(class='plotmodule-title', title=title, title), + label, + DropdowMenu( + shiny::tags$p(shiny::HTML(info.text), style = "font-size: smaller;"), + shiny::br(), + size = "xs", + icon = shiny::icon("info"), + status = "default" + ), + options.button, + shiny::div(class='download-button', title='download', dload.button), + shiny::div(class='zoom-button', title='zoom', zoom.button) + ) + + # Modal stuff + + popupdatatableUI <- function() { + w <- width.2 + h <- height.2 + if(any(class(caption2)=="reactive")) { + caption2 <- caption2() + } + if(any(class(caption2)=="character")) { + caption2 <- shiny::HTML(caption2) + caption2 <- shiny::div(caption2, class="caption2") + } + shiny::tagList( + shiny::div( + class = "popup-plot", + DT::DTOutput(ns("datatable2"), width=width.2, height=height.2) + ), + caption2 + ) + } + modaldialog.style <- paste0("#",ns("plotPopup")," .modal-dialog {width:",width.2,";}") + modalbody.style <- paste0("#",ns("plotPopup")," .modal-body {min-height:",height.2,"; padding:30px 300px;}") + modalcontent.style <- paste0("#",ns("plotPopup")," .modal-content {width:100vw;}") + modalfooter.none <- paste0("#",ns("plotPopup")," .modal-footer{display:none;}") + + # Div construction + + div( class="plotmodule", + shiny::fillCol( + flex = c(NA,1,NA,0.001,NA), + height = height.1, + div( header, class="plotmodule-header"), + DT::DTOutput(ns("datatable"), width=width.1, height=height.1), + div( + class = "footer", + shiny::HTML(caption) + ), + shiny::div(class="popup-plot", + modalUI( + ns("datatablePopup"), + title, + size="fullscreen", + popupdatatableUI() + ) + ), + shiny::tagList( + shiny::tags$head(shiny::tags$style(modaldialog.style)), + shiny::tags$head(shiny::tags$style(modalbody.style)), + shiny::tags$head(shiny::tags$style(modalcontent.style)), + shiny::tags$head(shiny::tags$style(modalfooter.none)) + ) + ) + ) +} + +TableModuleServer <- function(id, + func, + func2 = NULL, + csvFunc = NULL, + height = c(640,800), + width = c("auto",1400), + selector = c("none","single", "multi","key")[1], + filename = "data.csv") +{ + moduleServer( + id, + function(input, output, session) { + ns <- session$ns + if(is.null(func2)) func2 <- func + + # Downloader + download.csv <- shiny::downloadHandler( + filename = filename, + content = function(file) { + if(!is.null(csvFunc)) { + dt <- csvFunc() + } else { + dt <- func()$x$data + } + ##write.csv(dt, file=CSVFILE, row.names=FALSE) + ##file.copy(CSVFILE, file, overwrite=TRUE) + write.csv(dt, file=file, row.names=FALSE) + } + ) + output$download <- download.csv + + output$datatable <- DT::renderDT({ + # If the options `scrollX` or `autoWidth` or `selector` are set, + # the global defaults of the global.R + # will be overwritten. This ensures those options + # are kept so that the header scrolls properly, and clickable + # properties for tables. + dt <- func() + active_options <- names(dt$x$options) + if("scrollX" %in% active_options){ + dt$x$options$scrollX <- TRUE + } + if("autoWidth" %in% active_options){ + dt$x$options$autoWidth <- FALSE + } + if(!is.null(selector)){ + dt$x$selection$mode = selector + } + # Remove striping and borders from all tables + dt$x$container <- stringr::str_remove(dt$x$container, "stripe") + dt$x$container <- stringr::str_remove(dt$x$container, "table-bordered") + dt + }, + fillContainer = T) + + output$datatable2 <- DT::renderDT({ + dt <- func2() + active_options <- names(dt$x$options) + if("scrollX" %in% active_options){ + dt$x$options$scrollX <- TRUE + } + if("autoWidth" %in% active_options){ + dt$x$options$autoWidth <- FALSE + } + if(!is.null(selector)){ + dt$x$selection$mode = selector + } + dt$x$container <- stringr::str_remove(dt$x$container, "stripe") + dt$x$container <- stringr::str_remove(dt$x$container, "table-bordered") + dt + }, + fillContainer = T) + + module <- list( + ##data = func, + data = shiny::reactive(func()$x$data), + rows_current = shiny::reactive(input$datatable_rows_current), + rows_selected = shiny::reactive(input$datatable_rows_selected), + rows_all = shiny::reactive(input$datatable_rows_all), + rownames_current = shiny::reactive({ + rns <- rownames(func()$x$data) + if(is.null(rns)) rns <- 1:nrow(func()$x$data) + rns[input$datatable_rows_current] + }), + rownames_selected = shiny::reactive({ + rns <- rownames(func()$x$data) + if(is.null(rns)) rns <- 1:nrow(func()$x$data) + rns[input$datatable_rows_selected] + }), + rownames_all = shiny::reactive({ + rns <- rownames(func()$x$data) + if(is.null(rns)) rns <- 1:nrow(func()$x$data) + rns[input$datatable_rows_all] + }) + ) + return(module) + }) +} From 903c5a60ddfb1b402a2941e6eaffa97dfe645e27 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Thu, 16 Feb 2023 16:26:29 +0100 Subject: [PATCH 02/49] `TableModule` implemented on `board.loading` --- components/board.loading/R/loading_server.R | 73 ++----------------- .../board.loading/R/loading_table_datasets.R | 70 ++++++++++++++++++ components/board.loading/R/loading_ui.R | 24 +++--- 3 files changed, 90 insertions(+), 77 deletions(-) create mode 100644 components/board.loading/R/loading_table_datasets.R diff --git a/components/board.loading/R/loading_server.R b/components/board.loading/R/loading_server.R index 3bcfa8e43..a824fa7a7 100644 --- a/components/board.loading/R/loading_server.R +++ b/components/board.loading/R/loading_server.R @@ -36,6 +36,11 @@ LoadingBoard <- function(id, ##================================================================================ loading_tsne_server("tsne", watermark=FALSE) + pgxtable <- loading_table_datasets_server( + "pgxtable", + pgxTable_data = pgxTable_data + ) + ##----------------------------------------------------------------------------- ## Description ##----------------------------------------------------------------------------- @@ -483,73 +488,7 @@ LoadingBoard <- function(id, df }) - pgxTable_DT <- function() { - df <- pgxTable_data() - req(df) - - ##df <- data.frame(nr=rownames(df), df) - - target1 <- grep("date",colnames(df)) - target2 <- grep("description",colnames(df)) - target3 <- grep("conditions",colnames(df)) - target4 <- grep("dataset",colnames(df)) - - DT::datatable( - df, - # class = 'compact cell-border hover', - class = 'compact hover', - rownames = TRUE, - extensions = c('Scroller'), - selection = list(mode='single', target='row', selected=1), - fillContainer = TRUE, - options=list( - ##dom = 'Blfrtip', - dom = 'ft', - ##columnDefs = list(list(searchable = FALSE, targets = 1)), - pageLength = 9999, - ##lengthMenu = c(20, 30, 40, 100), - scrollX = FALSE, - ##scrollY =400, ## scroller=TRUE, - ##scrollY = '100vh', ## scroller=TRUE, - scrollY = FALSE, - deferRender=TRUE, - autoWidth = TRUE, - columnDefs = list( - list(width='60px', targets=target1), - list(width='30vw', targets=target2) - ) - ) ## end of options.list - ) - } - - pgxTable.RENDER <- function() { - pgxTable_DT() %>% - DT::formatStyle(0, target='row', fontSize='12px', lineHeight='95%') - } - - pgxTable_modal.RENDER <- function() { - pgxTable_DT() %>% - DT::formatStyle(0, target='row', fontSize='16px', lineHeight='95%') - } - - info_text = "This table contains a general information about all available datasets within the platform. For each dataset, it reports a brief description as well as the total number of samples, genes, gene sets (or pathways), corresponding phenotypes and the creation date." - - pgxtable <- shiny::callModule( - tableModule, id = "pgxtable", - func = pgxTable.RENDER, - func2 = pgxTable_modal.RENDER, - title = "Data files", - ##height = c(600,700), - height = c("65vh",700), - width = c('100%','100%'), - info.text = info_text, - caption2 = info_text, - selector = "single" - ) - - - - ##------------------------------------------------ + ##------------------------------------------------ ## Board return object ##------------------------------------------------ res <- list( diff --git a/components/board.loading/R/loading_table_datasets.R b/components/board.loading/R/loading_table_datasets.R new file mode 100644 index 000000000..e95b5939f --- /dev/null +++ b/components/board.loading/R/loading_table_datasets.R @@ -0,0 +1,70 @@ +loading_table_datasets_ui <- function(id, height, width){ + ns <- shiny::NS(id) + + info_text = "This table contains a general information about all available datasets within the platform. For each dataset, it reports a brief description as well as the total number of samples, genes, gene sets (or pathways), corresponding phenotypes and the creation date." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Data files" + ) +} + +loading_table_datasets_server <- function(id, + pgxTable_data){ + + moduleServer( id, function(input, output, session) { + pgxTable_DT <- function() { + df <- pgxTable_data() + req(df) + + ##df <- data.frame(nr=rownames(df), df) + + target1 <- grep("date",colnames(df)) + target2 <- grep("description",colnames(df)) + target3 <- grep("conditions",colnames(df)) + target4 <- grep("dataset",colnames(df)) + + DT::datatable( + df, + class = 'compact hover', + rownames = TRUE, + extensions = c('Scroller'), + selection = list(mode='single', target='row', selected=1), + fillContainer = TRUE, + options=list( + dom = 'ft', + pageLength = 9999, + scrollX = FALSE, + scrollY = FALSE, + deferRender=TRUE, + autoWidth = TRUE, + columnDefs = list( + list(width='60px', targets=target1), + list(width='30vw', targets=target2) + ) + ) ## end of options.list + ) + } + + pgxTable.RENDER <- function() { + pgxTable_DT() %>% + DT::formatStyle(0, target='row', fontSize='12px', lineHeight='95%') + } + + pgxTable_modal.RENDER <- function() { + pgxTable_DT() %>% + DT::formatStyle(0, target='row', fontSize='16px', lineHeight='95%') + } + + TableModuleServer( + "datasets", + func = pgxTable.RENDER, + func2 = pgxTable_modal.RENDER, + selector = "single" + ) + }) + +} \ No newline at end of file diff --git a/components/board.loading/R/loading_ui.R b/components/board.loading/R/loading_ui.R index d1592324a..e08405ebc 100644 --- a/components/board.loading/R/loading_ui.R +++ b/components/board.loading/R/loading_ui.R @@ -6,7 +6,7 @@ downloadButton2 <- function (outputId, label = "Download", class = NULL, ...) { aTag <- shiny::tags$a(id = outputId, class = paste("btn btn-default shiny-download-link", class), - href = "", target = "_blank", download = NA, + href = "", target = "_blank", download = NA, shiny::icon("file-csv"), label, ...) } @@ -28,22 +28,26 @@ LoadingUI <- function(id) { uiOutput(ns("navheader")), br(), br(), - ## table---------------- + ## table---------------- div( class = "row", div( class = "col-md-7", - tableWidget(ns("pgxtable")) + loading_table_datasets_ui( + ns("pgxtable"), + height = c("65vh",700), + width = c('100%','50%') + ) ), - div( - class = "col-md-5", - loading_tsne_ui(ns("tsne"), height=c("65vh","70vh")) - ) + div( + class = "col-md-5", + loading_tsne_ui(ns("tsne"), height=c("65vh","70vh")) + ) ), br(), - + ## buttons---------------- - div( + div( id="load-action-buttons", shiny::actionButton( ns("deletebutton"), label="Delete dataset", icon=icon("trash"), @@ -60,7 +64,7 @@ LoadingUI <- function(id) { shiny::actionButton( ns("loadbutton"), label="Load dataset", icon=icon("file-import"), class="btn btn-outline-primary" - ) + ) ) ) } From e99b7ad861ecad21ddaa47bcdf612021f1e0e7c2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Thu, 16 Feb 2023 16:43:03 +0100 Subject: [PATCH 03/49] `TableModule` implemented on `board.dataview` --- .../R/dataview_table_contrasts.R | 63 ++++++++++++------- .../board.dataview/R/dataview_table_rawdata.R | 35 ++++++----- .../board.dataview/R/dataview_table_samples.R | 31 ++++----- components/board.dataview/R/dataview_ui.R | 17 ++++- 4 files changed, 88 insertions(+), 58 deletions(-) diff --git a/components/board.dataview/R/dataview_table_contrasts.R b/components/board.dataview/R/dataview_table_contrasts.R index eec3f32e9..30518bc60 100644 --- a/components/board.dataview/R/dataview_table_contrasts.R +++ b/components/board.dataview/R/dataview_table_contrasts.R @@ -4,9 +4,31 @@ ## -dataview_table_contrasts_ui <- function(id) { +dataview_table_contrasts_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("tbl")) + + info_text = "Contrast table. Table summarizing the contrasts of all comparisons. Here, you can check which samples belong to which groups for the different comparisons. Non-zero entries '+1' and '-1' correspond to the group of interest and control group, respectively. Zero or empty entries denote samples not use for that comparison." + + opts <- shiny::tagList( + withTooltip( + shiny::radioButtons( + ns("ctbygroup"), + "Show by:", + choices = c("sample", "group") + ), + "Show contrasts by group or by samples.", + placement = "right", options = list(container = "body") + ) + ) + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Contrast table", + options = opts + ) } @@ -48,7 +70,6 @@ dataview_table_contrasts_server <- function(id, dbg("[DataView:contrasts:table.RENDER] reacted!") - tabH <- 600 ## height of tables colnames(dt) <- sub("[_. ]vs[_. ]", "\nvs ", colnames(dt)) DT::datatable( @@ -65,7 +86,7 @@ dataview_table_contrasts_server <- function(id, dom = "lfrtip", scroller = TRUE, scrollX = TRUE, - scrollY = tabH, + scrollY = 350, deferRender = TRUE, autoWidth = TRUE ) @@ -85,28 +106,24 @@ dataview_table_contrasts_server <- function(id, ) } - info_text <- "Contrast table. Table summarizing the contrasts of all comparisons. Here, you can check which samples belong to which groups for the different comparisons. Non-zero entries '+1' and '-1' correspond to the group of interest and control group, respectively. Zero or empty entries denote samples not use for that comparison." + # info_text <- "Contrast table. Table summarizing the contrasts of all comparisons. Here, you can check which samples belong to which groups for the different comparisons. Non-zero entries '+1' and '-1' correspond to the group of interest and control group, respectively. Zero or empty entries denote samples not use for that comparison." + - opts <- shiny::tagList( - withTooltip( - shiny::radioButtons( - ns("ctbygroup"), - "Show by:", - choices = c("sample", "group") - ), - "Show contrasts by group or by samples.", - placement = "right", options = list(container = "body") - ) - ) - contrastTable <- shiny::callModule( - tableModule, "tbl", + TableModuleServer( + "datasets", func = table.RENDER, - csvFunc = contrasts_data, - options = opts, - title = "Contrast table", - filename = "contrasts.csv", - info.text = info_text + selector = "none" ) + + # contrastTable <- shiny::callModule( + # tableModule, "tbl", + # func = table.RENDER, + # csvFunc = contrasts_data, + # options = opts, + # title = "Contrast table", + # filename = "contrasts.csv", + # info.text = info_text + # ) }) ## end of moduleServer } ## end of server diff --git a/components/board.dataview/R/dataview_table_rawdata.R b/components/board.dataview/R/dataview_table_rawdata.R index a118db9e4..1876c1a9a 100644 --- a/components/board.dataview/R/dataview_table_rawdata.R +++ b/components/board.dataview/R/dataview_table_rawdata.R @@ -4,12 +4,22 @@ ## -dataview_table_rawdata_ui <- function(id) { +dataview_table_rawdata_ui <- function(id, width, height) { ns <- shiny::NS(id) - tagList( - ## br(), - tableWidget(ns("tbl")) + + dropdown_search_gene <- "Search gene" + menu_grouped <- "grouped" + menu_options <- "Options" + info_text <- paste0("Under the gene table , the average expression values of genes across the groups can be read. The samples (or cells) can be ungrouped by unclicking the ", menu_grouped, " in the main Options to see the exact expression values per sample (or cell).", "The genes in the table are ordered by the correlation (rho column) with respect to the gene selected by users from the ", dropdown_search_gene, " setting. SD column reports the standard deviation of expression across samples (or cells).") + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Gene expression table" ) + } dataview_table_rawdata_server <- function(id, @@ -196,20 +206,11 @@ dataview_table_rawdata_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "20px", lineHeight = "70%") } - dropdown_search_gene <- "Search gene" - menu_grouped <- "grouped" - menu_options <- "Options" - info_text <- paste0("Under the gene table , the average expression values of genes across the groups can be read. The samples (or cells) can be ungrouped by unclicking the ", menu_grouped, " in the main Options to see the exact expression values per sample (or cell).", "The genes in the table are ordered by the correlation (rho column) with respect to the gene selected by users from the ", dropdown_search_gene, " setting. SD column reports the standard deviation of expression across samples (or cells).") - - shiny::callModule( - tableModule, "tbl", + TableModuleServer( + "datasets", func = rawdataTable.RENDER, - csvFunc = table_data, - title = "Gene expression table", - filename = "counts.csv", - height = c("75vh", 700), - info.text = info_text, - caption2 = info_text + selector = "none" ) + }) ## end of moduleServer } ## end of server diff --git a/components/board.dataview/R/dataview_table_samples.R b/components/board.dataview/R/dataview_table_samples.R index 90fd5491e..62ea1eeb0 100644 --- a/components/board.dataview/R/dataview_table_samples.R +++ b/components/board.dataview/R/dataview_table_samples.R @@ -4,11 +4,21 @@ ## -dataview_table_samples_ui <- function(id) { +dataview_table_samples_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("tbl")) -} + info_text = "Sample information table. Phenotype information about the samples. Phenotype variables + starting with a 'dot' (e.g. '.cell cycle' and '.gender' ) have been estimated from the data." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Sample information", + label = "c" + ) +} dataview_table_samples_server <- function(id, pgx, @@ -55,20 +65,11 @@ dataview_table_samples_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "20px", lineHeight = "70%") } - info_text <- "Sample information table. Phenotype information about the samples. Phenotype variables - starting with a 'dot' (e.g. '.cell cycle' and '.gender' ) have been estimated from the data." - - shiny::callModule( - tableModule, "tbl", - label = "", + TableModuleServer( + "datasets", func = table.RENDER, func2 = modal_table.RENDER, - title = "Sample information", - filename = "samples.csv", - info.text = info_text, - caption2 = info_text - ## height = c(280,750), - ## width=c('auto','100%') + selector = "none" ) }) ## end of moduleServer } ## end of server diff --git a/components/board.dataview/R/dataview_ui.R b/components/board.dataview/R/dataview_ui.R index 9b1b0a918..43ab2dbb9 100644 --- a/components/board.dataview/R/dataview_ui.R +++ b/components/board.dataview/R/dataview_ui.R @@ -194,7 +194,11 @@ DataViewUI <- function(id) { shiny::tabPanel( "Counts table", - dataview_table_rawdata_ui(ns("rawdatatable")), + dataview_table_rawdata_ui( + ns("rawdatatable"), + height = c("75vh", 700), + width = c("100%", "90%") + ), tags$div( class = "caption", HTML("Gene table. The table shows the gene expression values per sample, or average @@ -229,7 +233,10 @@ DataViewUI <- function(id) { ) ), dataview_table_samples_ui( - ns("sampletable")), + ns("sampletable"), + height = c(280,750), + width=c('auto','90%') + ), tags$div( class = "caption", HTML( @@ -249,7 +256,11 @@ DataViewUI <- function(id) { shiny::tabPanel( "Contrasts", - dataview_table_contrasts_ui(ns("contrastTable")), + dataview_table_contrasts_ui( + ns("contrastTable"), + height = c(500,750), + width=c('auto','90%') + ), tags$div( class = "caption", HTML( From 245563e1ce89af61790e98778d3a5ab366fc320d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Thu, 16 Feb 2023 16:47:58 +0100 Subject: [PATCH 04/49] `TableModule` implemented on `board.drugconnectivity` --- .../R/drugconnectivity_plot_cmap_enplot.R | 6 +- .../R/drugconnectivity_table_cmap.R | 42 +++++----- .../R/drugconnectivity_table_dsea.R | 42 +++++----- .../R/drugconnectivity_ui.R | 78 +++++++++---------- 4 files changed, 84 insertions(+), 84 deletions(-) diff --git a/components/board.drugconnectivity/R/drugconnectivity_plot_cmap_enplot.R b/components/board.drugconnectivity/R/drugconnectivity_plot_cmap_enplot.R index 171eab8da..30984e943 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_plot_cmap_enplot.R +++ b/components/board.drugconnectivity/R/drugconnectivity_plot_cmap_enplot.R @@ -16,19 +16,17 @@ drugconnectivity_plot_cmap_enplot_ui <- function(id, label = "", height = c(305, 600)) { ns <- shiny::NS(id) - info_text <- strwrap("Connectivity map. correlates your + info_text <- "Connectivity map. correlates your signature with known drug profiles from the L1000 database, and shows similar and opposite profiles by running the GSEA algorithm on the drug profile - correlation space.") - plot_opts <- shiny::tagList() + correlation space." PlotModuleUI(ns("plot"), title = "Enrichment Plot", label = label, plotlib = "plotly", info.text = info_text, - options = plot_opts, download.fmt = c("png", "pdf", "csv"), height = c(305, 600), width=c('auto', 1000), diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R index 85c4660e0..002a81900 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R @@ -4,9 +4,26 @@ ## -drugconnectivity_table_cmap_ui <- function(id) { +drugconnectivity_table_cmap_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("cmap_table")) + + info_text <- strwrap("Enrichment table. Enrichment is calculated by + correlating your signature with known drug profiles + from the L1000 database. Because the L1000 has multiple + perturbation experiment for a single drug, drugs are + scored by running the GSEA algorithm on the + contrast-drug profile correlation space. In this way, + we obtain a single score for multiple profiles of a + single drug.") + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Connectivity table", + label = "b" + ) } @@ -55,25 +72,10 @@ drugconnectivity_table_cmap_server <- function(id, ) } - info_text <- strwrap("Enrichment table. Enrichment is calculated by - correlating your signature with known drug profiles - from the L1000 database. Because the L1000 has multiple - perturbation experiment for a single drug, drugs are - scored by running the GSEA algorithm on the - contrast-drug profile correlation space. In this way, - we obtain a single score for multiple profiles of a - single drug.") - - table.opts <- shiny::tagList() - cmap_table <- shiny::callModule( - tableModule, - id = "cmap_table", - label = "", + cmap_table <- TableModuleServer( + "datasets", func = table.RENDER, - options = table.opts, - info.text = info_text, - title = "Connectivity table", - height = c(380, 740) + selector = "single" ) return(cmap_table) diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R index e94bd559d..8112d6e06 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R @@ -4,9 +4,26 @@ ## -drugconnectivity_table_dsea_ui <- function(id) { +drugconnectivity_table_dsea_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("dsea_table")) + + info_text <- strwrap("Enrichment table. Enrichment is calculated by + correlating your signature with known drug profiles + from the L1000 database. Because the L1000 has multiple + perturbation experiment for a single drug, drugs are + scored by running the GSEA algorithm on the + contrast-drug profile correlation space. In this way, + we obtain a single score for multiple profiles of a + single drug.") + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Enrichment table", + label = "b" + ) } @@ -59,25 +76,10 @@ drugconnectivity_table_dsea_server <- function(id, ) } - info_text <- strwrap("Enrichment table. Enrichment is calculated by - correlating your signature with known drug profiles - from the L1000 database. Because the L1000 has multiple - perturbation experiment for a single drug, drugs are - scored by running the GSEA algorithm on the - contrast-drug profile correlation space. In this way, - we obtain a single score for multiple profiles of a - single drug.") - - table.opts <- shiny::tagList() - dsea_table <- shiny::callModule( - tableModule, - id = "dsea_table", + dsea_table <- TableModuleServer( + "datasets", func = table.RENDER, - options = table.opts, - info.text = info_text, - selector = "single", - title = "Enrichment table", - height = c(360, 700) + selector = "single" ) return(dsea_table) diff --git a/components/board.drugconnectivity/R/drugconnectivity_ui.R b/components/board.drugconnectivity/R/drugconnectivity_ui.R index fc3e75928..3185f18be 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_ui.R +++ b/components/board.drugconnectivity/R/drugconnectivity_ui.R @@ -8,12 +8,12 @@ DrugConnectivityInputs <- function(id) { bigdash::tabSettings( shiny::hr(), withTooltip(shiny::selectInput(ns("dsea_contrast"), "Contrast:", choices = NULL), - "Select the contrast corresponding to the comparison of interest.", - placement = "top" + "Select the contrast corresponding to the comparison of interest.", + placement = "top" ), withTooltip(shiny::selectInput(ns("dsea_method"), "Analysis type:", choices = ""), - "Select type of drug enrichment analysis: activity or sensitivity (if available).", - placement = "top" + "Select type of drug enrichment analysis: activity or sensitivity (if available).", + placement = "top" ), shiny::hr(), withTooltip( @@ -30,40 +30,37 @@ DrugConnectivityUI <- function(id) { div( boardHeader(title = "Drug Connectivity", info_link = ns("dsea_info")), - div( - shiny::tabsetPanel( - id = ns("tabs"), - shiny::tabPanel( - "Drug enrichment", - div(class = "row", - div(class = "col-md-10", + shiny::tabsetPanel( + id = ns("tabs"), + shiny::tabPanel( + "Drug enrichment", + div( + class = "row", + div(class = "col-md-10", div(class = "row", - div(class = "col-md-6", - drugconnectivity_plot_enplots_ui(ns("dsea_enplots"),label = "a") - ), - div(class = "col-md-6", - drugconnectivity_plot_moa_ui(ns("dsea_moaplot"),label = "b") - ) + div(class = "col-md-6", + drugconnectivity_plot_enplots_ui(ns("dsea_enplots"),label = "a") + ), + div(class = "col-md-6", + drugconnectivity_plot_moa_ui(ns("dsea_moaplot"),label = "c") + ) ), br(), - drugconnectivity_table_dsea_ui(ns("dsea_table")) - ), - div(class = "col-md-2", - drugconnectivity_plot_actmap_ui(ns("dsea_actmap"),label = "d") - ) + drugconnectivity_table_dsea_ui( + ns("dsea_table"), + height = c(360, 700), + width = c("100%", "90%") + ) ), div( - HTML("(a) Drug connectivity correlates your signature with known drug perturbation - profiles from the L1000 database. The figures show the most similar (or opposite) profiles by running - the GSEA algorithm on the profile correlation space. (b) Enrichment table summarizing - the statistical results of the drug enrichment analysis. (c) Mechanism-of-action - plot showing the top most frequent drug class (or target genes) having similar or opposite enrichment - compared to the query signature. (d) Activation matrix visualizing enrichment - levels of drug signatures across multiple contrast profiles.") + class = "col-md-2", + drugconnectivity_plot_actmap_ui(ns("dsea_actmap"),label = "d") ) - ), - shiny::tabPanel( - "Connectivity map (beta)", + ) + ), + shiny::tabPanel( + "Connectivity map - Development", + shiny::div( shiny::fillCol( flex = c(NA, 0.035, 1), height = 750, @@ -72,22 +69,23 @@ DrugConnectivityUI <- function(id) { flex = c(1, 0.05, 1.5), shiny::fillCol( flex = c(1.15, 0.05, 1), - #plotWidget(ns("cmap_enplot")), drugconnectivity_plot_cmap_enplot_ui(ns("cmap_enplot"),label = "a"), shiny::br(), - #tableWidget(ns("cmap_table")) - drugconnectivity_table_cmap_ui(ns("cmap_table")) + drugconnectivity_table_cmap_ui( + ns("cmap_table"), + height = c(380, 740), + width = c("100%", "90%") + ) ), shiny::br(), - #plotWidget(ns("dsea_cmap")) drugconnectivity_plot_cmap_dsea_ui(ns("cmap_dsea"),label = "c") ), div( HTML("(a) Enrichment plot. Enrichment of the selected drug perturbation - profile with your signature. (b) Enrichment table summarizing the statistical - results of the drug enrichment analysis. (c) Connectivity map. - Plot showing the top signatures as UMAP. Each point is one L1000 experiment. - The color corresponds to the rank correlation between the drug signatures and your selected contrast.") + profile with your signature. (b) Enrichment table summarizing the statistical + results of the drug enrichment analysis. (c) Connectivity map. + Plot showing the top signatures as UMAP. Each point is one L1000 experiment. + The color corresponds to the rank correlation between the drug signatures and your selected contrast.") ) ) ) From 47b3dc89dd5e6f025b3114ecd16981b15c1e5c8f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 11:14:11 +0100 Subject: [PATCH 05/49] `TableModule` implemented on `board.enrichment` --- .../R/enrichment_table_enrichment_analysis.R | 48 ++++++++++--------- .../R/enrichment_table_genes_in_geneset_ui.R | 36 +++++++------- ...richment_table_gset_enrich_all_contrasts.R | 29 +++++------ .../R/enrichment_table_n_sig_gsets.R | 29 +++++------ components/board.enrichment/R/enrichment_ui.R | 34 +++++++++++-- 5 files changed, 104 insertions(+), 72 deletions(-) diff --git a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R index 7b89aef7a..1b177c725 100644 --- a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R +++ b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R @@ -3,10 +3,29 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -enrichment_table_enrichment_analysis_ui <- function(id) { +enrichment_table_enrichment_analysis_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("gseatable")) + info_text = paste("Similar to the differential gene expression analysis, users can perform differential expression analysis on a geneset level that is referred as gene set enrichment analysis. To ensure statistical reliability, the platform performs the gene set enrichment analysis using multiple methods, including", a_Spearman, ", ", a_GSVA, ", ", a_ssGSEA, ", ", a_Fisher, ", ", a_GSEA, ", ", a_camera, " and ", a_fry, ".

The combined result from the methods is displayed in this table, where for each geneset the meta.q corresponds to the highest q value provided by the methods and the number of stars indicate how many methods identified the geneset as significant (q < 0.05). The table is interactive; users can sort it by logFC, meta.q and starts. Additionally, the list of genes in that geneset are displayed in the second table on the right. Users can filter top N = {10} differently enriched gene sets in the table by clicking the top 10 gene sets from the table Settings.") + + + gseatable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("gs_showqvalues"), "show indivivual q-values", FALSE), + "Show all q-values of each individual statistical method in the table.", + placement = "top", options = list(container = "body") + ) + ) + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + options = gseatable_opts, + title = "Enrichment analysis", + label = "I" + ) + } enrichment_table_enrichment_analysis_server <- function(id, @@ -62,8 +81,8 @@ enrichment_table_enrichment_analysis_server <- function(id, paging = TRUE, pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = FALSE, - scroller = FALSE, + scrollY = "200px", + scroller = TRUE, deferRender = TRUE, search = list( regex = TRUE, @@ -78,26 +97,9 @@ enrichment_table_enrichment_analysis_server <- function(id, ) }) - gseatable_text <- paste("Similar to the differential gene expression analysis, users can perform differential expression analysis on a geneset level that is referred as gene set enrichment analysis. To ensure statistical reliability, the platform performs the gene set enrichment analysis using multiple methods, including", a_Spearman, ", ", a_GSVA, ", ", a_ssGSEA, ", ", a_Fisher, ", ", a_GSEA, ", ", a_camera, " and ", a_fry, ".

The combined result from the methods is displayed in this table, where for each geneset the meta.q corresponds to the highest q value provided by the methods and the number of stars indicate how many methods identified the geneset as significant (q < 0.05). The table is interactive; users can sort it by logFC, meta.q and starts. Additionally, the list of genes in that geneset are displayed in the second table on the right. Users can filter top N = {10} differently enriched gene sets in the table by clicking the top 10 gene sets from the table Settings.") - - gseatable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("gs_showqvalues"), "show indivivual q-values", FALSE), - "Show all q-values of each individual statistical method in the table.", - placement = "top", options = list(container = "body") - ) - ) - - gseatable <- shiny::callModule( - tableModule, - id = "gseatable", + gseatable <- TableModuleServer( + "datasets", func = gseatable.RENDER, - info.text = gseatable_text, - options = gseatable_opts, - title = tags$div( - HTML('(I)Enrichment analysis') - ), - info.width = "500px", - height = c(285, 700), selector = "single" ) diff --git a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R index 6785566f9..7ae377f3c 100644 --- a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R +++ b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -enrichment_table_genes_in_geneset_ui <- function(id) { +enrichment_table_genes_in_geneset_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("genetable")) + info_text <- "By clicking on a gene set in the table I, it is possible to see the gene list of that gene set in this table. By clicking on a gene in this table, users can check the expression status of the gene for the selected contrast in the Expression barplot and its correlation to the gene set in the Gene to gene set correlation scatter plot under the Plots section." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Genes in gene set", + label = "II" + ) + } enrichment_table_genes_in_geneset_server <- function(id, @@ -41,11 +51,11 @@ enrichment_table_genes_in_geneset_server <- function(id, fillContainer = TRUE, options = list( dom = "frtip", - paging = TRUE, - pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + #paging = TRUE, + #pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = FALSE, - scroller = FALSE, + scrollY = 700, + scroller = TRUE, deferRender = TRUE, search = list( regex = TRUE, @@ -64,18 +74,10 @@ enrichment_table_genes_in_geneset_server <- function(id, tbl }) - genetable_text <- "By clicking on a gene set in the table I, it is possible to see the gene list of that gene set in this table. By clicking on a gene in this table, users can check the expression status of the gene for the selected contrast in the Expression barplot and its correlation to the gene set in the Gene to gene set correlation scatter plot under the Plots section." - - genetable <- shiny::callModule( - tableModule, - id = "genetable", + genetable <- TableModuleServer( + "datasets", func = genetable.RENDER, - info.text = genetable_text, - selector = "single", - title = tags$div( - HTML('(II)Genes in gene set') - ), - height = c(285, 700), width = c("auto", 800) + selector = "single" ) return(genetable) diff --git a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R index 0fa5c8950..1acbcf83f 100644 --- a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R +++ b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R @@ -3,10 +3,19 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -enrichment_table_gset_enrich_all_contrasts_ui <- function(id) { +enrichment_table_gset_enrich_all_contrasts_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("fctable")) + info_text <- "The Enrichment (all) panel reports the gene set enrichment for all contrasts in the selected dataset." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Gene set enrichment for all contrasts" + ) + } enrichment_table_gset_enrich_all_contrasts_server <- function(id, @@ -58,19 +67,11 @@ enrichment_table_gset_enrich_all_contrasts_server <- function(id, ) }) - gx_fctable_text <- "The Enrichment (all) panel reports the gene set enrichment for all contrasts in the selected dataset." - - gx_fctable_caption <- "Enrichment for all contrasts. Table summarizing the enrichment for all gene sets across all contrasts. The column `fc.var` corresponds to the variance of the gene set across all contrasts." - - shiny::callModule( - tableModule, - id = "fctable", + TableModuleServer( + "datasets", func = fctable.RENDER, - title = "Gene set enrichment for all contrasts", - info.text = gx_fctable_text, - caption = gx_fctable_caption, - height = c(295, 750), - width = c("100%", 1600) + selector = "none" ) + }) } diff --git a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R index 2947da9a1..1baf01954 100644 --- a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R +++ b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R @@ -3,10 +3,19 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -enrichment_table_n_sig_gsets_ui <- function(id) { +enrichment_table_n_sig_gsets_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("FDRtable")) + info_text <- "The FDR table panel reports the number of significant gene sets at different FDR thresholds, for all contrasts and all methods. Using the table the user can determine which statistical methods perform better for a particular contrast." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Number of significant gene sets" + ) + } enrichment_table_n_sig_gsets_server <- function(id, @@ -84,19 +93,11 @@ enrichment_table_n_sig_gsets_server <- function(id, ) }) - FDRtable_text <- "The FDR table panel reports the number of significant gene sets at different FDR thresholds, for all contrasts and all methods. Using the table the user can determine which statistical methods perform better for a particular contrast." - - FDRtable_caption <- "FDR table. Number of significant gene sets versus different FDR thresholds, for all contrasts and all methods. The blue color denote the number of downregulated genes, the red color for upregulated genes." - - shiny::callModule( - tableModule, - id = "FDRtable", + TableModuleServer( + "datasets", func = FDRtable.RENDER, - title = "Number of significant gene sets", - info.text = FDRtable_text, - caption = FDRtable_caption, - height = c(295, 750), - width = c("100%", 1600) + selector = "none" ) + }) } diff --git a/components/board.enrichment/R/enrichment_ui.R b/components/board.enrichment/R/enrichment_ui.R index 9ecb56ad0..81dfa980e 100644 --- a/components/board.enrichment/R/enrichment_ui.R +++ b/components/board.enrichment/R/enrichment_ui.R @@ -198,21 +198,47 @@ EnrichmentUI <- function(id) { class = "row", div( class = "col-md-7", - enrichment_table_enrichment_analysis_ui(ns("gseatable")) + enrichment_table_enrichment_analysis_ui( + ns("gseatable"), + width = c("100%", "90%"), + height = c(285, 700) + ) ), div( class = "col-md-5", - enrichment_table_genes_in_geneset_ui(ns("genetable")) + enrichment_table_genes_in_geneset_ui( + ns("genetable"), + height = c(285, 700), + width = c("100%", "90%") + ) ) ) ), shiny::tabPanel( "Foldchange (all)", - enrichment_table_gset_enrich_all_contrasts_ui(ns("fctable")) + div( + shiny::HTML("Enrichment for all contrasts. Table summarizing the enrichment + for all gene sets across all contrasts. The column `fc.var` corresponds + to the variance of the gene set across all contrasts.") + ), + enrichment_table_gset_enrich_all_contrasts_ui( + ns("fctable"), + height = c(295, 750), + width = c("100%", "90%") + ) ), shiny::tabPanel( "FDR table", - enrichment_table_n_sig_gsets_ui(ns("FDRtable")) + div( + shiny::HTML("FDR table. Number of significant gene sets versus different + FDR thresholds, for all contrasts and all methods. The blue color + denote the number of downregulated genes, the red color for upregulated genes.") + ), + enrichment_table_n_sig_gsets_ui( + ns("FDRtable"), + height = c(295, 750), + width = c("100%", "90%") + ) ) ) ) From 4481b1d700fa270e7c13ddcb249a040a733d04f8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 12:12:07 +0100 Subject: [PATCH 06/49] `TableModule` implemented on `board.signature` --- .../R/signature_table_enrich_by_contrasts.R | 29 ++++++------ .../R/signature_table_genes_in_signature.R | 45 +++++++++++++------ .../R/signature_table_overlap.R | 38 +++++++++++----- components/board.signature/R/signature_ui.R | 18 ++++++-- 4 files changed, 90 insertions(+), 40 deletions(-) diff --git a/components/board.signature/R/signature_table_enrich_by_contrasts.R b/components/board.signature/R/signature_table_enrich_by_contrasts.R index 526aa6f01..746664019 100644 --- a/components/board.signature/R/signature_table_enrich_by_contrasts.R +++ b/components/board.signature/R/signature_table_enrich_by_contrasts.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -signature_table_enrich_by_contrasts_ui <- function(id) { +signature_table_enrich_by_contrasts_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("table")) + info_text <- "Enrichment by contrast. Enrichment scores of query signature across all contrasts. The table summarizes the enrichment statistics of the gene list in all contrasts using the GSEA algorithm. The NES corresponds to the normalized enrichment score of the GSEA analysis. " + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Enrichment by contrasts", + label = "a" + ) + } signature_table_enrich_by_contrasts_server <- function(id, @@ -53,19 +63,12 @@ signature_table_enrich_by_contrasts_server <- function(id, ) }) - info.text1 <- "Enrichment by contrast. Enrichment scores of query signature across all contrasts. The table summarizes the enrichment statistics of the gene list in all contrasts using the GSEA algorithm. The NES corresponds to the normalized enrichment score of the GSEA analysis. " - - enrichmentContrastTable <- shiny::callModule( - tableModule, - id = "table", + enrichmentContrastTable <- TableModuleServer( + "datasets", func = enrichmentContrastTable.RENDER, - info.text = info.text1, - caption2 = info.text1, - title = tags$div( - HTML('(a)Enrichment by contrasts') - ), - height = c(230, 700) + selector = "single" ) + return(enrichmentContrastTable) }) } diff --git a/components/board.signature/R/signature_table_genes_in_signature.R b/components/board.signature/R/signature_table_genes_in_signature.R index f02b16ccf..149b904b8 100644 --- a/components/board.signature/R/signature_table_genes_in_signature.R +++ b/components/board.signature/R/signature_table_genes_in_signature.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -signature_table_genes_in_signature_ui <- function(id) { +signature_table_genes_in_signature_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("table")) + info_text <- "Gene table. Genes of the current signature corresponding to the selected contrast. Genes are sorted by decreasing (absolute) fold-change." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Genes in signature", + label = "b" + ) + } signature_table_genes_in_signature_server <- function(id, @@ -15,7 +25,10 @@ signature_table_genes_in_signature_server <- function(id, moduleServer(id, function(input, output, session) { enrichmentGeneTable.RENDER <- shiny::reactive({ df <- getEnrichmentGeneTable() - shiny::req(df) + if (is.null(df)) { + shiny::validate(shiny::need(!is.null(df), "Select a signature.")) + return(NULL) + } color_fx <- as.numeric(df[, 3:ncol(df)]) color_fx[is.na(color_fx)] <- 0 ## yikes... @@ -45,17 +58,23 @@ signature_table_genes_in_signature_server <- function(id, ) }) - info.text2 <- "Gene table. Genes of the current signature corresponding to the selected contrast. Genes are sorted by decreasing (absolute) fold-change." - enrichmentGeneTable <- shiny::callModule( - tableModule, - id = "table", + # info.text2 <- "Gene table. Genes of the current signature corresponding to the selected contrast. Genes are sorted by decreasing (absolute) fold-change." + # enrichmentGeneTable <- shiny::callModule( + # tableModule, + # id = "table", + # func = enrichmentGeneTable.RENDER, + # info.text = info.text2, + # caption2 = info.text2, + # title = tags$div( + # HTML('(b)Genes in signature') + # ), + # height = c(360, 700) + # ) + + enrichmentGeneTable <- TableModuleServer( + "datasets", func = enrichmentGeneTable.RENDER, - info.text = info.text2, - caption2 = info.text2, - title = tags$div( - HTML('(b)Genes in signature') - ), - height = c(360, 700) + selector = "single" ) return(enrichmentGeneTable) }) diff --git a/components/board.signature/R/signature_table_overlap.R b/components/board.signature/R/signature_table_overlap.R index 434c1b2f6..6dd20866b 100644 --- a/components/board.signature/R/signature_table_overlap.R +++ b/components/board.signature/R/signature_table_overlap.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -signature_table_overlap_ui <- function(id) { +signature_table_overlap_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("table")) + info_text <- "Under the Overlap/similarity tab, users can find the similarity of their gene list with all the gene sets and pathways in the platform, including statistics such as the total number of genes in the gene set (K), the number of intersecting genes between the list and the gene set (k), the overlapping ratio of k/K, logarithm of the odds ratio (log.OR), as well as the p and q values by the Fisher’s test for the overlap test." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Overlap with other signatures", + label = "b" + ) + } signature_table_overlap_server <- function(id, @@ -44,17 +54,23 @@ signature_table_overlap_server <- function(id, ) }) - info.text <- "Under the Overlap/similarity tab, users can find the similarity of their gene list with all the gene sets and pathways in the platform, including statistics such as the total number of genes in the gene set (K), the number of intersecting genes between the list and the gene set (k), the overlapping ratio of k/K, logarithm of the odds ratio (log.OR), as well as the p and q values by the Fisher’s test for the overlap test." + # info.text <- "Under the Overlap/similarity tab, users can find the similarity of their gene list with all the gene sets and pathways in the platform, including statistics such as the total number of genes in the gene set (K), the number of intersecting genes between the list and the gene set (k), the overlapping ratio of k/K, logarithm of the odds ratio (log.OR), as well as the p and q values by the Fisher’s test for the overlap test." + + # overlapTable <- shiny::callModule( + # tableModule, + # id = "table", + # func = overlapTable.RENDER, + # title = tags$div( + # HTML('(b)Overlap with other signatures') + # ), + # info.text = info.text, + # height = 0.4 * fullH + # ) - overlapTable <- shiny::callModule( - tableModule, - id = "table", + overlapTable <- TableModuleServer( + "datasets", func = overlapTable.RENDER, - title = tags$div( - HTML('(b)Overlap with other signatures') - ), - info.text = info.text, - height = 0.4 * fullH + selector = "none" ) return(overlapTable) }) diff --git a/components/board.signature/R/signature_ui.R b/components/board.signature/R/signature_ui.R index d737b9a65..1249e36ca 100644 --- a/components/board.signature/R/signature_ui.R +++ b/components/board.signature/R/signature_ui.R @@ -115,7 +115,11 @@ SignatureUI <- function(id) { height = 0.45 * fullH ), shiny::br(), - signature_table_overlap_ui(ns("overlapTable")), + signature_table_overlap_ui( + ns("overlapTable"), + height = 0.4 * fullH, + width = c("auto", "90%") + ), shiny::br(), tags$div( HTML(" @@ -147,9 +151,17 @@ SignatureUI <- function(id) { id = ns("tabs2"), shiny::tabPanel( "Enrichment table", - signature_table_enrich_by_contrasts_ui(ns("enrichmentContrastTable")), + signature_table_enrich_by_contrasts_ui( + ns("enrichmentContrastTable"), + height = c(230, 700), + width = c("auto", "90%") + ), shiny::br(), - signature_table_genes_in_signature_ui(ns("enrichmentGeneTable")), + signature_table_genes_in_signature_ui( + ns("enrichmentGeneTable"), + height = c(360, 700), + width = c("auto", "90%") + ), shiny::br(), tags$div( HTML(" From ba03a89eb7ff298f38fa4ea2517d03f7fd54b5d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 12:16:55 +0100 Subject: [PATCH 07/49] remove commented code --- .../R/signature_table_genes_in_signature.R | 13 ------------- .../board.signature/R/signature_table_overlap.R | 13 ------------- 2 files changed, 26 deletions(-) diff --git a/components/board.signature/R/signature_table_genes_in_signature.R b/components/board.signature/R/signature_table_genes_in_signature.R index 149b904b8..df461dd7b 100644 --- a/components/board.signature/R/signature_table_genes_in_signature.R +++ b/components/board.signature/R/signature_table_genes_in_signature.R @@ -58,19 +58,6 @@ signature_table_genes_in_signature_server <- function(id, ) }) - # info.text2 <- "Gene table. Genes of the current signature corresponding to the selected contrast. Genes are sorted by decreasing (absolute) fold-change." - # enrichmentGeneTable <- shiny::callModule( - # tableModule, - # id = "table", - # func = enrichmentGeneTable.RENDER, - # info.text = info.text2, - # caption2 = info.text2, - # title = tags$div( - # HTML('(b)Genes in signature') - # ), - # height = c(360, 700) - # ) - enrichmentGeneTable <- TableModuleServer( "datasets", func = enrichmentGeneTable.RENDER, diff --git a/components/board.signature/R/signature_table_overlap.R b/components/board.signature/R/signature_table_overlap.R index 6dd20866b..6a2f4b275 100644 --- a/components/board.signature/R/signature_table_overlap.R +++ b/components/board.signature/R/signature_table_overlap.R @@ -54,19 +54,6 @@ signature_table_overlap_server <- function(id, ) }) - # info.text <- "Under the Overlap/similarity tab, users can find the similarity of their gene list with all the gene sets and pathways in the platform, including statistics such as the total number of genes in the gene set (K), the number of intersecting genes between the list and the gene set (k), the overlapping ratio of k/K, logarithm of the odds ratio (log.OR), as well as the p and q values by the Fisher’s test for the overlap test." - - # overlapTable <- shiny::callModule( - # tableModule, - # id = "table", - # func = overlapTable.RENDER, - # title = tags$div( - # HTML('(b)Overlap with other signatures') - # ), - # info.text = info.text, - # height = 0.4 * fullH - # ) - overlapTable <- TableModuleServer( "datasets", func = overlapTable.RENDER, From 1bb1dd23e74da24622c3838f9e008fda4f26b9f1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 12:23:13 +0100 Subject: [PATCH 08/49] `TableModule` implemented on `board.compare` --- .../R/compare_table_corr_score.R | 28 ++++++++++--------- components/board.compare/R/compare_ui.R | 7 +++-- 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/components/board.compare/R/compare_table_corr_score.R b/components/board.compare/R/compare_table_corr_score.R index 967c80c16..c3816fafa 100644 --- a/components/board.compare/R/compare_table_corr_score.R +++ b/components/board.compare/R/compare_table_corr_score.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -compare_table_corr_score_ui <- function(id, label = "", height = c(600, 800)) { +compare_table_corr_score_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("table")) + info_text <- "In this table, users can check mean expression values of features across the conditions for the selected genes." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Correlation score", + label = "b" + ) + } compare_table_corr_score_server <- function(id, @@ -40,18 +50,10 @@ compare_table_corr_score_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) - score_table_info <- "In this table, users can check mean expression values of features across the conditions for the selected genes." - - score_table <- shiny::callModule( - tableModule, - id = "table", + score_table <- TableModuleServer( + "datasets", func = score_table.RENDER, - info.text = score_table_info, - title = tags$div( - HTML('(b)Correlation score') - ), - height = c(235, 750), - width = c("auto", 1600) + selector = "none" ) return(score_table) }) diff --git a/components/board.compare/R/compare_ui.R b/components/board.compare/R/compare_ui.R index 1ec46e6d9..c1821758d 100644 --- a/components/board.compare/R/compare_ui.R +++ b/components/board.compare/R/compare_ui.R @@ -140,8 +140,11 @@ CompareUI <- function(id) { div( class = "col-md-6", compare_plot_expression_ui(ns("multibarplot")), - compare_table_corr_score_ui(ns("score_table")) - # tableWidget(ns("score_table")) + compare_table_corr_score_ui( + ns("score_table"), + height = c(235, 750), + width = c("auto", "90%") + ) ), div( class = "col-md-6", From c3c3dc0f1fcb96199b42bc972365b47279a582de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 15:24:36 +0100 Subject: [PATCH 09/49] `TableModule` implemented on `board.wgcna` --- components/board.wgcna/R/wgcna_server.R | 112 ------------------ .../board.wgcna/R/wgcna_table_enrichment.R | 27 +++-- components/board.wgcna/R/wgcna_table_genes.R | 29 +++-- components/board.wgcna/R/wgcna_ui.R | 22 ++-- 4 files changed, 46 insertions(+), 144 deletions(-) diff --git a/components/board.wgcna/R/wgcna_server.R b/components/board.wgcna/R/wgcna_server.R index 849109b5e..ef3eb6e6e 100644 --- a/components/board.wgcna/R/wgcna_server.R +++ b/components/board.wgcna/R/wgcna_server.R @@ -366,118 +366,6 @@ WgcnaBoard <- function(id, inputData) { df }) - ## ---------------------------------------- - ## ------ intramodular analysis ----------- - ## ---------------------------------------- - - # intraHeatmap.RENDER <- shiny::reactive({ - # ##intraHeatmap.RENDER <- shiny::reactive({ - # - # message("[intraHeatmap.RENDER] reacted") - # - # out <- wgcna.compute() - # - # MEs <- out$net$MEs - # rho1 <- cor(MEs, out$datExpr, use="pairwise") - # rho1[is.na(rho1) | is.infinite(rho1)] <- 0 - # - # rho2 <- cor(out$datTraits, out$datExpr, use="pairwise") - # rho2[is.na(rho2) | is.infinite(rho2)] <- 0 - # - # rho3 <- cor( t(rho2), t(rho1), use="pairwise") - # rho3[is.na(rho3) | is.infinite(rho3)] <- 0 - # - # gx.heatmap(rho3, nmax=50, mar=c(5,10), - # keysize=0.5, scale="none", key=FALSE) - # - # }) - - # intraHeatmap_opts = shiny::tagList( - # shiny::checkboxInput(ns("eigen_cov"),"covariance", FALSE) - # ) - # - # intraHeatmap_info = - # "WGCNA Module membership (eigengene correlation). For each module, we also define a quantitative measure of module membership (MM) as the correlation of the module eigengene and the gene expression profile. This allows us to quantify the similarity of all genes on the array to every module." - - # shiny::callModule( - # plotModule, - # id = "intraHeatmap", ##ns=ns, - # title="Membership-trait heatmap", label="a", - # func = intraHeatmap.RENDER, - # func2 = intraHeatmap.RENDER, - # download.fmt = c("png","pdf"), - # options = intraHeatmap_opts, - # info.text = intraHeatmap_info, - # height = c(fullH,720), width = c('auto',1050), - # pdf.width=6, pdf.height=9, res=c(85,100), - # add.watermark = WATERMARK - # ) - - - ## ---------------------------------------- - ## ------ intramodular scatter ------------ - ## ---------------------------------------- - - # intraScatter.RENDER <- shiny::reactive({ - # ##intraScatter.RENDER <- shiny::reactive({ - # - # message("[intraScatter.RENDER] reacted") - # - # out <- wgcna.compute() - # - # MEs <- out$net$MEs - # rho1 <- cor(MEs, out$datExpr, use="pairwise") - # rho1[is.na(rho1) | is.infinite(rho1)] <- 0 - # - # rho2 <- cor(out$datTraits, out$datExpr, use="pairwise") - # rho2[is.na(rho2) | is.infinite(rho2)] <- 0 - # - # rho3 <- cor( t(rho2), t(rho1), use="pairwise") - # rho3[is.na(rho3) | is.infinite(rho3)] <- 0 - # - # k="ME1" - # k = input$selected_module - # in.mod <- colnames(rho1) %in% out$me.genes[[k]] - # table(in.mod) - # col1 <- c("grey60",out$me.colors[k])[1 + 1*in.mod] - # - # ntop <- ifelse(nrow(rho3)>=20, 20, 12) - # top.px <- head(order(-abs(rho3[,k])), ntop) - # if(ntop==20) mfrow0 <- c(4,5) - # if(ntop==12) mfrow0 <- c(3,4) - # - # par(mfrow=mfrow0, mar=c(4,4,2,1), mgp=c(2.0,0.8,0)) - # i=top.px[1] - # for(i in top.px) { - # base::plot( rho1[k,], rho2[i,], pch=20, cex=0.7, col=col1, - # xlab = "Module membership (eigengene cor)", - # ylab = "Gene significance (trait cor)") - # title(paste(k,"vs.",paste(rownames(rho2)[i])), cex=1) - # } - # - # }) - - # intraScatter_opts = shiny::tagList( - # ## shiny::checkboxInput(ns("eigen_cov"),"covariance", FALSE) - # ) - - # intraScatter_info = - # "WGCNA Module membership (eigengene correlation). For each module, we also define a quantitative measure of module membership (MM) as the correlation of the module eigengene and the gene expression profile. This allows us to quantify the similarity of all genes on the array to every module." - - # shiny::callModule( - # plotModule, - # id = "intraScatter", ##ns=ns, - # title="Membership vs. trait correlation", label="b", - # func = intraScatter.RENDER, - # func2 = intraScatter.RENDER, - # download.fmt = c("png","pdf"), - # options = intraScatter_opts, - # info.text = intraScatter_info, - # height = c(fullH,720), width = c('auto',1150), - # pdf.width=12, pdf.height=9, res=c(85,90), - # add.watermark = WATERMARK - # ) - ## ================================================================================ ## =========================== MODULES ============================================ ## ================================================================================ diff --git a/components/board.wgcna/R/wgcna_table_enrichment.R b/components/board.wgcna/R/wgcna_table_enrichment.R index 75de0d260..04f0e9b6a 100644 --- a/components/board.wgcna/R/wgcna_table_enrichment.R +++ b/components/board.wgcna/R/wgcna_table_enrichment.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -wgcna_table_enrichment_ui <- function(id) { +wgcna_table_enrichment_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("enrichTable")) + info_text <- "In this table, users can check mean expression values of features across the conditions for the selected genes." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Module enrichment", + label = "e" + ) + } wgcna_table_enrichment_server <- function(id, @@ -34,17 +44,10 @@ wgcna_table_enrichment_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) - enrichTable_info <- "In this table, users can check mean expression values of features across the conditions for the selected genes." - - enrichTable_module <- shiny::callModule( - tableModule, - id = "enrichTable", + enrichTable_module <- TableModuleServer( + "datasets", func = enrichTable.RENDER, - info.text = enrichTable_info, - title = tags$div( - HTML('(e)Module enrichment') - ), - height = c(250, 650) + selector = "none" ) return(enrichTable_module) diff --git a/components/board.wgcna/R/wgcna_table_genes.R b/components/board.wgcna/R/wgcna_table_genes.R index 1ab912a30..d8f812239 100644 --- a/components/board.wgcna/R/wgcna_table_genes.R +++ b/components/board.wgcna/R/wgcna_table_genes.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -wgcna_table_genes_ui <- function(id) { +wgcna_table_genes_ui <- function(id, height, width) { ns <- shiny::NS(id) - tableWidget(ns("geneTable")) + info_text <- "Genes in the selected WGCNA module." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Module genes", + label = "d" + ) + } wgcna_table_genes_server <- function(id, @@ -45,17 +55,10 @@ wgcna_table_genes_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) - geneTable_info <- "Genes in the selected WGCNA module." - - geneTable_module <- shiny::callModule( - tableModule, - id = "geneTable", - func = geneTable.RENDER, ## ns=ns, - info.text = geneTable_info, - title = tags$div( - HTML('(d)Module genes') - ), - height = c(250, 650) + geneTable_module <- TableModuleServer( + "datasets", + func = geneTable.RENDER, + selector = "none" ) return(geneTable_module) diff --git a/components/board.wgcna/R/wgcna_ui.R b/components/board.wgcna/R/wgcna_ui.R index 2e38fcece..f5c2da375 100644 --- a/components/board.wgcna/R/wgcna_ui.R +++ b/components/board.wgcna/R/wgcna_ui.R @@ -6,7 +6,6 @@ WgcnaInputs <- function(id) { ns <- shiny::NS(id) ## namespace bigdash::tabSettings( - shiny::actionLink(ns("info"), "Info", icon = icon("info-circle")), shiny::hr(), shiny::br(), ## data set parameters @@ -49,8 +48,9 @@ WgcnaUI <- function(id) { rowH1 <- 250 ## row 1 height rowH2 <- 440 ## row 2 height - shiny::fillCol( - height = 750, + shiny::div( + # height = 750, + boardHeader(title = "WGCNA", info_link = ns("info")), shiny::tabsetPanel( id = ns("tabs"), shiny::tabPanel( @@ -143,12 +143,20 @@ WgcnaUI <- function(id) { div( class = "row", div( - class = "col-md-3", - wgcna_table_genes_ui(ns("geneTable")) + class = "col-md-4", + wgcna_table_genes_ui( + ns("geneTable"), + height = c(250, 650), + width = c("auto", "90%") + ) ), div( - class = "col-md-9", - wgcna_table_enrichment_ui(ns("enrichTable")) + class = "col-md-8", + wgcna_table_enrichment_ui( + ns("enrichTable"), + height = c(250, 650), + width = c("auto", "90%") + ) ) ), tags$div( From 7573322749dbdd17ffd50aff973fb7927e496912 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 15:26:27 +0100 Subject: [PATCH 10/49] `TableModule` implemented on `board.wordcloud` --- .../R/wordcloud_table_enrichment.R | 42 +++++++++++++------ .../R/wordcloud_table_leading_edge.R | 25 ++++++----- components/board.wordcloud/R/wordcloud_ui.R | 12 +++++- 3 files changed, 54 insertions(+), 25 deletions(-) diff --git a/components/board.wordcloud/R/wordcloud_table_enrichment.R b/components/board.wordcloud/R/wordcloud_table_enrichment.R index be37e074e..ba239a08e 100644 --- a/components/board.wordcloud/R/wordcloud_table_enrichment.R +++ b/components/board.wordcloud/R/wordcloud_table_enrichment.R @@ -3,10 +3,21 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -wordcloud_table_enrichment_ui <- function(id) { +wordcloud_table_enrichment_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("wordcloud_enrichmentTable")) + info_text <- "Keyword enrichment table. This table shows the keyword enrichment statistics for the selected contrast. The enrichment is calculated using GSEA for occurance of the keywork in the ordered list of gene set descriptions." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Enrichment table", + label = "d" + ) + + # tableWidget(ns("wordcloud_enrichmentTable")) } wordcloud_table_enrichment_server <- function(id, @@ -42,19 +53,24 @@ wordcloud_table_enrichment_server <- function(id, return(tbl) }) - wordcloud_enrichmentTable_info <- - "Keyword enrichment table. This table shows the keyword enrichment statistics for the selected contrast. The enrichment is calculated using GSEA for occurance of the keywork in the ordered list of gene set descriptions." + # wordcloud_enrichmentTable_info <- + # "Keyword enrichment table. This table shows the keyword enrichment statistics for the selected contrast. The enrichment is calculated using GSEA for occurance of the keywork in the ordered list of gene set descriptions." - wordcloud_enrichmentTable <- shiny::callModule( - tableModule, - id = "wordcloud_enrichmentTable", + # wordcloud_enrichmentTable <- shiny::callModule( + # tableModule, + # id = "wordcloud_enrichmentTable", + # func = wordcloud_enrichmentTable.RENDER, + # info.text = wordcloud_enrichmentTable_info, + # selector = "single", + # title = tags$div( + # HTML('(d)Enrichment table') + # ), + # height = c(270, 700) + # ) + wordcloud_enrichmentTable <- TableModuleServer( + "datasets", func = wordcloud_enrichmentTable.RENDER, - info.text = wordcloud_enrichmentTable_info, - selector = "single", - title = tags$div( - HTML('(d)Enrichment table') - ), - height = c(270, 700) + selector = "single" ) return(wordcloud_enrichmentTable) diff --git a/components/board.wordcloud/R/wordcloud_table_leading_edge.R b/components/board.wordcloud/R/wordcloud_table_leading_edge.R index fe38acf07..dfd43b427 100644 --- a/components/board.wordcloud/R/wordcloud_table_leading_edge.R +++ b/components/board.wordcloud/R/wordcloud_table_leading_edge.R @@ -3,10 +3,20 @@ ## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. ## -wordcloud_table_leading_edge_ui <- function(id) { +wordcloud_table_leading_edge_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("wordcloud_leadingEdgeTable")) + info_text <- "Keyword leading edge table." + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Leading-edge table", + label = "e" + ) + } wordcloud_table_leading_edge_server <- function(id, @@ -57,15 +67,10 @@ wordcloud_table_leading_edge_server <- function(id, return(tbl) }) - wordcloud_leadingEdgeTable <- shiny::callModule( - tableModule, - id = "wordcloud_leadingEdgeTable", + wordcloud_leadingEdgeTable <- TableModuleServer( + "datasets", func = wordcloud_leadingEdgeTable.RENDER, - info.text = "Keyword leading edge table.", - title = tags$div( - HTML('(e)Leading-edge table') - ), - height = c(270, 700) + selector = "none" ) return(wordcloud_leadingEdgeTable) diff --git a/components/board.wordcloud/R/wordcloud_ui.R b/components/board.wordcloud/R/wordcloud_ui.R index 26b6b8391..c2fed2bcd 100644 --- a/components/board.wordcloud/R/wordcloud_ui.R +++ b/components/board.wordcloud/R/wordcloud_ui.R @@ -43,11 +43,19 @@ WordCloudUI <- function(id) { class = "row", div( class = "col-md-6", - wordcloud_table_enrichment_ui(ns("wordcloud_enrichmentTable")) + wordcloud_table_enrichment_ui( + ns("wordcloud_enrichmentTable"), + height = c(270, 700), + width = c("100%", "90%") + ) ), div( class = "col-md-6", - wordcloud_table_leading_edge_ui(ns("wordcloud_leadingEdgeTable")) + wordcloud_table_leading_edge_ui( + ns("wordcloud_leadingEdgeTable"), + height = c(270, 700), + width = c("100%", "90%") + ) ) ), tags$div( From e8f65a2cb9b850ffc2118aa69f8f973a23189d52 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 15:26:52 +0100 Subject: [PATCH 11/49] `TableModule` implemented on `board.intersection` --- .../R/intersection_plot_table_venn_diagram.R | 32 ++-- .../R/intersection_table_venntable.R | 168 ------------------ .../board.intersection/R/intersection_ui.R | 4 +- 3 files changed, 18 insertions(+), 186 deletions(-) delete mode 100644 components/board.intersection/R/intersection_table_venntable.R diff --git a/components/board.intersection/R/intersection_plot_table_venn_diagram.R b/components/board.intersection/R/intersection_plot_table_venn_diagram.R index 66eedac1e..771cc5569 100644 --- a/components/board.intersection/R/intersection_plot_table_venn_diagram.R +++ b/components/board.intersection/R/intersection_plot_table_venn_diagram.R @@ -31,6 +31,11 @@ intersection_plot_venn_diagram_ui <- function(id, label = "", height = c(600, 80 shiny::radioButtons(ns("include"), "Counting:", choices = c("both", "up/down"), inline = TRUE) ) + info_text.table <- "Table of genes in selected intersection." + venntable_opts <- shiny::tagList( + shiny::selectInput(ns("venntable_intersection"), "Filter intersection:", choices = NULL) + ) + div( PlotModuleUI( ns("vennplot"), @@ -42,7 +47,15 @@ intersection_plot_venn_diagram_ui <- function(id, label = "", height = c(600, 80 height = c(400, 700), width = c("100%", 900) ), - tableWidget(ns("venntable")) + TableModuleUI( + ns("datasets"), + info.text = info_text.table, + options = venntable_opts, + height = c(260, 750), + width = c("auto", 1200), + title = "Leading-edge table", + label = "e" + ) ) } @@ -366,22 +379,11 @@ intersection_plot_venn_diagram_server <- function(id, dt }) - venntable_opts <- shiny::tagList( - shiny::selectInput(ns("venntable_intersection"), "Filter intersection:", choices = NULL) - ) - - shiny::callModule( - tableModule, - id = "venntable", + TableModuleServer( + "datasets", func = venntable.RENDER, func2 = venntable.RENDER2, - options = venntable_opts, - title = tags$div( - HTML('(c)Intersection') - ), - info.text = "Table of genes in selected intersection.", - height = c(260, 750), - width = c("auto", 1200) + selector = "none" ) }) } diff --git a/components/board.intersection/R/intersection_table_venntable.R b/components/board.intersection/R/intersection_table_venntable.R deleted file mode 100644 index cac9fd1ef..000000000 --- a/components/board.intersection/R/intersection_table_venntable.R +++ /dev/null @@ -1,168 +0,0 @@ -## -## This file is part of the Omics Playground project. -## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. -## - - -intersection_table_venntable_ui <- function(id) { - ns <- shiny::NS(id) - tableWidget(ns("venntable")) -} - - -intersection_table_venntable_server <- function(id, - getSignificanceCalls, - inputData, - level, - getFoldChangeMatrix) { - moduleServer(id, function(input, output, session) { - ns <- session$ns - - getSignificantFoldChangeMatrix <- shiny::reactive({ - ## - ## Filters FC matrix with significance and user-defined - ## intersection region. - dt <- getSignificanceCalls() - shiny::req(dt) - - isect <- input$intersection - fc0 <- getFoldChangeMatrix()$fc - if (length(isect) == 0) { - fc1 <- fc0 - } else { - ## only genes at least significant in one group - jj <- which(rowSums(dt[, 2:ncol(dt), drop = FALSE] != 0) > 0) - if (length(jj) == 0) { - return(NULL) - } - dt <- dt[jj, , drop = FALSE] - - ## check same sign - if (input$include == "up/down") { - kk <- 1 + match(c("B", "C"), LETTERS[1:10]) - kk <- 1 + match(isect, LETTERS[1:10]) - kk <- intersect(kk, 1:ncol(dt)) - - dt1 <- dt[, kk, drop = FALSE] - jj <- which(rowMeans(sign(dt1) == +1) == 1 | - (rowMeans(sign(dt1) == -1) == 1)) - dt <- dt[jj, , drop = FALSE] - remove(dt1) - } - - ## only genes in the selected intersection - intersection <- "ABC" - intersection <- paste0(input$intersection, collapse = "") - dt <- dt[which(dt$intersection == intersection), , drop = FALSE] - } - - ## filtered by family/collection - fc1 <- fc0[intersect(rownames(dt), rownames(fc0)), , drop = FALSE] - if (nrow(dt) == 1) { - fc1 <- matrix(fc1, nrow = 1) - rownames(fc1) <- rownames(dt) - colnames(fc1) <- colnames(fc0) - } - - ## filtered by SPLOM selection - splom.sel <- plotly::event_data("plotly_selected", source = "splom") - sel.keys <- as.character(splom.sel$key) - if (1 && length(sel.keys) > 0) { - sel <- intersect(sel.keys, rownames(fc1)) - fc1 <- fc1[sel, , drop = FALSE] - } - - ## only active/selected comparisons - sel <- colnames(dt)[-1] - kk <- match(sel, gsub(" \\(-\\)", "", colnames(fc1))) - fc1 <- fc1[, kk, drop = FALSE] - - ## order - fc1 <- fc1[order(-rowMeans(fc1)), , drop = FALSE] - fc1 <- round(fc1, digits = 3) - colnames(fc1) <- LETTERS[1:ncol(fc1)] - ## fc0 = data.frame(fc0) - - ## add intersection code - sel <- match(rownames(fc1), rownames(dt)) - fc1 <- data.frame(intersection = dt$intersection[sel], fc = fc1) - - ## filter on user selection - vv <- input$venntable_intersection - if (vv != "") { - sel <- which(fc1$intersection == vv) - fc1 <- fc1[sel, , drop = FALSE] - } - return(fc1) - }) - - venntable.RENDER <- shiny::reactive({ - ngs <- inputData() - shiny::req(ngs) - - ## get foldchanges - fc0 <- getSignificantFoldChangeMatrix() ## isolate?? - if (is.null(fc0) || nrow(fc0) == 0) { - return(NULL) - } - - ## add gene name/title - if (level == "gene") { - gene <- as.character(ngs$genes[rownames(fc0), "gene_name"]) - gene.tt <- substring(GENE.TITLE[gene], 1, 50) - gene.tt <- as.character(gene.tt) - ## fc0 = data.frame( name=name, title=gene.tt, fc0) - fc0 <- data.frame(name = gene, fc0, check.names = FALSE) - } else { - name <- substring(rownames(fc0), 1, 50) - name[is.na(name)] <- "NA" - fc0 <- data.frame(name = name, fc0, check.names = FALSE) - } - - df <- data.frame(fc0, check.names = FALSE) - nsc <- setdiff(1:ncol(df), 2) - ## dt <- dt[rownames(fc0),] - ## D <- cbind(intersection=dt$intersection, D) - DT::datatable(df, - class = "compact cell-border stripe", - rownames = FALSE, - extensions = c("Scroller"), selection = "none", - fillContainer = TRUE, - options = list( - ## dom = 'lfrtip', - dom = "tip", - ## buttons = c('copy','csv','pdf'), - ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), - ## columnDefs = list(list(targets=nsc, searchable = FALSE)), - scrollX = TRUE, - ## scrollY = 150, - scrollY = "70vh", - scroller = TRUE, - deferRender = TRUE - ) ## end of options.list - ) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") - }) - - - info_text <- "Table of genes in selected intersection." - - venntable_opts <- shiny::tagList( - shiny::selectInput(ns("venntable_intersection"), "Filter intersection:", choices = NULL) - ) - - shiny::callModule( - tableModule, - id = "venntable", - func = venntable.RENDER, - ## caption = venntable_buttons, - options = venntable_opts, - title = "INTERSECTION", - label = "c", - info.text = info_text, - ## info.width = "400px", - height = c(260, 750), - width = c("auto", 1200) - ) - }) ## end of moduleServer -} ## end of server diff --git a/components/board.intersection/R/intersection_ui.R b/components/board.intersection/R/intersection_ui.R index 533bc785e..0c58c4352 100644 --- a/components/board.intersection/R/intersection_ui.R +++ b/components/board.intersection/R/intersection_ui.R @@ -61,9 +61,7 @@ IntersectionUI <- function(id) { ), div( class = "col-md-6", - # plotWidget(ns("venndiagram"))#, - intersection_plot_venn_diagram_ui(ns("venndiagram")) # , - # tableWidget(ns("venntable")) + intersection_plot_venn_diagram_ui(ns("venndiagram")) ) ), tags$div( From 59a50fd34e87bb594e5d4cd9d20c1257467b9bc4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 15:39:33 +0100 Subject: [PATCH 12/49] `TableModule` implemented on `board.correlation` --- .../R/correlation_plot_table_corr.R | 26 +++++++++---------- 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index a400f1d02..8ec94b460 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -19,6 +19,8 @@ correlation_plot_table_corr_ui <- function(id, ns <- shiny::NS(id) info_text <- "Top correlated genes. Highest correlated genes in respect to the selected gene. The height of the bars correspond to the Pearson correlation value. The dark grey bars correspond to the 'partial correlation' which essentially corrects the correlation value for indirect effects and tries to estimate the amount of direct interaction." + cor_table.info <- "DGCA table. Statistical results from the DGCA computation for differentially correlated gene pairs." + div( PlotModuleUI(ns("plot"), title = "Top correlated genes", @@ -29,7 +31,14 @@ correlation_plot_table_corr_ui <- function(id, width = width, height = height ), - tableWidget(ns("cor_table")) + TableModuleUI( + ns("datasets"), + info.text = cor_table.info, + height = c(360, 700), + width = c("auto", "90%"), + title = "Correlation table", + label = "b" + ) ) } @@ -155,19 +164,10 @@ correlation_plot_table_corr_server <- function(id, ) }) - cor_table.info <- "DGCA table. Statistical results from the DGCA computation for differentially correlated gene pairs." - - cor_table <- shiny::callModule( - tableModule, - id = "cor_table", + TableModuleServer( + "datasets", func = cor_table.RENDER, - info.text = cor_table.info, - caption2 = cor_table.info, - title = tags$div( - HTML('(b)Correlation table') - ), - height = c(360, 700), width = c("auto", 1400) - ## caption = dgca_caption + selector = "none" ) }) ## end of moduleServer } From ed22c72639009a6267615fc5caa7efa94120d466 Mon Sep 17 00:00:00 2001 From: ncullen93 Date: Fri, 17 Feb 2023 16:05:17 +0100 Subject: [PATCH 13/49] loading button changes --- components/00SourceAll.R | 17 +- components/app/R/modules/WelcomeBoard.R | 41 ++-- components/app/R/server.R | 196 ++++++++++---------- components/board.loading/R/loading_server.R | 13 +- 4 files changed, 140 insertions(+), 127 deletions(-) diff --git a/components/00SourceAll.R b/components/00SourceAll.R index c7a47f419..38b784eb9 100644 --- a/components/00SourceAll.R +++ b/components/00SourceAll.R @@ -71,6 +71,7 @@ if(!file.exists('00SourceAll.R')) { source('base/R/pgx-vizpanels.R',encoding='UTF-8') source('base/R/pgx-wordcloud.R',encoding='UTF-8') source('base/R/PlotModule.R',encoding='UTF-8') + source('base/R/TableModule.R',encoding='UTF-8') source('base/R/ui-code.R',encoding='UTF-8') source('base/R/xcr-graph.r',encoding='UTF-8') source('base/R/xcr-math.r',encoding='UTF-8') @@ -162,8 +163,8 @@ if(!file.exists('00SourceAll.R')) { source('board.expression/R/expression_plot_volcanoAll.R',encoding='UTF-8') source('board.expression/R/expression_plot_volcanoMethods.R',encoding='UTF-8') source('board.expression/R/expression_server.R',encoding='UTF-8') - source('board.expression/R/expression_table_FDRtable.R',encoding='UTF-8') source('board.expression/R/expression_table_fctable.R',encoding='UTF-8') + source('board.expression/R/expression_table_FDRtable.R',encoding='UTF-8') source('board.expression/R/expression_table_genetable.R',encoding='UTF-8') source('board.expression/R/expression_table_gsettable.R',encoding='UTF-8') source('board.expression/R/expression_ui.R',encoding='UTF-8') @@ -216,7 +217,21 @@ if(!file.exists('00SourceAll.R')) { source('board.upload/R/UploadModule.R',encoding='UTF-8') source('board.user/R/user_server.R',encoding='UTF-8') source('board.user/R/user_ui.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_correlation_network.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_eigengene_clustering.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_enrichment.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_gclustering.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_gdendogram.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_heatmap_membership.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_membership_v_trait.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_module_graph.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_module_membership.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_MTrelationships.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_s_independence.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_plot_TOMheatmap.R',encoding='UTF-8') source('board.wgcna/R/wgcna_server.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_table_enrichment.R',encoding='UTF-8') + source('board.wgcna/R/wgcna_table_genes.R',encoding='UTF-8') source('board.wgcna/R/wgcna_ui.R',encoding='UTF-8') source('board.wordcloud/R/wordcloud_plot_enrichment.R',encoding='UTF-8') source('board.wordcloud/R/wordcloud_plot_wordcloud.R',encoding='UTF-8') diff --git a/components/app/R/modules/WelcomeBoard.R b/components/app/R/modules/WelcomeBoard.R index 084d06aa8..8dc77b915 100644 --- a/components/app/R/modules/WelcomeBoard.R +++ b/components/app/R/modules/WelcomeBoard.R @@ -8,15 +8,15 @@ WelcomeBoardInputs <- function(id) {} WelcomeBoardUI <- function(id) {} -WelcomeBoard <- function(id, auth) +WelcomeBoard <- function(id, auth, rvals) { - moduleServer(id, function(input, output, session) + moduleServer(id, function(input, output, session) { ns <- session$ns ## NAMESPACE output$welcome <- shiny::renderText({ name <- auth$name() - dbg("[HomeBoard] name = ",name) + dbg("[HomeBoard] name = ",name) if(name %in% c("",NA,NULL)) { welcome <- "Welcome back..." } else { @@ -28,14 +28,13 @@ WelcomeBoard <- function(id, auth) welcome }) - observeEvent( input$load_data, { - ## shinyjs::click("") + observeEvent(input$init_example_data, { + print('loaded new data') + shinyjs::runjs("$('.tab-sidebar:eq(1)').trigger('click');") + shinyjs::runjs("$('.sidebar-label').trigger('click');") + rvals$load_example_trigger <- TRUE }) - observeEvent( input$upload_new, { - ## shinyjs::click("") - }) - }) } @@ -52,14 +51,12 @@ WelcomeBoardUI <- function(id) { div( id = "welcome-page", - ##style = "text-align:center;background-color:#eaf7fd;", - ##style = "text-align:center;", - br(), + br(), br(), div(shiny::textOutput(ns("welcome")), id="welcome-text"), h2("What would you like to do today?"), br(), - br(), + br(), br(), div( class = "row", @@ -67,10 +64,10 @@ WelcomeBoardUI <- function(id) { div( class = "col-md-5", h3("I am new..."), - tags$a( - id = "init-example-data", - "Try example dataset", - class = "btn btn-outline-info welcome-btn" + shiny::actionButton( + ns('init_example_data'), + label = "Try example dataset (new)", + class = "btn btn-outline-info welcome-btn" ) ), div( @@ -88,15 +85,7 @@ WelcomeBoardUI <- function(id) { ) ) ), - ## br(), - ## div( - ## id="welcome-subtext", - ## HTML("BigOmics Playground. Never Stop Discovering.
- ## BigOmics is focused on one thing — helping life scientists see and understand their omics - ## data. Our mission is to create smart tools and make advanced omics analysis accessible to - ## everyone. Want to know more? Read our paper \"Omics Playground: a comprehensive self- - ## service platform for visualization, analytics and exploration of Big Omics Data\".")), br() - + ) } diff --git a/components/app/R/server.R b/components/app/R/server.R index 158db6cd6..29eccc8c7 100644 --- a/components/app/R/server.R +++ b/components/app/R/server.R @@ -10,7 +10,7 @@ #' DO NOT REMOVE. #' @export app_server <- function(input, output, session) { - + message("\n=======================================================================") message("================================ SERVER =================================") message("=======================================================================\n") @@ -18,7 +18,7 @@ app_server <- function(input, output, session) { dbg("[SERVER] 0: getwd = ",getwd()) dbg("[SERVER] 0: HONCHO_URL = ",opt$HONCHO_URL) dbg("[SERVER] 0: SESSION = ",session$token) - + ## Logging of input/output events ------------------------------------- log.path <- file.path(OPG,"logs") dbg("[SERVER] shinylog log path = ",log.path) @@ -29,15 +29,15 @@ app_server <- function(input, output, session) { ##curl.resp <- try(RCurl::getURL("http://localhost:8000/__docs__/")) curl.resp <- try(RCurl::getURL(paste0(opt$HONCHO_URL,"/__docs__/"))) honcho.responding <- grepl("Swagger", curl.resp) - honcho.responding + honcho.responding honcho.token <- Sys.getenv("HONCHO_TOKEN", "") has.honcho <- (honcho.token!="" && honcho.responding) if(1 && has.honcho) { - dbg("[SERVER] Honcho is alive! ") - sever::sever(sever_screen2(session$token), bg_color = "#004c7d") + dbg("[SERVER] Honcho is alive! ") + sever::sever(sever_screen2(session$token), bg_color = "#004c7d") } else { ## No honcho, no email.... - dbg("[SERVER] No Honcho? No party..") + dbg("[SERVER] No Honcho? No party..") sever::sever(sever_screen0(), bg_color = "#004c7d") ## lightblue=2780e3 } @@ -45,14 +45,14 @@ app_server <- function(input, output, session) { server.start_time <- Sys.time() session.start_time <- -1 authentication <- opt$AUTHENTICATION - + limits <- c("samples" = opt$MAX_SAMPLES, "comparisons" = opt$MAX_COMPARISONS, "genes" = opt$MAX_GENES, "genesets" = opt$MAX_GENESETS, "datasets" = opt$MAX_DATASETS) pgx_dir <- PGX.DIR - + ## Parse and show URL query string if(0 && ALLOW_URL_QUERYSTRING) { observe({ @@ -64,18 +64,18 @@ app_server <- function(input, output, session) { } } else { dbg("[SERVER:parseQueryString] no queryString!") - } + } if(!is.null(query[['csv']])) { ## focus on this tab updateTabsetPanel(session, "load-tabs", selected="Upload data") updateTextAreaInput(session, "load-upload_panel-compute-upload_description", - value = "CSV FILE DESCRIPTION") + value = "CSV FILE DESCRIPTION") } - + }) dbg("[SERVER:parseQueryString] pgx_dir = ",pgx_dir) } - + ##------------------------------------------------------------- ## Authentication ##------------------------------------------------------------- @@ -87,58 +87,62 @@ app_server <- function(input, output, session) { credentials.file = "CREDENTIALS") } else if(authentication == "firebase") { auth <- shiny::callModule(FirebaseAuthenticationModule, "auth") - } else if(authentication == "shinyproxy") { + } else if(authentication == "shinyproxy") { username <- Sys.getenv("SHINYPROXY_USERNAME") - ##email <- Sys.getenv("SHINYPROXY_EMAIL") + ##email <- Sys.getenv("SHINYPROXY_EMAIL") auth <- shiny::callModule(NoAuthenticationModule, "auth", show_modal=TRUE, username=username, email=username) - } else if(authentication == "none2") { + } else if(authentication == "none2") { auth <- shiny::callModule(NoAuthenticationModule, "auth", show_modal=FALSE) } else { ##} else if(authentication == "none") { auth <- shiny::callModule(NoAuthenticationModule, "auth", show_modal=TRUE) - } + } dbg("[LoadingBoard] names.auth = ",names(auth)) - - + + ##------------------------------------------------------------- ## Call modules ##------------------------------------------------------------- env <- list() ## communication "environment" - + ## *** EXPERIMENTAL *** global reactive value replacing env list ## above create session global reactiveValue from list PGX <- reactiveValues() - - ## Modules needed from the start + rvals <- reactiveValues( + load_example_trigger = FALSE + ) + + ## Modules needed from the start env$load <- LoadingBoard( id = "load", pgx_dir = pgx_dir, pgx = PGX, limits = limits, - auth = auth, - enable_userdir = opt$ENABLE_USERDIR, + auth = auth, + enable_userdir = opt$ENABLE_USERDIR, enable_upload = opt$ENABLE_UPLOAD, - enable_delete = opt$ENABLE_DELETE, - enable_save = opt$ENABLE_SAVE - ) + enable_delete = opt$ENABLE_DELETE, + enable_save = opt$ENABLE_SAVE, + rvals = rvals + ) - ## Modules needed from the start + ## Modules needed from the start env$upload <- UploadBoard( id = "upload", pgx_dir = pgx_dir, pgx = PGX, - auth = auth, + auth = auth, limits = limits, - enable_userdir = opt$ENABLE_USERDIR, + enable_userdir = opt$ENABLE_USERDIR, enable_upload = opt$ENABLE_UPLOAD, enable_save = opt$ENABLE_SAVE - ) - + ) + ## If user is logged off, we clear the data observeEvent( auth$logged(), { is.logged <- auth$logged() @@ -154,20 +158,20 @@ app_server <- function(input, output, session) { data_loaded <- reactive({ (env$load$loaded() || env$upload$loaded()) }) - + ## Default boards - WelcomeBoard("welcome", auth=auth) - UserBoard("user", user=auth) -> env$user - + WelcomeBoard("welcome", auth=auth, rvals=rvals) + env$user <- UserBoard("user", user=auth) + ## Modules needed after dataset is loaded (deferred) -------------- modules_loaded <- FALSE - observeEvent( data_loaded(), { + observeEvent( data_loaded(), { - message("[SERVER:data.loaded] data_loaded = ",data_loaded()) + message("[SERVER:data.loaded] data_loaded = ",data_loaded()) if(data_loaded()==0){ return(NULL) } - + if(modules_loaded) { Sys.sleep(4) shiny::removeModal() ## remove modal from LoadingBoard @@ -177,22 +181,22 @@ app_server <- function(input, output, session) { ## load other modules if not yet loaded message("[SERVER] --------- calling shiny modules ----------") - dbg("[SERVER] names(pgx) = ",names(PGX)) + dbg("[SERVER] names(pgx) = ",names(PGX)) loadModule <- function(...) { id <- list(...)[[2]] if(ENABLED[id]) env[[id]] <<- shiny::callModule(...) } - + ## TEMPORARY SOLUTION. All modules should use PGX eventually. inputData <- reactive({ if(all(sapply(PGX,is.null))) return(NULL) PGX }) - + shiny::withProgress(message="Preparing your dashboards...", value=0, { - DataViewBoard("view", pgx=PGX) + DataViewBoard("view", pgx=PGX) ClusteringBoard("clust", pgx=PGX) WordCloudBoard("word", pgx=PGX) shiny::incProgress(0.2) @@ -213,7 +217,7 @@ app_server <- function(input, output, session) { SignatureBoard("sig", inputData = inputData, selected_gxmethods = env$expr$selected_gxmethods) CorrelationBoard("cor", inputData = inputData) - shiny::incProgress(0.6) + shiny::incProgress(0.6) BiomarkerBoard("bio", inputData = inputData) ConnectivityBoard("cmap", inputData = inputData) SingleCellBoard("scell", inputData = inputData) @@ -221,19 +225,19 @@ app_server <- function(input, output, session) { TcgaBoard("tcga", inputData = inputData) WgcnaBoard("wgcna", inputData = inputData) CompareBoard("comp", inputData = inputData) - + }) message("[SERVER:data_loaded] --------- done! ----------") ## remove modal from LoadingBoard shiny::removeModal() }) - + ##-------------------------------------------------------------------------- ## Current navigation ##-------------------------------------------------------------------------- - + output$current_user <- shiny::renderText({ ## trigger on change of user user <- auth$email() @@ -241,7 +245,7 @@ app_server <- function(input, output, session) { if(user %in% c("",NA,NULL)) user <- "User" user }) - + output$current_dataset <- shiny::renderText({ ## trigger on change of dataset name <- gsub(".*\\/|[.]pgx$","",PGX$name) @@ -256,13 +260,13 @@ app_server <- function(input, output, session) { dbg("[SERVER:output$current_section] section = ",section) section }) - + ##-------------------------------------------------------------------------- ## Dynamically hide/show certain sections depending on USERMODE/object ##-------------------------------------------------------------------------- shiny::observeEvent({ - auth$logged() + auth$logged() env$user$enable_beta() PGX$name }, { @@ -275,56 +279,56 @@ app_server <- function(input, output, session) { dbg("[SERVER] show.beta = ",show.beta) if(is.null(show.beta) || length(show.beta)==0) show.beta=FALSE is.logged <- auth$logged() - + ## hide all main tabs until we have an object if(is.null(PGX) || is.null(PGX$name) || !is.logged) { - message("[SERVER] !!! no data. hiding menu.") + message("[SERVER] !!! no data. hiding menu.") lapply(MAINTABS, function(m) shiny::hideTab("maintabs",m)) - updateTabsetPanel(session, "maintabs", selected = "Home") + updateTabsetPanel(session, "maintabs", selected = "Home") toggleTab("load-tabs","Upload data",opt$ENABLE_UPLOAD) return(NULL) } - + message("[SERVER] dataset changed. reconfiguring menu...") ## show all main tabs lapply(MAINTABS, function(m) shiny::showTab("maintabs",m)) - + ## Beta features - toggleTab("drug-tabs","Connectivity map (beta)",show.beta) + toggleTab("drug-tabs","Connectivity map (beta)",show.beta) toggleTab("maintabs","TCGA survival (beta)",show.beta,req.file="tcga_matrix.h5") ##toggleTab("maintabs","Cluster features",show.beta) toggleTab("maintabs","WGCNA (beta)",show.beta) - toggleTab("maintabs","Compare datasets (beta)",show.beta) - + toggleTab("maintabs","Compare datasets (beta)",show.beta) + ## DEVELOPER only tabs (still too alpha) if(DEV) toggleTab("maintabs","DEV",DEV) toggleTab("cor-tabs","Functional",DEV) ## too slow - toggleTab("cor-tabs","Differential",DEV) + toggleTab("cor-tabs","Differential",DEV) toggleTab("view-tabs","Resource info",DEV) toggleTab("scell-tabs","iTALK",DEV) ## DEV only - toggleTab("scell-tabs","CNV",DEV) ## DEV only + toggleTab("scell-tabs","CNV",DEV) ## DEV only toggleTab("scell-tabs","Monocle",DEV) ## DEV only toggleTab("cor-tabs","Functional",DEV) - + ## Dynamically show upon availability in pgx object - toggleTab("load-tabs","Upload data", opt$ENABLE_UPLOAD) + toggleTab("load-tabs","Upload data", opt$ENABLE_UPLOAD) tabRequire(PGX, "connectivity", "maintabs", "Similar experiments") tabRequire(PGX, "drugs", "maintabs", "Drug connectivity") tabRequire(PGX, "wordcloud", "maintabs", "Word cloud") tabRequire(PGX, "deconv", "maintabs", "CellProfiling") - toggleTab("user-tabs","Visitors map",!is.null(ACCESS.LOG)) + toggleTab("user-tabs","Visitors map",!is.null(ACCESS.LOG)) - message("[SERVER] reconfiguring menu done.") + message("[SERVER] reconfiguring menu done.") }) - + ##------------------------------------------------------------- ## Session TimerModule ##------------------------------------------------------------- reset_timer <- function() {} run_timer <- function(run=TRUE) {} - + if( TIMEOUT > 0 ) { rv.timer <- reactiveValues(reset=0, run=FALSE) @@ -340,8 +344,8 @@ app_server <- function(input, output, session) { message("[SERVER] Creating TimerModule...") message("[SERVER] TIMEOUT = ", TIMEOUT) - message("[SERVER] WARN_BEFORE = ", WARN_BEFORE) - + message("[SERVER] WARN_BEFORE = ", WARN_BEFORE) + timer <- TimerModule( "timer", timeout = TIMEOUT, @@ -349,12 +353,12 @@ app_server <- function(input, output, session) { max_warn = 1, poll = Inf, ## not needed, just for timer output reset = reactive(rv.timer$reset), - run = reactive(rv.timer$run) + run = reactive(rv.timer$run) ) - + observe({ message("[SERVER] timer = ",timer$timer()) - message("[SERVER] lapse_time = ",timer$lapse_time()) + message("[SERVER] lapse_time = ",timer$lapse_time()) }) observeEvent( timer$warn(), { @@ -379,13 +383,13 @@ app_server <- function(input, output, session) { ## Choose type of referral modal upon timeout: mod.timeout <- SocialMediaModule("socialmodal", r.show = r.timeout) ##mod.timeout <- SendReferralModule("sendreferral", r.user=auth$name, r.show=r.timeout) - - observeEvent( mod.timeout$success(), { + + observeEvent( mod.timeout$success(), { success <- mod.timeout$success() - message("[SERVER] success = ",success) + message("[SERVER] success = ",success) if(success==0) { message("[SERVER] logout after no referral!!!") - shinyjs::runjs("logout()") + shinyjs::runjs("logout()") } if(success > 1) { message("[SERVER] resetting timer after referral!!!") @@ -393,8 +397,8 @@ app_server <- function(input, output, session) { msg = HTML("

Thanks!

Your FREE session has been extended.
") msg = HTML(paste0("

Ditch the ",timeout.min,"-minute limit

Upgrade today and experience advanced analysis features without the time limit.
")) - - + + showModal(modalDialog( msg, @@ -410,17 +414,17 @@ Upgrade today and experience advanced analysis features without the time limit.< ## trigger on change of USER logged <- auth$logged() message("[SERVER] logged = ",logged) - + ##--------- start timer -------------- - if(TIMEOUT>0 && logged) { + if(TIMEOUT>0 && logged) { message("[SERVER] starting session timer!!!") reset_timer() - run_timer(TRUE) - + run_timer(TRUE) + } else { - message("[SERVER] no timer!!!") - run_timer(FALSE) - } + message("[SERVER] no timer!!!") + run_timer(FALSE) + } }) } ## end of if TIMEOUT>0 @@ -429,25 +433,25 @@ Upgrade today and experience advanced analysis features without the time limit.< ##------------------------------------------------------------- ## Session logout functions ##------------------------------------------------------------- - + shiny::observe({ ## trigger on change of USER logged <- auth$logged() message("[SERVER] logged = ",logged) - + ##--------- force logout callback??? -------------- if(opt$AUTHENTICATION!='firebase' && !logged) { ## Forcing logout ensures "clean" sessions. For firebase ## we allow sticky sessions. - message("[SERVER] user not logged in? forcing logout() JS callback...") - shinyjs::runjs("logout()") + message("[SERVER] user not logged in? forcing logout() JS callback...") + shinyjs::runjs("logout()") } - + }) ## logout helper function - logout.JScallback = "logout()" + logout.JScallback = "logout()" if(opt$AUTHENTICATION=="shinyproxy") { logout.JScallback = "function(x){logout();quit();window.location.assign('/logout');}" } @@ -462,25 +466,25 @@ Upgrade today and experience advanced analysis features without the time limit.< ## This code listens to the JS quit signal observeEvent( input$quit, { dbg("[SERVER:quit] !!!reacted!!!") - dbg("[SERVER:quit] closing session... ") + dbg("[SERVER:quit] closing session... ") session$close() }) - + ## This code will be run after the client has disconnected ## Note!!!: Strange behaviour, sudden session ending. session$onSessionEnded(function() { message("******** doing session cleanup ********") ## fill me... if(opt$AUTHENTICATION == "shinyproxy") { - session$sendCustomMessage("shinyproxy-logout", list()) + session$sendCustomMessage("shinyproxy-logout", list()) } - - }) + + }) ##------------------------------------------------------------- ## report server times - ##------------------------------------------------------------- - server.init_time <- round(Sys.time() - server.start_time, digits=4) + ##------------------------------------------------------------- + server.init_time <- round(Sys.time() - server.start_time, digits=4) message("[SERVER] server.init_time = ",server.init_time," ",attr(server.init_time,"units")) total.lapse_time <- round(Sys.time() - main.start_time,digits=4) message("[SERVER] total lapse time = ",total.lapse_time," ",attr(total.lapse_time,"units")) diff --git a/components/board.loading/R/loading_server.R b/components/board.loading/R/loading_server.R index 3bcfa8e43..e9b809d5a 100644 --- a/components/board.loading/R/loading_server.R +++ b/components/board.loading/R/loading_server.R @@ -6,7 +6,6 @@ LoadingBoard <- function(id, pgx_dir, pgx, - ##authentication="none", auth, limits = c("samples"=1000,"comparisons"=20, "genes"=20000, "genesets"=10000, @@ -14,8 +13,8 @@ LoadingBoard <- function(id, enable_upload = TRUE, enable_delete = TRUE, enable_save = TRUE, - enable_userdir = TRUE - ##force_reload = reactive(0) + enable_userdir = TRUE, + rvals ) { moduleServer(id, function(input, output, session) @@ -311,6 +310,7 @@ LoadingBoard <- function(id, ##========================== LOAD DATA FROM LIST ================================= ##================================================================================ + load_react <- reactive({ btn <- input$loadbutton query <- parseQueryString(session$clientData$url_search) @@ -318,8 +318,13 @@ LoadingBoard <- function(id, (!is.null(btn) || !is.null(query[['pgx']])) && logged }) - shiny::observeEvent( load_react(), { + observeEvent(rvals$load_example_trigger, { + # click button + }) + shiny::observeEvent( load_react(), { + #shiny::observeEvent( load_react(), { + print('loading example triggered') if(!load_react()) { return(NULL) } From 04345678d07c13933afa7c685c60c766b5b91a1d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 16:30:17 +0100 Subject: [PATCH 14/49] `TableModule` implemented on `board.expression` --- .../R/expression_table_FDRtable.R | 27 +++---- .../R/expression_table_fctable.R | 45 ++++++------ .../R/expression_table_genetable.R | 70 +++++++++---------- .../R/expression_table_gsettable.R | 43 ++++++------ components/board.expression/R/expression_ui.R | 36 +++++++--- 5 files changed, 115 insertions(+), 106 deletions(-) diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index a498233c8..3af97064a 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -11,10 +11,19 @@ #' @param width #' #' @export -expression_table_FDRtable_ui <- function(id) { +expression_table_FDRtable_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("FDRtable")) + FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." + + TableModuleUI( + ns("datasets"), + info.text = FDRtable_text, + width = width, + height = height, + title = "Number of significant genes" + ) + } #' Server side table code: expression board @@ -99,18 +108,10 @@ expression_table_FDRtable_server <- function(id, ) }) - FDRtable_text <- "The FDR table tab reports the number of significant genes at different FDR thresholds for all contrasts within the dataset." - - FDRtable_caption <- "Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes." - - shiny::callModule( - tableModule, - id = "FDRtable", + TableModuleServer( + "datasets", func = FDRtable.RENDER, - info.text = FDRtable_text, - title = "Number of significant genes", - caption = FDRtable_caption, - height = height + selector = "none" ) }) # end module server } # end server diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 79bc9617e..37d240b21 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -11,10 +11,27 @@ #' @param width #' #' @export -expression_table_fctable_ui <- function(id) { +expression_table_fctable_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("fctable")) + fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." + + fctable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), + "Show q-values next to FC values.", + placement = "right", options = list(container = "body") + ) + ) + + TableModuleUI( + ns("datasets"), + info.text = fctable_text, + width = width, + height = height, + options = fctable_opts, + title = "Gene fold changes for all contrasts" + ) + } #' Server side table code: expression board @@ -111,30 +128,14 @@ expression_table_fctable_server <- function(id, dt <- dt %>% DT::formatSignif(columns = qv.cols, digits = 3) } - dt }) - fctable_text <- "The Foldchange (all) tab reports the gene fold changes for all contrasts in the selected dataset." - - fctable_caption <- "Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts." - - fctable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("fctable_showq"), "show q-values", TRUE), - "Show q-values next to FC values.", - placement = "right", options = list(container = "body") - ) - ) - - shiny::callModule( - tableModule, - id = "fctable", + TableModuleServer( + "datasets", func = fctable.RENDER, - title = "Gene fold changes for all contrasts", - info.text = fctable_text, - options = fctable_opts, - caption = fctable_caption, - height = height + selector = "none" ) + }) # end module server } # end server diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R index 32ecf9c8c..c31fdafc7 100644 --- a/components/board.expression/R/expression_table_genetable.R +++ b/components/board.expression/R/expression_table_genetable.R @@ -11,14 +11,34 @@ #' @param width #' #' @export -expression_table_genetable_ui <- function(id) { - # message("expression_table_genetable_ui called") +expression_table_genetable_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("genetable")) + genetable_opts <- shiny::tagList( + withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), + "Display only top 10 differentially (positively and negatively) expressed genes in the table.", + placement = "top", options = list(container = "body") + ), + withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), + "Show q-values of each indivivual statistical method in the table.", + placement = "top", options = list(container = "body") + ) + ) + + genetable_text <- "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. +

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." + + TableModuleUI( + ns("datasets"), + info.text = genetable_text, + width = width, + height = height, + options = genetable_opts, + title = "Differential expression analysis", + label = "I" + ) - # message("expression_table_genetable_ui done") } #' Server side table code: expression board @@ -36,17 +56,6 @@ expression_table_genetable_server <- function(id, ns <- session$ns - genetable_opts <- shiny::tagList( - withTooltip(shiny::checkboxInput(ns("gx_top10"), "top 10 up/down genes", FALSE), - "Display only top 10 differentially (positively and negatively) expressed genes in the table.", - placement = "top", options = list(container = "body") - ), - withTooltip(shiny::checkboxInput(ns("gx_showqvalues"), "show indivivual q-values", FALSE), - "Show q-values of each indivivual statistical method in the table.", - placement = "top", options = list(container = "body") - ) - ) - table.RENDER <- shiny::reactive({ res <- res() @@ -82,11 +91,11 @@ expression_table_genetable_server <- function(id, fillContainer = TRUE, options = list( dom = "frtip", - paging = TRUE, - pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + # paging = TRUE, + # pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = FALSE, - scroller = FALSE, + scrollY = 300, + scroller = TRUE, deferRender = TRUE, search = list( regex = TRUE, @@ -104,29 +113,14 @@ expression_table_genetable_server <- function(id, backgroundRepeat = "no-repeat", backgroundPosition = "center" ) - }) # %>% - # bindCache(filteredDiffExprTable(), input$gx_showqvalues) + }) - genetable_text <- "Table I shows the results of the statistical tests. To increase the statistical reliability of the Omics Playground, we perform the DE analysis using four commonly accepted methods in the literature, namely, T-test (standard, Welch), limma (no trend, trend, voom), edgeR (QLF, LRT), and DESeq2 (Wald, LRT), and merge the results. -

For a selected comparison under the Contrast setting, the results of the selected methods are combined and reported under the table, where meta.q for a gene represents the highest q value among the methods and the number of stars for a gene indicate how many methods identified significant q values (q < 0.05). The table is interactive (scrollable, clickable); users can sort genes by logFC, meta.q, or average expression in either conditions. Users can filter top N = {10} differently expressed genes in the table by clicking the top 10 genes from the table Settings." - - - - genetable <- shiny::callModule( - tableModule, - id = "genetable", + genetable <- TableModuleServer( + "datasets", func = table.RENDER, - info.text = genetable_text, - info.width = "500px", - options = genetable_opts, - selector = "single", - title = tags$div( - HTML('(I)Differential expression analysis') - ) + selector = "single" ) - message("expression_table_genetable_server done") - return(genetable) }) } diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index 2862611c2..541396b9b 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -11,10 +11,20 @@ #' @param width #' #' @export -expression_table_gsettable_ui <- function(id) { +expression_table_gsettable_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("gsettable")) + gsettable_text <- "By clicking on a gene in the Table I, it is possible to see which genesets contain that gene in this table, and check the differential expression status in other comparisons from the Gene in contrasts plot under the Plots tab." + + TableModuleUI( + ns("datasets"), + info.text = gsettable_text, + width = width, + height = height, + title = "Gene sets with gene", + label = "II" + ) + } #' Server side table code: expression board @@ -40,48 +50,35 @@ expression_table_gsettable_server <- function(id, df$geneset <- wrapHyperLink(df$geneset, rownames(df)) DT::datatable(df, - ## class = 'compact cell-border stripe', class = "compact", rownames = FALSE, escape = c(-1, -2), extensions = c("Scroller"), fillContainer = TRUE, options = list( - ## dom = 'lfrtip', dom = "frtip", - paging = TRUE, - pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), + # paging = TRUE, + # pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - ## scrollY = tabV, - scrollY = FALSE, - scroller = FALSE, + scrollY = 300, + scroller = TRUE, deferRender = TRUE, search = list( regex = TRUE, caseInsensitive = TRUE - ## search = 'GOBP:' ) ), ## end of options.list selection = list(mode = "single", target = "row", selected = NULL) ) %>% - ## formatSignif(1:ncol(df),4) %>% DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% DT::formatStyle("fx", background = color_from_middle(df$fx, "lightblue", "#f5aeae")) - # }, server=FALSE) }) - gsettable_text <- "By clicking on a gene in the Table I, it is possible to see which genesets contain that gene in this table, and check the differential expression status in other comparisons from the Gene in contrasts plot under the Plots tab." - - gsettable <- shiny::callModule( - tableModule, - id = "gsettable", + gsettable <- TableModuleServer( + "datasets", func = gsettable.RENDER, - info.text = gsettable_text, - selector = "single", - title = tags$div( - HTML('(II)Gene sets with gene') - ), - height = height, width = width + selector = "single" ) + return(gsettable) }) # end module server } # end server diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index e7c34303a..fc89f0cbf 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -7,10 +7,6 @@ ExpressionInputs <- function(id) { ns <- shiny::NS(id) ## namespace bigdash::tabSettings( - withTooltip( - shiny::actionLink(ns("gx_info"), "Tutorial", icon = shiny::icon("youtube")), - "Show more information about this module." - ), shiny::hr(), shiny::br(), withTooltip(shiny::selectInput(ns("gx_contrast"), "Contrast:", choices = NULL), "Select a contrast of interest for the analysis.", @@ -180,30 +176,50 @@ ExpressionUI <- function(id) { shiny::tabPanel( "Table", tags$div( - class = "caption", HTML("Differential Expression Analysis. Compare expression between two conditions. Determine which genes are significantly downregulated or overexpressed in one of the groups.") ), - shiny::br(), div( class = "row", div( class = "col-md-8", - expression_table_genetable_ui(id = ns("genetable")) + expression_table_genetable_ui( + ns("genetable"), + width = c("100%", "90%"), + height = c("300px", "600px") + ) ), div( class = "col-md-4", - expression_table_gsettable_ui(id = ns("gsettable")) + expression_table_gsettable_ui( + ns("gsettable"), + width = c("100%", "90%"), + height = c("300px", "600px") + ) ) ) ), shiny::tabPanel( "Foldchange (all)", - expression_table_fctable_ui(ns("fctable")) + tags$div( + HTML("Differential expression (fold-change) across all contrasts. The column `rms.FC` corresponds to the root-mean-square fold-change across all contrasts.") + ), + expression_table_fctable_ui( + ns("fctable"), + width = c("100%", "90%"), + height = c("300px", "600px") + ) ), shiny::tabPanel( "FDR table", - expression_table_FDRtable_ui(ns("FDRtable")) + tags$div( + HTML("Number of significant genes versus FDR. This table reports the number of significant genes at different FDR thresholds for all contrasts and methods. This enables to quickly see which methods are more sensitive. The left part of the table (in blue) correspond to the number of significant down-regulated genes, the right part (in red) correspond to the number of significant overexpressed genes.") + ), + expression_table_FDRtable_ui( + ns("FDRtable"), + width = c("100%", "90%"), + height = c("300px", "600px") + ) ) ) ) From 1b19e11e0480f2121e3afb4133fca51491477199 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 16:45:46 +0100 Subject: [PATCH 15/49] `TableModule` implemented on `board.featuremap` --- .../R/featuremap_plot_table_gene_map.R | 57 ++++++----- .../R/featuremap_plot_table_geneset_map.R | 98 ++++++++++--------- components/board.featuremap/R/featuremap_ui.R | 17 +--- 3 files changed, 88 insertions(+), 84 deletions(-) diff --git a/components/board.featuremap/R/featuremap_plot_table_gene_map.R b/components/board.featuremap/R/featuremap_plot_table_gene_map.R index a9947cfb5..7d41505fe 100644 --- a/components/board.featuremap/R/featuremap_plot_table_gene_map.R +++ b/components/board.featuremap/R/featuremap_plot_table_gene_map.R @@ -8,6 +8,8 @@ featuremap_plot_gene_map_ui <- function(id, label = "", height = c(600, 800)) { info_text <- "Gene map. UMAP clustering of genes colored by standard-deviation (sd.X), variance (var.FC) or mean of fold-change (mean.FC). The distance metric is covariance. Genes that are clustered nearby exihibit high covariance and may have similar biological function." + info_text_table <- "Gene table. The contents of this table can be subsetted by selecting (by click&drag) on the Gene map plot." + plot.opts <- shiny::tagList( shiny::selectInput(ns("umap_nlabel"), "nr labels:", c(0, 10, 20, 50, 100, 1000), @@ -22,23 +24,34 @@ featuremap_plot_gene_map_ui <- function(id, label = "", height = c(600, 800)) { ) ) - plotui <- PlotModuleUI( - ns("gene_map"), - title = "Gene Map", - label = "a", - outputFunc = function(x, width, height) { - plotOutput(x, - brush = ns("geneUMAP_brush"), width = width, - height = height - ) - }, - plotlib2 = "plotly", - info.text = info_text, - options = plot.opts, - height = c(600, 750), width = c("auto", 1200), - download.fmt = c("png", "pdf") + div( + PlotModuleUI( + ns("gene_map"), + title = "Gene Map", + label = "a", + outputFunc = function(x, width, height) { + plotOutput(x, + brush = ns("geneUMAP_brush"), width = width, + height = height + ) + }, + plotlib2 = "plotly", + info.text = info_text, + options = plot.opts, + height = c(600, 750), + width = c("auto", 1200), + download.fmt = c("png", "pdf") + ), + TableModuleUI( + ns("datasets"), + info.text = info_text_table, + height = c(280, 750), + width = c("auto", "90%"), + title = "Gene table", + label = "c" + ) ) - return(list(plotui, ns)) + } featuremap_plot_gene_map_server <- function(id, @@ -206,16 +219,10 @@ featuremap_plot_gene_map_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) - shiny::callModule( - tableModule, - id = "geneTable", + TableModuleServer( + "datasets", func = geneTable.RENDER, - options = NULL, - info.text = "Gene table. The contents of this table can be subsetted by selecting (by click&drag) on the Gene map plot.", - title = tags$div( - HTML('(c)Gene table') - ), - height = c(280, 750), width = c("auto", 1400) + selector = "none" ) }) } diff --git a/components/board.featuremap/R/featuremap_plot_table_geneset_map.R b/components/board.featuremap/R/featuremap_plot_table_geneset_map.R index 3a5b24acd..fd4f83f5e 100644 --- a/components/board.featuremap/R/featuremap_plot_table_geneset_map.R +++ b/components/board.featuremap/R/featuremap_plot_table_geneset_map.R @@ -8,36 +8,48 @@ featuremap_plot_table_geneset_map_ui <- function(id, label = "", height = c(600, info_text <- "Geneset UMAP. UMAP clustering of genesets colored by standard-deviation (sd.X), variance (var.FC) or mean of fold-change (mean.FC). The distance metric is covariance. Genesets that are clustered nearby have high covariance." + info_text_table <- "Geneset table. The contents of this table can be subsetted by selecting (by click&drag) on the Geneset map plot." + plot.opts <- shiny::tagList( shiny::selectInput(ns("gsmap_nlabel"), "nr labels:", - choices = c(0, 10, 20, 50, 100, 1000), selected = 20 + choices = c(0, 10, 20, 50, 100, 1000), selected = 20 ), shiny::sliderInput(ns("gsmap_gamma"), "color gamma:", - min = 0.1, max = 1.2, value = 0.4, step = 0.1 + min = 0.1, max = 1.2, value = 0.4, step = 0.1 ), shiny::radioButtons(ns("gsmap_colorby"), "color by:", - choices = c("sd.X", "sd.FC", "mean.FC"), - selected = "sd.X", inline = TRUE + choices = c("sd.X", "sd.FC", "mean.FC"), + selected = "sd.X", inline = TRUE ) ) - plotui <- PlotModuleUI( - ns("gset_map"), - title = "Geneset UMAP", - label = "a", - outputFunc = function(x, width, height) { - plotOutput(x, - brush = ns("gsetUMAP_brush"), width = width, - height = height - ) - }, - plotlib2 = "plotly", - info.text = info_text, - options = plot.opts, - height = c(600, 750), width = c("auto", 1200), - download.fmt = c("png", "pdf") + div( + PlotModuleUI( + ns("gset_map"), + title = "Geneset UMAP", + label = "a", + outputFunc = function(x, width, height) { + plotOutput(x, + brush = ns("gsetUMAP_brush"), width = width, + height = height + ) + }, + plotlib2 = "plotly", + info.text = info_text, + options = plot.opts, + height = c(600, 750), width = c("auto", 1200), + download.fmt = c("png", "pdf") + ), + TableModuleUI( + ns("datasets"), + info.text = info_text_table, + height = c(280, 750), + width = c("auto", "90%"), + title = "Geneset table", + label = "c" + ) ) - return(list(plotui, ns)) + } featuremap_plot_table_geneset_map_server <- function(id, @@ -83,8 +95,8 @@ featuremap_plot_table_geneset_map_server <- function(id, par(mfrow = c(1, 1)) p <- plotUMAP(pos, fc, hilight, - nlabel = nlabel, title = colorby, - cex = 0.9, source = "", plotlib = "base" + nlabel = nlabel, title = colorby, + cex = 0.9, source = "", plotlib = "base" ) p }) @@ -115,8 +127,8 @@ featuremap_plot_table_geneset_map_server <- function(id, par(mfrow = c(1, 1)) p <- plotUMAP(pos, fc, hilight, - nlabel = nlabel, title = colorby, - cex = 1.2, source = "", plotlib = "plotly" + nlabel = nlabel, title = colorby, + cex = 1.2, source = "", plotlib = "plotly" ) p }) @@ -148,7 +160,7 @@ featuremap_plot_table_geneset_map_server <- function(id, if (!is.null(b) & length(b)) { sel <- which(pos[, 1] > b$xmin & pos[, 1] < b$xmax & - pos[, 2] > b$ymin & pos[, 2] < b$ymax) + pos[, 2] > b$ymin & pos[, 2] < b$ymax) sel.gsets <- rownames(pos)[sel] } @@ -180,32 +192,26 @@ featuremap_plot_table_geneset_map_server <- function(id, df <- data.frame(geneset = gs, F, check.names = FALSE) DT::datatable(df, - rownames = FALSE, - class = "compact cell-border stripe hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = NULL), - fillContainer = TRUE, - options = list( - dom = "lfrtip", - scrollX = TRUE, ## scrollY = TRUE, - scrollY = "70vh", - scroller = TRUE, - deferRender = TRUE - ) ## end of options.list + rownames = FALSE, + class = "compact cell-border stripe hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = NULL), + fillContainer = TRUE, + options = list( + dom = "lfrtip", + scrollX = TRUE, ## scrollY = TRUE, + scrollY = "70vh", + scroller = TRUE, + deferRender = TRUE + ) ## end of options.list ) %>% DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) - shiny::callModule( - tableModule, - id = "gsetTable", + TableModuleServer( + "datasets", func = gsetTable.RENDER, - options = NULL, - title = tags$div( - HTML('(c)Geneset table') - ), - info.text = "Geneset table. The contents of this table can be subsetted by selecting (by click&drag) on the Geneset map plot.", - height = c(280, 750), width = c("auto", 1400) + selector = "none" ) }) } diff --git a/components/board.featuremap/R/featuremap_ui.R b/components/board.featuremap/R/featuremap_ui.R index 27f32d234..d4a388626 100644 --- a/components/board.featuremap/R/featuremap_ui.R +++ b/components/board.featuremap/R/featuremap_ui.R @@ -48,13 +48,6 @@ FeatureMapInputs <- function(id) { FeatureMapUI <- function(id) { ns <- shiny::NS(id) ## namespace - # NOTE: Output from `featuremap_plot_gene_map_ui` is - # [[1]] The results from `PlotModuleUI` (what we want to draw on the UI) - # [[2]] The `ns()` function from that module - # We need that so we can place the Gene table on a different div() - ns2 <- featuremap_plot_gene_map_ui(ns("gene_map")) - # NOTE: Same as above - ns3 <- featuremap_plot_table_geneset_map_ui(ns("gsetUMAP")) div( boardHeader(title = "Cluster features", info_link = ns("info")), @@ -66,14 +59,13 @@ FeatureMapUI <- function(id) { class = "row", div( class = "col-md-6", - ns2[[1]] + featuremap_plot_gene_map_ui(ns("gene_map")) ), div( class = "col-md-6", featuremap_plot_gene_sig_ui(ns("gene_sig")) ) - ), - tableWidget(ns2[[2]]("geneTable")) + ) ), shiny::tabPanel( "Geneset", @@ -81,14 +73,13 @@ FeatureMapUI <- function(id) { class = "row", div( class = "col-md-6", - ns3[[1]] + featuremap_plot_table_geneset_map_ui(ns("gsetUMAP")) ), div( class = "col-md-6", featuremap_plot_gset_sig_ui(ns("gsetSigPlots")) ) - ), - tableWidget(ns3[[2]]("gsetTable")) + ) ) ) ) From fadba0e279132290e4023c3749d50d5a3ad99bf0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 16:48:56 +0100 Subject: [PATCH 16/49] remove commented code --- components/board.functional/R/functional_ui.R | 8 -------- .../board.wordcloud/R/wordcloud_table_enrichment.R | 14 -------------- 2 files changed, 22 deletions(-) diff --git a/components/board.functional/R/functional_ui.R b/components/board.functional/R/functional_ui.R index bbc53b7d8..bee9b3356 100644 --- a/components/board.functional/R/functional_ui.R +++ b/components/board.functional/R/functional_ui.R @@ -44,21 +44,17 @@ FunctionalUI <- function(id) { class = "row", div( class = "col-md-6", - #plotWidget(ns("kegg_graph")), functional_plot_kegg_graph_ui(ns("kegg_graph"), label = "a"), - #plotWidget(ns("kegg_actmap")) functional_plot_kegg_actmap_ui( ns("kegg_actmap"),label = "c") ), div( class = "col-md-6", - #tableWidget(ns("kegg_table")) functional_table_kegg_table_ui(ns("kegg_table")) ) ), tags$div( - class = "caption", HTML(strwrap("(a) KEGG pathway map. Genes are colored according to their upregulation (red) or downregulation (blue) in the contrast profile. (b) Enrichment table reporting enrichment @@ -73,24 +69,20 @@ FunctionalUI <- function(id) { class = "row", div( class = "col-md-6", - #plotWidget(ns("GO_network")), functional_plot_go_network_ui( ns("GO_network"), label = "a"), - #tableWidget(ns("GO_table")) functional_table_go_table_ui( ns("GO_table") ) ), div( class = "col-md-6", - #plotWidget(ns("GO_actmap")) functional_plot_go_actmap_ui(ns("GO_actmap"), label = "c") ) ), tags$div( - class = "caption", HTML(strwrap("(a)Gene Ontology graph. The graph represents the enrichment of the GO terms as a tree structure. (b) GO score table. The score of a GO term is the cumulative score of diff --git a/components/board.wordcloud/R/wordcloud_table_enrichment.R b/components/board.wordcloud/R/wordcloud_table_enrichment.R index ba239a08e..3229ca584 100644 --- a/components/board.wordcloud/R/wordcloud_table_enrichment.R +++ b/components/board.wordcloud/R/wordcloud_table_enrichment.R @@ -53,20 +53,6 @@ wordcloud_table_enrichment_server <- function(id, return(tbl) }) - # wordcloud_enrichmentTable_info <- - # "Keyword enrichment table. This table shows the keyword enrichment statistics for the selected contrast. The enrichment is calculated using GSEA for occurance of the keywork in the ordered list of gene set descriptions." - - # wordcloud_enrichmentTable <- shiny::callModule( - # tableModule, - # id = "wordcloud_enrichmentTable", - # func = wordcloud_enrichmentTable.RENDER, - # info.text = wordcloud_enrichmentTable_info, - # selector = "single", - # title = tags$div( - # HTML('(d)Enrichment table') - # ), - # height = c(270, 700) - # ) wordcloud_enrichmentTable <- TableModuleServer( "datasets", func = wordcloud_enrichmentTable.RENDER, From 71ea8466acb031bc81730b207e9c08e0e7dac1a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 17 Feb 2023 16:57:19 +0100 Subject: [PATCH 17/49] `TableModule` implemented on `board.functional` --- .../R/functional_table_go_table.R | 57 +++++++++++++------ .../R/functional_table_kegg_table.R | 51 +++++++++-------- components/board.functional/R/functional_ui.R | 22 ++++--- 3 files changed, 79 insertions(+), 51 deletions(-) diff --git a/components/board.functional/R/functional_table_go_table.R b/components/board.functional/R/functional_table_go_table.R index b697c3137..a42b1a167 100644 --- a/components/board.functional/R/functional_table_go_table.R +++ b/components/board.functional/R/functional_table_go_table.R @@ -4,9 +4,24 @@ ## -functional_table_go_table_ui <- function(id) { +functional_table_go_table_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("table")) + + info_text <- strwrap("GO score table. The scoring of a GO + term is performed by considering the cumulative score + of all terms from that term to the root node. That + means that GO terms that are supported by higher level + terms levels are preferentially scored.") + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "GO score table", + label = "b" + ) + } @@ -94,23 +109,29 @@ functional_table_go_table_server <- function(id, ) } - info_text <- strwrap("GO score table. The scoring of a GO - term is performed by considering the cumulative score - of all terms from that term to the root node. That - means that GO terms that are supported by higher level - terms levels are preferentially scored.") - - table_opts <- shiny::tagList() - - shiny::callModule( - tableModule, - id = "table", - label = "", + # info_text <- strwrap("GO score table. The scoring of a GO + # term is performed by considering the cumulative score + # of all terms from that term to the root node. That + # means that GO terms that are supported by higher level + # terms levels are preferentially scored.") + + # table_opts <- shiny::tagList() + # + # shiny::callModule( + # tableModule, + # id = "table", + # label = "", + # func = table_RENDER, + # options = table_opts, + # info.text = info_text, + # title = "GO score table", + # height = c(270, 700) + # ) + + TableModuleServer( + "datasets", func = table_RENDER, - options = table_opts, - info.text = info_text, - title = "GO score table", - height = c(270, 700) + selector = "none" ) }) ## end of moduleServer diff --git a/components/board.functional/R/functional_table_kegg_table.R b/components/board.functional/R/functional_table_kegg_table.R index d5468e3b0..d72f4f8ec 100644 --- a/components/board.functional/R/functional_table_kegg_table.R +++ b/components/board.functional/R/functional_table_kegg_table.R @@ -4,9 +4,30 @@ ## -functional_table_kegg_table_ui <- function(id) { +functional_table_kegg_table_ui <- function(id, width, height) { ns <- shiny::NS(id) - tableWidget(ns("table")) + + info_text <- strwrap("Enrichment table. The table is + interactive; enabling user to sort on different + variables and select a pathway by clicking on the row + in the table. The scoring is performed by considering + the total number of genes in the pathway (n), the + number of genes in the pathway supported by the contrast + profile (k), the ratio of k/n, and the ratio of + |upregulated or downregulated genes|/k. Additionally, + the table contains the list of the upregulated and + downregulated genes for each pathway and a q value from + the Fisher’s test for the overlap.") + + TableModuleUI( + ns("datasets"), + info.text = info_text, + width = width, + height = height, + title = "Enrichment table", + label = "b" + ) + } @@ -75,30 +96,10 @@ functional_table_kegg_table_server <- function(id, ) } - info_text <- strwrap("Enrichment table. The table is - interactive; enabling user to sort on different - variables and select a pathway by clicking on the row - in the table. The scoring is performed by considering - the total number of genes in the pathway (n), the - number of genes in the pathway supported by the contrast - profile (k), the ratio of k/n, and the ratio of - |upregulated or downregulated genes|/k. Additionally, - the table contains the list of the upregulated and - downregulated genes for each pathway and a q value from - the Fisher’s test for the overlap.") - - table_opts <- shiny::tagList() - - my_table <- shiny::callModule( - tableModule, - id = "table", - label = "", + my_table <- TableModuleServer( + "datasets", func = table_RENDER, - options = table_opts, - info.text = info_text, - info.width = '350px', - title = "Enrichment table", - height = c(270, 700) + selector = "none" ) return(my_table) diff --git a/components/board.functional/R/functional_ui.R b/components/board.functional/R/functional_ui.R index bee9b3356..319c46769 100644 --- a/components/board.functional/R/functional_ui.R +++ b/components/board.functional/R/functional_ui.R @@ -9,13 +9,13 @@ FunctionalInputs <- function(id) { shiny::hr(), shiny::br(), withTooltip(shiny::selectInput(ns("fa_contrast"), "Contrast:", choices = NULL), - "Select the contrast corresponding to the comparison of interest.", - placement = "top" + "Select the contrast corresponding to the comparison of interest.", + placement = "top" ), withTooltip(shiny::actionLink(ns("fa_options"), "Options", icon = icon("cog", lib = "glyphicon")), - "Show/hide advanced options", - placement = "top" + "Show/hide advanced options", + placement = "top" ), shiny::br(), shiny::conditionalPanel( @@ -51,7 +51,11 @@ FunctionalUI <- function(id) { ), div( class = "col-md-6", - functional_table_kegg_table_ui(ns("kegg_table")) + functional_table_kegg_table_ui( + ns("kegg_table"), + height = c(270, 700), + width = c("100%", "90%") + ) ) ), tags$div( @@ -73,8 +77,10 @@ FunctionalUI <- function(id) { ns("GO_network"), label = "a"), functional_table_go_table_ui( - ns("GO_table") - ) + ns("GO_table"), + height = c(270, 700), + width = c("100%", "90%") + ) ), div( class = "col-md-6", @@ -83,7 +89,7 @@ FunctionalUI <- function(id) { ) ), tags$div( - HTML(strwrap("(a)Gene Ontology graph. The graph represents + HTML(strwrap("(a) Gene Ontology graph. The graph represents the enrichment of the GO terms as a tree structure. (b) GO score table. The score of a GO term is the cumulative score of all higher order terms. (c) Activation matrix From d3db9ac32820ff63c10ad6404f6912bc2e2269f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sat, 18 Feb 2023 17:12:30 +0100 Subject: [PATCH 18/49] feat: tables scrollY works properly Implemented proper scrollY values for tables --- components/base/R/TableModule2.R | 9 ++++-- .../R/compare_table_corr_score.R | 2 +- .../R/correlation_plot_table_corr.R | 2 +- .../R/drugconnectivity_table_cmap.R | 2 +- .../R/drugconnectivity_table_dsea.R | 2 +- .../R/enrichment_table_enrichment_analysis.R | 2 +- .../R/enrichment_table_genes_in_geneset_ui.R | 2 +- ...richment_table_gset_enrich_all_contrasts.R | 2 +- .../R/enrichment_table_n_sig_gsets.R | 2 +- .../R/expression_table_FDRtable.R | 9 +++++- .../R/expression_table_fctable.R | 9 +++++- .../R/expression_table_genetable.R | 9 +++++- .../R/expression_table_gsettable.R | 9 +++++- components/board.expression/R/expression_ui.R | 31 +++++++++---------- .../R/functional_table_go_table.R | 21 +------------ .../R/functional_table_kegg_table.R | 2 +- .../R/signature_table_enrich_by_contrasts.R | 2 +- .../R/signature_table_genes_in_signature.R | 2 +- .../R/signature_table_overlap.R | 2 +- .../R/wordcloud_table_enrichment.R | 2 +- .../R/wordcloud_table_leading_edge.R | 2 +- 21 files changed, 68 insertions(+), 57 deletions(-) diff --git a/components/base/R/TableModule2.R b/components/base/R/TableModule2.R index bce8aac84..046e63aec 100644 --- a/components/base/R/TableModule2.R +++ b/components/base/R/TableModule2.R @@ -166,7 +166,7 @@ TableModuleServer <- function(id, output$download <- download.csv output$datatable <- DT::renderDT({ - # If the options `scrollX` or `autoWidth` or `selector` are set, + # If the options `scrollX` or `autoWidth`, `fillContainer` or `selector` are set, # the global defaults of the global.R # will be overwritten. This ensures those options # are kept so that the header scrolls properly, and clickable @@ -182,6 +182,9 @@ TableModuleServer <- function(id, if(!is.null(selector)){ dt$x$selection$mode = selector } + if(!is.null(dt$x$fillContainer)){ + dt$x$fillContainer = FALSE + } # Remove striping and borders from all tables dt$x$container <- stringr::str_remove(dt$x$container, "stripe") dt$x$container <- stringr::str_remove(dt$x$container, "table-bordered") @@ -201,6 +204,9 @@ TableModuleServer <- function(id, if(!is.null(selector)){ dt$x$selection$mode = selector } + if(!is.null(dt$x$fillContainer)){ + dt$x$fillContainer = FALSE + } dt$x$container <- stringr::str_remove(dt$x$container, "stripe") dt$x$container <- stringr::str_remove(dt$x$container, "table-bordered") dt @@ -208,7 +214,6 @@ TableModuleServer <- function(id, fillContainer = T) module <- list( - ##data = func, data = shiny::reactive(func()$x$data), rows_current = shiny::reactive(input$datatable_rows_current), rows_selected = shiny::reactive(input$datatable_rows_selected), diff --git a/components/board.compare/R/compare_table_corr_score.R b/components/board.compare/R/compare_table_corr_score.R index c3816fafa..a0267356b 100644 --- a/components/board.compare/R/compare_table_corr_score.R +++ b/components/board.compare/R/compare_table_corr_score.R @@ -41,7 +41,7 @@ compare_table_corr_score_server <- function(id, options = list( dom = "lfrtip", scrollX = TRUE, - scrollY = "70vh", + scrollY = "15vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index 8ec94b460..544687715 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -147,7 +147,7 @@ correlation_plot_table_corr_server <- function(id, ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, ## scrollY = TRUE, ## scrollY = 170, - scrollY = "70vh", + scrollY = "25vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R index 002a81900..faa58c76f 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R @@ -61,7 +61,7 @@ drugconnectivity_table_cmap_server <- function(id, options = list( dom = "lfrtip", scrollX = TRUE, - scrollY = "70vh", scroller = TRUE, deferRender = TRUE + scrollY = "15vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R index 8112d6e06..f2506c8ff 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R @@ -60,7 +60,7 @@ drugconnectivity_table_dsea_server <- function(id, options = list( dom = "lfrtip", scroller = TRUE, scrollX = TRUE, - scrollY = "70vh", + scrollY = "25vh", deferRender = TRUE ) ) %>% diff --git a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R index 1b177c725..c28865dcd 100644 --- a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R +++ b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R @@ -81,7 +81,7 @@ enrichment_table_enrichment_analysis_server <- function(id, paging = TRUE, pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = "200px", + scrollY = "190px", scroller = TRUE, deferRender = TRUE, search = list( diff --git a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R index 7ae377f3c..a1dba2c88 100644 --- a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R +++ b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R @@ -54,7 +54,7 @@ enrichment_table_genes_in_geneset_server <- function(id, #paging = TRUE, #pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = 700, + scrollY = 190, scroller = TRUE, deferRender = TRUE, search = list( diff --git a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R index 1acbcf83f..931f1f7c5 100644 --- a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R +++ b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R @@ -49,7 +49,7 @@ enrichment_table_gset_enrich_all_contrasts_server <- function(id, options = list( dom = "frtip", scrollX = TRUE, - scrollY = tabH, + scrollY = 190, scroller = TRUE, deferRender = TRUE ) ## end of options.list diff --git a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R index 1baf01954..b929f2951 100644 --- a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R +++ b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R @@ -75,7 +75,7 @@ enrichment_table_n_sig_gsets_server <- function(id, dom = "frtip", pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = tabH, + scrollY = 190, scroller = TRUE, deferRender = TRUE ) ## end of options.list diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index 3af97064a..b500e860e 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -89,7 +89,7 @@ expression_table_FDRtable_server <- function(id, dom = "lfrtip", pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = tabV, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% @@ -108,9 +108,16 @@ expression_table_FDRtable_server <- function(id, ) }) + FDRtable.RENDER_modal <- shiny::reactive({ + dt <- FDRtable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + TableModuleServer( "datasets", func = FDRtable.RENDER, + func2 = FDRtable.RENDER_modal, selector = "none" ) }) # end module server diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 37d240b21..939ee828f 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -105,7 +105,7 @@ expression_table_fctable_server <- function(id, dom = "lfrtip", ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = tabV, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% @@ -131,9 +131,16 @@ expression_table_fctable_server <- function(id, dt }) + fctable.RENDER_modal <- shiny::reactive({ + dt <- fctable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + TableModuleServer( "datasets", func = fctable.RENDER, + func2 = fctable.RENDER_modal, selector = "none" ) diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R index c31fdafc7..d1a04711e 100644 --- a/components/board.expression/R/expression_table_genetable.R +++ b/components/board.expression/R/expression_table_genetable.R @@ -94,7 +94,7 @@ expression_table_genetable_server <- function(id, # paging = TRUE, # pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = 300, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE, search = list( @@ -115,9 +115,16 @@ expression_table_genetable_server <- function(id, ) }) + table.RENDER_modal <- shiny::reactive({ + dt <- table.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + genetable <- TableModuleServer( "datasets", func = table.RENDER, + func2 = table.RENDER_modal, selector = "single" ) diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index 541396b9b..6d5f4b46f 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -59,7 +59,7 @@ expression_table_gsettable_server <- function(id, # paging = TRUE, # pageLength = 16, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = 300, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE, search = list( @@ -73,9 +73,16 @@ expression_table_gsettable_server <- function(id, DT::formatStyle("fx", background = color_from_middle(df$fx, "lightblue", "#f5aeae")) }) + gsettable.RENDER_modal <- shiny::reactive({ + dt <- gsettable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + gsettable <- TableModuleServer( "datasets", func = gsettable.RENDER, + func2 = gsettable.RENDER_modal, selector = "single" ) diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index fc89f0cbf..a8f86db43 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -64,13 +64,14 @@ ExpressionUI <- function(id) { fullH <- 800 ## full height of page rowH <- 340 ## full height of page imgH <- 340 ## height of images + modal_heigh <- "70vh" div( boardHeader(title = "Differential expression", info_link = ns("gx_info")), div( tagList( div( - style = "max-height:50vh;", + # style = "max-height:50vh;", shiny::tabsetPanel( id = ns("tabs1"), shiny::tabPanel( @@ -81,7 +82,7 @@ ExpressionUI <- function(id) { class = "col-md-3", expression_plot_volcano_ui(ns("plots_volcano"), label = "a", - height = c(imgH, imgH), + height = c(imgH, modal_heigh), width = c("auto", imgH) ), ), @@ -90,7 +91,7 @@ ExpressionUI <- function(id) { expression_plot_maplot_ui( id = ns("plots_maplot"), label = "b", - height = c(imgH, imgH), + height = c(imgH, modal_heigh), width = c("auto", imgH) ), ), @@ -99,7 +100,7 @@ ExpressionUI <- function(id) { expression_plot_barplot_ui( id = ns("plots_barplot"), label = "c", - height = c(imgH, imgH), + height = c(imgH, modal_heigh), width = c("auto", imgH) ), ), @@ -108,13 +109,12 @@ ExpressionUI <- function(id) { expression_plot_topfoldchange_ui( id = ns("plots_topfoldchange"), label = "d", - height = c(imgH, imgH), + height = c(imgH, modal_heigh), width = c("auto", imgH) ), ) ), tags$div( - class = "caption", HTML("Expression plots associated with the selected contrast. (a) Volcano-plot plotting fold-change versuson significance the x and y axes, respectively. (b) MA-plot plotting signal intensity versus fold-change on the x and y axes, respectively. (c) Sorted barplot of the top diffentially expressed genes with largest (absolute) fold-change @@ -126,12 +126,11 @@ ExpressionUI <- function(id) { expression_plot_topgenes_ui( id = ns("topgenes"), label = "a", - height = c(imgH, 420), + height = c(imgH, modal_heigh), width = c("auto", 1600) ), shiny::br(), tags$div( - class = "caption", HTML("Top differentially expressed genes. Expression barplots of the top most differentially (both positively and negatively) expressed genes for the selected contrast.") ) @@ -140,12 +139,11 @@ ExpressionUI <- function(id) { "Volcano (all)", expression_plot_volcanoAll_ui(ns("volcanoAll"), label = "a", - height = c(imgH, 500), + height = c(imgH, modal_heigh), width = c("auto", 1600) ), shiny::br(), tags$div( - class = "caption", HTML("Volcano plot for all contrasts. Simultaneous visualisation of volcano plots of genes for all contrasts. Experimental contrasts with better statistical significance will show volcano plots with 'higher' wings.") @@ -156,12 +154,11 @@ ExpressionUI <- function(id) { expression_plot_volcanoMethods_ui( id = ns("volcanoMethods"), label = "a", - height = c(imgH, 450), + height = c(imgH, modal_heigh), width = c("auto", 1600) ), shiny::br(), tags$div( - class = "caption", HTML("Volcano plot for all statistical methods. Simultaneous visualisation of volcano plots of genes by multiple differential expression methods for the selected contrast. Methods showing better statistical significance will show volcano plots with 'higher' wings.") @@ -170,7 +167,7 @@ ExpressionUI <- function(id) { ) ), div( - style = "max-height: 50vh", + # style = "max-height: 50vh", shiny::tabsetPanel( id = ns("tabs2"), shiny::tabPanel( @@ -186,7 +183,7 @@ ExpressionUI <- function(id) { expression_table_genetable_ui( ns("genetable"), width = c("100%", "90%"), - height = c("300px", "600px") + height = c("300px", modal_heigh) ) ), div( @@ -194,7 +191,7 @@ ExpressionUI <- function(id) { expression_table_gsettable_ui( ns("gsettable"), width = c("100%", "90%"), - height = c("300px", "600px") + height = c("300px", modal_heigh) ) ) ) @@ -207,7 +204,7 @@ ExpressionUI <- function(id) { expression_table_fctable_ui( ns("fctable"), width = c("100%", "90%"), - height = c("300px", "600px") + height = c("300px", modal_heigh) ) ), shiny::tabPanel( @@ -218,7 +215,7 @@ ExpressionUI <- function(id) { expression_table_FDRtable_ui( ns("FDRtable"), width = c("100%", "90%"), - height = c("300px", "600px") + height = c("300px", modal_heigh) ) ) ) diff --git a/components/board.functional/R/functional_table_go_table.R b/components/board.functional/R/functional_table_go_table.R index a42b1a167..2d1c8996e 100644 --- a/components/board.functional/R/functional_table_go_table.R +++ b/components/board.functional/R/functional_table_go_table.R @@ -95,7 +95,7 @@ functional_table_go_table_server <- function(id, options = list( dom = "lfrtip", scrollX = TRUE, - scrollY = tabH, scroller = TRUE, deferRender = TRUE + scrollY = "15vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% DT::formatSignif(numeric.cols, 4) %>% @@ -109,25 +109,6 @@ functional_table_go_table_server <- function(id, ) } - # info_text <- strwrap("GO score table. The scoring of a GO - # term is performed by considering the cumulative score - # of all terms from that term to the root node. That - # means that GO terms that are supported by higher level - # terms levels are preferentially scored.") - - # table_opts <- shiny::tagList() - # - # shiny::callModule( - # tableModule, - # id = "table", - # label = "", - # func = table_RENDER, - # options = table_opts, - # info.text = info_text, - # title = "GO score table", - # height = c(270, 700) - # ) - TableModuleServer( "datasets", func = table_RENDER, diff --git a/components/board.functional/R/functional_table_kegg_table.R b/components/board.functional/R/functional_table_kegg_table.R index d72f4f8ec..0396150ca 100644 --- a/components/board.functional/R/functional_table_kegg_table.R +++ b/components/board.functional/R/functional_table_kegg_table.R @@ -80,7 +80,7 @@ functional_table_kegg_table_server <- function(id, options = list( dom = "lfrtip", scrollX = TRUE, - scrollY = tabH, scroller = TRUE, deferRender = TRUE + scrollY = "15vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% DT::formatSignif(numeric.cols, 4) %>% diff --git a/components/board.signature/R/signature_table_enrich_by_contrasts.R b/components/board.signature/R/signature_table_enrich_by_contrasts.R index 746664019..566db13e3 100644 --- a/components/board.signature/R/signature_table_enrich_by_contrasts.R +++ b/components/board.signature/R/signature_table_enrich_by_contrasts.R @@ -49,7 +49,7 @@ signature_table_enrich_by_contrasts_server <- function(id, fillContainer = TRUE, options = list( dom = "lrtip", - scrollX = TRUE, scrollY = tabH, scroller = TRUE, + scrollX = TRUE, scrollY = "20vh", scroller = TRUE, deferRender = FALSE ) ) %>% ## end of options.list diff --git a/components/board.signature/R/signature_table_genes_in_signature.R b/components/board.signature/R/signature_table_genes_in_signature.R index df461dd7b..681d5b456 100644 --- a/components/board.signature/R/signature_table_genes_in_signature.R +++ b/components/board.signature/R/signature_table_genes_in_signature.R @@ -43,7 +43,7 @@ signature_table_genes_in_signature_server <- function(id, fillContainer = TRUE, options = list( dom = "lrftip", - scrollX = TRUE, scrollY = tabH, scroller = TRUE, + scrollX = TRUE, scrollY = "30vh", scroller = TRUE, deferRender = FALSE ) ) %>% ## end of options.list diff --git a/components/board.signature/R/signature_table_overlap.R b/components/board.signature/R/signature_table_overlap.R index 6a2f4b275..88f019b66 100644 --- a/components/board.signature/R/signature_table_overlap.R +++ b/components/board.signature/R/signature_table_overlap.R @@ -41,7 +41,7 @@ signature_table_overlap_server <- function(id, fillContainer = TRUE, options = list( dom = "frtip", - scrollX = TRUE, scrollY = tabH, scroller = TRUE + scrollX = TRUE, scrollY = "25vh", scroller = TRUE ) ## end of options.list ) %>% DT::formatSignif(numeric.cols, 4) %>% diff --git a/components/board.wordcloud/R/wordcloud_table_enrichment.R b/components/board.wordcloud/R/wordcloud_table_enrichment.R index 3229ca584..a50adb775 100644 --- a/components/board.wordcloud/R/wordcloud_table_enrichment.R +++ b/components/board.wordcloud/R/wordcloud_table_enrichment.R @@ -39,7 +39,7 @@ wordcloud_table_enrichment_server <- function(id, fillContainer = TRUE, options = list( dom = "lfrtip", - scrollX = TRUE, scrollY = 200, + scrollX = TRUE, scrollY = 170, scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% diff --git a/components/board.wordcloud/R/wordcloud_table_leading_edge.R b/components/board.wordcloud/R/wordcloud_table_leading_edge.R index dfd43b427..849123fd5 100644 --- a/components/board.wordcloud/R/wordcloud_table_leading_edge.R +++ b/components/board.wordcloud/R/wordcloud_table_leading_edge.R @@ -53,7 +53,7 @@ wordcloud_table_leading_edge_server <- function(id, fillContainer = TRUE, options = list( dom = "lfrtip", - scrollX = TRUE, scrollY = 200, + scrollX = TRUE, scrollY = 170, scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% From ee2f455e9b3eef9ce6c7727f297cf29b6473c816 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sat, 18 Feb 2023 19:19:59 +0100 Subject: [PATCH 19/49] feat: tables scrollY works properly --- .../board.correlation/R/correlation_plot_table_corr.R | 9 ++++++++- components/board.correlation/R/correlation_ui.R | 2 +- .../R/enrichment_table_enrichment_analysis.R | 9 ++++++++- .../R/enrichment_table_genes_in_geneset_ui.R | 9 ++++++++- .../R/enrichment_table_gset_enrich_all_contrasts.R | 9 ++++++++- .../board.enrichment/R/enrichment_table_n_sig_gsets.R | 9 ++++++++- components/board.enrichment/R/enrichment_ui.R | 9 +++++---- .../board.functional/R/functional_table_go_table.R | 7 +++++++ components/board.functional/R/functional_ui.R | 2 +- .../board.wordcloud/R/wordcloud_table_enrichment.R | 9 ++++++++- .../board.wordcloud/R/wordcloud_table_leading_edge.R | 9 ++++++++- components/board.wordcloud/R/wordcloud_ui.R | 6 ++++-- 12 files changed, 74 insertions(+), 15 deletions(-) diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index 544687715..6aca74c0f 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -147,7 +147,7 @@ correlation_plot_table_corr_server <- function(id, ## pageLength = 20,## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, ## scrollY = TRUE, ## scrollY = 170, - scrollY = "25vh", + scrollY = "30vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list @@ -164,9 +164,16 @@ correlation_plot_table_corr_server <- function(id, ) }) + cor_table.RENDER_modal <- shiny::reactive({ + dt <- cor_table.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + TableModuleServer( "datasets", func = cor_table.RENDER, + func2 = cor_table.RENDER_modal, selector = "none" ) }) ## end of moduleServer diff --git a/components/board.correlation/R/correlation_ui.R b/components/board.correlation/R/correlation_ui.R index 9c07e3473..f82971b5e 100644 --- a/components/board.correlation/R/correlation_ui.R +++ b/components/board.correlation/R/correlation_ui.R @@ -60,7 +60,7 @@ CorrelationUI <- function(id) { class = "col-md-6", correlation_plot_table_corr_ui(ns("cor_barplot"), label = "a", - height = c(0.45 * fullH, 700), + height = c("30vh", "70vh"), width = c("auto", 1200) ), ), diff --git a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R index c28865dcd..e4b806a58 100644 --- a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R +++ b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R @@ -81,7 +81,7 @@ enrichment_table_enrichment_analysis_server <- function(id, paging = TRUE, pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = "190px", + scrollY = "20vh", scroller = TRUE, deferRender = TRUE, search = list( @@ -97,9 +97,16 @@ enrichment_table_enrichment_analysis_server <- function(id, ) }) + gseatable.RENDER_modal <- shiny::reactive({ + dt <- gseatable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + gseatable <- TableModuleServer( "datasets", func = gseatable.RENDER, + func2 = gseatable.RENDER_modal, selector = "single" ) diff --git a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R index a1dba2c88..b07d630a5 100644 --- a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R +++ b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R @@ -54,7 +54,7 @@ enrichment_table_genes_in_geneset_server <- function(id, #paging = TRUE, #pageLength = 15, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = 190, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE, search = list( @@ -74,9 +74,16 @@ enrichment_table_genes_in_geneset_server <- function(id, tbl }) + genetable.RENDER_modal <- shiny::reactive({ + dt <- genetable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + genetable <- TableModuleServer( "datasets", func = genetable.RENDER, + func2 = genetable.RENDER_modal, selector = "single" ) diff --git a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R index 931f1f7c5..3b3278481 100644 --- a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R +++ b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R @@ -49,7 +49,7 @@ enrichment_table_gset_enrich_all_contrasts_server <- function(id, options = list( dom = "frtip", scrollX = TRUE, - scrollY = 190, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list @@ -67,9 +67,16 @@ enrichment_table_gset_enrich_all_contrasts_server <- function(id, ) }) + fctable.RENDER_modal <- shiny::reactive({ + dt <- fctable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + TableModuleServer( "datasets", func = fctable.RENDER, + func2 = fctable.RENDER_modal, selector = "none" ) diff --git a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R index b929f2951..85c95ad64 100644 --- a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R +++ b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R @@ -75,7 +75,7 @@ enrichment_table_n_sig_gsets_server <- function(id, dom = "frtip", pageLength = 999, ## lengthMenu = c(20, 30, 40, 60, 100, 250), scrollX = TRUE, - scrollY = 190, + scrollY = "20vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list @@ -93,9 +93,16 @@ enrichment_table_n_sig_gsets_server <- function(id, ) }) + FDRtable.RENDER_modal <- shiny::reactive({ + dt <- FDRtable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + TableModuleServer( "datasets", func = FDRtable.RENDER, + func2 = FDRtable.RENDER_modal, selector = "none" ) diff --git a/components/board.enrichment/R/enrichment_ui.R b/components/board.enrichment/R/enrichment_ui.R index 81dfa980e..b9a9c0ed2 100644 --- a/components/board.enrichment/R/enrichment_ui.R +++ b/components/board.enrichment/R/enrichment_ui.R @@ -61,6 +61,7 @@ EnrichmentUI <- function(id) { tabV <- "70vh" ## height of tables tabH <- 340 ## row height of panels tabH <- "80vh" ## height of tables + modal_heigh <- "70vh" tabs <- tagList( shiny::tabsetPanel( @@ -201,14 +202,14 @@ EnrichmentUI <- function(id) { enrichment_table_enrichment_analysis_ui( ns("gseatable"), width = c("100%", "90%"), - height = c(285, 700) + height = c(285, modal_heigh) ) ), div( class = "col-md-5", enrichment_table_genes_in_geneset_ui( ns("genetable"), - height = c(285, 700), + height = c(285, modal_heigh), width = c("100%", "90%") ) ) @@ -223,7 +224,7 @@ EnrichmentUI <- function(id) { ), enrichment_table_gset_enrich_all_contrasts_ui( ns("fctable"), - height = c(295, 750), + height = c(295, modal_heigh), width = c("100%", "90%") ) ), @@ -236,7 +237,7 @@ EnrichmentUI <- function(id) { ), enrichment_table_n_sig_gsets_ui( ns("FDRtable"), - height = c(295, 750), + height = c(295, modal_heigh), width = c("100%", "90%") ) ) diff --git a/components/board.functional/R/functional_table_go_table.R b/components/board.functional/R/functional_table_go_table.R index 2d1c8996e..791033db7 100644 --- a/components/board.functional/R/functional_table_go_table.R +++ b/components/board.functional/R/functional_table_go_table.R @@ -109,9 +109,16 @@ functional_table_go_table_server <- function(id, ) } + table_RENDER_modal <- shiny::reactive({ + dt <- table_RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + TableModuleServer( "datasets", func = table_RENDER, + func2 = table_RENDER_modal, selector = "none" ) diff --git a/components/board.functional/R/functional_ui.R b/components/board.functional/R/functional_ui.R index 319c46769..abd9936ef 100644 --- a/components/board.functional/R/functional_ui.R +++ b/components/board.functional/R/functional_ui.R @@ -78,7 +78,7 @@ FunctionalUI <- function(id) { label = "a"), functional_table_go_table_ui( ns("GO_table"), - height = c(270, 700), + height = c("20vh", "70vh"), width = c("100%", "90%") ) ), diff --git a/components/board.wordcloud/R/wordcloud_table_enrichment.R b/components/board.wordcloud/R/wordcloud_table_enrichment.R index a50adb775..05c3fa46f 100644 --- a/components/board.wordcloud/R/wordcloud_table_enrichment.R +++ b/components/board.wordcloud/R/wordcloud_table_enrichment.R @@ -39,7 +39,7 @@ wordcloud_table_enrichment_server <- function(id, fillContainer = TRUE, options = list( dom = "lfrtip", - scrollX = TRUE, scrollY = 170, + scrollX = TRUE, scrollY = "25vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% @@ -53,9 +53,16 @@ wordcloud_table_enrichment_server <- function(id, return(tbl) }) + wordcloud_enrichmentTable.RENDER_modal <- shiny::reactive({ + dt <- wordcloud_enrichmentTable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + wordcloud_enrichmentTable <- TableModuleServer( "datasets", func = wordcloud_enrichmentTable.RENDER, + func2 = wordcloud_enrichmentTable.RENDER_modal, selector = "single" ) diff --git a/components/board.wordcloud/R/wordcloud_table_leading_edge.R b/components/board.wordcloud/R/wordcloud_table_leading_edge.R index 849123fd5..822584ef6 100644 --- a/components/board.wordcloud/R/wordcloud_table_leading_edge.R +++ b/components/board.wordcloud/R/wordcloud_table_leading_edge.R @@ -53,7 +53,7 @@ wordcloud_table_leading_edge_server <- function(id, fillContainer = TRUE, options = list( dom = "lfrtip", - scrollX = TRUE, scrollY = 170, + scrollX = TRUE, scrollY = "25vh", scroller = TRUE, deferRender = TRUE ) ## end of options.list ) %>% @@ -67,9 +67,16 @@ wordcloud_table_leading_edge_server <- function(id, return(tbl) }) + wordcloud_leadingEdgeTable.RENDER_modal <- shiny::reactive({ + dt <- wordcloud_leadingEdgeTable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + wordcloud_leadingEdgeTable <- TableModuleServer( "datasets", func = wordcloud_leadingEdgeTable.RENDER, + func2 = wordcloud_leadingEdgeTable.RENDER_modal, selector = "none" ) diff --git a/components/board.wordcloud/R/wordcloud_ui.R b/components/board.wordcloud/R/wordcloud_ui.R index c2fed2bcd..8234bbc07 100644 --- a/components/board.wordcloud/R/wordcloud_ui.R +++ b/components/board.wordcloud/R/wordcloud_ui.R @@ -19,6 +19,8 @@ WordCloudUI <- function(id) { rowH <- 660 ## row height of panel tabH <- 200 ## row height of panel tabH <- "70vh" ## row height of panel + modal_heigh <- "70vh" + ns <- shiny::NS(id) ## namespace shiny::tabsetPanel( id = ns("tabs"), @@ -45,7 +47,7 @@ WordCloudUI <- function(id) { class = "col-md-6", wordcloud_table_enrichment_ui( ns("wordcloud_enrichmentTable"), - height = c(270, 700), + height = c("35vh", modal_heigh), width = c("100%", "90%") ) ), @@ -53,7 +55,7 @@ WordCloudUI <- function(id) { class = "col-md-6", wordcloud_table_leading_edge_ui( ns("wordcloud_leadingEdgeTable"), - height = c(270, 700), + height = c("35vh", modal_heigh), width = c("100%", "90%") ) ) From 783eff8b7f4e557e397e73ecd6b3b2ce009f4529 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sat, 18 Feb 2023 19:47:40 +0100 Subject: [PATCH 20/49] feat: tables scrollY works properly --- components/board.compare/R/compare_table_corr_score.R | 7 +++++++ components/board.compare/R/compare_ui.R | 3 ++- .../board.drugconnectivity/R/drugconnectivity_table_cmap.R | 7 +++++++ .../board.drugconnectivity/R/drugconnectivity_table_dsea.R | 7 +++++++ components/board.drugconnectivity/R/drugconnectivity_ui.R | 5 +++-- .../R/signature_table_enrich_by_contrasts.R | 7 +++++++ .../board.signature/R/signature_table_genes_in_signature.R | 7 +++++++ components/board.signature/R/signature_table_overlap.R | 7 +++++++ components/board.signature/R/signature_ui.R | 7 ++++--- 9 files changed, 51 insertions(+), 6 deletions(-) diff --git a/components/board.compare/R/compare_table_corr_score.R b/components/board.compare/R/compare_table_corr_score.R index a0267356b..984bc98e6 100644 --- a/components/board.compare/R/compare_table_corr_score.R +++ b/components/board.compare/R/compare_table_corr_score.R @@ -50,9 +50,16 @@ compare_table_corr_score_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) + score_table.RENDER_modal <- shiny::reactive({ + dt <- score_table.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + score_table <- TableModuleServer( "datasets", func = score_table.RENDER, + func2 = score_table.RENDER_modal, selector = "none" ) return(score_table) diff --git a/components/board.compare/R/compare_ui.R b/components/board.compare/R/compare_ui.R index c1821758d..fbc331356 100644 --- a/components/board.compare/R/compare_ui.R +++ b/components/board.compare/R/compare_ui.R @@ -81,6 +81,7 @@ CompareUI <- function(id) { fullH <- 770 tabH <- "70vh" + modal_heigh <- "70vh" tabs <- shiny::tabsetPanel( id = ns("tabs1"), @@ -142,7 +143,7 @@ CompareUI <- function(id) { compare_plot_expression_ui(ns("multibarplot")), compare_table_corr_score_ui( ns("score_table"), - height = c(235, 750), + height = c(235, modal_heigh), width = c("auto", "90%") ) ), diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R index faa58c76f..67476486d 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R @@ -72,9 +72,16 @@ drugconnectivity_table_cmap_server <- function(id, ) } + table.RENDER_modal <- shiny::reactive({ + dt <- table.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + cmap_table <- TableModuleServer( "datasets", func = table.RENDER, + func2 = table.RENDER_modal, selector = "single" ) diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R index f2506c8ff..c4478e21a 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R @@ -76,9 +76,16 @@ drugconnectivity_table_dsea_server <- function(id, ) } + table.RENDER_modal <- shiny::reactive({ + dt <- table.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + dsea_table <- TableModuleServer( "datasets", func = table.RENDER, + func2 = table.RENDER_modal, selector = "single" ) diff --git a/components/board.drugconnectivity/R/drugconnectivity_ui.R b/components/board.drugconnectivity/R/drugconnectivity_ui.R index 3185f18be..e7d49bb08 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_ui.R +++ b/components/board.drugconnectivity/R/drugconnectivity_ui.R @@ -27,6 +27,7 @@ DrugConnectivityInputs <- function(id) { DrugConnectivityUI <- function(id) { ns <- shiny::NS(id) + modal_heigh <- "70vh" div( boardHeader(title = "Drug Connectivity", info_link = ns("dsea_info")), @@ -48,7 +49,7 @@ DrugConnectivityUI <- function(id) { br(), drugconnectivity_table_dsea_ui( ns("dsea_table"), - height = c(360, 700), + height = c(360, modal_heigh), width = c("100%", "90%") ) ), @@ -73,7 +74,7 @@ DrugConnectivityUI <- function(id) { shiny::br(), drugconnectivity_table_cmap_ui( ns("cmap_table"), - height = c(380, 740), + height = c(380, modal_heigh), width = c("100%", "90%") ) ), diff --git a/components/board.signature/R/signature_table_enrich_by_contrasts.R b/components/board.signature/R/signature_table_enrich_by_contrasts.R index 566db13e3..75ad81d47 100644 --- a/components/board.signature/R/signature_table_enrich_by_contrasts.R +++ b/components/board.signature/R/signature_table_enrich_by_contrasts.R @@ -63,9 +63,16 @@ signature_table_enrich_by_contrasts_server <- function(id, ) }) + enrichmentContrastTable.RENDER_render <- shiny::reactive({ + dt <- enrichmentContrastTable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + enrichmentContrastTable <- TableModuleServer( "datasets", func = enrichmentContrastTable.RENDER, + func2 = enrichmentContrastTable.RENDER_render, selector = "single" ) diff --git a/components/board.signature/R/signature_table_genes_in_signature.R b/components/board.signature/R/signature_table_genes_in_signature.R index 681d5b456..ad1548f7e 100644 --- a/components/board.signature/R/signature_table_genes_in_signature.R +++ b/components/board.signature/R/signature_table_genes_in_signature.R @@ -58,9 +58,16 @@ signature_table_genes_in_signature_server <- function(id, ) }) + enrichmentGeneTable.RENDER_modal <- shiny::reactive({ + dt <- enrichmentGeneTable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + enrichmentGeneTable <- TableModuleServer( "datasets", func = enrichmentGeneTable.RENDER, + func2 = enrichmentGeneTable.RENDER_modal, selector = "single" ) return(enrichmentGeneTable) diff --git a/components/board.signature/R/signature_table_overlap.R b/components/board.signature/R/signature_table_overlap.R index 88f019b66..5ad9a5be7 100644 --- a/components/board.signature/R/signature_table_overlap.R +++ b/components/board.signature/R/signature_table_overlap.R @@ -54,9 +54,16 @@ signature_table_overlap_server <- function(id, ) }) + overlapTable.RENDER_modal <- shiny::reactive({ + dt <- overlapTable.RENDER() + dt$x$options$scrollY <- "55vh" + dt + }) + overlapTable <- TableModuleServer( "datasets", func = overlapTable.RENDER, + func2 = overlapTable.RENDER_modal, selector = "none" ) return(overlapTable) diff --git a/components/board.signature/R/signature_ui.R b/components/board.signature/R/signature_ui.R index 1249e36ca..15cc7f151 100644 --- a/components/board.signature/R/signature_ui.R +++ b/components/board.signature/R/signature_ui.R @@ -72,6 +72,7 @@ SignatureUI <- function(id) { fullH <- 800 ## full height of page tabH <- "70vh" + modal_heigh <- "70vh" tabs <- div( class = "row", @@ -117,7 +118,7 @@ SignatureUI <- function(id) { shiny::br(), signature_table_overlap_ui( ns("overlapTable"), - height = 0.4 * fullH, + height = c(0.4 * fullH, modal_heigh), width = c("auto", "90%") ), shiny::br(), @@ -153,13 +154,13 @@ SignatureUI <- function(id) { "Enrichment table", signature_table_enrich_by_contrasts_ui( ns("enrichmentContrastTable"), - height = c(230, 700), + height = c(230, modal_heigh), width = c("auto", "90%") ), shiny::br(), signature_table_genes_in_signature_ui( ns("enrichmentGeneTable"), - height = c(360, 700), + height = c(360, modal_heigh), width = c("auto", "90%") ), shiny::br(), From f8f3f4ceec4ab675c3c000850f045d09ab16db46 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sun, 19 Feb 2023 20:22:19 +0100 Subject: [PATCH 21/49] feat: add shinycssloaders --- components/base/R/TableModule2.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/components/base/R/TableModule2.R b/components/base/R/TableModule2.R index 046e63aec..6e2a71149 100644 --- a/components/base/R/TableModule2.R +++ b/components/base/R/TableModule2.R @@ -111,7 +111,8 @@ TableModuleUI <- function(id, flex = c(NA,1,NA,0.001,NA), height = height.1, div( header, class="plotmodule-header"), - DT::DTOutput(ns("datatable"), width=width.1, height=height.1), + DT::DTOutput(ns("datatable"), width=width.1, height=height.1) %>% + shinycssloaders::withSpinner(), div( class = "footer", shiny::HTML(caption) From 732b5e99d9f53fb7d73a510ac4f676e1e21cb623 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sun, 19 Feb 2023 20:35:34 +0100 Subject: [PATCH 22/49] feat: pdf size appears when download format is set to pdf --- components/base/R/PlotModule.R | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/components/base/R/PlotModule.R b/components/base/R/PlotModule.R index 4112071bb..42ae39a52 100644 --- a/components/base/R/PlotModule.R +++ b/components/base/R/PlotModule.R @@ -134,7 +134,11 @@ PlotModuleUI <- function(id, label = "Format", choices = download.fmt ), - pdf_size, + shiny::conditionalPanel( + condition = "input.downloadOption == 'pdf'", + ns = ns, + pdf_size + ), shiny::br(), div( shiny::downloadButton( From 1c841054903d6d9c68bd4a419a2f832d4dd8c79f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sun, 19 Feb 2023 23:55:40 +0100 Subject: [PATCH 23/49] style: bigger well font size --- scss/components/_all.scss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/scss/components/_all.scss b/scss/components/_all.scss index 64d6ebc3e..c1629791c 100644 --- a/scss/components/_all.scss +++ b/scss/components/_all.scss @@ -83,7 +83,7 @@ html { } .well { - font-size: 12px; + font-size: 14px; line-height: 1.2em; } From da42bfedfbb0543257a1ff358ca7cdaa9e381371 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sun, 19 Feb 2023 23:55:51 +0100 Subject: [PATCH 24/49] style: bigger text --- components/board.upload/R/UploadModule.R | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/components/board.upload/R/UploadModule.R b/components/board.upload/R/UploadModule.R index ae829fca3..6266481fb 100644 --- a/components/board.upload/R/UploadModule.R +++ b/components/board.upload/R/UploadModule.R @@ -22,7 +22,8 @@ UploadModuleUI <- function(id) { shiny::sidebarLayout( shiny::sidebarPanel( width = 3, - shiny::fileInput(ns("upload_files"), "Choose files", + shiny::fileInput(ns("upload_files"), + shiny::h4("Choose files"), multiple = TRUE, accept = c(".csv", ".pgx") ), shinyWidgets::prettySwitch(ns("load_example"), "load example data"), From 58efe783644da4c2241a6981f68885ad9c2b407a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Sun, 19 Feb 2023 23:56:15 +0100 Subject: [PATCH 25/49] style: separation between wells + font style --- components/app/R/modules/ComputePgxModule.R | 160 ++++++++++---------- 1 file changed, 82 insertions(+), 78 deletions(-) diff --git a/components/app/R/modules/ComputePgxModule.R b/components/app/R/modules/ComputePgxModule.R index bb7ec2e46..5b4a39b36 100644 --- a/components/app/R/modules/ComputePgxModule.R +++ b/components/app/R/modules/ComputePgxModule.R @@ -6,16 +6,16 @@ if(0) { source("~/Playground/omicsplayground/R/pgx-include.R") - load("~/Playground/omicsplayground/data/GSE10846-dlbcl-nc.pgx") + load("~/Playground/omicsplayground/data/GSE10846-dlbcl-nc.pgx") PgxComputeGadget(X=ngs$X, pheno=ngs$samples) out <- gadgetize2( ComputePgxUI, ComputePgxServer, - title = "UploadGadget", height=640, size="l", + title = "UploadGadget", height=640, size="l", X = ngs$X, pheno=ngs$samples ) names(out) - + } ComputePgxGadget <- function(counts, samples, contrasts, height=720) { @@ -34,7 +34,7 @@ ComputePgxUI <- function(id) { } ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, metaRT, - FILES, pgx.dirRT, enable_button = TRUE, alertready = TRUE, + FILES, pgx.dirRT, enable_button = TRUE, alertready = TRUE, max.genes = 20000, max.genesets = 10000, max.datasets = 100, height = 720 ) { @@ -49,7 +49,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta GENETEST.METHODS = c("ttest","ttest.welch","voom.limma","trend.limma","notrend.limma", "deseq2.wald","deseq2.lrt","edger.qlf","edger.lrt") GENETEST.SELECTED = c("trend.limma","deseq2.wald","edger.qlf") - + ## statistical method for GENESET level testing GENESET.METHODS = c("fisher","ssgsea","gsva", "spearman", "camera", "fry", ##"plage","enricher","gsea.permPH","gsea.permGS","gseaPR", @@ -124,9 +124,10 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta "input.options%2 == 1", ns=ns, shiny::fillRow( shiny::wellPanel( + style = "width: 95%;", shiny::checkboxGroupInput( ns('filter_methods'), - 'Feature filtering:', + shiny::h4('Feature filtering:'), choiceValues = c("only.hugo", "only.proteincoding", @@ -152,25 +153,28 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta ) ), shiny::wellPanel( + style = "width: 95%;", shiny::checkboxGroupInput( ns('gene_methods'), - 'Gene tests:', + shiny::h4('Gene tests:'), GENETEST.METHODS, selected = GENETEST.SELECTED ) ), shiny::wellPanel( + style = "width: 95%;", shiny::checkboxGroupInput( ns('gset_methods'), - 'Enrichment methods:', + shiny::h4('Enrichment methods:'), GENESET.METHODS, selected = GENESET.SELECTED ), ), shiny::wellPanel( + style = "width: 95%;", shiny::checkboxGroupInput( ns('extra_methods'), - 'Extra analysis:', + shiny::h4('Extra analysis:'), choiceValues = EXTRA.METHODS, choiceNames = EXTRA.NAMES, selected = EXTRA.SELECTED @@ -179,7 +183,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta shiny::wellPanel( shiny::checkboxGroupInput( ns('dev_options'), - 'Developer options:', + shiny::h4('Developer options:'), choiceValues = DEV.METHODS, choiceNames = DEV.NAMES, selected = DEV.SELECTED @@ -189,8 +193,8 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta ) ## end of conditional panel ) ## end of fill Col }) - shiny::outputOptions(output, "UI", suspendWhenHidden=FALSE) ## important!!! - + shiny::outputOptions(output, "UI", suspendWhenHidden=FALSE) ## important!!! + if(FALSE) { shiny::observeEvent( input$gene_methods, { @@ -203,13 +207,13 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta } }) } - + shiny::observeEvent( input$options, { ## shinyjs::disable(ns("gene_methods2")) }) - + shiny::observeEvent( enable_button(), { - ## NEED CHECK. not working... + ## NEED CHECK. not working... ## if(!enable_button()){ message("[ComputePgxServer:@enable] disabling compute button") @@ -219,27 +223,27 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta shinyjs::enable(ns("compute")) } }) - + shiny::observeEvent( metaRT(), { - + dbg("[ComputePgxServer:@metaRT] parsing meta information...") meta <- metaRT() dbg("[ComputePgxServer:@metaRT] names.meta =",names(meta)) - + if(!is.null(meta[['name']])) { dbg("[ComputePgxServer:@metaRT] NS.upload_name = ",ns("upload_name")) dbg("[ComputePgxServer:@metaRT] meta.name => ",meta[['name']]) shiny::updateTextInput(session, "upload_name", value=meta[['name']]) - ## shiny::updateTextInput(session, ns("upload_name"), value=meta[['name']]) + ## shiny::updateTextInput(session, ns("upload_name"), value=meta[['name']]) } if(!is.null(meta[['description']])) { dbg("[ComputePgxServer:@metaRT] NS.upload_description = ",ns("upload_description")) dbg("[ComputePgxServer:@metaRT] meta.description => '",meta[['description']],"'") shiny::updateTextAreaInput(session, "upload_description", value=meta[['description']]) - ##shiny::updateTextAreaInput(session, ns("upload_description"), value=meta[['description']]) + ##shiny::updateTextAreaInput(session, ns("upload_description"), value=meta[['description']]) } - + }) ##------------------------------------------------------------------ @@ -247,15 +251,15 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta ## object from the uploaded files ## ------------------------------------------------------------------ computedPGX <- shiny::reactiveVal(NULL) - + shiny::observeEvent( input$compute, { - + message("[ComputePgxServer::@compute] reacted!") ## shiny::req(input$upload_hugo,input$upload_filtergenes) - + + ##----------------------------------------------------------- + ## Check validity ##----------------------------------------------------------- - ## Check validity - ##----------------------------------------------------------- if(!enable_button()) { message("[ComputePgxServer:@compute] WARNING:: *** NOT ENABLED ***") return(NULL) @@ -265,8 +269,8 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta dbg("[ComputePgxServer::@compute] pgxdir = ", pgxdir ) numpgx <- length(dir(pgxdir, pattern="*.pgx$")) - dbg("[ComputePgxServer::@compute] numpgx = ", numpgx ) - + dbg("[ComputePgxServer::@compute] numpgx = ", numpgx ) + if(numpgx >= max.datasets) { msg = "Your storage is full. You have NUMPGX pgx files in your data folder and your quota is LIMIT datasets. Please delete some datasets or consider buying extra storage." msg <- sub("NUMPGX",numpgx,msg) @@ -287,25 +291,25 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta shinyalert::shinyalert("ERROR","You must give a dataset name and description") return(NULL) } - + ##----------------------------------------------------------- ## Retrieve the most recent matrices from reactive values - ##----------------------------------------------------------- + ##----------------------------------------------------------- counts <- countsRT() samples <- samplesRT() samples <- data.frame(samples, stringsAsFactors=FALSE, check.names=FALSE) contrasts <- as.matrix(contrastsRT()) - + dbg("[ComputePgxServer:@enable] ct1 = ", contrasts[,1]) - + ## contrasts[is.na(contrasts)] <- 0 - ## contrasts[is.na(contrasts)] <- "" + ## contrasts[is.na(contrasts)] <- "" ##!!!!!!!!!!!!!! This is blocking the computation !!!!!!!!!!! ##batch <- batchRT() ## batch correction vectors for GLM - + ##----------------------------------------------------------- ## Set statistical methods and run parameters - ##----------------------------------------------------------- + ##----------------------------------------------------------- max.genes=20000;max.genesets=5000 gx.methods = c("ttest.welch","trend.limma") gset.methods = c("fisher") @@ -321,7 +325,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta gx.methods <- c(input$gene_methods,input$gene_methods2) gset.methods <- c(input$gset_methods,input$gset_methods2) extra.methods <- c(input$extra_methods,input$extra_methods2) - + if(length(gx.methods)==0) { shinyalert::shinyalert("ERROR","You must select at least one gene test method") return(NULL) @@ -333,22 +337,22 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta ## at least do meta.go, infer extra.methods <- unique(c("meta.go","infer",extra.methods)) - + ##---------------------------------------------------------------------- ## Start computation ##---------------------------------------------------------------------- - message("[ComputePgxServer:@compute] start computations...") + message("[ComputePgxServer:@compute] start computations...") message("[ComputePgxServer::@compute] gx.methods = ",paste(gx.methods,collapse=" ")) message("[ComputePgxServer::@compute] gset.methods = ",paste(gset.methods,collapse=" ")) message("[ComputePgxServer::@compute] extra.methods = ",paste(extra.methods,collapse=" ")) - + start_time <- Sys.time() ## Create a Progress object progress <- shiny::Progress$new() - on.exit(progress$close()) + on.exit(progress$close()) progress$set(message = "Processing", value = 0) pgx.showCartoonModal("Computation may take 5-20 minutes...") - + flt="";use.design=TRUE;prune.samples=FALSE flt <- input$filter_methods only.hugo <- ("only.hugo" %in% flt) @@ -357,37 +361,37 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta excl.immuno <- ("excl.immuno" %in% flt) excl.xy <- ("excl.xy" %in% flt) only.proteincoding <- ("only.proteincoding" %in% flt) - filter.genes <- ("remove.notexpressed" %in% flt) - + filter.genes <- ("remove.notexpressed" %in% flt) + use.design <- !("noLM.prune" %in% input$dev_options) prune.samples <- ("noLM.prune" %in% input$dev_options) - message("[ComputePgxServer:@compute] creating PGX object") - progress$inc(0.1, detail = "creating PGX object") + message("[ComputePgxServer:@compute] creating PGX object") + progress$inc(0.1, detail = "creating PGX object") USE_FUTURES=1 USE_FUTURES=0 - - if(USE_FUTURES) { + + if(USE_FUTURES) { ## !!!TRYING TO USE FUTURES. BUT SEEMS STILL TO BLOCK ## OTHER SESSIONS!!!! ## ## IK 10.11.2021 - message("[ComputePgxServer:@compute] using futures ") + message("[ComputePgxServer:@compute] using futures ") f <- future::future({ pgx.createPGX( counts, samples, contrasts, ## genes, X = NULL, ## should we pass the pre-normalized expresson X ???? - batch.correct = FALSE, ## done in UI + batch.correct = FALSE, ## done in UI prune.samples = TRUE, ## always prune filter.genes = filter.genes, ##only.chrom = FALSE, ##rik.orf = !excl.rikorf, only.known = !remove.unknown, - only.proteincoding = only.proteincoding, + only.proteincoding = only.proteincoding, only.hugo = only.hugo, convert.hugo = only.hugo, do.cluster = TRUE, @@ -397,89 +401,89 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta ## wait until done... while (!future::resolved(f)) { ##cat(count, "\n") - message(".",appendLF = FALSE) + message(".",appendLF = FALSE) Sys.sleep(15) ## every 15s } - message("done!\n") + message("done!\n") ##value(f) ngs <- future::value(f) names(ngs) - + } else { ngs <- pgx.createPGX( counts, samples, contrasts, ## genes, X = NULL, ## should we pass the pre-normalized expresson X ???? - batch.correct = FALSE, ## done in UI + batch.correct = FALSE, ## done in UI prune.samples = TRUE, ## always prune filter.genes = filter.genes, ##only.chrom = FALSE, ##rik.orf = !excl.rikorf, only.known = !remove.unknown, - only.proteincoding = only.proteincoding, + only.proteincoding = only.proteincoding, only.hugo = only.hugo, convert.hugo = only.hugo, do.cluster = TRUE, cluster.contrasts = FALSE ) } - - names(ngs) + + names(ngs) message("[ComputePgxServer:@compute] computing PGX object") - progress$inc(0.2, detail = "computing PGX object") + progress$inc(0.2, detail = "computing PGX object") + + if(USE_FUTURES) { - if(USE_FUTURES) { - - message("[ComputePgxServer:@compute] using futures ") + message("[ComputePgxServer:@compute] using futures ") f <- future::future({ pgx.computePGX( ngs, max.genes = max.genes, - max.genesets = max.genesets, + max.genesets = max.genesets, gx.methods = gx.methods, gset.methods = gset.methods, extra.methods = extra.methods, - use.design = use.design, ## no.design+prune are combined + use.design = use.design, ## no.design+prune are combined prune.samples = prune.samples, ## - do.cluster = TRUE, + do.cluster = TRUE, progress = progress, - lib.dir = FILES + lib.dir = FILES ) }) ## wait until done... while (!future::resolved(f)) { ##cat(count, "\n") - message(".",appendLF = FALSE) + message(".",appendLF = FALSE) Sys.sleep(15) ## every 15s } - message("done!\n") + message("done!\n") ##value(f) ngs <- future::value(f) names(ngs) } else { - + ngs <- pgx.computePGX( ngs, max.genes = max.genes, - max.genesets = max.genesets, + max.genesets = max.genesets, gx.methods = gx.methods, gset.methods = gset.methods, extra.methods = extra.methods, - use.design = use.design, ## no.design+prune are combined + use.design = use.design, ## no.design+prune are combined prune.samples = prune.samples, ## - do.cluster = TRUE, + do.cluster = TRUE, progress = progress, - lib.dir = FILES + lib.dir = FILES ) } - + end_time <- Sys.time() run_time = end_time - start_time run_time message("[ComputePgxServer:@compute] total processing time of ",run_time," secs") - + ##---------------------------------------------------------------------- ## annotate object ##---------------------------------------------------------------------- @@ -491,18 +495,18 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta ngs$name = gsub("[ ]","_",input$upload_name) ngs$datatype = input$upload_datatype ngs$description = input$upload_description - ngs$creator <- "user" - + ngs$creator <- "user" + this.date <- format(Sys.time(), "%Y-%m-%d %H:%M:%S") ##ngs$date = date() ngs$date = this.date message("[ComputePgxServer:@compute] initialize object") - + ## initialize and update global PGX object ## ngs <- pgx.initialize(ngs) ## here or later??? ##uploaded$pgx <- ngs - computedPGX(ngs) + computedPGX(ngs) ##---------------------------------------------------------------------- ## Remove modal and show we are ready From 867310d29e02cdcfafeae6008d96517f2e368a3c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 00:28:38 +0100 Subject: [PATCH 26/49] style: capitalize --- components/board.upload/R/UploadModule.R | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/components/board.upload/R/UploadModule.R b/components/board.upload/R/UploadModule.R index 6266481fb..cb51e071e 100644 --- a/components/board.upload/R/UploadModule.R +++ b/components/board.upload/R/UploadModule.R @@ -26,8 +26,8 @@ UploadModuleUI <- function(id) { shiny::h4("Choose files"), multiple = TRUE, accept = c(".csv", ".pgx") ), - shinyWidgets::prettySwitch(ns("load_example"), "load example data"), - shinyWidgets::prettySwitch(ns("advanced_mode"), "batch correction (beta)") + shinyWidgets::prettySwitch(ns("load_example"), "Load example data"), + shinyWidgets::prettySwitch(ns("advanced_mode"), "Batch correction (beta)") ), shiny::mainPanel( width = 9, From f7bf1f5c4301d82856cb110a83ac238a7b78d218 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 00:57:51 +0100 Subject: [PATCH 27/49] feat: add fileInput2 copy of shiny fileInput but changing the class of the button it creates. Maybe on future releases of shiny they will allow us to place our own class on that button, not at the moment. With that the button matches the rest --- components/base/R/ui-code.R | 39 +++++++++++++++++++++++++++++++++++++ 1 file changed, 39 insertions(+) diff --git a/components/base/R/ui-code.R b/components/base/R/ui-code.R index 7a103bea8..f0807b6bc 100644 --- a/components/base/R/ui-code.R +++ b/components/base/R/ui-code.R @@ -127,4 +127,43 @@ DropdowMenu <- function (..., size = "default", status = "default", icon = NULL, ), tags$script(HTML(jsCode(id))) ) +} + + +# Copied code from shiny::fileInput but changed the class of the button +# it creates to btn-outline-primary. +# Maybe on future versions of that function they will add +# a `class` argument so we can submit our own class to that button. +fileInput2 <- function(inputId, label, multiple = FALSE, accept = NULL, width = NULL, + buttonLabel = "Browse...", placeholder = "No file selected", + capture = NULL) +{ + restoredValue <- restoreInput(id = inputId, default = NULL) + if (!is.null(restoredValue) && !is.data.frame(restoredValue)) { + warning("Restored value for ", inputId, " has incorrect format.") + restoredValue <- NULL + } + if (!is.null(restoredValue)) { + restoredValue <- toJSON(restoredValue, strict_atomic = FALSE) + } + inputTag <- tags$input(id = inputId, name = inputId, type = "file", + style = "position: absolute !important; top: -99999px !important; left: -99999px !important;", + `data-restore` = restoredValue) + if (multiple) + inputTag$attribs$multiple <- "multiple" + if (length(accept) > 0) + inputTag$attribs$accept <- paste(accept, collapse = ",") + if (!is.null(capture)) { + inputTag$attribs$capture <- capture + } + div(class = "form-group shiny-input-container", + style = htmltools::css(width = htmltools::validateCssUnit(width)), + shiny:::shinyInputLabel(inputId, label), div(class = "input-group", + tags$label(class = "input-group-btn input-group-prepend", + span(class = "btn btn-default btn-outline-primary", buttonLabel, + inputTag)), tags$input(type = "text", class = "form-control", + placeholder = placeholder, readonly = "readonly")), + tags$div(id = paste(inputId, "_progress", sep = ""), + class = "progress active shiny-file-input-progress", + tags$div(class = "progress-bar"))) } \ No newline at end of file From 82ad7d531c68edc0ead717e077a4d40ed684731a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 00:58:21 +0100 Subject: [PATCH 28/49] style: btn-outline-primary on buttons --- components/app/R/modules/ComputePgxModule.R | 2 +- components/app/R/modules/MakeContrastModule.R | 13 +++++++++---- 2 files changed, 10 insertions(+), 5 deletions(-) diff --git a/components/app/R/modules/ComputePgxModule.R b/components/app/R/modules/ComputePgxModule.R index 5b4a39b36..29cc1cb7e 100644 --- a/components/app/R/modules/ComputePgxModule.R +++ b/components/app/R/modules/ComputePgxModule.R @@ -111,7 +111,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta shiny::br(), shiny::div( shiny::actionButton(ns("compute"),"Compute!",icon=icon("running"), - class="run-button"), + class="btn-outline-primary"), shiny::br(),br(), shiny::actionLink(ns("options"), "Computation options", icon=icon("cog", lib="glyphicon")), diff --git a/components/app/R/modules/MakeContrastModule.R b/components/app/R/modules/MakeContrastModule.R index 80f434f1a..cbf8df4c8 100644 --- a/components/app/R/modules/MakeContrastModule.R +++ b/components/app/R/modules/MakeContrastModule.R @@ -116,7 +116,10 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) "Give a name for your contrast as MAIN_vs_CONTROL, with the name of the main group first. You must keep _vs_ in the name to separate the names of the two groups."), shiny::br(), ## tipifyL( - shiny::actionButton(ns("addcontrast"),"add comparison", icon=icon("plus")), + shiny::actionButton(ns("addcontrast"), + "add comparison", + icon=icon("plus"), + class = "btn-outline-primary"), ##"After creating the groups, press this button to add the comparison to the table."a), shiny::br() ), @@ -136,8 +139,10 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) height = 24, flex = c(NA,0.05,NA,NA,1), withTooltip( - shiny::actionButton(ns("autocontrast"),"add auto-contrasts", icon=icon("plus"), - class="small-button"), + shiny::actionButton(ns("autocontrast"), + "add auto-contrasts", + icon=icon("plus"), + class="small-button btn-outline-primary"), "If you are feeling lucky, try this to automatically create contrasts.", placement="top", options = list(container = "body") ), @@ -436,7 +441,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) width = "50px", inline = TRUE, icon = shiny::icon("trash-alt"), - class = "btn-inline", + class = "btn-inline btn-outline-danger-hover", style='padding:2px; margin:2px; font-size:95%; color: #B22222;', ##onclick = 'Shiny.onInputChange(\"contrast_delete\",this.id)' onclick = paste0('Shiny.onInputChange(\"',ns("contrast_delete"),'\",this.id)') From 7e697d9541f9a9af6a73c07f86ee7dd57eb8c1d9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 00:58:36 +0100 Subject: [PATCH 29/49] feat: use new fileInput2 --- components/board.upload/R/UploadModule.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/board.upload/R/UploadModule.R b/components/board.upload/R/UploadModule.R index cb51e071e..001836527 100644 --- a/components/board.upload/R/UploadModule.R +++ b/components/board.upload/R/UploadModule.R @@ -22,7 +22,7 @@ UploadModuleUI <- function(id) { shiny::sidebarLayout( shiny::sidebarPanel( width = 3, - shiny::fileInput(ns("upload_files"), + fileInput2(ns("upload_files"), shiny::h4("Choose files"), multiple = TRUE, accept = c(".csv", ".pgx") ), From bd2e9f60e0c18ee4d86e4238bce020ed60dd9a0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 00:59:40 +0100 Subject: [PATCH 30/49] feat: new DT global options --- components/app/R/global.R | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/components/app/R/global.R b/components/app/R/global.R index b57b045b1..e749b43bd 100644 --- a/components/app/R/global.R +++ b/components/app/R/global.R @@ -28,7 +28,12 @@ options(shiny.maxRequestSize = 999*1024^2) ## max 999Mb upload options(shiny.fullstacktrace = TRUE) # The following DT global options ensure # 1. The header scrolls with the X scroll bar -options(DT.options = list(autoWidth = FALSE, scrollX = TRUE)) + # 2. The Y scroller works properly and no blank rows are displayed +options(DT.options = list( + autoWidth = FALSE, + scrollX = TRUE, + fillContainer = FALSE +)) reticulate::use_miniconda('r-reticulate') get_opg_root <- function() { From 4e6fa306999de1401c190b5994ba1f35f53e27dc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 10:54:15 +0100 Subject: [PATCH 31/49] test: change pixels to vh --- components/board.dataview/R/dataview_ui.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/board.dataview/R/dataview_ui.R b/components/board.dataview/R/dataview_ui.R index 43ab2dbb9..cff6ba2fd 100644 --- a/components/board.dataview/R/dataview_ui.R +++ b/components/board.dataview/R/dataview_ui.R @@ -196,7 +196,7 @@ DataViewUI <- function(id) { "Counts table", dataview_table_rawdata_ui( ns("rawdatatable"), - height = c("75vh", 700), + height = c("75vh", "75vh"), width = c("100%", "90%") ), tags$div( From a6266114702bd2f1a44a21ba5767e3bbc15e9f65 Mon Sep 17 00:00:00 2001 From: ncullen93 Date: Mon, 20 Feb 2023 12:05:59 +0100 Subject: [PATCH 32/49] load example fix --- components/app/R/modules/WelcomeBoard.R | 11 +- components/app/R/server.R | 6 +- components/app/R/www/temp.js | 53 ++++----- components/board.loading/R/loading_server.R | 114 ++++++++------------ 4 files changed, 67 insertions(+), 117 deletions(-) diff --git a/components/app/R/modules/WelcomeBoard.R b/components/app/R/modules/WelcomeBoard.R index 8dc77b915..9acb3b81e 100644 --- a/components/app/R/modules/WelcomeBoard.R +++ b/components/app/R/modules/WelcomeBoard.R @@ -8,7 +8,7 @@ WelcomeBoardInputs <- function(id) {} WelcomeBoardUI <- function(id) {} -WelcomeBoard <- function(id, auth, rvals) +WelcomeBoard <- function(id, auth, r_global) { moduleServer(id, function(input, output, session) { @@ -29,20 +29,15 @@ WelcomeBoard <- function(id, auth, rvals) }) observeEvent(input$init_example_data, { - print('loaded new data') shinyjs::runjs("$('.tab-sidebar:eq(1)').trigger('click');") shinyjs::runjs("$('.sidebar-label').trigger('click');") - rvals$load_example_trigger <- TRUE + r_global$load_example_trigger <- TRUE }) }) } WelcomeBoardInputs <- function(id) { - ## ns <- shiny::NS(id) ## namespace - ## bigdash::tabSettings( - ## shiny::actionLink(ns("module_info"), "Tutorial", icon = shiny::icon("youtube")) - ## ) return(NULL) } @@ -66,7 +61,7 @@ WelcomeBoardUI <- function(id) { h3("I am new..."), shiny::actionButton( ns('init_example_data'), - label = "Try example dataset (new)", + label = "Try example dataset", class = "btn btn-outline-info welcome-btn" ) ), diff --git a/components/app/R/server.R b/components/app/R/server.R index 29eccc8c7..96b26950b 100644 --- a/components/app/R/server.R +++ b/components/app/R/server.R @@ -113,7 +113,7 @@ app_server <- function(input, output, session) { ## *** EXPERIMENTAL *** global reactive value replacing env list ## above create session global reactiveValue from list PGX <- reactiveValues() - rvals <- reactiveValues( + r_global <- reactiveValues( load_example_trigger = FALSE ) @@ -128,7 +128,7 @@ app_server <- function(input, output, session) { enable_upload = opt$ENABLE_UPLOAD, enable_delete = opt$ENABLE_DELETE, enable_save = opt$ENABLE_SAVE, - rvals = rvals + r_global = r_global ) ## Modules needed from the start @@ -160,7 +160,7 @@ app_server <- function(input, output, session) { }) ## Default boards - WelcomeBoard("welcome", auth=auth, rvals=rvals) + WelcomeBoard("welcome", auth=auth, r_global=r_global) env$user <- UserBoard("user", user=auth) ## Modules needed after dataset is loaded (deferred) -------------- diff --git a/components/app/R/www/temp.js b/components/app/R/www/temp.js index f7c9e7133..cd21d96df 100644 --- a/components/app/R/www/temp.js +++ b/components/app/R/www/temp.js @@ -18,8 +18,8 @@ const unloadSidebar = () => { if(index == 0){ $(el).show(); return; - } - + } + $(el).hide(); }); } @@ -53,23 +53,6 @@ $(function(){ $('.sidebar-label').trigger('click'); }); - $('#init-example-data').on('click', (e) => { - $(".tab-sidebar:eq(1)").trigger('click'); - $('.sidebar-label').trigger('click'); - setTimeout(() => { - let first = $('tbody') - .find('tr') - .first() - .find('td:eq(1)') - .text(); - - if(first != 'example-data') - return; - - $('#load-loadbutton').trigger('click'); - }, 1000); - }); - $('#init-upload-data').on('click', (e) => { $(".tab-sidebar:eq(2)").trigger('click'); $('.sidebar-label').trigger('click'); @@ -86,7 +69,7 @@ Shiny.addCustomMessageHandler('manage-sub', (msg) => { Shiny.addCustomMessageHandler('get-permissions', (msg) => { if(!db) db = firebase.firestore(); - + db .collection('customers') .doc(firebase.auth().currentUser.uid) @@ -110,17 +93,17 @@ Shiny.addCustomMessageHandler('get-permissions', (msg) => { try { Shiny.setInputValue( - msg.ns + '-permissions', - { + msg.ns + '-permissions', + { success: true, - response: doc.data() + response: doc.data() }, {priority: 'event'} ); } catch (error) { Shiny.setInputValue( - msg.ns + '-permissions', - { + msg.ns + '-permissions', + { success: false, response: error }, @@ -129,8 +112,8 @@ Shiny.addCustomMessageHandler('get-permissions', (msg) => { } }, (error) => { Shiny.setInputValue( - msg.ns + '-permissions', - { + msg.ns + '-permissions', + { success: false, response: error }, @@ -203,8 +186,8 @@ Shiny.addCustomMessageHandler('get-subs', (msg) => { }, (error) => { Shiny.setInputValue( - msg.ns + '-subs', - { + msg.ns + '-subs', + { success: false, response: error }, @@ -217,7 +200,7 @@ const logout = () => { unloadSidebar(); sidebarClose(); Shiny.setInputValue('auth-userLogout', 1, {priority: 'event'}); - Shiny.setInputValue('userLogout', 1, {priority: 'event'}); + Shiny.setInputValue('userLogout', 1, {priority: 'event'}); }; const quit = () => { @@ -230,7 +213,7 @@ Shiny.addCustomMessageHandler('shinyproxy-logout', (msg) => { const show_plans = () => { - Shiny.setInputValue('auth-firebaseUpgrade', 1, {priority: 'event'}); + Shiny.setInputValue('auth-firebaseUpgrade', 1, {priority: 'event'}); }; async function upgrade_plan(){ @@ -248,7 +231,7 @@ async function upgrade_plan(){ docRef.onSnapshot((snap) => { const { error, url } = snap.data(); if (error) { - // Show an error to your customer and + // Show an error to your customer and // inspect your Cloud Function logs in the Firebase console. alert(`An error occured: ${error.message}`); } @@ -256,7 +239,7 @@ async function upgrade_plan(){ // We have a Stripe Checkout URL, let's redirect. window.location.assign(url); } - }); + }); } Shiny.addCustomMessageHandler('email-feedback', function(msg) { @@ -272,7 +255,7 @@ const priceChange = (name) => { $('#yearlyCheck').prop('checked', false); } else { $('#monthlyCheck').prop('checked', false); - } + } if($('#yearlyCheck').prop('checked')){ $('#starter-pricing').text('CHF49 / month'); $('#premium-pricing').text('CHF490 / month'); @@ -303,7 +286,7 @@ fetch(`log?msg=${encodeURIComponent(msg)}`) } const sendLog2 = (msg) => { - fetch(`log?msg=${encodeURIComponent(msg)}`) + fetch(`log?msg=${encodeURIComponent(msg)}`) .then(res => { console.info(res); hideSub(); diff --git a/components/board.loading/R/loading_server.R b/components/board.loading/R/loading_server.R index e9b809d5a..800202a74 100644 --- a/components/board.loading/R/loading_server.R +++ b/components/board.loading/R/loading_server.R @@ -14,20 +14,28 @@ LoadingBoard <- function(id, enable_delete = TRUE, enable_save = TRUE, enable_userdir = TRUE, - rvals + r_global ) { moduleServer(id, function(input, output, session) { ns <- session$ns ## NAMESPACE - dbg("[LoadingBoard] >>> initializing LoadingBoard...") loadedDataset <- shiny::reactiveVal(0) ## counts/trigger dataset upload - message("[LoadingBoard] in.shinyproxy = ",in.shinyproxy()) - message("[LoadingBoard] SHINYPROXY_USERNAME = ",Sys.getenv("SHINYPROXY_USERNAME")) - message("[LoadingBoard] SHINYPROXY_USERGROUPS = ",Sys.getenv("SHINYPROXY_USERGROUPS")) - message("[LoadingBoard] pgx_dir = ",pgx_dir) + ## info that's needed + r_local <- reactiveValues( + selected_row = NULL + ) + + observeEvent(pgxtable$rows_selected(), { + r_local$selected_row <- pgxtable$rows_selected() + }) + + observeEvent(r_global$load_example_trigger, { + r_local$selected_row <- 1 + print(paste('selected row:', r_local$selected_row)) + }) ##================================================================================ @@ -46,15 +54,19 @@ LoadingBoard <- function(id, easyClose = TRUE, size="xl" )) }) - module_infotext =paste0( - "This panel shows the available datasets within the platform. The table reports a brief description as well as the total number of samples, genes, gene sets (or pathways), corresponding phenotypes and the creation date. - -

Selecting the dataset: Users can select a dataset in the table. The Dataset info shows the information of the dataset of interest and users can load the data by clicking the 'Load dataset' button. - -


-
- -") + module_infotext <- paste0( + "This panel shows the available datasets within the platform. The table + reports a brief description as well as the total number of samples, + genes, gene sets (or pathways), corresponding phenotypes and the creation + date.

Selecting the dataset: Users can select a dataset in + the table. The Dataset info shows the information of the dataset of + interest and users can load the data by clicking the 'Load dataset' + button.


" + ) ##----------------------------------------------------------------------------- ## User interface @@ -97,9 +109,7 @@ LoadingBoard <- function(id, pdir <- paste0(pdir,"/",email) if(!is.null(email) && !is.na(email) && email!="") pdir <- paste0(pdir,'/') if(!dir.exists(pdir)) { - dbg("[LoadingBoard:getPGXDIR] userdir does not exists. creating pdir = ",pdir) dir.create(pdir) - dbg("[LoadingBoard:getPGXDIR] copy example pgx") file.copy(file.path(pgx_dir,"example-data.pgx"),pdir) } } @@ -109,7 +119,7 @@ LoadingBoard <- function(id, getPGXINFO <- shiny::reactive({ req(auth) if(!auth$logged()) { - dbg("[LoadingBoard:getPGXINFO] user not logged in!") + warning("[LoadingBoard:getPGXINFO] user not logged in!") return(NULL) } info <- NULL @@ -129,7 +139,8 @@ LoadingBoard <- function(id, ## get the filtered table of pgx datasets req(auth) if(!auth$logged()) { - dbg("[LoadingBoard:getFilteredPGXINFO] user not logged in! not showing table!") + warning("[LoadingBoard:getFilteredPGXINFO] user not logged in! + not showing table!") return(NULL) } df <- getPGXINFO() @@ -148,12 +159,10 @@ LoadingBoard <- function(id, if(notnull(input$flt_organism)) f3 <- (df$organism %in% input$flt_organism) df <- df[which(f1 & f2 & f3),,drop=FALSE] df$date <- as.Date(df$date, format='%Y-%m-%d') - ##df <- df[order(df$date,decreasing=FALSE),] df <- df[order(df$date,decreasing=TRUE),] rownames(df) <- nrow(df):1 } - ##kk = unique(c("dataset","datatype","organism","description",colnames(df))) kk = unique(c("dataset","description","datatype","nsamples", "ngenes","nsets","conditions","date","organism")) kk = intersect(kk,colnames(df)) @@ -163,7 +172,8 @@ LoadingBoard <- function(id, selectedPGX <- shiny::reactive({ req(pgxtable) - sel <- pgxtable$rows_selected() + sel <- r_local$selected_row + #sel <- pgxtable$rows_selected() if(is.null(sel) || length(sel)==0) return(NULL) df <- getFilteredPGXINFO() if(is.null(df) || nrow(df)==0) return(NULL) @@ -175,7 +185,6 @@ LoadingBoard <- function(id, ##============================================================================= ##========================== OBSERVE/REACT ==================================== ##============================================================================= - ##pgxfile="geiger2016-arginine" loadPGX <- function(pgxfile) { @@ -187,7 +196,6 @@ LoadingBoard <- function(id, pgx.path <- pgxdir[file.exists(file.path(pgxdir,pgxfile))][1] pgxfile1 = file.path(pgx.path,pgxfile) - pgxfile1 pgx <- NULL if(file.exists(pgxfile1)) { @@ -195,14 +203,14 @@ LoadingBoard <- function(id, pgx <- local(get(load(pgxfile1,verbose=0))) ## override any name }) } else { - message("[LoadingBoard::loadPGX] ***ERROR*** file not found : ",pgxfile) + warning("[LoadingBoard::loadPGX] ***ERROR*** file not found : ",pgxfile) return(NULL) } if(!is.null(pgx)) { pgx$name <- pgxfile return(pgx) } else { - message("[LoadingBoard::loadPGX] ERROR loading pgx object") + warning("[LoadingBoard::loadPGX] ERROR loading pgx object") return(NULL) } } @@ -214,11 +222,9 @@ LoadingBoard <- function(id, }, content = function(file) { pgxfile <- selectedPGX() - cat("[LoadingBoard::loadPGX] pgxfile = ",pgxfile,"\n") if(is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) return(NULL) pgx <- loadPGX(pgxfile) temp <- tempfile() - cat("[LoadingBoard::loadPGX] temp = ",temp) save(pgx, file=temp) file.copy(temp,file) } @@ -231,7 +237,6 @@ LoadingBoard <- function(id, }, content = function(file) { pgxfile <- selectedPGX() - cat("[LoadingBoard::downloadZIP] pgxfile = ",pgxfile,"\n") if(is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) return(NULL) pgxname <- sub("[.]pgx$","",pgxfile) pgx <- loadPGX(pgxfile) @@ -252,8 +257,6 @@ LoadingBoard <- function(id, zip::zip(zipfile, files=paste0(pgxname,"/",c("counts.csv","samples.csv","contrasts.csv","normalized.csv")), root=tmp) - ## zip::zip_list(zipfile) - cat("[LoadingBoard::downloadZIP] zipfile = ",zipfile) file.copy(zipfile,file) remove(pgx); gc(); } @@ -282,12 +285,10 @@ LoadingBoard <- function(id, not.anonymous <- !is.na(auth$name()) && auth$name()!="" allow.delete <- !not.anonymous - message("[LoadingBoard::@deletebutton] current user = ",auth$name()," \n") - message("[LoadingBoard::@deletebutton] allow.delete = ",allow.delete," \n") allow.delete = TRUE if(!allow.delete) { - message("[LoadingBoard::@deletebutton] WARNING:: ",pgxfile, + warning("[LoadingBoard::@deletebutton] WARNING:: ",pgxfile, " not owned by ",auth$name()," \n") shinyalert::shinyalert( title = "Error!", @@ -313,18 +314,13 @@ LoadingBoard <- function(id, load_react <- reactive({ btn <- input$loadbutton + btn2 <- r_global$load_example_trigger query <- parseQueryString(session$clientData$url_search) logged <- isolate(auth$logged()) ## avoid reloading when logout/login (!is.null(btn) || !is.null(query[['pgx']])) && logged }) - observeEvent(rvals$load_example_trigger, { - # click button - }) - shiny::observeEvent( load_react(), { - #shiny::observeEvent( load_react(), { - print('loading example triggered') if(!load_react()) { return(NULL) } @@ -348,9 +344,13 @@ LoadingBoard <- function(id, ## Observe button press (over-rides URL query) btn <- input$loadbutton - if(!is.null(btn) && btn!=0) { + if (!is.null(btn) && btn!=0) { pgxfile <- selectedPGX() } + ## Observe "try example dataset" press + if (r_global$load_example_trigger) { + pgxfile <- selectedPGX() + } ## check if file is there if(is.na(pgxfile) || is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) { @@ -365,25 +365,19 @@ LoadingBoard <- function(id, ##----------------- Loaded PGX object --------------------------------- ##--------------------------------------------------------------------- - dbg("[LoadingBoard@load_react] loading pgxfile = ",pgxfile) loaded_pgx <- loadPGX(pgxfile) - dbg("[LoadingBoard@load_react] is.null(pgx) = ",is.null(loaded_pgx)) - if(is.null(loaded_pgx)) { - message("[LoadingBoard@load_react] ERROR loading PGX file ",pgxfile,"\n") + warning("[LoadingBoard@load_react] ERROR loading PGX file ",pgxfile,"\n") beepr::beep(10) shiny::removeModal() return(NULL) } ##----------------- update PGX object --------------------------------- - dbg("[LoadingBoard@load_react] initializing PGX object") loaded_pgx <- pgx.initialize(loaded_pgx) - dbg("[LoadingBoard@load_react] initialization done!") - if(is.null(loaded_pgx)) { - cat("[LoadingBoard@load_react] ERROR in object initialization\n") + warning("[LoadingBoard@load_react] ERROR in object initialization\n") beepr::beep(10) shiny::showNotification("ERROR in object initialization!\n") shiny::removeModal() @@ -408,14 +402,10 @@ LoadingBoard <- function(id, } ##----------------- remove modal on exit?? ------------------------- - ##Sys.sleep(3) - ##shiny::removeModal() remove(loaded_pgx) gc() }) - ##}, ignoreNULL=FALSE ) - ##}, ignoreNULL=TRUE ) ##================================================================================ @@ -425,7 +415,6 @@ LoadingBoard <- function(id, pgx_stats <- reactive({ pgx <- getFilteredPGXINFO() shiny::req(pgx) - ##dbg("valuebox2:: pgx$nsamples=",pgx$nsamples) ndatasets <- nrow(pgx) nsamples <- sum(as.integer(pgx$nsamples),na.rm=TRUE) paste(ndatasets,"Data sets    ", nsamples, "Samples") @@ -434,7 +423,6 @@ LoadingBoard <- function(id, output$navheader <- shiny::renderUI({ fillRow( flex=c(NA,NA,1), - ##h2(input$nav), shiny::div( id="navheader-current-section", HTML("Load dataset  "), @@ -456,7 +444,6 @@ LoadingBoard <- function(id, ## reactive value for updating table touchtable <- shiny::reactiveVal(0) - ##split=" ";n=5 andothers <- function(s, split=" ", n=8) { if(is.na(s)) return("") s <- sub("^[ ]*","",s) @@ -469,15 +456,10 @@ LoadingBoard <- function(id, pgxTable_data <- shiny::reactive({ - - dbg("[pgxTable.RENDER] reacted") - - ##touchtable() ## explicit reactive on this reload_pgxdir() df <- getFilteredPGXINFO() shiny::req(df) - dbg("[pgxTable.RENDER] dim(df)=",dim(df)) df$dataset <- gsub("[.]pgx$"," ",df$dataset) df$conditions <- gsub("[,]"," ",df$conditions) @@ -492,8 +474,6 @@ LoadingBoard <- function(id, df <- pgxTable_data() req(df) - ##df <- data.frame(nr=rownames(df), df) - target1 <- grep("date",colnames(df)) target2 <- grep("description",colnames(df)) target3 <- grep("conditions",colnames(df)) @@ -501,21 +481,15 @@ LoadingBoard <- function(id, DT::datatable( df, - # class = 'compact cell-border hover', class = 'compact hover', rownames = TRUE, extensions = c('Scroller'), selection = list(mode='single', target='row', selected=1), fillContainer = TRUE, options=list( - ##dom = 'Blfrtip', dom = 'ft', - ##columnDefs = list(list(searchable = FALSE, targets = 1)), pageLength = 9999, - ##lengthMenu = c(20, 30, 40, 100), scrollX = FALSE, - ##scrollY =400, ## scroller=TRUE, - ##scrollY = '100vh', ## scroller=TRUE, scrollY = FALSE, deferRender=TRUE, autoWidth = TRUE, @@ -544,7 +518,6 @@ LoadingBoard <- function(id, func = pgxTable.RENDER, func2 = pgxTable_modal.RENDER, title = "Data files", - ##height = c(600,700), height = c("65vh",700), width = c('100%','100%'), info.text = info_text, @@ -560,7 +533,6 @@ LoadingBoard <- function(id, res <- list( loaded = loadedDataset, auth = auth - ##usermode = shiny::reactive({ USERMODE() }) ) return(res) }) From 866b64abdde548fbec14a0ec2da1f1a588c5637c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 13:05:41 +0100 Subject: [PATCH 33/49] fix: plots not showing + select message --- .../R/enrichment_plot_barplot.R | 18 ++++++++++++------ .../R/enrichment_plot_compare.R | 4 +++- .../R/enrichment_plot_freq_top_gsets.R | 1 + .../R/enrichment_plot_geneplot.R | 12 +++++++----- 4 files changed, 23 insertions(+), 12 deletions(-) diff --git a/components/board.enrichment/R/enrichment_plot_barplot.R b/components/board.enrichment/R/enrichment_plot_barplot.R index 93be6cf32..8d58f5777 100644 --- a/components/board.enrichment/R/enrichment_plot_barplot.R +++ b/components/board.enrichment/R/enrichment_plot_barplot.R @@ -23,6 +23,7 @@ enrichment_plot_barplot_ui <- function(id, height, width) { ns("plot"), title = "Enrichment barplot", label = "b", + plotlib = "plotly", info.text = info_text, options = options, height = height, @@ -49,11 +50,17 @@ enrichment_plot_barplot_server <- function(id, gset <- rownames(ngs$gsetX)[1] gset <- gset_selected() if (is.null(gset) || length(gset) == 0) { - return(NULL) + return(plotly::plotly_empty(type = "scatter", mode = "markers") %>% + plotly::config( + displayModeBar = FALSE + )) } gset <- gset[1] if (!gset %in% rownames(ngs$gsetX)) { - return(NULL) + return(plotly::plotly_empty(type = "scatter", mode = "markers") %>% + plotly::config( + displayModeBar = FALSE + )) } comp0 <- colnames(ngs$model.parameters$contr.matrix)[1] @@ -73,15 +80,14 @@ enrichment_plot_barplot_server <- function(id, ngs, gset, comp = comp0, logscale = TRUE, level = "geneset", collapse.others = collapse.others, grouped = grouped, - cex = 1.1, srt = srt, main = "", ylab = "enrichment (avg logFC)" + cex = 1.1, srt = srt, main = "", ylab = "enrichment (avg logFC)", + xlab = breakstring(gset, 42, 80) ) - title(breakstring(gset, 42, 80), cex.main = 0.85) - p <- grDevices::recordPlot() - p }) PlotModuleServer( "plot", + plotlib = "plotly", func = subplot_barplot.RENDER, pdf.width = 5, pdf.height = 5, res = c(72, 100), diff --git a/components/board.enrichment/R/enrichment_plot_compare.R b/components/board.enrichment/R/enrichment_plot_compare.R index dab650fab..5bc9ecd75 100644 --- a/components/board.enrichment/R/enrichment_plot_compare.R +++ b/components/board.enrichment/R/enrichment_plot_compare.R @@ -38,7 +38,9 @@ enrichment_plot_compare_server <- function(id, gset <- rownames(ngs$gsetX)[1] gset <- gset_selected() if (is.null(gset)) { - return(NULL) + frame() + text(0.5, 0.5, "Please select a geneset", col = "grey50") + return() } gset <- gset[1] diff --git a/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R b/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R index 211de183f..6f7bbba25 100644 --- a/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R +++ b/components/board.enrichment/R/enrichment_plot_freq_top_gsets.R @@ -125,6 +125,7 @@ enrichment_plot_freq_top_gsets_server <- function(id, topEnrichedFreq.RENDER <- shiny::reactive({ dt <- plot_data() + shiny::req(dt) ngs <- dt[[1]] rpt <- dt[[2]] ntop <- dt[[3]] diff --git a/components/board.enrichment/R/enrichment_plot_geneplot.R b/components/board.enrichment/R/enrichment_plot_geneplot.R index b8dd16efa..0a4b74e5b 100644 --- a/components/board.enrichment/R/enrichment_plot_geneplot.R +++ b/components/board.enrichment/R/enrichment_plot_geneplot.R @@ -20,6 +20,7 @@ enrichment_plot_geneplot_ui <- function(id, height, width) { ns("plot"), title = "Expression geneplot", label = "c", + plotlib = "plotly", info.text = info_text, options = options, height = height, @@ -51,7 +52,10 @@ enrichment_plot_geneplot_server <- function(id, sel <- gene_selected() if (is.null(sel) || is.na(sel) || length(sel) == 0) { - frame() + return(plotly::plotly_empty(type = "scatter", mode = "markers") %>% + plotly::config( + displayModeBar = FALSE + )) } else { probe <- sel$probe gene <- sel$gene @@ -67,16 +71,14 @@ enrichment_plot_geneplot_server <- function(id, ngs, probe, comp = comp0, logscale = TRUE, level = "gene", collapse.others = collapse.others, grouped = grouped, - srt = srt, main = "" + srt = srt, main = "", xlab = gene ) - title(gene, cex.main = 0.9) } - p <- grDevices::recordPlot() - p }) PlotModuleServer( "plot", + plotlib = "plotly", func = subplot_geneplot.RENDER, pdf.width = 5, pdf.height = 5, res = c(78, 100), From fa61b6a1a321054b6c4e8ba1db87edd9121a2280 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 13:38:28 +0100 Subject: [PATCH 34/49] fix: global table modal height values as vh --- components/app/R/global.R | 8 +++++++ .../R/compare_table_corr_score.R | 2 +- components/board.compare/R/compare_ui.R | 3 +-- .../R/correlation_plot_table_corr.R | 4 ++-- .../R/dataview_table_contrasts.R | 18 +++++---------- .../board.dataview/R/dataview_table_rawdata.R | 10 ++++---- .../board.dataview/R/dataview_table_samples.R | 2 +- components/board.dataview/R/dataview_ui.R | 6 ++--- .../R/drugconnectivity_table_cmap.R | 2 +- .../R/drugconnectivity_table_dsea.R | 2 +- .../R/drugconnectivity_ui.R | 5 ++-- .../R/enrichment_table_enrichment_analysis.R | 2 +- .../R/enrichment_table_genes_in_geneset_ui.R | 2 +- ...richment_table_gset_enrich_all_contrasts.R | 2 +- .../R/enrichment_table_n_sig_gsets.R | 2 +- components/board.enrichment/R/enrichment_ui.R | 9 ++++---- .../R/expression_table_FDRtable.R | 2 +- .../R/expression_table_fctable.R | 2 +- .../R/expression_table_genetable.R | 2 +- .../R/expression_table_gsettable.R | 2 +- components/board.expression/R/expression_ui.R | 23 +++++++++---------- .../R/featuremap_plot_table_gene_map.R | 9 +++++++- .../R/featuremap_plot_table_geneset_map.R | 9 +++++++- .../R/functional_table_go_table.R | 2 +- .../R/functional_table_kegg_table.R | 7 ++++++ components/board.functional/R/functional_ui.R | 4 ++-- .../R/intersection_plot_table_venn_diagram.R | 4 ++-- .../R/signature_table_enrich_by_contrasts.R | 2 +- .../R/signature_table_genes_in_signature.R | 2 +- .../R/signature_table_overlap.R | 2 +- components/board.signature/R/signature_ui.R | 7 +++--- .../board.wgcna/R/wgcna_table_enrichment.R | 7 ++++++ components/board.wgcna/R/wgcna_table_genes.R | 7 ++++++ components/board.wgcna/R/wgcna_ui.R | 4 ++-- .../R/wordcloud_table_enrichment.R | 2 +- .../R/wordcloud_table_leading_edge.R | 2 +- components/board.wordcloud/R/wordcloud_ui.R | 5 ++-- 37 files changed, 109 insertions(+), 76 deletions(-) diff --git a/components/app/R/global.R b/components/app/R/global.R index e749b43bd..0eafaa01d 100644 --- a/components/app/R/global.R +++ b/components/app/R/global.R @@ -34,6 +34,14 @@ options(DT.options = list( scrollX = TRUE, fillContainer = FALSE )) +# Set global modal height values for tables. + # - The SCROLLY_MODAL defines the size of the scroll Y bar on the modals, + # this only defines the srollable part of the table, not the header height. + # - The TABLE_HEIGHT_MODAL defines the whole width of the table + header, + # this will define how close the caption is to the table. +SCROLLY_MODAL <<- "55vh" +TABLE_HEIGHT_MODAL <<- "75vh" + reticulate::use_miniconda('r-reticulate') get_opg_root <- function() { diff --git a/components/board.compare/R/compare_table_corr_score.R b/components/board.compare/R/compare_table_corr_score.R index 984bc98e6..3be7516d4 100644 --- a/components/board.compare/R/compare_table_corr_score.R +++ b/components/board.compare/R/compare_table_corr_score.R @@ -52,7 +52,7 @@ compare_table_corr_score_server <- function(id, score_table.RENDER_modal <- shiny::reactive({ dt <- score_table.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.compare/R/compare_ui.R b/components/board.compare/R/compare_ui.R index fbc331356..4a5ec0703 100644 --- a/components/board.compare/R/compare_ui.R +++ b/components/board.compare/R/compare_ui.R @@ -81,7 +81,6 @@ CompareUI <- function(id) { fullH <- 770 tabH <- "70vh" - modal_heigh <- "70vh" tabs <- shiny::tabsetPanel( id = ns("tabs1"), @@ -143,7 +142,7 @@ CompareUI <- function(id) { compare_plot_expression_ui(ns("multibarplot")), compare_table_corr_score_ui( ns("score_table"), - height = c(235, modal_heigh), + height = c(235, TABLE_HEIGHT_MODAL), width = c("auto", "90%") ) ), diff --git a/components/board.correlation/R/correlation_plot_table_corr.R b/components/board.correlation/R/correlation_plot_table_corr.R index 6aca74c0f..42cda084a 100644 --- a/components/board.correlation/R/correlation_plot_table_corr.R +++ b/components/board.correlation/R/correlation_plot_table_corr.R @@ -34,7 +34,7 @@ correlation_plot_table_corr_ui <- function(id, TableModuleUI( ns("datasets"), info.text = cor_table.info, - height = c(360, 700), + height = c(360, TABLE_HEIGHT_MODAL), width = c("auto", "90%"), title = "Correlation table", label = "b" @@ -166,7 +166,7 @@ correlation_plot_table_corr_server <- function(id, cor_table.RENDER_modal <- shiny::reactive({ dt <- cor_table.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.dataview/R/dataview_table_contrasts.R b/components/board.dataview/R/dataview_table_contrasts.R index 30518bc60..bddbb1458 100644 --- a/components/board.dataview/R/dataview_table_contrasts.R +++ b/components/board.dataview/R/dataview_table_contrasts.R @@ -106,24 +106,18 @@ dataview_table_contrasts_server <- function(id, ) } - # info_text <- "Contrast table. Table summarizing the contrasts of all comparisons. Here, you can check which samples belong to which groups for the different comparisons. Non-zero entries '+1' and '-1' correspond to the group of interest and control group, respectively. Zero or empty entries denote samples not use for that comparison." - - + table.RENDER_modal <- shiny::reactive({ + dt <- table.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) TableModuleServer( "datasets", func = table.RENDER, + func2 = table.RENDER_modal, selector = "none" ) - # contrastTable <- shiny::callModule( - # tableModule, "tbl", - # func = table.RENDER, - # csvFunc = contrasts_data, - # options = opts, - # title = "Contrast table", - # filename = "contrasts.csv", - # info.text = info_text - # ) }) ## end of moduleServer } ## end of server diff --git a/components/board.dataview/R/dataview_table_rawdata.R b/components/board.dataview/R/dataview_table_rawdata.R index 1876c1a9a..c9fb4cbfb 100644 --- a/components/board.dataview/R/dataview_table_rawdata.R +++ b/components/board.dataview/R/dataview_table_rawdata.R @@ -201,14 +201,16 @@ dataview_table_rawdata_server <- function(id, ) } - rawdataTable_modal.RENDER <- function() { - rawdataTable.RENDER() %>% - DT::formatStyle(0, target = "row", fontSize = "20px", lineHeight = "70%") - } + rawdataTable.RENDER_modal <- shiny::reactive({ + dt <- rawdataTable.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) TableModuleServer( "datasets", func = rawdataTable.RENDER, + func2 = rawdataTable.RENDER_modal, selector = "none" ) diff --git a/components/board.dataview/R/dataview_table_samples.R b/components/board.dataview/R/dataview_table_samples.R index 62ea1eeb0..f1b1b78db 100644 --- a/components/board.dataview/R/dataview_table_samples.R +++ b/components/board.dataview/R/dataview_table_samples.R @@ -58,7 +58,7 @@ dataview_table_samples_server <- function(id, selection = list(mode = "single", target = "row", selected = 1), options = list( dom = "lfrtip", - scroller = TRUE, scrollX = TRUE, scrollY = 600, + scroller = TRUE, scrollX = TRUE, scrollY = SCROLLY_MODAL, deferRender = TRUE ) ) %>% diff --git a/components/board.dataview/R/dataview_ui.R b/components/board.dataview/R/dataview_ui.R index cff6ba2fd..9669e1736 100644 --- a/components/board.dataview/R/dataview_ui.R +++ b/components/board.dataview/R/dataview_ui.R @@ -196,7 +196,7 @@ DataViewUI <- function(id) { "Counts table", dataview_table_rawdata_ui( ns("rawdatatable"), - height = c("75vh", "75vh"), + height = c("75vh", TABLE_HEIGHT_MODAL), width = c("100%", "90%") ), tags$div( @@ -234,7 +234,7 @@ DataViewUI <- function(id) { ), dataview_table_samples_ui( ns("sampletable"), - height = c(280,750), + height = c(280,TABLE_HEIGHT_MODAL), width=c('auto','90%') ), tags$div( @@ -258,7 +258,7 @@ DataViewUI <- function(id) { "Contrasts", dataview_table_contrasts_ui( ns("contrastTable"), - height = c(500,750), + height = c(500,TABLE_HEIGHT_MODAL), width=c('auto','90%') ), tags$div( diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R index 67476486d..1c33535bf 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_cmap.R @@ -74,7 +74,7 @@ drugconnectivity_table_cmap_server <- function(id, table.RENDER_modal <- shiny::reactive({ dt <- table.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R index c4478e21a..ecfe95729 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R +++ b/components/board.drugconnectivity/R/drugconnectivity_table_dsea.R @@ -78,7 +78,7 @@ drugconnectivity_table_dsea_server <- function(id, table.RENDER_modal <- shiny::reactive({ dt <- table.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.drugconnectivity/R/drugconnectivity_ui.R b/components/board.drugconnectivity/R/drugconnectivity_ui.R index e7d49bb08..bfca30532 100644 --- a/components/board.drugconnectivity/R/drugconnectivity_ui.R +++ b/components/board.drugconnectivity/R/drugconnectivity_ui.R @@ -27,7 +27,6 @@ DrugConnectivityInputs <- function(id) { DrugConnectivityUI <- function(id) { ns <- shiny::NS(id) - modal_heigh <- "70vh" div( boardHeader(title = "Drug Connectivity", info_link = ns("dsea_info")), @@ -49,7 +48,7 @@ DrugConnectivityUI <- function(id) { br(), drugconnectivity_table_dsea_ui( ns("dsea_table"), - height = c(360, modal_heigh), + height = c(360, TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ), @@ -74,7 +73,7 @@ DrugConnectivityUI <- function(id) { shiny::br(), drugconnectivity_table_cmap_ui( ns("cmap_table"), - height = c(380, modal_heigh), + height = c(380, TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ), diff --git a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R index e4b806a58..7b5cd694c 100644 --- a/components/board.enrichment/R/enrichment_table_enrichment_analysis.R +++ b/components/board.enrichment/R/enrichment_table_enrichment_analysis.R @@ -99,7 +99,7 @@ enrichment_table_enrichment_analysis_server <- function(id, gseatable.RENDER_modal <- shiny::reactive({ dt <- gseatable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R index b07d630a5..0d6285c4c 100644 --- a/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R +++ b/components/board.enrichment/R/enrichment_table_genes_in_geneset_ui.R @@ -76,7 +76,7 @@ enrichment_table_genes_in_geneset_server <- function(id, genetable.RENDER_modal <- shiny::reactive({ dt <- genetable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R index 3b3278481..a441733d2 100644 --- a/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R +++ b/components/board.enrichment/R/enrichment_table_gset_enrich_all_contrasts.R @@ -69,7 +69,7 @@ enrichment_table_gset_enrich_all_contrasts_server <- function(id, fctable.RENDER_modal <- shiny::reactive({ dt <- fctable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R index 85c95ad64..8a07205a5 100644 --- a/components/board.enrichment/R/enrichment_table_n_sig_gsets.R +++ b/components/board.enrichment/R/enrichment_table_n_sig_gsets.R @@ -95,7 +95,7 @@ enrichment_table_n_sig_gsets_server <- function(id, FDRtable.RENDER_modal <- shiny::reactive({ dt <- FDRtable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.enrichment/R/enrichment_ui.R b/components/board.enrichment/R/enrichment_ui.R index b9a9c0ed2..350d73278 100644 --- a/components/board.enrichment/R/enrichment_ui.R +++ b/components/board.enrichment/R/enrichment_ui.R @@ -61,7 +61,6 @@ EnrichmentUI <- function(id) { tabV <- "70vh" ## height of tables tabH <- 340 ## row height of panels tabH <- "80vh" ## height of tables - modal_heigh <- "70vh" tabs <- tagList( shiny::tabsetPanel( @@ -202,14 +201,14 @@ EnrichmentUI <- function(id) { enrichment_table_enrichment_analysis_ui( ns("gseatable"), width = c("100%", "90%"), - height = c(285, modal_heigh) + height = c(285, TABLE_HEIGHT_MODAL) ) ), div( class = "col-md-5", enrichment_table_genes_in_geneset_ui( ns("genetable"), - height = c(285, modal_heigh), + height = c(285, TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ) @@ -224,7 +223,7 @@ EnrichmentUI <- function(id) { ), enrichment_table_gset_enrich_all_contrasts_ui( ns("fctable"), - height = c(295, modal_heigh), + height = c(295, TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ), @@ -237,7 +236,7 @@ EnrichmentUI <- function(id) { ), enrichment_table_n_sig_gsets_ui( ns("FDRtable"), - height = c(295, modal_heigh), + height = c(295, TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ) diff --git a/components/board.expression/R/expression_table_FDRtable.R b/components/board.expression/R/expression_table_FDRtable.R index b500e860e..c1f3c76d0 100644 --- a/components/board.expression/R/expression_table_FDRtable.R +++ b/components/board.expression/R/expression_table_FDRtable.R @@ -110,7 +110,7 @@ expression_table_FDRtable_server <- function(id, FDRtable.RENDER_modal <- shiny::reactive({ dt <- FDRtable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.expression/R/expression_table_fctable.R b/components/board.expression/R/expression_table_fctable.R index 939ee828f..db0a72959 100644 --- a/components/board.expression/R/expression_table_fctable.R +++ b/components/board.expression/R/expression_table_fctable.R @@ -133,7 +133,7 @@ expression_table_fctable_server <- function(id, fctable.RENDER_modal <- shiny::reactive({ dt <- fctable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.expression/R/expression_table_genetable.R b/components/board.expression/R/expression_table_genetable.R index d1a04711e..b8ee7e806 100644 --- a/components/board.expression/R/expression_table_genetable.R +++ b/components/board.expression/R/expression_table_genetable.R @@ -117,7 +117,7 @@ expression_table_genetable_server <- function(id, table.RENDER_modal <- shiny::reactive({ dt <- table.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.expression/R/expression_table_gsettable.R b/components/board.expression/R/expression_table_gsettable.R index 6d5f4b46f..d75db3c31 100644 --- a/components/board.expression/R/expression_table_gsettable.R +++ b/components/board.expression/R/expression_table_gsettable.R @@ -75,7 +75,7 @@ expression_table_gsettable_server <- function(id, gsettable.RENDER_modal <- shiny::reactive({ dt <- gsettable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index a8f86db43..3f2bbca71 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -64,7 +64,6 @@ ExpressionUI <- function(id) { fullH <- 800 ## full height of page rowH <- 340 ## full height of page imgH <- 340 ## height of images - modal_heigh <- "70vh" div( boardHeader(title = "Differential expression", info_link = ns("gx_info")), @@ -82,7 +81,7 @@ ExpressionUI <- function(id) { class = "col-md-3", expression_plot_volcano_ui(ns("plots_volcano"), label = "a", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", imgH) ), ), @@ -91,7 +90,7 @@ ExpressionUI <- function(id) { expression_plot_maplot_ui( id = ns("plots_maplot"), label = "b", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", imgH) ), ), @@ -100,7 +99,7 @@ ExpressionUI <- function(id) { expression_plot_barplot_ui( id = ns("plots_barplot"), label = "c", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", imgH) ), ), @@ -109,7 +108,7 @@ ExpressionUI <- function(id) { expression_plot_topfoldchange_ui( id = ns("plots_topfoldchange"), label = "d", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", imgH) ), ) @@ -126,7 +125,7 @@ ExpressionUI <- function(id) { expression_plot_topgenes_ui( id = ns("topgenes"), label = "a", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", 1600) ), shiny::br(), @@ -139,7 +138,7 @@ ExpressionUI <- function(id) { "Volcano (all)", expression_plot_volcanoAll_ui(ns("volcanoAll"), label = "a", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", 1600) ), shiny::br(), @@ -154,7 +153,7 @@ ExpressionUI <- function(id) { expression_plot_volcanoMethods_ui( id = ns("volcanoMethods"), label = "a", - height = c(imgH, modal_heigh), + height = c(imgH, TABLE_HEIGHT_MODAL), width = c("auto", 1600) ), shiny::br(), @@ -183,7 +182,7 @@ ExpressionUI <- function(id) { expression_table_genetable_ui( ns("genetable"), width = c("100%", "90%"), - height = c("300px", modal_heigh) + height = c("300px", TABLE_HEIGHT_MODAL) ) ), div( @@ -191,7 +190,7 @@ ExpressionUI <- function(id) { expression_table_gsettable_ui( ns("gsettable"), width = c("100%", "90%"), - height = c("300px", modal_heigh) + height = c("300px", TABLE_HEIGHT_MODAL) ) ) ) @@ -204,7 +203,7 @@ ExpressionUI <- function(id) { expression_table_fctable_ui( ns("fctable"), width = c("100%", "90%"), - height = c("300px", modal_heigh) + height = c("300px", TABLE_HEIGHT_MODAL) ) ), shiny::tabPanel( @@ -215,7 +214,7 @@ ExpressionUI <- function(id) { expression_table_FDRtable_ui( ns("FDRtable"), width = c("100%", "90%"), - height = c("300px", modal_heigh) + height = c("300px", TABLE_HEIGHT_MODAL) ) ) ) diff --git a/components/board.featuremap/R/featuremap_plot_table_gene_map.R b/components/board.featuremap/R/featuremap_plot_table_gene_map.R index 7d41505fe..32bfa4d6a 100644 --- a/components/board.featuremap/R/featuremap_plot_table_gene_map.R +++ b/components/board.featuremap/R/featuremap_plot_table_gene_map.R @@ -45,7 +45,7 @@ featuremap_plot_gene_map_ui <- function(id, label = "", height = c(600, 800)) { TableModuleUI( ns("datasets"), info.text = info_text_table, - height = c(280, 750), + height = c(280, TABLE_HEIGHT_MODAL), width = c("auto", "90%"), title = "Gene table", label = "c" @@ -219,9 +219,16 @@ featuremap_plot_gene_map_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) + geneTable.RENDER_modal <- shiny::reactive({ + dt <- geneTable.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + TableModuleServer( "datasets", func = geneTable.RENDER, + func2 = geneTable.RENDER_modal, selector = "none" ) }) diff --git a/components/board.featuremap/R/featuremap_plot_table_geneset_map.R b/components/board.featuremap/R/featuremap_plot_table_geneset_map.R index fd4f83f5e..6ddf5c78a 100644 --- a/components/board.featuremap/R/featuremap_plot_table_geneset_map.R +++ b/components/board.featuremap/R/featuremap_plot_table_geneset_map.R @@ -43,7 +43,7 @@ featuremap_plot_table_geneset_map_ui <- function(id, label = "", height = c(600, TableModuleUI( ns("datasets"), info.text = info_text_table, - height = c(280, 750), + height = c(280, TABLE_HEIGHT_MODAL), width = c("auto", "90%"), title = "Geneset table", label = "c" @@ -208,9 +208,16 @@ featuremap_plot_table_geneset_map_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) + gsetTable.RENDER_modal <- shiny::reactive({ + dt <- gsetTable.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + TableModuleServer( "datasets", func = gsetTable.RENDER, + func2 = gsetTable.RENDER_modal, selector = "none" ) }) diff --git a/components/board.functional/R/functional_table_go_table.R b/components/board.functional/R/functional_table_go_table.R index 791033db7..0503c66e0 100644 --- a/components/board.functional/R/functional_table_go_table.R +++ b/components/board.functional/R/functional_table_go_table.R @@ -111,7 +111,7 @@ functional_table_go_table_server <- function(id, table_RENDER_modal <- shiny::reactive({ dt <- table_RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.functional/R/functional_table_kegg_table.R b/components/board.functional/R/functional_table_kegg_table.R index 0396150ca..583dfcfb3 100644 --- a/components/board.functional/R/functional_table_kegg_table.R +++ b/components/board.functional/R/functional_table_kegg_table.R @@ -96,9 +96,16 @@ functional_table_kegg_table_server <- function(id, ) } + table_RENDER_modal <- shiny::reactive({ + dt <- table_RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + my_table <- TableModuleServer( "datasets", func = table_RENDER, + func2 = table_RENDER_modal, selector = "none" ) diff --git a/components/board.functional/R/functional_ui.R b/components/board.functional/R/functional_ui.R index abd9936ef..5ec0ff683 100644 --- a/components/board.functional/R/functional_ui.R +++ b/components/board.functional/R/functional_ui.R @@ -53,7 +53,7 @@ FunctionalUI <- function(id) { class = "col-md-6", functional_table_kegg_table_ui( ns("kegg_table"), - height = c(270, 700), + height = c(270, TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ) @@ -78,7 +78,7 @@ FunctionalUI <- function(id) { label = "a"), functional_table_go_table_ui( ns("GO_table"), - height = c("20vh", "70vh"), + height = c("20vh", TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ), diff --git a/components/board.intersection/R/intersection_plot_table_venn_diagram.R b/components/board.intersection/R/intersection_plot_table_venn_diagram.R index 771cc5569..1cc824535 100644 --- a/components/board.intersection/R/intersection_plot_table_venn_diagram.R +++ b/components/board.intersection/R/intersection_plot_table_venn_diagram.R @@ -51,7 +51,7 @@ intersection_plot_venn_diagram_ui <- function(id, label = "", height = c(600, 80 ns("datasets"), info.text = info_text.table, options = venntable_opts, - height = c(260, 750), + height = c(260, TABLE_HEIGHT_MODAL), width = c("auto", 1200), title = "Leading-edge table", label = "e" @@ -375,7 +375,7 @@ intersection_plot_venn_diagram_server <- function(id, venntable.RENDER2 <- shiny::reactive({ dt <- venntable.RENDER() - dt$x$options$scrollY <- 500 + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.signature/R/signature_table_enrich_by_contrasts.R b/components/board.signature/R/signature_table_enrich_by_contrasts.R index 75ad81d47..a98035a50 100644 --- a/components/board.signature/R/signature_table_enrich_by_contrasts.R +++ b/components/board.signature/R/signature_table_enrich_by_contrasts.R @@ -65,7 +65,7 @@ signature_table_enrich_by_contrasts_server <- function(id, enrichmentContrastTable.RENDER_render <- shiny::reactive({ dt <- enrichmentContrastTable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.signature/R/signature_table_genes_in_signature.R b/components/board.signature/R/signature_table_genes_in_signature.R index ad1548f7e..0bb07fd5c 100644 --- a/components/board.signature/R/signature_table_genes_in_signature.R +++ b/components/board.signature/R/signature_table_genes_in_signature.R @@ -60,7 +60,7 @@ signature_table_genes_in_signature_server <- function(id, enrichmentGeneTable.RENDER_modal <- shiny::reactive({ dt <- enrichmentGeneTable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.signature/R/signature_table_overlap.R b/components/board.signature/R/signature_table_overlap.R index 5ad9a5be7..c7b3c2cb3 100644 --- a/components/board.signature/R/signature_table_overlap.R +++ b/components/board.signature/R/signature_table_overlap.R @@ -56,7 +56,7 @@ signature_table_overlap_server <- function(id, overlapTable.RENDER_modal <- shiny::reactive({ dt <- overlapTable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.signature/R/signature_ui.R b/components/board.signature/R/signature_ui.R index 15cc7f151..4f30b8b0e 100644 --- a/components/board.signature/R/signature_ui.R +++ b/components/board.signature/R/signature_ui.R @@ -72,7 +72,6 @@ SignatureUI <- function(id) { fullH <- 800 ## full height of page tabH <- "70vh" - modal_heigh <- "70vh" tabs <- div( class = "row", @@ -118,7 +117,7 @@ SignatureUI <- function(id) { shiny::br(), signature_table_overlap_ui( ns("overlapTable"), - height = c(0.4 * fullH, modal_heigh), + height = c(0.4 * fullH, TABLE_HEIGHT_MODAL), width = c("auto", "90%") ), shiny::br(), @@ -154,13 +153,13 @@ SignatureUI <- function(id) { "Enrichment table", signature_table_enrich_by_contrasts_ui( ns("enrichmentContrastTable"), - height = c(230, modal_heigh), + height = c(230, TABLE_HEIGHT_MODAL), width = c("auto", "90%") ), shiny::br(), signature_table_genes_in_signature_ui( ns("enrichmentGeneTable"), - height = c(360, modal_heigh), + height = c(360, TABLE_HEIGHT_MODAL), width = c("auto", "90%") ), shiny::br(), diff --git a/components/board.wgcna/R/wgcna_table_enrichment.R b/components/board.wgcna/R/wgcna_table_enrichment.R index 04f0e9b6a..0d128ad28 100644 --- a/components/board.wgcna/R/wgcna_table_enrichment.R +++ b/components/board.wgcna/R/wgcna_table_enrichment.R @@ -44,9 +44,16 @@ wgcna_table_enrichment_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) + enrichTable.RENDER_modal <- shiny::reactive({ + dt <- enrichTable.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + enrichTable_module <- TableModuleServer( "datasets", func = enrichTable.RENDER, + func2 = enrichTable.RENDER_modal, selector = "none" ) diff --git a/components/board.wgcna/R/wgcna_table_genes.R b/components/board.wgcna/R/wgcna_table_genes.R index d8f812239..26e222534 100644 --- a/components/board.wgcna/R/wgcna_table_genes.R +++ b/components/board.wgcna/R/wgcna_table_genes.R @@ -55,9 +55,16 @@ wgcna_table_genes_server <- function(id, DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") }) + geneTable.RENDER_modal <- shiny::reactive({ + dt <- geneTable.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + geneTable_module <- TableModuleServer( "datasets", func = geneTable.RENDER, + func2 = geneTable.RENDER_modal, selector = "none" ) diff --git a/components/board.wgcna/R/wgcna_ui.R b/components/board.wgcna/R/wgcna_ui.R index f5c2da375..16c2f2f27 100644 --- a/components/board.wgcna/R/wgcna_ui.R +++ b/components/board.wgcna/R/wgcna_ui.R @@ -146,7 +146,7 @@ WgcnaUI <- function(id) { class = "col-md-4", wgcna_table_genes_ui( ns("geneTable"), - height = c(250, 650), + height = c(250, TABLE_HEIGHT_MODAL), width = c("auto", "90%") ) ), @@ -154,7 +154,7 @@ WgcnaUI <- function(id) { class = "col-md-8", wgcna_table_enrichment_ui( ns("enrichTable"), - height = c(250, 650), + height = c(250, TABLE_HEIGHT_MODAL), width = c("auto", "90%") ) ) diff --git a/components/board.wordcloud/R/wordcloud_table_enrichment.R b/components/board.wordcloud/R/wordcloud_table_enrichment.R index 05c3fa46f..a83a39d02 100644 --- a/components/board.wordcloud/R/wordcloud_table_enrichment.R +++ b/components/board.wordcloud/R/wordcloud_table_enrichment.R @@ -55,7 +55,7 @@ wordcloud_table_enrichment_server <- function(id, wordcloud_enrichmentTable.RENDER_modal <- shiny::reactive({ dt <- wordcloud_enrichmentTable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.wordcloud/R/wordcloud_table_leading_edge.R b/components/board.wordcloud/R/wordcloud_table_leading_edge.R index 822584ef6..6cebac9c5 100644 --- a/components/board.wordcloud/R/wordcloud_table_leading_edge.R +++ b/components/board.wordcloud/R/wordcloud_table_leading_edge.R @@ -69,7 +69,7 @@ wordcloud_table_leading_edge_server <- function(id, wordcloud_leadingEdgeTable.RENDER_modal <- shiny::reactive({ dt <- wordcloud_leadingEdgeTable.RENDER() - dt$x$options$scrollY <- "55vh" + dt$x$options$scrollY <- SCROLLY_MODAL dt }) diff --git a/components/board.wordcloud/R/wordcloud_ui.R b/components/board.wordcloud/R/wordcloud_ui.R index 8234bbc07..346007c99 100644 --- a/components/board.wordcloud/R/wordcloud_ui.R +++ b/components/board.wordcloud/R/wordcloud_ui.R @@ -19,7 +19,6 @@ WordCloudUI <- function(id) { rowH <- 660 ## row height of panel tabH <- 200 ## row height of panel tabH <- "70vh" ## row height of panel - modal_heigh <- "70vh" ns <- shiny::NS(id) ## namespace shiny::tabsetPanel( @@ -47,7 +46,7 @@ WordCloudUI <- function(id) { class = "col-md-6", wordcloud_table_enrichment_ui( ns("wordcloud_enrichmentTable"), - height = c("35vh", modal_heigh), + height = c("35vh", TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ), @@ -55,7 +54,7 @@ WordCloudUI <- function(id) { class = "col-md-6", wordcloud_table_leading_edge_ui( ns("wordcloud_leadingEdgeTable"), - height = c("35vh", modal_heigh), + height = c("35vh", TABLE_HEIGHT_MODAL), width = c("100%", "90%") ) ) From e8e02ab1daac3536e8b5c61c08ea8bcda7022b95 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 16:50:05 +0100 Subject: [PATCH 35/49] `TableModule` implemented on `board.connectivity` --- .../R/connectivity_server.R | 157 ++---------------- .../R/connectivity_table_similarity_scores.R | 95 +++++++++++ .../R/connectivity_table_similarity_scores2.R | 87 ++++++++++ .../board.connectivity/R/connectivity_ui.R | 16 +- 4 files changed, 208 insertions(+), 147 deletions(-) create mode 100644 components/board.connectivity/R/connectivity_table_similarity_scores.R create mode 100644 components/board.connectivity/R/connectivity_table_similarity_scores2.R diff --git a/components/board.connectivity/R/connectivity_server.R b/components/board.connectivity/R/connectivity_server.R index 49d6b9052..2219c9b87 100644 --- a/components/board.connectivity/R/connectivity_server.R +++ b/components/board.connectivity/R/connectivity_server.R @@ -272,6 +272,7 @@ ConnectivityBoard <- function(id, inputData) { } getConnectivityScores <- shiny::reactive({ + # browser() ngs <- inputData() shiny::req(ngs, input$cmap_contrast) shiny::validate(shiny::need("connectivity" %in% names(ngs), "no 'connectivity' in object.")) @@ -384,87 +385,6 @@ ConnectivityBoard <- function(id, inputData) { PERTINFO <- read.csv(pert_info.file, sep = "\t", row.names = 1) } - connectivityScoreTable.RENDER <- shiny::reactive({ - df <- getConnectivityScores() - if (is.null(df)) { - return(NULL) - } - - kk <- c("pathway", "score", "rho", "NES", "padj", "leadingEdge") - kk <- intersect(kk, colnames(df)) - df <- df[, kk] - df <- df[abs(df$score) > 0, , drop = FALSE] - - ## --------- temporarily add LINCS descriptive name !!!!!!!!!!!!!! ----------------- - if (DEV && input$cmap_sigdb == "sigdb-lincs.h5" && !is.null(PERTINFO)) { - dd <- sub("\\|.*", "", df$pathway) - pert_iname <- PERTINFO[match(dd, rownames(PERTINFO)), "pert_iname"] - df$pathway <- paste0(df$pathway, " (", pert_iname, ")") - } - ## ---------- temporarily add LINCS descriptive name !!!!!!!!!!!!!! ----------------- - - ## colnames(df) <- sub("padj","NES.q",colnames(df)) - df$leadingEdge <- shortstring(sapply(df$leadingEdge, paste, collapse = ","), 40) - df$pathway <- shortstring(df$pathway, 100) - df$leadingEdge <- NULL - - colnames(df) <- sub("pathway", "dataset/contrast", colnames(df)) - score.col <- which(colnames(df) == "score") - numcols <- c("score", "pval", "padj", "NES.q", "ES", "NES", "rho", "R2") - numcols <- intersect(numcols, colnames(df)) - - DT::datatable(df, - rownames = FALSE, - class = "compact cell-border stripe hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = 1), - fillContainer = TRUE, - options = list( - dom = "lfrtip", - pageLength = 99999, - scrollX = TRUE, - scrollY = tabH, - scroller = TRUE, deferRender = TRUE - ) ## end of options.list - ) %>% - DT::formatSignif(numcols, 3) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatStyle("score", - background = color_from_middle( - df[, "score"], "lightblue", "#f5aeae" - ), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) - }) - - connectivityScoreTable.RENDER2 <- shiny::reactive({ - connectivityScoreTable.RENDER() %>% - DT::formatStyle(0, target = "row", fontSize = "13px", lineHeight = "90%") - }) - - - connectivityScoreTable_info <- "Similarity scores. Normalized enrichment scores (NES) and Pearson correlation (rho) of reference profiles with respect to the currently selected contrast. The top 100 up/down genes are considered for the calculation of rho or NES. The score is calculated as rho^2*NES. " - - connectivityScoreTable_opts <- shiny::tagList( - shiny::selectInput(ns("connectivityScoreTable_qsig"), "threshold (padj)", - c(0.01, 0.05, 0.2, 1), - selected = 1 - ) - ) - - connectivityScoreTable <- shiny::callModule( - tableModule, - id = "connectivityScoreTable", - func = connectivityScoreTable.RENDER, - info.text = connectivityScoreTable_info, - options = connectivityScoreTable_opts, - info.width = "300px", - title = "Similarity scores", - height = c(260, 720), width = c("auto", 1280) - ) - getTopProfiles <- shiny::reactive({ ## Get profiles of top-enriched contrasts (not all genes...) ## @@ -507,6 +427,12 @@ ConnectivityBoard <- function(id, inputData) { watermark = WATERMARK ) + connectivityScoreTable <- connectivity_table_similarity_scores_server( + "connectivityScoreTable", + getConnectivityScores = getConnectivityScores, + cmap_sigdb = shiny::reactive(input$cmap_sigdb) + ) + ## ================================================================================ ## Cumulative FC barplot @@ -546,6 +472,11 @@ ConnectivityBoard <- function(id, inputData) { getEnrichmentMatrix ) + connectivityScoreTable2 <- connectivity_table_similarity_scores2_server( + "connectivityScoreTable2", + getConnectivityScores = getConnectivityScores + ) + ## ------------------------------------------------------------------------------- ## Leading-edge graph ## ------------------------------------------------------------------------------- @@ -594,70 +525,6 @@ ConnectivityBoard <- function(id, inputData) { watermark = WATERMARK ) - connectivityScoreTable2.RENDER <- shiny::reactive({ - df <- getConnectivityScores() - if (is.null(df)) { - return(NULL) - } - - kk <- c("pathway", "score", "rho", "NES", "padj", "size", "leadingEdge") - kk <- c("score", "pathway", "rho", "NES", "padj") - kk <- intersect(kk, colnames(df)) - df <- df[, kk] - df <- df[abs(df$score) > 0, , drop = FALSE] - - df$pathway <- shortstring(df$pathway, 110) - df$leadingEdge <- NULL - - colnames(df) <- sub("pathway", "dataset/contrast", colnames(df)) - score.col <- which(colnames(df) == "score") - numcols <- c("score", "pval", "padj", "NES.q", "ES", "NES", "rho", "R2") - numcols <- intersect(numcols, colnames(df)) - - DT::datatable(df, - rownames = FALSE, - class = "compact cell-border stripe hover", - extensions = c("Scroller"), - selection = list(mode = "single", target = "row", selected = 1), - fillContainer = TRUE, - options = list( - dom = "lfrtip", - pageLength = 99999, - scrollX = TRUE, - scrollY = "100vh", - scroller = TRUE, deferRender = TRUE - ) ## end of options.list - ) %>% - DT::formatSignif(numcols, 3) %>% - DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% - DT::formatStyle("score", - background = color_from_middle( - df[, "score"], "lightblue", "#f5aeae" - ), - backgroundSize = "98% 88%", - backgroundRepeat = "no-repeat", - backgroundPosition = "center" - ) - }) - - connectivityScoreTable2_opts <- shiny::tagList( - shiny::selectInput(ns("connectivityScoreTable2_qsig"), "threshold (padj)", - c(0.01, 0.05, 0.2, 1), - selected = 1 - ) - ) - - connectivityScoreTable2 <- shiny::callModule( - tableModule, - id = "connectivityScoreTable2", label = "b", - func = connectivityScoreTable2.RENDER, - info.text = connectivityScoreTable_info, - options = connectivityScoreTable2_opts, - info.width = "150px", - title = "Similarity scores", - height = c(660, 700), width = c("auto", 1280) - ) - ## ============================================================================= ## CONNECTIVITY HEATMAP ## ============================================================================= diff --git a/components/board.connectivity/R/connectivity_table_similarity_scores.R b/components/board.connectivity/R/connectivity_table_similarity_scores.R new file mode 100644 index 000000000..5af0ccde8 --- /dev/null +++ b/components/board.connectivity/R/connectivity_table_similarity_scores.R @@ -0,0 +1,95 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +connectivity_table_similarity_scores_ui <- function(id, width, height) { + ns <- shiny::NS(id) + + connectivityScoreTable_info <- "Similarity scores. Normalized enrichment scores (NES) and Pearson correlation (rho) of reference profiles with respect to the currently selected contrast. The top 100 up/down genes are considered for the calculation of rho or NES. The score is calculated as rho^2*NES. " + + TableModuleUI( + ns("datasets"), + info.text = connectivityScoreTable_info, + width = width, + height = height, + title = "Similarity scores", + label = "b" + ) + +} + +connectivity_table_similarity_scores_server <- function(id, + getConnectivityScores, + cmap_sigdb) { + moduleServer(id, function(input, output, session) { + + connectivityScoreTable.RENDER <- shiny::reactive({ + df <- getConnectivityScores() + shiny::req(df) + + kk <- c("pathway", "score", "rho", "NES", "padj", "leadingEdge") + kk <- intersect(kk, colnames(df)) + df <- df[, kk] + df <- df[abs(df$score) > 0, , drop = FALSE] + + ## --------- temporarily add LINCS descriptive name !!!!!!!!!!!!!! ----------------- + if (DEV && cmap_sigdb() == "sigdb-lincs.h5" && !is.null(PERTINFO)) { + dd <- sub("\\|.*", "", df$pathway) + pert_iname <- PERTINFO[match(dd, rownames(PERTINFO)), "pert_iname"] + df$pathway <- paste0(df$pathway, " (", pert_iname, ")") + } + ## ---------- temporarily add LINCS descriptive name !!!!!!!!!!!!!! ----------------- + + ## colnames(df) <- sub("padj","NES.q",colnames(df)) + df$leadingEdge <- shortstring(sapply(df$leadingEdge, paste, collapse = ","), 40) + df$pathway <- shortstring(df$pathway, 100) + df$leadingEdge <- NULL + + colnames(df) <- sub("pathway", "dataset/contrast", colnames(df)) + score.col <- which(colnames(df) == "score") + numcols <- c("score", "pval", "padj", "NES.q", "ES", "NES", "rho", "R2") + numcols <- intersect(numcols, colnames(df)) + + DT::datatable(df, + rownames = FALSE, + class = "compact cell-border stripe hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = 1), + fillContainer = TRUE, + options = list( + dom = "lfrtip", + pageLength = 99999, + scrollX = TRUE, + scrollY = "25vh", + scroller = TRUE, deferRender = TRUE + ) ## end of options.list + ) %>% + DT::formatSignif(numcols, 3) %>% + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatStyle("score", + background = color_from_middle( + df[, "score"], "lightblue", "#f5aeae" + ), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + }) + + connectivityScoreTable.RENDER_modal <- shiny::reactive({ + dt <- connectivityScoreTable.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + + connectivityScoreTable <- TableModuleServer( + "datasets", + func = connectivityScoreTable.RENDER, + func2 = connectivityScoreTable.RENDER_modal, + selector = "single" + ) + + return(connectivityScoreTable) + }) +} diff --git a/components/board.connectivity/R/connectivity_table_similarity_scores2.R b/components/board.connectivity/R/connectivity_table_similarity_scores2.R new file mode 100644 index 000000000..116779caa --- /dev/null +++ b/components/board.connectivity/R/connectivity_table_similarity_scores2.R @@ -0,0 +1,87 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +connectivity_table_similarity_scores2_ui <- function(id, width, height) { + ns <- shiny::NS(id) + + connectivityScoreTable_info <- "Similarity scores. Normalized enrichment scores (NES) and Pearson correlation (rho) of reference profiles with respect to the currently selected contrast. The top 100 up/down genes are considered for the calculation of rho or NES. The score is calculated as rho^2*NES. " + + TableModuleUI( + ns("datasets"), + info.text = connectivityScoreTable_info, + width = width, + height = height, + title = "Similarity scores", + label = "b" + ) + +} + +connectivity_table_similarity_scores2_server <- function(id, + getConnectivityScores) { + moduleServer(id, function(input, output, session) { + + connectivityScoreTable2.RENDER <- shiny::reactive({ + df <- getConnectivityScores() + if (is.null(df)) { + return(NULL) + } + + kk <- c("pathway", "score", "rho", "NES", "padj", "size", "leadingEdge") + kk <- c("score", "pathway", "rho", "NES", "padj") + kk <- intersect(kk, colnames(df)) + df <- df[, kk] + df <- df[abs(df$score) > 0, , drop = FALSE] + + df$pathway <- shortstring(df$pathway, 110) + df$leadingEdge <- NULL + + colnames(df) <- sub("pathway", "dataset/contrast", colnames(df)) + score.col <- which(colnames(df) == "score") + numcols <- c("score", "pval", "padj", "NES.q", "ES", "NES", "rho", "R2") + numcols <- intersect(numcols, colnames(df)) + + DT::datatable(df, + rownames = FALSE, + class = "compact cell-border stripe hover", + extensions = c("Scroller"), + selection = list(mode = "single", target = "row", selected = 1), + fillContainer = TRUE, + options = list( + dom = "lfrtip", + pageLength = 99999, + scrollX = TRUE, + scrollY = "55vh", + scroller = TRUE, deferRender = TRUE + ) ## end of options.list + ) %>% + DT::formatSignif(numcols, 3) %>% + DT::formatStyle(0, target = "row", fontSize = "11px", lineHeight = "70%") %>% + DT::formatStyle("score", + background = color_from_middle( + df[, "score"], "lightblue", "#f5aeae" + ), + backgroundSize = "98% 88%", + backgroundRepeat = "no-repeat", + backgroundPosition = "center" + ) + }) + + connectivityScoreTable2.RENDER_modal <- shiny::reactive({ + dt <- connectivityScoreTable2.RENDER() + dt$x$options$scrollY <- SCROLLY_MODAL + dt + }) + + connectivityScoreTable <- TableModuleServer( + "datasets", + func = connectivityScoreTable2.RENDER, + func2 = connectivityScoreTable2.RENDER_modal, + selector = "none" + ) + + return(connectivityScoreTable) + }) +} diff --git a/components/board.connectivity/R/connectivity_ui.R b/components/board.connectivity/R/connectivity_ui.R index 00ed28037..31ad51706 100644 --- a/components/board.connectivity/R/connectivity_ui.R +++ b/components/board.connectivity/R/connectivity_ui.R @@ -22,6 +22,10 @@ ConnectivityInputs <- function(id) { "Select reference signature database.", placement = "right", options = list(container = "body") ), + shiny::selectInput(ns("connectivityScoreTable_qsig"), "threshold (padj)", + c(0.01, 0.05, 0.2, 1), + selected = 1 + ), shiny::br(), withTooltip(shiny::actionLink(ns("cmap_options"), "Options", icon = icon("cog", lib = "glyphicon")), "Toggle advanced options.", @@ -61,7 +65,11 @@ ConnectivityUI <- function(id) { ), div( class = "col-md-6", - tableWidget(ns("connectivityScoreTable")) + connectivity_table_similarity_scores_ui( + ns("connectivityScoreTable"), + height = c(260, TABLE_HEIGHT_MODAL), + width = c("auto", "90%") + ) ) ), connectivity_plot_cmapPairsPlot_ui(ns("cmapPairsPlot"),label = "c"), @@ -138,7 +146,11 @@ ConnectivityUI <- function(id) { ), div( class = "col-md-6", - tableWidget(ns("connectivityScoreTable2")) + connectivity_table_similarity_scores2_ui( + ns("connectivityScoreTable2"), + height = c(660, TABLE_HEIGHT_MODAL), + width = c("auto", "90%") + ) ) ), tags$div( From b550284a3067e4cb2d62d664da930db814a5f943 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 16:50:19 +0100 Subject: [PATCH 36/49] fix: modal output --- .../board.connectivity/R/connectivity_plot_cmap_FCFCplots.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/components/board.connectivity/R/connectivity_plot_cmap_FCFCplots.R b/components/board.connectivity/R/connectivity_plot_cmap_FCFCplots.R index 7de6bf2f2..46f8b8e9f 100644 --- a/components/board.connectivity/R/connectivity_plot_cmap_FCFCplots.R +++ b/components/board.connectivity/R/connectivity_plot_cmap_FCFCplots.R @@ -158,6 +158,8 @@ connectivity_plot_cmap_FCFCplots_server <- function(id, df <- getConnectivityScores() cmap_FCFCenplot(fc, F, mfplots, ylab, df) } + p <- grDevices::recordPlot() + p }) PlotModuleServer( From 0659d5626fb2eeec55970f5a31db4b1084332aaf Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 16:50:34 +0100 Subject: [PATCH 37/49] feat: display message when no data --- .../R/connectivity_plot_cmapPairsPlot.R | 17 +++++++++++++++-- 1 file changed, 15 insertions(+), 2 deletions(-) diff --git a/components/board.connectivity/R/connectivity_plot_cmapPairsPlot.R b/components/board.connectivity/R/connectivity_plot_cmapPairsPlot.R index 993494018..7117daa37 100644 --- a/components/board.connectivity/R/connectivity_plot_cmapPairsPlot.R +++ b/components/board.connectivity/R/connectivity_plot_cmapPairsPlot.R @@ -99,7 +99,21 @@ connectivity_plot_cmapPairsPlot_server <- function(id, shiny::req(sigdb) ct2 <- all.ct[1] sel.row <- connectivityScoreTable$rows_selected() - shiny::req(sel.row) + if(is.null(sel.row)){ + return( + plotly::plotly_empty(type = "scatter", mode = "markers") %>% + plotly::config( + displayModeBar = FALSE + ) %>% + plotly::layout( + title = list( + text = "Select dataset/contrast", + yref = "paper", + y = 0.5 + ) + ) + ) + } df <- getConnectivityScores() df <- df[abs(df$score) > 0, , drop = FALSE] ct2 <- rownames(df)[sel.row] @@ -286,7 +300,6 @@ connectivity_plot_cmapPairsPlot_server <- function(id, "plot", plotlib = "plotly", func = plot_RENDER, - func2 = plot_RENDER, csvFunc = plot_data, pdf.width = 8, pdf.height = 8, res = 95, From 17bfebe65b1d2030d51fa4cb14a770f8b1e8ccd2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 16:54:17 +0100 Subject: [PATCH 38/49] fix: modal output --- .../R/connectivity_plot_connectivityHeatmap.R | 2 ++ 1 file changed, 2 insertions(+) diff --git a/components/board.connectivity/R/connectivity_plot_connectivityHeatmap.R b/components/board.connectivity/R/connectivity_plot_connectivityHeatmap.R index 4caef9a8f..5cc4636c7 100644 --- a/components/board.connectivity/R/connectivity_plot_connectivityHeatmap.R +++ b/components/board.connectivity/R/connectivity_plot_connectivityHeatmap.R @@ -111,6 +111,8 @@ connectivity_plot_connectivityHeatmap_server <- function(id, key.offset = c(0.90, 0.2), cexRow = 0.9, cexCol = 0.75 ) + p <- grDevices::recordPlot() + p }) PlotModuleServer( "plot", From b695aea5a9618b3fee90cd8c5d2c1711a2a6b909 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 17:06:18 +0100 Subject: [PATCH 39/49] remove code --- components/base/R/pgx-modules.R | 188 ------------------ .../R/wordcloud_table_enrichment.R | 1 - 2 files changed, 189 deletions(-) diff --git a/components/base/R/pgx-modules.R b/components/base/R/pgx-modules.R index d8714a909..fc2a60090 100644 --- a/components/base/R/pgx-modules.R +++ b/components/base/R/pgx-modules.R @@ -900,191 +900,3 @@ plotModule <- function(input, output, session, ) return(res) } - -##================================================================================ -##======================= TABLE MODULE =========================================== -##================================================================================ - - -# tableWidget <- function(id) { -# ns <- shiny::NS(id) -# shiny::uiOutput(ns("widget")) -# } -# -# tableModule <- function(input, output, session, -# func, func2=NULL, info.text="Info text", -# title=NULL, label="", server=TRUE, -# caption=NULL, caption2=caption, -# csvFunc=NULL, filename="data.csv", ##inputs=NULL, -# ##no.download = FALSE, just.info=FALSE, -# width=c("100%","100%"), height=c("auto","auto"), -# options = NULL, info.width="300px" -# ) -# { -# ##require(bsutils) -# ns <- session$ns -# -# if(any(class(caption)=="reactive")) { -# caption <- caption() -# } -# if(class(caption)=="character") { -# caption <- shiny::HTML(caption) -# } -# -# options.button <- "" -# if(!is.null(options) && length(options)>0) { -# options.button <- shinyWidgets::dropdownButton( -# options, -# ##shiny::br(), -# ##dload, -# circle = TRUE, size = "xs", ## status = "danger", -# ## icon = shiny::icon("gear"), -# icon = shiny::icon("bars"), -# width = "250px", -# inputId = ns("options"), -# tooltip = shinyWidgets::tooltipOptions(title = "Settings", placement = "right") -# ) -# } -# -# ##if(!is.null(label) && label!="") label <- paste0("(",label,")") -# label1 = shiny::HTML(paste0("",label,"")) -# title1 = title -# if(label!="") { -# title1 = shiny::HTML(paste0(title," (",label,")")) -# } -# -# zoom.button <- modalTrigger( -# ns("zoombutton"), -# ns("tablePopup"), -# icon("window-maximize"), -# class="btn-circle-xs" -# ) -# -# header <- shiny::fillRow( -# ##flex=c(NA,NA,NA,NA,1), -# flex=c(NA,1,NA,NA,NA,NA), -# label1, -# shiny::div(class='plotmodule-title', title=title, title1), -# shinyWidgets::dropdownButton( -# shiny::tags$p(shiny::HTML(info.text)), -# shiny::br(), -# circle = TRUE, size = "xs", ## status = "danger", -# icon = shiny::icon("info"), width = info.width, -# inputId = ns("info"), right=FALSE, -# tooltip = shinyWidgets::tooltipOptions(title = "Info", placement = "right") -# ), -# options.button, -# shiny::div(class='download-button', -# shinyWidgets::dropdownButton( -# shiny::downloadButton(ns("csv"), "CSV"), -# circle = TRUE, size = "xs", ## status = "danger", -# icon = shiny::icon("download"), width = "80px", right=FALSE, -# tooltip = shinyWidgets::tooltipOptions(title = "Download", -# placement = "right") -# )), -# ##withTooltip(zoom.button,"maximize table") -# zoom.button -# ) -# -# CSVFILE = paste0(gsub("file","data",tempfile()),".csv") -# CSVFILE -# -# ## render2 <- shiny::renderPlot({plot_array[[3]]()}, res=res) -# download.csv <- shiny::downloadHandler( -# filename = filename, -# content = function(file) { -# if(!is.null(csvFunc)) { -# dt <- csvFunc() -# } else { -# dt <- func()$x$data -# } -# ##write.csv(dt, file=CSVFILE, row.names=FALSE) -# ##file.copy(CSVFILE, file, overwrite=TRUE) -# write.csv(dt, file=file, row.names=FALSE) -# } -# ) -# output$csv <- download.csv -# -# if(is.null(func2)) func2 <- func -# if(length(height)==1) height <- c(height,height) -# if(length(width)==1) width <- c(width,width) -# ##ifnotchar.int <- function(s) ifelse(grepl("[%]$|auto|vmin|vh|vw|vmax",s),s,as.integer(s)) -# ifnotchar.int <- function(s) suppressWarnings( -# ifelse(!is.na(as.integer(s)), paste0(as.integer(s),"px"), s)) -# width.1 <- ifnotchar.int(width[1]) -# width.2 <- ifnotchar.int(width[2]) -# height.1 <- ifnotchar.int(height[1]) -# height.2 <- ifnotchar.int(height[2]) -# -# output$datatable <- DT::renderDT({ -# func() -# }) -# output$datatable2 <- DT::renderDT({ -# func2() -# }) -# -# output$popuptable <- shiny::renderUI({ -# if(any(class(caption2)=="reactive")) { -# caption2 <- caption2() -# } -# if(any(class(caption2)=="character")) { -# caption2 <- shiny::HTML(caption2) -# } -# shiny::tagList( -# shiny::div( caption2, class="caption2"), -# DT::DTOutput(ns("datatable2"), width=width.2, height=height.2) -# ) -# }) -# -# output$widget <- shiny::renderUI({ -# -# modaldialog.style <- paste0("#",ns("tablePopup")," .modal-dialog {width:",width.2,";}") -# modalbody.style <- paste0("#",ns("tablePopup")," .modal-body {min-height:",height.2,";}") -# modalfooter.none <- paste0("#",ns("tablePopup")," .modal-footer{display:none;}") -# div.caption <- NULL -# if(!is.null(caption)) div.caption <- shiny::div(caption, class="table-caption") -# -# div(class="tablewidget", -# shiny::fillCol( -# flex = c(NA,NA,1,NA), -# shiny::tags$head(shiny::tags$style(modaldialog.style)), -# shiny::tags$head(shiny::tags$style(modalbody.style)), -# shiny::tags$head(shiny::tags$style(modalfooter.none)), -# div(header, class="plotmodule-header"), -# div.caption, -# DT::DTOutput(ns("datatable"), width=width.1, height=height.1), -# shiny::div(class="popup-table", -# modalUI( -# id = ns("tablePopup"), -# title = title, -# size = "fullscreen", -# shiny::uiOutput(ns("popuptable")) -# )) -# )) -# }) -# -# module <- list( -# ##data = func, -# data = shiny::reactive(func()$x$data), -# rows_current = shiny::reactive(input$datatable_rows_current), -# rows_selected = shiny::reactive(input$datatable_rows_selected), -# rows_all = shiny::reactive(input$datatable_rows_all), -# rownames_current = shiny::reactive({ -# rns <- rownames(func()$x$data) -# if(is.null(rns)) rns <- 1:nrow(func()$x$data) -# rns[input$datatable_rows_current] -# }), -# rownames_selected = shiny::reactive({ -# rns <- rownames(func()$x$data) -# if(is.null(rns)) rns <- 1:nrow(func()$x$data) -# rns[input$datatable_rows_selected] -# }), -# rownames_all = shiny::reactive({ -# rns <- rownames(func()$x$data) -# if(is.null(rns)) rns <- 1:nrow(func()$x$data) -# rns[input$datatable_rows_all] -# }) -# ) -# return(module) -# } -# \ No newline at end of file diff --git a/components/board.wordcloud/R/wordcloud_table_enrichment.R b/components/board.wordcloud/R/wordcloud_table_enrichment.R index a83a39d02..e877566ba 100644 --- a/components/board.wordcloud/R/wordcloud_table_enrichment.R +++ b/components/board.wordcloud/R/wordcloud_table_enrichment.R @@ -17,7 +17,6 @@ wordcloud_table_enrichment_ui <- function(id, width, height) { label = "d" ) - # tableWidget(ns("wordcloud_enrichmentTable")) } wordcloud_table_enrichment_server <- function(id, From 42c259ecddd77452d7fa583420750e1382a1eeb0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 17:19:43 +0100 Subject: [PATCH 40/49] style: well bkg transparent --- scss/components/_all.scss | 1 + 1 file changed, 1 insertion(+) diff --git a/scss/components/_all.scss b/scss/components/_all.scss index c1629791c..c73f4b832 100644 --- a/scss/components/_all.scss +++ b/scss/components/_all.scss @@ -85,6 +85,7 @@ html { .well { font-size: 14px; line-height: 1.2em; + background: transparent; } .code { From 7e729518f3f6f6749e65d4eca13862c5a4b14b08 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 17:32:07 +0100 Subject: [PATCH 41/49] style: added spacing --- components/app/R/modules/ComputePgxModule.R | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/components/app/R/modules/ComputePgxModule.R b/components/app/R/modules/ComputePgxModule.R index 29cc1cb7e..8c6943cf4 100644 --- a/components/app/R/modules/ComputePgxModule.R +++ b/components/app/R/modules/ComputePgxModule.R @@ -127,7 +127,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta style = "width: 95%;", shiny::checkboxGroupInput( ns('filter_methods'), - shiny::h4('Feature filtering:'), + shiny::HTML('

Feature filtering:


'), choiceValues = c("only.hugo", "only.proteincoding", @@ -156,7 +156,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta style = "width: 95%;", shiny::checkboxGroupInput( ns('gene_methods'), - shiny::h4('Gene tests:'), + shiny::HTML('

Gene tests:


'), GENETEST.METHODS, selected = GENETEST.SELECTED ) @@ -165,7 +165,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta style = "width: 95%;", shiny::checkboxGroupInput( ns('gset_methods'), - shiny::h4('Enrichment methods:'), + shiny::HTML('

Enrichment methods:


'), GENESET.METHODS, selected = GENESET.SELECTED ), @@ -174,7 +174,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta style = "width: 95%;", shiny::checkboxGroupInput( ns('extra_methods'), - shiny::h4('Extra analysis:'), + shiny::HTML('

Extra analysis:


'), choiceValues = EXTRA.METHODS, choiceNames = EXTRA.NAMES, selected = EXTRA.SELECTED @@ -183,7 +183,7 @@ ComputePgxServer <- function(id, countsRT, samplesRT, contrastsRT, batchRT, meta shiny::wellPanel( shiny::checkboxGroupInput( ns('dev_options'), - shiny::h4('Developer options:'), + shiny::HTML('

Developer options:


'), choiceValues = DEV.METHODS, choiceNames = DEV.NAMES, selected = DEV.SELECTED From 6d8511e5fd4c1751a320ffae0daea894f65847f9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 22:57:43 +0100 Subject: [PATCH 42/49] style: increase margin-top --- components/app/R/modules/MakeContrastModule.R | 141 +++++++++--------- 1 file changed, 71 insertions(+), 70 deletions(-) diff --git a/components/app/R/modules/MakeContrastModule.R b/components/app/R/modules/MakeContrastModule.R index cbf8df4c8..96236b070 100644 --- a/components/app/R/modules/MakeContrastModule.R +++ b/components/app/R/modules/MakeContrastModule.R @@ -24,22 +24,22 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) shiny::moduleServer( id, - function(input, output, session) { - + function(input, output, session) { + message("[MakeContrastServer] moduleServer called...") ns <- session$ns rv <- shiny::reactiveValues(contr=NULL, pheno=NULL) - + ##updateSelectizeInput(session, "gene", choices=genes, server=TRUE) - + shiny::observe({ - rv$contr <- contrRT() + rv$contr <- contrRT() }) shiny::observe({ rv$pheno <- phenoRT() }) - + if(1) { shiny::observe({ message('[MakeContrast::observe::countsRT] reacted') @@ -49,20 +49,20 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) message('[observe::countsRT] nrow.counts = ',nrow(counts)) message('[observe::countsRT] ncol.counts = ',ncol(counts)) genes <- rownames(counts) - message('[observe::countsRT] len.genes = ', length(genes)) + message('[observe::countsRT] len.genes = ', length(genes)) message('[MakeContrast::observe::countsRT] updateSelectizeInput') shiny::updateSelectizeInput(session, "gene", choices=genes, server=TRUE) }) } - + shiny::observe({ shiny::req(phenoRT()) px <- colnames(phenoRT()) shiny::updateSelectInput(session, "pcaplot.colvar", choices=px) shiny::updateSelectInput(session, "strata", choices=c("",px)) }) - - + + output$UI <- shiny::renderUI({ ns <- session$ns @@ -70,7 +70,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) if(is.null(countsRT())) return(NULL) message('[MakeContrast::UI] called') - + genes <- sort(rownames(countsRT())) genes <- NULL phenotypes <- c(sort(unique(colnames(phenoRT()))),"","") @@ -90,7 +90,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) flex = c(3,0.06,1.0), shiny::fillCol( flex = c(NA,NA,1.0), - shiny::h4("Create comparisons"), + shiny::h4("Create comparisons"), ##p(help_text), shiny::fillRow( flex = c(1,4), @@ -104,7 +104,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) ), shiny::conditionalPanel( "input.param == ''", ns=ns, - ##tipifyL( + ##tipifyL( shiny::selectizeInput(ns("gene"), "Gene:", choices=genes, multiple=FALSE), ##"Select gene to divide your samples into high and low expression of that gene.") @@ -117,7 +117,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) shiny::br(), ## tipifyL( shiny::actionButton(ns("addcontrast"), - "add comparison", + "add comparison", icon=icon("plus"), class = "btn-outline-primary"), ##"After creating the groups, press this button to add the comparison to the table."a), @@ -140,34 +140,35 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) flex = c(NA,0.05,NA,NA,1), withTooltip( shiny::actionButton(ns("autocontrast"), - "add auto-contrasts", + "add auto-contrasts", icon=icon("plus"), class="small-button btn-outline-primary"), "If you are feeling lucky, try this to automatically create contrasts.", - placement="top", options = list(container = "body") + placement="top", options = list(container = "body") ), shiny::br(), shiny::div( shiny::HTML("Strata:"), style="padding: 4px 4px;"), shiny::selectInput(ns("strata"), NULL, choices=NULL, width="120px"), shiny::br() ), + # shiny::br(), ##shiny::tags$head(shiny::tags$style("table.dataTable.compact tbody th, table.dataTable.compact tbody td {padding: 0px 10px;}")), - ## this.style(ns("contrastTable"), "table.dataTable.compact tbody th, table.dataTable.compact tbody td {padding: 0px 10px;}"), + ## this.style(ns("contrastTable"), "table.dataTable.compact tbody th, table.dataTable.compact tbody td {padding: 0px 10px;}"), shiny::div(DT::dataTableOutput(ns("contrastTable")), - style="font-size:13px; height: 300px; margin-top: 10px;overflow-y: scroll;") + style="font-size:13px; height: 300px; margin-top: 20px;overflow-y: scroll;") ) - + }) shiny::outputOptions(output, "UI", suspendWhenHidden=FALSE) ## important!!! - + sel.conditions <- shiny::reactive({ message("[MakeContrastServer] sel.conditions : reacted") - shiny::req(phenoRT(),countsRT()) + shiny::req(phenoRT(),countsRT()) df <- phenoRT() message("[MakeContrastServer] sel.conditions : dim.df = ", paste(dim(df),collapse='x')) - - if("" %in% input$param) { + + if("" %in% input$param) { df$"" <- rownames(df) } if("" %in% input$param) { @@ -188,16 +189,16 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) for(i in ii) { x = df[,i] df[,i] <- c("low","high")[1 + 1*(x >= mean(x,na.rm=TRUE))] - } + } } - + pp <- intersect(input$param, colnames(df)) ss <- colnames(countsRT()) cond <- apply(df[ss,pp,drop=FALSE],1,paste,collapse="_") cond <- gsub("^_|_$","",cond) cond }) - + output$createcomparison <- shiny::renderUI({ shiny::req(input$param) @@ -206,7 +207,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) items <- c("",sort(unique(cond))) message("[MakeContrastServer:createcomparison] items=",items) - + shiny::tagList( shiny::tags$head(shiny::tags$style(".default-sortable .rank-list-item {padding: 2px 15px;}")), sortable::bucket_list( @@ -228,20 +229,20 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) ) ) }) - + buttonInput <- function(FUN, len, id, ...) { inputs <- character(len) for (i in seq_len(len)) { inputs[i] <- as.character(FUN(paste0(id, i), ...)) } inputs - } + } shiny::observeEvent( c(input$group1, input$group2), { g1 <- gsub("[-_.,<> ]",".",input$group1) g2 <- gsub("[-_.,<> ]",".",input$group2) g1 <- gsub("[.]+",".",g1) - g2 <- gsub("[.]+",".",g2) + g2 <- gsub("[.]+",".",g2) g1 <- paste(g1,collapse="") g2 <- paste(g2,collapse="") if(is.null(g1) || length(g1)==0) g1 <- "" @@ -259,7 +260,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) if(g1=="" && g2=="") tt <- "" shiny::updateTextInput(session, "newname", value=tt) }) - + shiny::observeEvent( input$contrast_delete, { ## Observe if a contrast is to be deleted ## @@ -270,35 +271,35 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) if(!is.null(rv$contr) && NCOL(rv$contr) <= 1) { rv$contr <- rv$contr[,0,drop=FALSE] } else { - rv$contr <- rv$contr[,-id,drop=FALSE] + rv$contr <- rv$contr[,-id,drop=FALSE] } }) - + shiny::observeEvent( input$addcontrast, { message("[MakeContrastServer:addcontrast] reacted") - + cond <- sel.conditions() message("[MakeContrastServer:addcontrast] len.cond = ",length(cond)) message("[MakeContrastServer:addcontrast] cond = ",paste(cond,collapse=' ')) if(length(cond)==0 || is.null(cond)) return(NULL) - + group1 <- input$group1 group2 <- input$group2 in.main <- 1*(cond %in% group1) in.ref1 <- 1*(cond %in% group2) in.ref2 <- ("" %in% group2) & (!cond %in% group1) - in.ref <- in.ref1 | in.ref2 - + in.ref <- in.ref1 | in.ref2 + message("[MakeContrastServer:addcontrast] 1 : ") ## ctx <- 1*(in.main) - 1*(in.ref) ##ct.name <- paste0(input$group1name,"_vs_",input$group2name) ct.name <- input$newname gr1 <- gsub(".*:|_vs_.*","",ct.name) ## first is MAIN group!!! - gr2 <- gsub(".*_vs_|@.*","",ct.name) + gr2 <- gsub(".*_vs_|@.*","",ct.name) ctx <- c(NA,gr1, gr2)[1 + 1*in.main + 2*in.ref] - + if( sum(in.main)==0 || sum(in.ref)==0 ) { shinyalert::shinyalert("ERROR","Both groups must have samples") return(NULL) @@ -319,7 +320,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) shinyalert::shinyalert("ERROR","Contrast must include _vs_ in name") return(NULL) } - + message("[MakeContrastServer:addcontrast] update reactive values : 1") ## update reactive value @@ -328,7 +329,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) message("[MakeContrastServer:addcontrast] 1 : samples = ",samples) message("[MakeContrastServer:addcontrast] 1 : ct.name = ",ct.name) message("[MakeContrastServer:addcontrast] 1 : len.ctx = ",length(ctx)) - + ctx1 <- matrix(ctx, ncol=1, dimnames=list(samples,ct.name)) if(is.null(rv$contr)) { rv$contr <- ctx1 @@ -338,9 +339,9 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) message("[MakeContrastServer:addcontrast] update reactive values : 2") message("[MakeContrastServer:addcontrast] ct.name in pheno = ",ct.name %in% colnames(rv$pheno)) - + ##if(any(input$param %in% c('',''))) { - if(any(input$param %in% c(''))) { + if(any(input$param %in% c(''))) { if(is.null(rv$pheno) || NCOL(rv$pheno)==0 ) { rv$pheno <- ctx1 } else { @@ -350,11 +351,11 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) } } } - + message("[MakeContrastServer:addcontrast] done!") - + }) - + shiny::observeEvent( input$autocontrast, { shiny::req(phenoRT()) @@ -375,7 +376,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) mingrp = 3, slen = 20, ref=NULL, fix.degenerate=FALSE) } if(is.null(ctx)) return(NULL) - + ## update reactive value ctx2 <- contrastAsLabels(ctx) if(!is.null(rv$contr)) { @@ -387,15 +388,15 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) }) output$contrastTable <- DT::renderDataTable({ - + message("[MakeContrastServer:contrastTable] called!") - + ct <- rv$contr message("[contrastTable] is.null(ct) = ",is.null(ct)) message("[contrastTable] dim.ct = ",dim(ct)) - message("[contrastTable] dim.contrRT = ",dim(contrRT())) - + message("[contrastTable] dim.contrRT = ",dim(contrRT())) + if(is.null(ct) || NCOL(ct)==0) { df <- data.frame( delete = 0, @@ -408,18 +409,18 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) } else { message("[contrastTable] ct.rownames= ",paste(rownames(ct),collapse=' ')) message("[contrastTable] ct.colnames= ",paste(colnames(ct),collapse=' ')) - + paste.max <- function(x,n=6) { ##x <- unlist(x) if(length(x)>n) { x <- c(x[1:n], paste("+",length(x)-n,"others")) } paste(x,collapse=" ") - } + } ct1 <- makeContrastsFromLabelMatrix(ct) ct1[is.na(ct1)] <- 0 - + if(NCOL(ct)==1) { ss1 <- names(which(ct1[,1] > 0)) ss2 <- names(which(ct1[,1] < 0)) @@ -427,7 +428,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) ss2 <- paste.max(ss2,6) } else { ss0 <- rownames(ct) - ss1 <- apply(ct1,2,function(x) paste.max(ss0[which(x > 0)])) + ss1 <- apply(ct1,2,function(x) paste.max(ss0[which(x > 0)])) ss2 <- apply(ct1,2,function(x) paste.max(ss0[which(x < 0)])) } @@ -446,7 +447,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) ##onclick = 'Shiny.onInputChange(\"contrast_delete\",this.id)' onclick = paste0('Shiny.onInputChange(\"',ns("contrast_delete"),'\",this.id)') ) - + df <- data.frame( delete = deleteButtons, comparison = colnames(ct1), @@ -458,7 +459,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) } rownames(df) <- NULL - + DT::datatable( df, rownames=FALSE, escape = c(-1), @@ -472,12 +473,12 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) list(width='20px', targets=c(0,2,3)), list(width='150px', targets=c(1)), list(width='400px', targets=c(4,5)) - ) + ) ) ) %>% DT::formatStyle(0, target='row', fontSize='12px', lineHeight='99%') }, server=FALSE) - + pcaplot.RENDER <- shiny::reactive({ message("[MakeContrastServer] pcaplot.RENDER : reacted") @@ -489,34 +490,34 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) if(NCOL(pheno)==0 || NCOL(counts)==0) return(NULL) shiny::req(pheno) shiny::req(counts) - + method <- input$pcaplot.method X <- log2(1 + counts) clust <- pgx.clusterMatrix(X, dims=2, method=method) names(clust) cond <- sel.conditions() - if(length(cond)==0 || is.null(cond)) return(NULL) + if(length(cond)==0 || is.null(cond)) return(NULL) ##par(mar=c(4,1,1,1)) pgx.scatterPlotXY( clust$pos2d, var=cond, plotlib="plotly", legend = FALSE ##, labels=TRUE ) - + }) - + pcaplot.opts = shiny::tagList( withTooltip( shiny::selectInput( ns("pcaplot.method"), "Method:", choices = c("pca","tsne","umap"), width = '100%'),"Choose clustering method.", placement="right", options = list(container = "body")) ) - + shiny::callModule( - plotModule, + plotModule, id = "pcaplot", func = pcaplot.RENDER, ## ns=ns, - plotlib = "plotly", + plotlib = "plotly", options = pcaplot.opts, height = c(320,700), width=c("auto",800), pdf.width=8, pdf.height=8, @@ -524,18 +525,18 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) ##info.text = hm_PCAplot_text ##caption = pca_caption_static ) - + message("[MakeContrastServer] returning...") return(shiny::reactive({ - if(is.null(rv$contr)) return(NULL) + if(is.null(rv$contr)) return(NULL) ##rv$contr ## labeled contrast matrix ##list( contr=rv$contr, pheno=rv$pheno) rv })) ## pointing to reactive - + } ## end-of-server ) - + } From 58124844668ca607c77b0abef0cecd0d911a4d6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Mon, 20 Feb 2023 23:51:12 +0100 Subject: [PATCH 43/49] fix: plot --- components/board.expression/R/expression_plot_volcanoAll.R | 2 +- components/board.expression/R/expression_ui.R | 1 - 2 files changed, 1 insertion(+), 2 deletions(-) diff --git a/components/board.expression/R/expression_plot_volcanoAll.R b/components/board.expression/R/expression_plot_volcanoAll.R index 247e22679..610fdb4a3 100644 --- a/components/board.expression/R/expression_plot_volcanoAll.R +++ b/components/board.expression/R/expression_plot_volcanoAll.R @@ -153,7 +153,7 @@ expression_plot_volcanoAll_server <- function(id, ## ggplot2::theme(legend.position='none') ## ggplot2::theme_bw(base_size=11) - if (!interactive()) shiny::incProgress(1 / length(comp)) + if (!interactive()) shiny::incProgress(1 / length(pd[["comp"]])) } }) ## progress diff --git a/components/board.expression/R/expression_ui.R b/components/board.expression/R/expression_ui.R index e7c34303a..f9e14e7d8 100644 --- a/components/board.expression/R/expression_ui.R +++ b/components/board.expression/R/expression_ui.R @@ -129,7 +129,6 @@ ExpressionUI <- function(id) { "Top genes", expression_plot_topgenes_ui( id = ns("topgenes"), - label = "a", height = c(imgH, 420), width = c("auto", 1600) ), From fefdab2ac373434a6802eb9126e37bca1cef5ebb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Tue, 21 Feb 2023 11:39:17 +0100 Subject: [PATCH 44/49] style: remove text --- components/app/R/modules/MakeContrastModule.R | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/components/app/R/modules/MakeContrastModule.R b/components/app/R/modules/MakeContrastModule.R index 96236b070..3938ddf0e 100644 --- a/components/app/R/modules/MakeContrastModule.R +++ b/components/app/R/modules/MakeContrastModule.R @@ -437,7 +437,7 @@ MakeContrastServerRT <- function(id, phenoRT, contrRT, countsRT, height=720) len = ncol(ct), ##id = 'contrast_delete_', id = paste0('contrast_delete_',sample(99999,1),"_"), ## hack to allow double click - label = "delete", + label = "", ##size = "mini", width = "50px", inline = TRUE, From 71bc61caf8f2dae58422e789d09d5c912a7df5be Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Tue, 21 Feb 2023 11:47:28 +0100 Subject: [PATCH 45/49] feat: size for png and pdf --- components/base/R/PlotModule.R | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/components/base/R/PlotModule.R b/components/base/R/PlotModule.R index 42ae39a52..45c0751d9 100644 --- a/components/base/R/PlotModule.R +++ b/components/base/R/PlotModule.R @@ -135,11 +135,13 @@ PlotModuleUI <- function(id, choices = download.fmt ), shiny::conditionalPanel( - condition = "input.downloadOption == 'pdf'", + condition = "input.downloadOption == 'pdf' || input.downloadOption == 'png'", ns = ns, - pdf_size + shiny::div( + pdf_size, + shiny::br() + ) ), - shiny::br(), div( shiny::downloadButton( outputId = ns("download"), From 8bc9c0587b9fe41a11ba4a5d0704ccf70c1f5b6c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Tue, 21 Feb 2023 11:55:04 +0100 Subject: [PATCH 46/49] fix: correct scrollY --- components/board.loading/R/loading_table_datasets.R | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/components/board.loading/R/loading_table_datasets.R b/components/board.loading/R/loading_table_datasets.R index e95b5939f..7791c53d7 100644 --- a/components/board.loading/R/loading_table_datasets.R +++ b/components/board.loading/R/loading_table_datasets.R @@ -20,8 +20,6 @@ loading_table_datasets_server <- function(id, df <- pgxTable_data() req(df) - ##df <- data.frame(nr=rownames(df), df) - target1 <- grep("date",colnames(df)) target2 <- grep("description",colnames(df)) target3 <- grep("conditions",colnames(df)) @@ -38,7 +36,7 @@ loading_table_datasets_server <- function(id, dom = 'ft', pageLength = 9999, scrollX = FALSE, - scrollY = FALSE, + scrollY = "55vh", deferRender=TRUE, autoWidth = TRUE, columnDefs = list( From 37bf469aa3118c8e4ea3474604a1a5d6db760492 Mon Sep 17 00:00:00 2001 From: Mauro Miguel Masiero Date: Tue, 21 Feb 2023 12:53:20 +0100 Subject: [PATCH 47/49] center loading pop up text --- scss/components/_all.scss | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/scss/components/_all.scss b/scss/components/_all.scss index c73f4b832..53315ed2e 100644 --- a/scss/components/_all.scss +++ b/scss/components/_all.scss @@ -106,6 +106,11 @@ html { height: auto; } + .modal-title{ + margin-right: auto; + margin-left: auto; + } + .bg-cover-image { background-color: #dde6f0; background-color: #fff; From 50aa35d665b21539f60aa010791909a4112ded6c Mon Sep 17 00:00:00 2001 From: ncullen93 Date: Wed, 22 Feb 2023 14:55:11 +0100 Subject: [PATCH 48/49] "try example dataset" button loads the right dataset; modal if not found --- components/00SourceAll.R | 5 +- components/app/R/modules/WelcomeBoard.R | 103 ++- components/board.loading/R/loading_server.R | 723 ++++++++++---------- 3 files changed, 433 insertions(+), 398 deletions(-) diff --git a/components/00SourceAll.R b/components/00SourceAll.R index 38b784eb9..36f315d26 100644 --- a/components/00SourceAll.R +++ b/components/00SourceAll.R @@ -72,6 +72,7 @@ if(!file.exists('00SourceAll.R')) { source('base/R/pgx-wordcloud.R',encoding='UTF-8') source('base/R/PlotModule.R',encoding='UTF-8') source('base/R/TableModule.R',encoding='UTF-8') + source('base/R/TableModule2.R',encoding='UTF-8') source('base/R/ui-code.R',encoding='UTF-8') source('base/R/xcr-graph.r',encoding='UTF-8') source('base/R/xcr-math.r',encoding='UTF-8') @@ -103,6 +104,8 @@ if(!file.exists('00SourceAll.R')) { source('board.connectivity/R/connectivity_plot_enrichmentGraph.R',encoding='UTF-8') source('board.connectivity/R/connectivity_plot_leadingEdgeGraph.R',encoding='UTF-8') source('board.connectivity/R/connectivity_server.R',encoding='UTF-8') + source('board.connectivity/R/connectivity_table_similarity_scores.R',encoding='UTF-8') + source('board.connectivity/R/connectivity_table_similarity_scores2.R',encoding='UTF-8') source('board.connectivity/R/connectivity_ui.R',encoding='UTF-8') source('board.correlation/R/correlation_plot_cor_graph.R',encoding='UTF-8') source('board.correlation/R/correlation_plot_partial_correlation.R',encoding='UTF-8') @@ -187,9 +190,9 @@ if(!file.exists('00SourceAll.R')) { source('board.intersection/R/intersection_plot_scatterplot_pairs.R',encoding='UTF-8') source('board.intersection/R/intersection_plot_table_venn_diagram.R',encoding='UTF-8') source('board.intersection/R/intersection_server.R',encoding='UTF-8') - source('board.intersection/R/intersection_table_venntable.R',encoding='UTF-8') source('board.intersection/R/intersection_ui.R',encoding='UTF-8') source('board.loading/R/loading_server.R',encoding='UTF-8') + source('board.loading/R/loading_table_datasets.R',encoding='UTF-8') source('board.loading/R/loading_tsneplot.R',encoding='UTF-8') source('board.loading/R/loading_ui.R',encoding='UTF-8') source('board.signature/R/signature_plot_enplots.R',encoding='UTF-8') diff --git a/components/app/R/modules/WelcomeBoard.R b/components/app/R/modules/WelcomeBoard.R index 9acb3b81e..2c538afbb 100644 --- a/components/app/R/modules/WelcomeBoard.R +++ b/components/app/R/modules/WelcomeBoard.R @@ -8,32 +8,28 @@ WelcomeBoardInputs <- function(id) {} WelcomeBoardUI <- function(id) {} -WelcomeBoard <- function(id, auth, r_global) -{ - moduleServer(id, function(input, output, session) - { +WelcomeBoard <- function(id, auth, r_global) { + moduleServer(id, function(input, output, session) { ns <- session$ns ## NAMESPACE output$welcome <- shiny::renderText({ - name <- auth$name() - dbg("[HomeBoard] name = ",name) - if(name %in% c("",NA,NULL)) { - welcome <- "Welcome back..." - } else { - first.name <- strsplit("ivo kwee",split="[@ .]")[[1]][1] - first.name <- paste0(toupper(substring(first.name,1,1)), - substring(first.name,2,nchar(first.name))) - welcome <- paste0("Welcome back ",first.name,"...") - } - welcome + name <- auth$name() + if (name %in% c("", NA, NULL)) { + welcome <- "Welcome back..." + } else { + first.name <- strsplit("ivo kwee", split = "[@ .]")[[1]][1] + first.name <- paste0( + toupper(substring(first.name, 1, 1)), + substring(first.name, 2, nchar(first.name)) + ) + welcome <- paste0("Welcome back ", first.name, "...") + } + welcome }) observeEvent(input$init_example_data, { - shinyjs::runjs("$('.tab-sidebar:eq(1)').trigger('click');") - shinyjs::runjs("$('.sidebar-label').trigger('click');") r_global$load_example_trigger <- TRUE }) - }) } @@ -42,45 +38,44 @@ WelcomeBoardInputs <- function(id) { } WelcomeBoardUI <- function(id) { - ns <- shiny::NS(id) ## namespace + ns <- shiny::NS(id) ## namespace div( - id = "welcome-page", - br(), - br(), - div(shiny::textOutput(ns("welcome")), id="welcome-text"), - h2("What would you like to do today?"), - br(), - br(), - br(), + id = "welcome-page", + br(), + br(), + div(shiny::textOutput(ns("welcome")), id = "welcome-text"), + h2("What would you like to do today?"), + br(), + br(), + br(), + div( + class = "row", + id = "welcome-buttons", div( - class = "row", - id = "welcome-buttons", - div( - class = "col-md-5", - h3("I am new..."), - shiny::actionButton( - ns('init_example_data'), - label = "Try example dataset", - class = "btn btn-outline-info welcome-btn" - ) - ), - div( - class = "col-md-7", - h3("I'm an existing user..."), - tags$a( - id = "init-upload-data", - "Upload new data", - class = "btn btn-outline-info welcome-btn" - ), - tags$button( - id = "init-load-data", - "Use my saved data", - class = "btn btn-outline-primary welcome-btn" - ) - ) + class = "col-md-5", + h3("I am new..."), + shiny::actionButton( + ns("init_example_data"), + label = "Try example dataset", + class = "btn btn-outline-info welcome-btn" + ) ), - br() - + div( + class = "col-md-7", + h3("I'm an existing user..."), + tags$a( + id = "init-upload-data", + "Upload new data", + class = "btn btn-outline-info welcome-btn" + ), + tags$button( + id = "init-load-data", + "Use my saved data", + class = "btn btn-outline-primary welcome-btn" + ) + ) + ), + br() ) } diff --git a/components/board.loading/R/loading_server.R b/components/board.loading/R/loading_server.R index 0bdd1d7fc..9e560a1f5 100644 --- a/components/board.loading/R/loading_server.R +++ b/components/board.loading/R/loading_server.R @@ -7,25 +7,25 @@ LoadingBoard <- function(id, pgx_dir, pgx, auth, - limits = c("samples"=1000,"comparisons"=20, - "genes"=20000, "genesets"=10000, - "datasets"=10), + limits = c( + "samples" = 1000, "comparisons" = 20, + "genes" = 20000, "genesets" = 10000, + "datasets" = 10 + ), enable_upload = TRUE, enable_delete = TRUE, enable_save = TRUE, enable_userdir = TRUE, - r_global - ) -{ - moduleServer(id, function(input, output, session) - { + r_global) { + moduleServer(id, function(input, output, session) { ns <- session$ns ## NAMESPACE - loadedDataset <- shiny::reactiveVal(0) ## counts/trigger dataset upload + loadedDataset <- shiny::reactiveVal(0) ## counts/trigger dataset upload ## info that's needed r_local <- reactiveValues( - selected_row = NULL + selected_row = NULL, + found_example_trigger = NULL ) observeEvent(pgxtable$rows_selected(), { @@ -33,30 +33,49 @@ LoadingBoard <- function(id, }) observeEvent(r_global$load_example_trigger, { - r_local$selected_row <- 1 - print(paste('selected row:', r_local$selected_row)) + # get the row which corresponds to "example-data" + example_row <- which(pgxtable$data()$dataset == "example-data")[1] + + # if not found, throw error modal that example-data doesnt exist + if (is.na(example_row)) { + shiny::showModal(modalDialog( + title = "No example data found", + size = "l", + 'Sorry, it appears that the example dataset cannot be found. You may + have deleted it in a previous session. You can still load a copy of the + example dataset by clicking the "Upload New Data" button.' + )) + r_global$load_example_trigger <- NULL + return(NULL) + } else { + shinyjs::runjs("$('.tab-sidebar:eq(1)').trigger('click');") + shinyjs::runjs("$('.sidebar-label').trigger('click');") + r_local$selected_row <- example_row + r_local$found_example_trigger <- TRUE + } }) - ##================================================================================ + ## ================================================================================ ## Modules - ##================================================================================ - loading_tsne_server("tsne", watermark=FALSE) + ## ================================================================================ + loading_tsne_server("tsne", watermark = FALSE) pgxtable <- loading_table_datasets_server( "pgxtable", pgxTable_data = pgxTable_data ) - ##----------------------------------------------------------------------------- + ## ----------------------------------------------------------------------------- ## Description - ##----------------------------------------------------------------------------- - - shiny::observeEvent( input$module_info, { - shiny::showModal(shiny::modalDialog( - title = shiny::HTML("Load Dataset"), - shiny::HTML(module_infotext), - easyClose = TRUE, size="xl" )) + ## ----------------------------------------------------------------------------- + + shiny::observeEvent(input$module_info, { + shiny::showModal(shiny::modalDialog( + title = shiny::HTML("Load Dataset"), + shiny::HTML(module_infotext), + easyClose = TRUE, size = "xl" + )) }) module_infotext <- paste0( @@ -73,413 +92,431 @@ LoadingBoard <- function(id, gyroscope; picture-in-picture' allowfullscreen>
" ) - ##----------------------------------------------------------------------------- + ## ----------------------------------------------------------------------------- ## User interface - ##----------------------------------------------------------------------------- + ## ----------------------------------------------------------------------------- currentSection <- shiny::reactive({ - cdata <- session$clientData - sub("section-","",cdata[["url_hash"]]) + cdata <- session$clientData + sub("section-", "", cdata[["url_hash"]]) }) output$rowselected <- shiny::reactive({ - !is.null(selectedPGX()) && length(selectedPGX())>0 + !is.null(selectedPGX()) && length(selectedPGX()) > 0 }) - shiny::outputOptions(output, "rowselected", suspendWhenHidden=FALSE) + shiny::outputOptions(output, "rowselected", suspendWhenHidden = FALSE) observe({ - df <- getPGXINFO() - datatypes <- sort(setdiff(df$datatype,c(NA,""))) - organisms <- sort(setdiff(df$organism,c(NA,""))) - shiny::updateCheckboxGroupInput(session, "flt_datatype", choices = datatypes) - shiny::updateCheckboxGroupInput(session, "flt_organism", choices = organisms) + df <- getPGXINFO() + datatypes <- sort(setdiff(df$datatype, c(NA, ""))) + organisms <- sort(setdiff(df$organism, c(NA, ""))) + shiny::updateCheckboxGroupInput(session, "flt_datatype", choices = datatypes) + shiny::updateCheckboxGroupInput(session, "flt_organism", choices = organisms) }) - ##----------------------------------------------------------------------------- + ## ----------------------------------------------------------------------------- ## READ initial PGX file info - ##----------------------------------------------------------------------------- + ## ----------------------------------------------------------------------------- ## reactive value for updating table reload_pgxdir <- shiny::reactiveVal(0) getPGXDIR <- shiny::reactive({ - reload_pgxdir() ## force reload - - email <- auth$email() - email <- gsub(".*\\/","",email) - pdir <- pgx_dir ## from module input - - ##USERDIR=FALSE - if(enable_userdir) { - pdir <- paste0(pdir,"/",email) - if(!is.null(email) && !is.na(email) && email!="") pdir <- paste0(pdir,'/') - if(!dir.exists(pdir)) { - dir.create(pdir) - file.copy(file.path(pgx_dir,"example-data.pgx"),pdir) - } + reload_pgxdir() ## force reload + + email <- auth$email() + email <- gsub(".*\\/", "", email) + pdir <- pgx_dir ## from module input + + ## USERDIR=FALSE + if (enable_userdir) { + pdir <- paste0(pdir, "/", email) + if (!is.null(email) && !is.na(email) && email != "") pdir <- paste0(pdir, "/") + if (!dir.exists(pdir)) { + dir.create(pdir) + file.copy(file.path(pgx_dir, "example-data.pgx"), pdir) } - pdir + } + pdir }) getPGXINFO <- shiny::reactive({ - req(auth) - if(!auth$logged()) { - warning("[LoadingBoard:getPGXINFO] user not logged in!") - return(NULL) - } - info <- NULL - pdir <- getPGXDIR() - info <- pgx.scanInfoFile(pdir, file="datasets-info.csv", verbose=TRUE ) - if(is.null(info)) { - aa <- rep(NA,9) - names(aa) = c("dataset","datatype","description","nsamples", - "ngenes","nsets","conditions","organism","date") - info <- data.frame(rbind(aa))[0,] - } - info + req(auth) + if (!auth$logged()) { + warning("[LoadingBoard:getPGXINFO] user not logged in!") + return(NULL) + } + info <- NULL + pdir <- getPGXDIR() + info <- pgx.scanInfoFile(pdir, file = "datasets-info.csv", verbose = TRUE) + if (is.null(info)) { + aa <- rep(NA, 9) + names(aa) <- c( + "dataset", "datatype", "description", "nsamples", + "ngenes", "nsets", "conditions", "organism", "date" + ) + info <- data.frame(rbind(aa))[0, ] + } + info }) getFilteredPGXINFO <- shiny::reactive({ - - ## get the filtered table of pgx datasets - req(auth) - if(!auth$logged()) { - warning("[LoadingBoard:getFilteredPGXINFO] user not logged in! + ## get the filtered table of pgx datasets + req(auth) + if (!auth$logged()) { + warning("[LoadingBoard:getFilteredPGXINFO] user not logged in! not showing table!") - return(NULL) - } - df <- getPGXINFO() - if(is.null(df)) return(NULL) - - pgxdir <- getPGXDIR() - pgxfiles = dir(pgxdir, pattern=".pgx$") - sel <- sub("[.]pgx$","",df$dataset) %in% sub("[.]pgx$","",pgxfiles) - df <- df[sel,,drop=FALSE] - - ## Apply filters - if(nrow(df)>0) { - f1=f2=f3=rep(TRUE,nrow(df)) - notnull <- function(x) !is.null(x) && length(x)>0 && x[1]!="" && !is.na(x[1]) - if(notnull(input$flt_datatype)) f2 <- (df$datatype %in% input$flt_datatype) - if(notnull(input$flt_organism)) f3 <- (df$organism %in% input$flt_organism) - df <- df[which(f1 & f2 & f3),,drop=FALSE] - df$date <- as.Date(df$date, format='%Y-%m-%d') - df <- df[order(df$date,decreasing=TRUE),] - rownames(df) <- nrow(df):1 - } - - kk = unique(c("dataset","description","datatype","nsamples", - "ngenes","nsets","conditions","date","organism")) - kk = intersect(kk,colnames(df)) - df = df[,kk,drop=FALSE] - df + return(NULL) + } + df <- getPGXINFO() + if (is.null(df)) { + return(NULL) + } + + pgxdir <- getPGXDIR() + pgxfiles <- dir(pgxdir, pattern = ".pgx$") + sel <- sub("[.]pgx$", "", df$dataset) %in% sub("[.]pgx$", "", pgxfiles) + df <- df[sel, , drop = FALSE] + + ## Apply filters + if (nrow(df) > 0) { + f1 <- f2 <- f3 <- rep(TRUE, nrow(df)) + notnull <- function(x) !is.null(x) && length(x) > 0 && x[1] != "" && !is.na(x[1]) + if (notnull(input$flt_datatype)) f2 <- (df$datatype %in% input$flt_datatype) + if (notnull(input$flt_organism)) f3 <- (df$organism %in% input$flt_organism) + df <- df[which(f1 & f2 & f3), , drop = FALSE] + df$date <- as.Date(df$date, format = "%Y-%m-%d") + df <- df[order(df$date, decreasing = TRUE), ] + rownames(df) <- nrow(df):1 + } + + kk <- unique(c( + "dataset", "description", "datatype", "nsamples", + "ngenes", "nsets", "conditions", "date", "organism" + )) + kk <- intersect(kk, colnames(df)) + df <- df[, kk, drop = FALSE] + df }) selectedPGX <- shiny::reactive({ - req(pgxtable) - sel <- r_local$selected_row - #sel <- pgxtable$rows_selected() - if(is.null(sel) || length(sel)==0) return(NULL) - df <- getFilteredPGXINFO() - if(is.null(df) || nrow(df)==0) return(NULL) - pgxfile <- as.character(df$dataset[sel]) - pgxfile <- paste0(sub("[.]pgx$","",pgxfile),".pgx") ## add/replace .pgx - pgxfile + req(pgxtable) + sel <- r_local$selected_row + if (is.null(sel) || length(sel) == 0) { + return(NULL) + } + df <- getFilteredPGXINFO() + if (is.null(df) || nrow(df) == 0) { + return(NULL) + } + pgxfile <- as.character(df$dataset[sel]) + pgxfile <- paste0(sub("[.]pgx$", "", pgxfile), ".pgx") ## add/replace .pgx + pgxfile }) - ##============================================================================= - ##========================== OBSERVE/REACT ==================================== - ##============================================================================= + ## ============================================================================= + ## ========================== OBSERVE/REACT ==================================== + ## ============================================================================= loadPGX <- function(pgxfile) { + req(auth$logged()) + if (!auth$logged()) { + return(NULL) + } - req(auth$logged()) - if(!auth$logged()) return(NULL) - - pgxfile <- paste0(sub("[.]pgx$","",pgxfile),".pgx") ## add/replace .pgx - pgxdir <- getPGXDIR() + pgxfile <- paste0(sub("[.]pgx$", "", pgxfile), ".pgx") ## add/replace .pgx + pgxdir <- getPGXDIR() - pgx.path <- pgxdir[file.exists(file.path(pgxdir,pgxfile))][1] - pgxfile1 = file.path(pgx.path,pgxfile) + pgx.path <- pgxdir[file.exists(file.path(pgxdir, pgxfile))][1] + pgxfile1 <- file.path(pgx.path, pgxfile) - pgx <- NULL - if(file.exists(pgxfile1)) { - shiny::withProgress(message="Loading data...", value=0.33, { - pgx <- local(get(load(pgxfile1,verbose=0))) ## override any name - }) - } else { - warning("[LoadingBoard::loadPGX] ***ERROR*** file not found : ",pgxfile) - return(NULL) - } - if(!is.null(pgx)) { - pgx$name <- pgxfile - return(pgx) - } else { - warning("[LoadingBoard::loadPGX] ERROR loading pgx object") - return(NULL) - } + pgx <- NULL + if (file.exists(pgxfile1)) { + shiny::withProgress(message = "Loading data...", value = 0.33, { + pgx <- local(get(load(pgxfile1, verbose = 0))) ## override any name + }) + } else { + warning("[LoadingBoard::loadPGX] ***ERROR*** file not found : ", pgxfile) + return(NULL) + } + if (!is.null(pgx)) { + pgx$name <- pgxfile + return(pgx) + } else { + warning("[LoadingBoard::loadPGX] ERROR loading pgx object") + return(NULL) + } } output$downloadpgx <- shiny::downloadHandler( - ##filename = "userdata.pgx", - filename = function() { - selectedPGX() - }, - content = function(file) { - pgxfile <- selectedPGX() - if(is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) return(NULL) - pgx <- loadPGX(pgxfile) - temp <- tempfile() - save(pgx, file=temp) - file.copy(temp,file) + ## filename = "userdata.pgx", + filename = function() { + selectedPGX() + }, + content = function(file) { + pgxfile <- selectedPGX() + if (is.null(pgxfile) || pgxfile == "" || length(pgxfile) == 0) { + return(NULL) } + pgx <- loadPGX(pgxfile) + temp <- tempfile() + save(pgx, file = temp) + file.copy(temp, file) + } ) output$downloadzip <- shiny::downloadHandler( - ##filename = "userdata.zip", - filename = function() { - sub("pgx$","zip",selectedPGX()) - }, - content = function(file) { - pgxfile <- selectedPGX() - if(is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) return(NULL) - pgxname <- sub("[.]pgx$","",pgxfile) - pgx <- loadPGX(pgxfile) - dir.create(tmp <- tempfile()) - tmp2 <- file.path(tmp,pgxname) - dir.create(tmp2) - - exp.matrix <- sign(pgx$model.parameters$exp.matrix) - exp.matrix <- contrastAsLabels(exp.matrix) ## new recommended style - exp.matrix[is.na(exp.matrix)] <- "" - - write.csv(round(pgx$counts,digits=2), file=file.path(tmp2, "counts.csv")) - write.csv(pgx$samples, file=file.path(tmp2, "samples.csv")) - write.csv(exp.matrix, file=file.path(tmp2, "contrasts.csv")) - write.csv(round(pgx$X,digits=4), file=file.path(tmp2, "normalized.csv")) - - zipfile <- tempfile(fileext = ".zip") - zip::zip(zipfile, - files=paste0(pgxname,"/",c("counts.csv","samples.csv","contrasts.csv","normalized.csv")), - root=tmp) - file.copy(zipfile,file) - remove(pgx); gc(); - } - ) - - shiny::observeEvent( input$deletebutton, { - + ## filename = "userdata.zip", + filename = function() { + sub("pgx$", "zip", selectedPGX()) + }, + content = function(file) { pgxfile <- selectedPGX() - if(is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) return(NULL) - - pgx.path <- getPGXDIR() - pgxfile1 = file.path(pgx.path,pgxfile) - pgxfile1 - sel <- NULL - - deletePGX <- function() { - if(input$confirmdelete) { - cat(">>> deleting",pgxfile,"\n") - pgxfile2 <- paste0(pgxfile1,"_") ## mark as deleted - file.rename(pgxfile1, pgxfile2) - reload_pgxdir(reload_pgxdir()+1) - } else { - cat(">>> deletion cancelled\n") - } + if (is.null(pgxfile) || pgxfile == "" || length(pgxfile) == 0) { + return(NULL) } + pgxname <- sub("[.]pgx$", "", pgxfile) + pgx <- loadPGX(pgxfile) + dir.create(tmp <- tempfile()) + tmp2 <- file.path(tmp, pgxname) + dir.create(tmp2) + + exp.matrix <- sign(pgx$model.parameters$exp.matrix) + exp.matrix <- contrastAsLabels(exp.matrix) ## new recommended style + exp.matrix[is.na(exp.matrix)] <- "" + + write.csv(round(pgx$counts, digits = 2), file = file.path(tmp2, "counts.csv")) + write.csv(pgx$samples, file = file.path(tmp2, "samples.csv")) + write.csv(exp.matrix, file = file.path(tmp2, "contrasts.csv")) + write.csv(round(pgx$X, digits = 4), file = file.path(tmp2, "normalized.csv")) + + zipfile <- tempfile(fileext = ".zip") + zip::zip(zipfile, + files = paste0(pgxname, "/", c("counts.csv", "samples.csv", "contrasts.csv", "normalized.csv")), + root = tmp + ) + file.copy(zipfile, file) + remove(pgx) + gc() + } + ) - not.anonymous <- !is.na(auth$name()) && auth$name()!="" - allow.delete <- !not.anonymous - - allow.delete = TRUE - if(!allow.delete) { - warning("[LoadingBoard::@deletebutton] WARNING:: ",pgxfile, - " not owned by ",auth$name()," \n") - shinyalert::shinyalert( - title = "Error!", - text = "You do not have permission to delete this dataset", - type = "error" - ) + shiny::observeEvent(input$deletebutton, { + pgxfile <- selectedPGX() + if (is.null(pgxfile) || pgxfile == "" || length(pgxfile) == 0) { + return(NULL) + } + + pgx.path <- getPGXDIR() + pgxfile1 <- file.path(pgx.path, pgxfile) + pgxfile1 + sel <- NULL + + deletePGX <- function() { + if (input$confirmdelete) { + cat(">>> deleting", pgxfile, "\n") + pgxfile2 <- paste0(pgxfile1, "_") ## mark as deleted + file.rename(pgxfile1, pgxfile2) + reload_pgxdir(reload_pgxdir() + 1) } else { - shinyalert::shinyalert( - "Delete this dataset?", - paste("Are you sure you want\nto delete '",pgxfile,"'?"), - confirmButtonText = "Delete", - showCancelButton = TRUE, - callbackR = deletePGX, - inputId = "confirmdelete") + cat(">>> deletion cancelled\n") } + } + + not.anonymous <- !is.na(auth$name()) && auth$name() != "" + allow.delete <- !not.anonymous + + allow.delete <- TRUE + if (!allow.delete) { + warning( + "[LoadingBoard::@deletebutton] WARNING:: ", pgxfile, + " not owned by ", auth$name(), " \n" + ) + shinyalert::shinyalert( + title = "Error!", + text = "You do not have permission to delete this dataset", + type = "error" + ) + } else { + shinyalert::shinyalert( + "Delete this dataset?", + paste("Are you sure you want\nto delete '", pgxfile, "'?"), + confirmButtonText = "Delete", + showCancelButton = TRUE, + callbackR = deletePGX, + inputId = "confirmdelete" + ) + } }) - ##================================================================================ - ##========================== LOAD DATA FROM LIST ================================= - ##================================================================================ + ## ================================================================================ + ## ========================== LOAD DATA FROM LIST ================================= + ## ================================================================================ load_react <- reactive({ - btn <- input$loadbutton - btn2 <- r_global$load_example_trigger - query <- parseQueryString(session$clientData$url_search) - logged <- isolate(auth$logged()) ## avoid reloading when logout/login - (!is.null(btn) || !is.null(query[['pgx']])) && logged + btn <- input$loadbutton + btn2 <- r_local$found_example_trigger + query <- parseQueryString(session$clientData$url_search) + logged <- isolate(auth$logged()) ## avoid reloading when logout/login + (!is.null(btn) || !is.null(query[["pgx"]])) && logged }) - shiny::observeEvent( load_react(), { - if(!load_react()) { - return(NULL) - } - - on.exit({ - session$sendCustomMessage( - "show-tabs", - list() - ) - }) - - pgxfile = NULL - - ## Observe URL query - query <- parseQueryString(session$clientData$url_search) - if(!is.null(query[['pgx']])) { - pgxfile <- query[['pgx']] - pgxfile <- basename(pgxfile) ## for security - pgxfile <- paste0(sub("[.]pgx$","",pgxfile),".pgx") ## add/replace .pgx - } - - ## Observe button press (over-rides URL query) - btn <- input$loadbutton - if (!is.null(btn) && btn!=0) { - pgxfile <- selectedPGX() - } - ## Observe "try example dataset" press - if (r_global$load_example_trigger) { - pgxfile <- selectedPGX() - } - - ## check if file is there - if(is.na(pgxfile) || is.null(pgxfile) || pgxfile=="" || length(pgxfile)==0) { - message("[LoadingBoard@load_react] ERROR file not found : ",pgxfile,"\n") - return(NULL) - } - - ## During loading show loading pop-up modal - pgx.showCartoonModal() - - ##--------------------------------------------------------------------- - ##----------------- Loaded PGX object --------------------------------- - ##--------------------------------------------------------------------- - - loaded_pgx <- loadPGX(pgxfile) - if(is.null(loaded_pgx)) { - warning("[LoadingBoard@load_react] ERROR loading PGX file ",pgxfile,"\n") - beepr::beep(10) - shiny::removeModal() - return(NULL) - } - - ##----------------- update PGX object --------------------------------- - loaded_pgx <- pgx.initialize(loaded_pgx) - - if(is.null(loaded_pgx)) { - warning("[LoadingBoard@load_react] ERROR in object initialization\n") - beepr::beep(10) - shiny::showNotification("ERROR in object initialization!\n") - shiny::removeModal() - return(NULL) - } - loaded_pgx$name <- sub("[.]pgx$","",pgxfile) ## always use filename - - ##----------------- update input -------------------------------------- - loadedDataset(loadedDataset()+1) ## notify new data uploaded - - ## ***NEW*** update PGX from session - if(1) { - dbg("[LoadingBoard@load_react] pgx$name = ",loaded_pgx$name) - dbg("[LoadingBoard@load_react] tracemem(pgx) = ",tracemem(loaded_pgx)) - - ## *** EXPERIMENTAL ***. Copying to pgx list to reactiveValues in - ## session environment. - dbg("[LoadingBoard@load_react] **** copying current pgx to session.pgx ****") - for(i in 1:length(loaded_pgx)) { - pgx[[names(loaded_pgx)[i]]] <- loaded_pgx[[i]] - } + shiny::observeEvent(load_react(), { + if (!load_react()) { + return(NULL) + } + + on.exit({ + session$sendCustomMessage( + "show-tabs", + list() + ) + }) + + pgxfile <- NULL + + ## Observe URL query + query <- parseQueryString(session$clientData$url_search) + if (!is.null(query[["pgx"]])) { + pgxfile <- query[["pgx"]] + pgxfile <- basename(pgxfile) ## for security + pgxfile <- paste0(sub("[.]pgx$", "", pgxfile), ".pgx") ## add/replace .pgx + } + + ## Observe button press (over-rides URL query) + btn <- input$loadbutton + if (!is.null(btn) && btn != 0) { + pgxfile <- selectedPGX() + } + ## Observe "try example dataset" press + if (!is.null(r_local$found_example_trigger)) { + pgxfile <- selectedPGX() + } + + ## check if file is there + if (is.na(pgxfile) || is.null(pgxfile) || pgxfile == "" || length(pgxfile) == 0) { + message("[LoadingBoard@load_react] ERROR file not found : ", pgxfile, "\n") + return(NULL) + } + + ## During loading show loading pop-up modal + pgx.showCartoonModal() + + ## --------------------------------------------------------------------- + ## ----------------- Loaded PGX object --------------------------------- + ## --------------------------------------------------------------------- + + loaded_pgx <- loadPGX(pgxfile) + if (is.null(loaded_pgx)) { + warning("[LoadingBoard@load_react] ERROR loading PGX file ", pgxfile, "\n") + beepr::beep(10) + shiny::removeModal() + return(NULL) + } + + ## ----------------- update PGX object --------------------------------- + loaded_pgx <- pgx.initialize(loaded_pgx) + + if (is.null(loaded_pgx)) { + warning("[LoadingBoard@load_react] ERROR in object initialization\n") + beepr::beep(10) + shiny::showNotification("ERROR in object initialization!\n") + shiny::removeModal() + return(NULL) + } + loaded_pgx$name <- sub("[.]pgx$", "", pgxfile) ## always use filename + + ## ----------------- update input -------------------------------------- + loadedDataset(loadedDataset() + 1) ## notify new data uploaded + + ## ***NEW*** update PGX from session + if (1) { + ## *** EXPERIMENTAL ***. Copying to pgx list to reactiveValues in + ## session environment. + for (i in 1:length(loaded_pgx)) { + pgx[[names(loaded_pgx)[i]]] <- loaded_pgx[[i]] } + } - ##----------------- remove modal on exit?? ------------------------- - remove(loaded_pgx) - gc() - + ## ----------------- remove modal on exit?? ------------------------- + remove(loaded_pgx) + gc() }) - ##================================================================================ + ## ================================================================================ ## Header - ##================================================================================ + ## ================================================================================ pgx_stats <- reactive({ - pgx <- getFilteredPGXINFO() - shiny::req(pgx) - ndatasets <- nrow(pgx) - nsamples <- sum(as.integer(pgx$nsamples),na.rm=TRUE) - paste(ndatasets,"Data sets    ", nsamples, "Samples") + pgx <- getFilteredPGXINFO() + shiny::req(pgx) + ndatasets <- nrow(pgx) + nsamples <- sum(as.integer(pgx$nsamples), na.rm = TRUE) + paste(ndatasets, "Data sets    ", nsamples, "Samples") }) output$navheader <- shiny::renderUI({ fillRow( - flex=c(NA,NA,1), + flex = c(NA, NA, 1), shiny::div( - id="navheader-current-section", + id = "navheader-current-section", HTML("Load dataset  "), shiny::actionLink( ns("module_info"), "", - icon=shiny::icon("info-circle"), - style="color: #ccc;" - ) + icon = shiny::icon("info-circle"), + style = "color: #ccc;" + ) ), - shiny::div(HTML(pgx_stats()), id="navheader-dataset-stats"), + shiny::div(HTML(pgx_stats()), id = "navheader-dataset-stats"), shiny::br() ) }) - ##================================================================================ + ## ================================================================================ ## Data sets table - ##================================================================================ + ## ================================================================================ ## reactive value for updating table touchtable <- shiny::reactiveVal(0) - andothers <- function(s, split=" ", n=8) { - if(is.na(s)) return("") - s <- sub("^[ ]*","",s) - s <- sub("[ ]+"," ",s) - s1 <- strsplit(s, split=split)[[1]] - if(length(s1)<=n) return(s) - n2 <- setdiff(length(s1),n) - paste(paste(head(s1,n), collapse=" "),"(+",n2,"others)") + andothers <- function(s, split = " ", n = 8) { + if (is.na(s)) { + return("") + } + s <- sub("^[ ]*", "", s) + s <- sub("[ ]+", " ", s) + s1 <- strsplit(s, split = split)[[1]] + if (length(s1) <= n) { + return(s) + } + n2 <- setdiff(length(s1), n) + paste(paste(head(s1, n), collapse = " "), "(+", n2, "others)") } - + pgxTable_data <- shiny::reactive({ - reload_pgxdir() - - df <- getFilteredPGXINFO() - shiny::req(df) - - df$dataset <- gsub("[.]pgx$"," ",df$dataset) - df$conditions <- gsub("[,]"," ",df$conditions) - df$conditions <- sapply(as.character(df$conditions), andothers, split=" ", n=5) - df$description <- shortstring(as.character(df$description),200) - df$nsets <- NULL - df$organism <- NULL - df + reload_pgxdir() + + df <- getFilteredPGXINFO() + shiny::req(df) + + df$dataset <- gsub("[.]pgx$", " ", df$dataset) + df$conditions <- gsub("[,]", " ", df$conditions) + df$conditions <- sapply(as.character(df$conditions), andothers, split = " ", n = 5) + df$description <- shortstring(as.character(df$description), 200) + df$nsets <- NULL + df$organism <- NULL + df }) - ##------------------------------------------------ + ## ------------------------------------------------ ## Board return object - ##------------------------------------------------ + ## ------------------------------------------------ res <- list( - loaded = loadedDataset, - auth = auth + loaded = loadedDataset, + auth = auth ) return(res) }) From e6c2e1df2846d640b1e1e7870aedfff995822056 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Xavier=20Escrib=C3=A0=20Montagut?= Date: Fri, 24 Feb 2023 14:55:39 +0100 Subject: [PATCH 49/49] feat: new upload module structure --- .../board.upload/R/upload_plot_pcaplot.R | 72 + components/board.upload/R/upload_server.R | 1453 +++++++++++++++-- components/board.upload/R/upload_ui.R | 183 ++- 3 files changed, 1593 insertions(+), 115 deletions(-) create mode 100644 components/board.upload/R/upload_plot_pcaplot.R diff --git a/components/board.upload/R/upload_plot_pcaplot.R b/components/board.upload/R/upload_plot_pcaplot.R new file mode 100644 index 000000000..9d9d41a79 --- /dev/null +++ b/components/board.upload/R/upload_plot_pcaplot.R @@ -0,0 +1,72 @@ +## +## This file is part of the Omics Playground project. +## Copyright (c) 2018-2022 BigOmics Analytics Sagl. All rights reserved. +## + +upload_plot_pcaplot_ui <- function(id, height, width) { + ns <- shiny::NS(id) + + pcaplot.opts = shiny::tagList( + withTooltip( shiny::selectInput( ns("pcaplot.method"), "Method:", + choices = c("pca","tsne","umap"), + width = '100%'),"Choose clustering method.", + placement="right", options = list(container = "body")) + ) + + PlotModuleUI( + ns("plot"), + title = "PCA/tSNE plot", + plotlib = "plotly", + options = pcaplot.opts, + height = height, + width = width, + download.fmt = c("png", "pdf") + ) +} + +upload_plot_pcaplot_server <- function(id, + phenoRT, + countsRT, + sel.conditions, + watermark = FALSE) { + moduleServer(id, function(input, output, session) { + plot_data <- shiny::reactive({ + getCurrentWordEnrichment() + }) + + pcaplot.RENDER <- shiny::reactive({ + message("[MakeContrastServer] pcaplot.RENDER : reacted") + ##ngs <- inputData() + ##X <- ngs$X + pheno <- phenoRT() + counts <- countsRT() + if(is.null(pheno) || is.null(counts)) return(NULL) + if(NCOL(pheno)==0 || NCOL(counts)==0) return(NULL) + shiny::req(pheno) + shiny::req(counts) + + method <- input$pcaplot.method + X <- log2(1 + counts) + clust <- pgx.clusterMatrix(X, dims=2, method=method) + names(clust) + + cond <- sel.conditions() + if(length(cond)==0 || is.null(cond)) return(NULL) + ##par(mar=c(4,1,1,1)) + pgx.scatterPlotXY( + clust$pos2d, var=cond, plotlib="plotly", + legend = FALSE ##, labels=TRUE + ) + + }) + + PlotModuleServer( + "plot", + func = pcaplot.RENDER, + plotlib = "plotly", + pdf.width = 5, pdf.height = 5, + res = 72, + add.watermark = watermark + ) + }) +} diff --git a/components/board.upload/R/upload_server.R b/components/board.upload/R/upload_server.R index 400bc5619..03c84e448 100644 --- a/components/board.upload/R/upload_server.R +++ b/components/board.upload/R/upload_server.R @@ -13,50 +13,82 @@ UploadBoard <- function(id, enable_upload = TRUE, enable_save = TRUE, enable_userdir = TRUE - ) +) { - moduleServer(id, function(input, output, session) + moduleServer(id, function(input, output, session) { ns <- session$ns ## NAMESPACE dbg("[UploadBoard] >>> initializing UploadBoard...") loadedDataset <- shiny::reactiveVal(0) ## counts/trigger dataset upload - - message("[UploadBoard] in.shinyproxy = ",in.shinyproxy()) + + message("[UploadBoard] in.shinyproxy = ",in.shinyproxy()) message("[UploadBoard] SHINYPROXY_USERNAME = ",Sys.getenv("SHINYPROXY_USERNAME")) message("[UploadBoard] SHINYPROXY_USERGROUPS = ",Sys.getenv("SHINYPROXY_USERGROUPS")) message("[UploadBoard] pgx_dir = ",pgx_dir) - - dbg("[UploadBoard] getwd = ",getwd()) - + dbg("[UploadBoard] getwd = ",getwd()) + + phenoRT = shiny::reactive(uploaded$samples.csv) + contrRT = shiny::reactive(uploaded$contrasts.csv) + + rv <- shiny::reactiveValues(contr=NULL, pheno=NULL) + + shiny::observe({ + rv$contr <- contrRT() + }) + + shiny::observe({ + rv$pheno <- phenoRT() + }) + + observe({ + phenotypes <- c(sort(unique(colnames(phenoRT()))),"","") + phenotypes <- grep("_vs_",phenotypes,value=TRUE,invert=TRUE) ## no comparisons... + psel <- c(grep("sample|patient|name|id|^[.]",phenotypes,value=TRUE, + invert=TRUE), phenotypes)[1] + shiny::updateSelectInput( + session = session, + inputId = "param", + choices = phenotypes, + selected= psel + ) + genes <- sort(rownames(corrected_counts())) + shiny::updateSelectInput( + session = session, + inputId = "gene", + choices = genes, + selected= genes[1] + ) + }) + output$navheader <- shiny::renderUI({ fillRow( flex=c(NA,1,NA), ##h2(input$nav), shiny::div( id="navheader-current-section", - HTML("Upload data  "), + HTML("Upload data  "), shiny::actionLink( ns("module_info"), "", icon = shiny::icon("info-circle"), style = "color: #ccc;" - ) - ), + ) + ), shiny::br(), shiny::div(pgx$name, id="navheader-current-dataset") ) }) shiny::observeEvent( input$module_info, { - shiny::showModal(shiny::modalDialog( - title = shiny::HTML("Upload data"), - shiny::HTML(module_infotext), - easyClose = TRUE, size="l" )) + shiny::showModal(shiny::modalDialog( + title = shiny::HTML("Upload data"), + shiny::HTML(module_infotext), + easyClose = TRUE, size="l" )) }) module_infotext =paste0( - 'Under the Upload data panel users can upload their transcriptomics and proteomics data to the platform. The platform requires 3 data files as listed below: a data file containing counts/expression (counts.csv), a sample information file (samples.csv) and a file specifying the statistical comparisons as contrasts (contrasts.csv). It is important to name the files exactly as shown. The file format must be comma-separated-values (CSV) text. Be sure the dimensions, row names and column names match for all files. On the left side of the panel, users need to provide a unique name and brief description for the dataset while uploading. N.B. Users can now create contrasts from the platform itself, so the contrasts.csv file is optional. + 'Under the Upload data panel users can upload their transcriptomics and proteomics data to the platform. The platform requires 3 data files as listed below: a data file containing counts/expression (counts.csv), a sample information file (samples.csv) and a file specifying the statistical comparisons as contrasts (contrasts.csv). It is important to name the files exactly as shown. The file format must be comma-separated-values (CSV) text. Be sure the dimensions, row names and column names match for all files. On the left side of the panel, users need to provide a unique name and brief description for the dataset while uploading. N.B. Users can now create contrasts from the platform itself, so the contrasts.csv file is optional.

    @@ -69,121 +101,1324 @@ UploadBoard <- function(id,
    ') - + ##================================================================================ ##====================== NEW DATA UPLOAD ========================================= ##================================================================================ ##reload_pgxdir() - + getPGXDIR <- shiny::reactive({ - ##reload_pgxdir() ## force reload - - email="../me@company.com" - email <- auth$email() - email <- gsub(".*\\/","",email) - pdir <- pgx_dir ## from module input - - ##USERDIR=FALSE - if(enable_userdir) { - pdir <- paste0(pdir,"/",email) - if(!is.null(email) && !is.na(email) && email!="") pdir <- paste0(pdir,'/') - if(!dir.exists(pdir)) { - dbg("[LoadingBoard:getPGXDIR] userdir does not exists. creating pdir = ",pdir) - dir.create(pdir) - dbg("[LoadingBoard:getPGXDIR] copy example pgx") - file.copy(file.path(pgx_dir,"example-data.pgx"),pdir) - } + ##reload_pgxdir() ## force reload + + email="../me@company.com" + email <- auth$email() + email <- gsub(".*\\/","",email) + pdir <- pgx_dir ## from module input + + ##USERDIR=FALSE + if(enable_userdir) { + pdir <- paste0(pdir,"/",email) + if(!is.null(email) && !is.na(email) && email!="") pdir <- paste0(pdir,'/') + if(!dir.exists(pdir)) { + dbg("[LoadingBoard:getPGXDIR] userdir does not exists. creating pdir = ",pdir) + dir.create(pdir) + dbg("[LoadingBoard:getPGXDIR] copy example pgx") + file.copy(file.path(pgx_dir,"example-data.pgx"),pdir) } - pdir + } + pdir }) - + if(enable_upload) { - uploaded_pgx <- UploadModuleServer( - id = "upload_panel", - FILES = FILES, - pgx.dirRT = shiny::reactive(getPGXDIR()), - height = 720, - ## limits = c(samples=20, comparisons=20, genes=8000), - limits = limits + uploaded_pgx <- UploadModuleServer( + id = "upload_panel", + FILES = FILES, + pgx.dirRT = shiny::reactive(getPGXDIR()), + height = 720, + ## limits = c(samples=20, comparisons=20, genes=8000), + limits = limits + ) + + shiny::observeEvent( uploaded_pgx(), { + + dbg("[observe::uploaded_pgx] uploaded PGX detected!") + new_pgx <- uploaded_pgx() + + dbg("[observe::uploaded_pgx] initializing PGX object") + new_pgx <- pgx.initialize(new_pgx) + + ## update Session PGX + dbg("[UploadBoard@load_react] **** copying current pgx to session.pgx ****") + for(i in 1:length(new_pgx)) { + pgx[[names(new_pgx)[i]]] <- new_pgx[[i]] + } + + DT::selectRows(proxy = DT::dataTableProxy(ns("pgxtable")), selected=NULL) + + savedata_button <- NULL + if(enable_save) { + + dbg("[UploadBoard] observeEvent:savedata reacted") + ## -------------- save PGX file/object --------------- + pgxname <- sub("[.]pgx$","",new_pgx$name) + pgxname <- gsub("^[./-]*","",pgxname) ## prevent going to parent folder + pgxname <- paste0(gsub("[ \\/]","_",pgxname),".pgx") + pgxname + + pgxdir <- getPGXDIR() + fn <- file.path(pgxdir,pgxname) + fn <- iconv(fn, from = '', to = 'ASCII//TRANSLIT') + + ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + ## Note: Currently we use 'ngs' as object name but want to go + ## towards 'pgx' as standard name. Actually saving as RDS + ## should be better. + ngs=new_pgx + save(ngs, file=fn) + + remove(ngs) + remove(new_pgx) + + + message("[UploadBoard::@savedata] updating PGXINFO") + pgx.initDatasetFolder(pgxdir, force=FALSE, verbose=TRUE) + ## reload_pgxdir(reload_pgxdir()+1) + } + + ## shiny::removeModal() + msg1 <- "Ready!" + ##beepr::beep(sample(c(3,4,5,6,8),1)) ## music!! + beepr::beep(10) ## short beep + + if(enable_save) { + msg1 <- "Ready!
    Your data is ready and has been saved in your library. You can now start exploring your data." + } else { + msg1 <- "Ready!
    Your data is ready. You can now start exploring your data." + } + loadedDataset(loadedDataset()+1) ## notify new data uploaded + + showModal( + modalDialog( + HTML(msg1), + title = NULL, + size = "s", + footer = tagList( + modalButton("Start!") + ) + )) + }) + + } + + # Some 'global' reactive variables used in this file + uploaded <- shiny::reactiveValues() + + ## Hide/show tabpanels upon available data like a wizard dialog + shiny::observe({ + has.upload <- Vectorize(function(f) { + (f %in% names(uploaded) && !is.null(nrow(uploaded[[f]]))) + }) + need2 <- c("counts.csv", "samples.csv") + need3 <- c("counts.csv", "samples.csv", "contrasts.csv") + if (all(has.upload(need3))) { + shiny::showTab("tabs", "Contrasts") + shiny::showTab("tabs", "Compute") + if (input$advanced_mode) { + shiny::showTab("tabs", "Normalize") + shiny::showTab("tabs", "BatchCorrect") + } + } else if (all(has.upload(need2))) { + if (input$advanced_mode) { + shiny::showTab("tabs", "Normalize") + shiny::showTab("tabs", "BatchCorrect") + } + shiny::showTab("tabs", "Contrasts") + shiny::hideTab("tabs", "Compute") + } else { + shiny::hideTab("tabs", "Normalize") + shiny::hideTab("tabs", "BatchCorrect") + shiny::hideTab("tabs", "Contrasts") + shiny::hideTab("tabs", "Compute") + } + }) + + ## ===================================================================== + ## ======================= UI OBSERVERS ================================ + ## ===================================================================== + + shiny::observeEvent(input$advanced_mode, { + if (input$advanced_mode) { + shiny::showTab("tabs", "Normalize") ## NOT YET!!! + shiny::showTab("tabs", "BatchCorrect") + } else { + shiny::hideTab("tabs", "Normalize") + shiny::hideTab("tabs", "BatchCorrect") + } + }) + + ## ======================================================================== + ## ================================= UI =================================== + ## ======================================================================== + + # leaving this for now because not sure about the "suspendWhenHidden" thing (-NC) + output$contrasts_UI <- shiny::renderUI({ + shiny::fillCol( + height = height, ## width = 1200, + MakeContrastUI(ns("makecontrast")) + ) + }) + shiny::outputOptions(output, "contrasts_UI", suspendWhenHidden = FALSE) ## important!!! + + ## ===================================================================== + ## ================== DATA LOADING OBSERVERS =========================== + ## ===================================================================== + + ## ------------------------------------------------------------------ + ## Observer for uploading data files using fileInput widget. + ## + ## Reads in the data files from the file names, checks and + ## puts in the reactive values object 'uploaded'. Then + ## uploaded should trigger the computePGX module. + ## ------------------------------------------------------------------ + shiny::observeEvent(input$upload_files, { + message("[upload_files] >>> reading uploaded files") + message("[upload_files] upload_files$name=", input$upload_files$name) + message("[upload_files] upload_files$datapath=", input$upload_files$datapath) + + ## for(i in 1:length(uploaded)) uploaded[[i]] <- NULL + uploaded[["pgx"]] <- NULL + uploaded[["last_uploaded"]] <- NULL + + ## read uploaded files + pgx.uploaded <- any(grepl("[.]pgx$", input$upload_files$name)) + matlist <- list() + + if (pgx.uploaded) { + message("[upload_files] PGX upload detected") + + ## If the user uploaded a PGX file, we extract the matrix + ## dimensions from the given PGX/NGS object. Really? + ## + i <- grep("[.]pgx$", input$upload_files$name) + load(input$upload_files$datapath[i]) ## load NGS/PGX + ## matlist[["counts.csv"]] <- ngs$counts + ## matlist[["samples.csv"]] <- type.convert(ngs$samples) + ## matlist[["contrasts.csv"]] <- ngs$model.parameters$exp.matrix + uploaded[["pgx"]] <- ngs + } else { + ## If the user uploaded CSV files, we read in the data + ## from the files. + ## + message("[upload_files] getting matrices from CSV") + + ii <- grep("csv$", input$upload_files$name) + ii <- grep("sample|count|contrast|expression", + input$upload_files$name, + ignore.case = TRUE ) - - shiny::observeEvent( uploaded_pgx(), { - - dbg("[observe::uploaded_pgx] uploaded PGX detected!") - new_pgx <- uploaded_pgx() - - dbg("[observe::uploaded_pgx] initializing PGX object") - new_pgx <- pgx.initialize(new_pgx) - - ## update Session PGX - dbg("[UploadBoard@load_react] **** copying current pgx to session.pgx ****") - for(i in 1:length(new_pgx)) { - pgx[[names(new_pgx)[i]]] <- new_pgx[[i]] + if (length(ii) == 0) { + return(NULL) + } + + inputnames <- input$upload_files$name[ii] + uploadnames <- input$upload_files$datapath[ii] + + if (length(uploadnames) > 0) { + i <- 1 + for (i in 1:length(uploadnames)) { + fn1 <- inputnames[i] + fn2 <- uploadnames[i] + matname <- NULL + df <- NULL + if (grepl("count", fn1, ignore.case = TRUE)) { + dbg("[upload_files] counts.csv : fn1 = ", fn1) + ## allows duplicated rownames + df0 <- read.as_matrix(fn2) + if (TRUE && any(duplicated(rownames(df0)))) { + ndup <- sum(duplicated(rownames(df0))) + shinyWidgets::sendSweetAlert( + session = session, + title = "Duplicated gene names", + text = paste("Your counts matrix has", ndup, "duplicated gene names.\nCounts of those genes will be merged."), + type = "warning", + btn_labels = "OK", + closeOnClickOutside = FALSE, + ) + } + dbg( + "[upload_files] counts.csv : 1 : dim(df0) = ", + paste(dim(df0), collapse = "x") + ) + + if (nrow(df0) > 1 && NCOL(df0) > 1) { + df <- as.matrix(df0) + matname <- "counts.csv" + } + } else if (grepl("expression", fn1, ignore.case = TRUE)) { + dbg("[upload_files] expression.csv : fn1 = ", fn1) + ## allows duplicated rownames + df0 <- read.as_matrix(fn2) + if (TRUE && any(duplicated(rownames(df0)))) { + ndup <- sum(duplicated(rownames(df0))) + shinyWidgets::sendSweetAlert( + session = session, + title = "Duplicated gene names", + text = paste("Your counts matrix has", ndup, "duplicated gene names.\nCounts of those genes will be merged."), + type = "warning", + btn_labels = "OK", + closeOnClickOutside = FALSE, + ) + } + if (nrow(df0) > 1 && NCOL(df0) > 1) { + df <- as.matrix(df0) + message("[UploadModule::upload_files] converting expression to counts...") + df <- 2**df + matname <- "counts.csv" + } + } else if (grepl("sample", fn1, ignore.case = TRUE)) { + dbg("[upload_files] samples.csv : fn1 = ", fn1) + df0 <- read.as_matrix(fn2) + if (any(duplicated(rownames(df0)))) { + dup.rows <- rownames(df0)[which(duplicated(rownames(df0)))] + msg <- paste( + "Your samples file has duplicated entries: ", + dup.rows, ". This is not allowed, please correct." + ) + shinyWidgets::sendSweetAlert( + session = session, + title = "Duplicated sample name", + text = msg, + type = "error", + btn_labels = "OK", + ## btn_colors = "red", + closeOnClickOutside = FALSE, + ) + } else if (nrow(df0) > 1 && NCOL(df0) >= 1) { + df <- as.data.frame(df0) + matname <- "samples.csv" + } + } else if (grepl("contrast", fn1, ignore.case = TRUE)) { + dbg("[upload_files] contrasts.csv : fn1 = ", fn1) + df0 <- read.as_matrix(fn2) + if (any(duplicated(rownames(df0)))) { + dup.rows <- rownames(df0)[which(duplicated(rownames(df0)))] + msg <- paste( + "Your contrasts file has duplicated entries: ", + dup.rows, ". This is not allowed, please correct." + ) + shinyWidgets::sendSweetAlert( + session = session, + title = "Duplicated contrast name", + text = msg, + type = "error", + btn_labels = "OK", + ## btn_colors = "red", + closeOnClickOutside = FALSE, + ) + } else if (nrow(df0) > 1 && NCOL(df0) >= 1) { + df <- as.matrix(df0) + matname <- "contrasts.csv" + } + } + if (!is.null(matname)) { + matlist[[matname]] <- df } + } + } + } + + if ("counts.csv" %in% names(matlist)) { + ## Convert to gene names (need for biological effects) + dbg("[upload_files] converting probe names to symbols") + X0 <- matlist[["counts.csv"]] + pp <- rownames(X0) + rownames(X0) <- probe2symbol(pp) + sel <- !(rownames(X0) %in% c(NA, "", "NA")) + X0 <- X0[sel, ] + xx <- tapply(1:nrow(X0), rownames(X0), function(i) colSums(X0[i, , drop = FALSE])) + X0 <- do.call(rbind, xx) + matlist[["counts.csv"]] <- X0 + } - DT::selectRows(proxy = DT::dataTableProxy(ns("pgxtable")), selected=NULL) - - savedata_button <- NULL - if(enable_save) { - - dbg("[UploadBoard] observeEvent:savedata reacted") - ## -------------- save PGX file/object --------------- - pgxname <- sub("[.]pgx$","",new_pgx$name) - pgxname <- gsub("^[./-]*","",pgxname) ## prevent going to parent folder - pgxname <- paste0(gsub("[ \\/]","_",pgxname),".pgx") - pgxname - - pgxdir <- getPGXDIR() - fn <- file.path(pgxdir,pgxname) - fn <- iconv(fn, from = '', to = 'ASCII//TRANSLIT') - - ##!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ## Note: Currently we use 'ngs' as object name but want to go - ## towards 'pgx' as standard name. Actually saving as RDS - ## should be better. - ngs=new_pgx - save(ngs, file=fn) - - remove(ngs) - remove(new_pgx) - - - message("[UploadBoard::@savedata] updating PGXINFO") - pgx.initDatasetFolder(pgxdir, force=FALSE, verbose=TRUE) - ## reload_pgxdir(reload_pgxdir()+1) + ## put the matrices in the reactive values 'uploaded' + files.needed <- c("counts.csv", "samples.csv", "contrasts.csv") + if (length(matlist) > 0) { + matlist <- matlist[which(names(matlist) %in% files.needed)] + for (i in 1:length(matlist)) { + colnames(matlist[[i]]) <- gsub("[\n\t ]", "_", colnames(matlist[[i]])) + rownames(matlist[[i]]) <- gsub("[\n\t ]", "_", rownames(matlist[[i]])) + if (names(matlist)[i] %in% c("counts.csv", "contrasts.csv")) { + matlist[[i]] <- as.matrix(matlist[[i]]) + } else { + matlist[[i]] <- type.convert(matlist[[i]]) + } + m1 <- names(matlist)[i] + message("[upload_files] updating matrix ", m1) + uploaded[[m1]] <- matlist[[i]] + } + uploaded[["last_uploaded"]] <- names(matlist) + } + + message("[upload_files] done!\n") + }) + + ## ------------------------------------------------------------------ + ## Observer for loading from local exampledata.zip file + ## + ## Reads in the data files from zip and puts in the + ## reactive values object 'uploaded'. Then uploaded should + ## trigger the computePGX module. + ## ------------------------------------------------------------------ + shiny::observeEvent(input$load_example, { + if (input$load_example) { + zipfile <- file.path(FILES, "exampledata.zip") + readfromzip1 <- function(file) { + read.csv(unz(zipfile, file), + check.names = FALSE, stringsAsFactors = FALSE, + row.names = 1 + ) + } + readfromzip2 <- function(file) { + ## allows for duplicated names + df0 <- read.csv(unz(zipfile, file), check.names = FALSE, stringsAsFactors = FALSE) + mat <- as.matrix(df0[, -1]) + rownames(mat) <- as.character(df0[, 1]) + mat + } + uploaded$counts.csv <- readfromzip2("exampledata/counts.csv") + uploaded$samples.csv <- readfromzip1("exampledata/samples.csv") + uploaded$contrasts.csv <- readfromzip1("exampledata/contrasts.csv") + } else { + ## Remove files + uploaded$counts.csv <- NULL + uploaded$samples.csv <- NULL + uploaded$contrasts.csv <- NULL + } + }) + + ## ------------------------------------------------------------------ + ## Observer for loading CSV from local folder on + ## host/server using URL. Reads the CSV files from folder + ## and puts in the reactive values object 'uploaded'. + ## ------------------------------------------------------------------ + + if (ALLOW_URL_QUERYSTRING) { + shiny::observeEvent(session$clientData$url_search, { + ## ------------------------------------------------------------- + ## Parse URL query string + ## ------------------------------------------------------------- + query <- parseQueryString(session$clientData$url_search) + if (length(query) > 0) { + dbg("[UploadModule:parseQueryString] names.query =", names(query)) + for (i in 1:length(query)) { + dbg("[UploadModule:parseQueryString]", names(query)[i], "=>", query[[i]]) + } + } else { + dbg("[UploadModule:parseQueryString] no queryString!") + } + + if (!is.null(query[["csv"]])) { + qdir <- query[["csv"]] + dbg("[UploadModule:parseQueryString] *** parseQueryString ***") + dbg("[UploadModule:parseQueryString] qdir = ", qdir) + + counts_file <- file.path(qdir, "counts.csv") + samples_file <- file.path(qdir, "samples.csv") + if (!file.exists(counts_file)) { + dbg("[SERVER:parseQueryString] ***ERROR*** missing counts.csv in dir = ", qdir) + } + if (!file.exists(samples_file)) { + dbg("[SERVER:parseQueryString] ***ERROR*** missing samples.csv in dir = ", qdir) + } + if (!file.exists(counts_file) || !file.exists(samples_file)) { + return(NULL) + } + + FUN.readfromdir <- function() { + dbg("[UploadModule:parseQueryString] *** loading CSV from dir = ", qdir, "***") + + readfromdir1 <- function(file) { + read.csv(file, + check.names = FALSE, stringsAsFactors = FALSE, + row.names = 1 + ) } - - ## shiny::removeModal() - msg1 <- "Ready!" - ##beepr::beep(sample(c(3,4,5,6,8),1)) ## music!! - beepr::beep(10) ## short beep - - if(enable_save) { - msg1 <- "Ready!
    Your data is ready and has been saved in your library. You can now start exploring your data." - } else { - msg1 <- "Ready!
    Your data is ready. You can now start exploring your data." + readfromdir2 <- function(file) { + ## allows for duplicated names + df0 <- read.csv(file, check.names = FALSE, stringsAsFactors = FALSE) + mat <- as.matrix(df0[, -1]) + rownames(mat) <- as.character(df0[, 1]) + mat } - loadedDataset(loadedDataset()+1) ## notify new data uploaded - - showModal( - modalDialog( - HTML(msg1), - title = NULL, - size = "s", - footer = tagList( - modalButton("Start!") - ) - )) + + dbg("[UploadModule:parseQueryString] reading samples_csv = ", samples_file) + uploaded$samples.csv <- readfromdir1(samples_file) + + dbg("[UploadModule:parseQueryString] reading samples_csv = ", samples_file) + uploaded$counts.csv <- readfromdir2(counts_file) + uploaded$contrasts.csv <- NULL + + meta_file <- file.path(qdir, "meta.txt") + uploaded$meta <- NULL + if (file.exists(meta_file)) { + dbg("[UploadModule:parseQueryString] reading meta file = ", meta_file) + ## meta <- read.table(meta_file,sep='\t',header=TRUE,row.names=1) + meta <- read.table(meta_file, sep = "", header = TRUE, row.names = 1) + meta <- as.list(array(meta[, 1], dimnames = list(rownames(meta)))) + uploaded$meta <- meta + } + } + + shinyalert::shinyalert( + title = "Load CSV data from folder?", + text = paste0("folder = ", qdir), + callbackR = FUN.readfromdir, + confirmButtonText = "Load!", + type = "info" + ) + + dbg("[UploadModule:parseQueryString] dim(samples) = ", dim(uploaded$samples.csv)) + dbg("[UploadModule:parseQueryString] dim(counts) = ", dim(uploaded$counts.csv)) + + ## focus on this tab + updateTabsetPanel(session, "tabs", selected = "Upload data") + } + + if (0 && !is.null(query[["pgx"]])) { + qdir <- query[["pgx"]] + dbg("[UploadModule:parseQueryString] pgx =>", qdir) + + pgx_file <- query[["pgx"]] + pgx_file <- paste0(sub("[.]pgx$", "", pgx_file), ".pgx") + dbg("[UploadModule:parseQueryString] pgx_file = ", pgx_file) + + if (!file.exists(pgx_file)) { + dbg("[SERVER:parseQueryString] ***ERROR*** missing pgx_file", pgx_file) + return(NULL) + } + + dbg("[UploadModule:parseQueryString] 1:") + + FUN.readPGX <- function() { + dbg("[UploadModule:parseQueryString] *** loading PGX file = ", pgx_file, "***") + + load(pgx_file) ## load NGS/PGX + uploaded$pgx <- ngs + remove(ngs) + + uploaded$meta <- NULL + } + + dbg("[UploadModule:parseQueryString] 2:") + + shinyalert::shinyalert( + title = "Load PGX data from folder?", + text = paste0("folder = ", qdir), + callbackR = FUN.readPGX, + confirmButtonText = "Load!", + type = "info" + ) + + dbg("[UploadModule:parseQueryString] 3:") + + ## focus on this tab + updateTabsetPanel(session, "tabs", selected = "Upload data") + + dbg("[UploadModule:parseQueryString] 4:") + } + }) + + } + + ## ===================================================================== + ## ===================== checkTables =================================== + ## ===================================================================== + + checkTables <- shiny::reactive({ + ## check dimensions + status <- rep("please upload", 3) + files.needed <- c("counts.csv", "samples.csv", "contrasts.csv") + names(status) <- files.needed + files.nrow <- rep(NA, 3) + files.ncol <- rep(NA, 3) + + for (i in 1:3) { + fn <- files.needed[i] + upfile <- uploaded[[fn]] + if (fn %in% names(uploaded) && !is.null(upfile)) { + status[i] <- "OK" + files.nrow[i] <- nrow(upfile) + files.ncol[i] <- ncol(upfile) + } + } + + has.pgx <- ("pgx" %in% names(uploaded)) + if (has.pgx) has.pgx <- has.pgx && !is.null(uploaded[["pgx"]]) + if (has.pgx == TRUE) { + ## Nothing to check. Always OK. + } else if (!has.pgx) { + ## check rownames of samples.csv + if (status["samples.csv"] == "OK" && status["counts.csv"] == "OK") { + samples1 <- uploaded[["samples.csv"]] + counts1 <- uploaded[["counts.csv"]] + a1 <- mean(rownames(samples1) %in% colnames(counts1)) + a2 <- mean(samples1[, 1] %in% colnames(counts1)) + + if (a2 > a1 && NCOL(samples1) > 1) { + message("[UploadModuleServer] getting sample names from first column\n") + rownames(samples1) <- samples1[, 1] + uploaded[["samples.csv"]] <- samples1[, -1, drop = FALSE] + } + } + + ## check files: matching dimensions + if (status["counts.csv"] == "OK" && status["samples.csv"] == "OK") { + nsamples <- max(ncol(uploaded[["counts.csv"]]), nrow(uploaded[["samples.csv"]])) + ok.samples <- intersect( + rownames(uploaded$samples.csv), + colnames(uploaded$counts.csv) + ) + n.ok <- length(ok.samples) + message("[UploadModule::checkTables] n.ok = ", n.ok) + if (n.ok > 0 && n.ok < nsamples) { + ## status["counts.csv"] = "WARNING: some samples with missing annotation)" + } + + if (n.ok > 0) { + message("[UploadModule::checkTables] conforming samples/counts...") + uploaded[["samples.csv"]] <- uploaded$samples.csv[ok.samples, , drop = FALSE] + uploaded[["counts.csv"]] <- uploaded$counts.csv[, ok.samples, drop = FALSE] + } + + if (n.ok == 0) { + status["counts.csv"] <- "ERROR: colnames do not match (with samples)" + status["samples.csv"] <- "ERROR: rownames do not match (with counts)" + } + + dbg("[UploadModule::checkTables] dim(samples.csv) = ", dim(uploaded$samples.csv)) + dbg("[UploadModule::checkTables] dim(counts.csv) = ", dim(uploaded$counts.csv)) + } + + if (status["contrasts.csv"] == "OK" && status["samples.csv"] == "OK") { + samples1 <- uploaded[["samples.csv"]] + contrasts1 <- uploaded[["contrasts.csv"]] + group.col <- grep("group", tolower(colnames(samples1))) + old1 <- (length(group.col) > 0 && + nrow(contrasts1) < nrow(samples1) && + all(rownames(contrasts1) %in% samples1[, group.col]) + ) + old2 <- all(rownames(contrasts1) == rownames(samples1)) && + all(unique(as.vector(contrasts1)) %in% c(-1, 0, 1, NA)) + + old.style <- (old1 || old2) + if (old.style && old1) { + message("[UploadModule] WARNING: converting old1 style contrast to new format") + new.contrasts <- samples1[, 0] + if (NCOL(contrasts1) > 0) { + new.contrasts <- contrastAsLabels(contrasts1) + grp <- as.character(samples1[, group.col]) + new.contrasts <- new.contrasts[grp, , drop = FALSE] + rownames(new.contrasts) <- rownames(samples1) + } + dbg("[UploadModule] old.ct1 = ", paste(contrasts1[, 1], collapse = " ")) + dbg("[UploadModule] old.nn = ", paste(rownames(contrasts1), collapse = " ")) + dbg("[UploadModule] new.ct1 = ", paste(new.contrasts[, 1], collapse = " ")) + dbg("[UploadModule] new.nn = ", paste(rownames(new.contrasts), collapse = " ")) + + contrasts1 <- new.contrasts + } + if (old.style && old2) { + message("[UploadModule] WARNING: converting old2 style contrast to new format") + new.contrasts <- samples1[, 0] + if (NCOL(contrasts1) > 0) { + new.contrasts <- contrastAsLabels(contrasts1) + rownames(new.contrasts) <- rownames(samples1) + } + contrasts1 <- new.contrasts + } + + dbg("[UploadModule] 1 : dim.contrasts1 = ", dim(contrasts1)) + dbg("[UploadModule] 1 : dim.samples1 = ", dim(samples1)) + + ok.contrast <- length(intersect(rownames(samples1), rownames(contrasts1))) > 0 + if (ok.contrast && NCOL(contrasts1) > 0) { + ## always clean up + contrasts1 <- apply(contrasts1, 2, as.character) + rownames(contrasts1) <- rownames(samples1) + for (i in 1:ncol(contrasts1)) { + isz <- (contrasts1[, i] %in% c(NA, "NA", "NA ", "", " ", " ", " ", " NA")) + if (length(isz)) contrasts1[isz, i] <- NA + } + uploaded[["contrasts.csv"]] <- contrasts1 + status["contrasts.csv"] <- "OK" + } else { + uploaded[["contrasts.csv"]] <- NULL + status["contrasts.csv"] <- "ERROR: dimension mismatch" + } + } + + MAXSAMPLES <- 25 + MAXCONTRASTS <- 5 + MAXSAMPLES <- as.integer(limits["samples"]) + MAXCONTRASTS <- as.integer(limits["comparisons"]) + + ## check files: maximum contrasts allowed + if (status["contrasts.csv"] == "OK") { + if (ncol(uploaded[["contrasts.csv"]]) > MAXCONTRASTS) { + status["contrasts.csv"] <- paste("ERROR: max", MAXCONTRASTS, "contrasts allowed") + } + } + + ## check files: maximum samples allowed + if (status["counts.csv"] == "OK" && status["samples.csv"] == "OK") { + if (ncol(uploaded[["counts.csv"]]) > MAXSAMPLES) { + status["counts.csv"] <- paste("ERROR: max", MAXSAMPLES, " samples allowed") + } + if (nrow(uploaded[["samples.csv"]]) > MAXSAMPLES) { + status["samples.csv"] <- paste("ERROR: max", MAXSAMPLES, "samples allowed") + } + } + + ## check samples.csv: must have group column defined + if (status["samples.csv"] == "OK" && status["contrasts.csv"] == "OK") { + samples1 <- uploaded[["samples.csv"]] + contrasts1 <- uploaded[["contrasts.csv"]] + if (!all(rownames(contrasts1) %in% rownames(samples1))) { + status["contrasts.csv"] <- "ERROR: contrasts do not match samples" + } + } + } ## end-if-from-pgx + + e1 <- grepl("ERROR", status["samples.csv"]) + e2 <- grepl("ERROR", status["contrasts.csv"]) + e3 <- grepl("ERROR", status["counts.csv"]) + s1 <- "samples.csv" %in% uploaded$last_uploaded + s2 <- "contrasts.csv" %in% uploaded$last_uploaded + s3 <- "counts.csv" %in% uploaded$last_uploaded + + if (e1 || e2 || e3) { + message("[checkTables] ERROR in samples table : e1 = ", e1) + message("[checkTables] ERROR in contrasts table : e2 = ", e2) + message("[checkTables] ERROR in counts table : e2 = ", e3) + + if (e1 && !s1) { + uploaded[["samples.csv"]] <- NULL + status["samples.csv"] <- "please upload" + } + if (e2 && !s2) { + uploaded[["contrasts.csv"]] <- NULL + status["contrasts.csv"] <- "please upload" + } + if (e3 && !s3) { + uploaded[["counts.csv"]] <- NULL + status["counts.csv"] <- "please upload" + } + } + + + if (!is.null(uploaded$contrasts.csv) && + (is.null(uploaded$counts.csv) || + is.null(uploaded$samples.csv))) { + uploaded[["contrasts.csv"]] <- NULL + status["contrasts.csv"] <- "please upload" + } + + + ## check files + description <- c( + "Count/expression file with gene on rows, samples as columns", + "Samples file with samples on rows, phenotypes as columns", + ## "Gene information file with genes on rows, gene info as columns.", + "Contrast file with conditions on rows, contrasts as columns" + ) + df <- data.frame( + filename = files.needed, + description = description, + nrow = files.nrow, + ncol = files.ncol, + status = status + ) + rownames(df) <- files.needed + + ## deselect + ## DT::selectRows(proxy = DT::dataTableProxy("pgxtable"), selected=NULL) + return(df) + }) + + output$downloadExampleData <- shiny::downloadHandler( + filename = "exampledata.zip", + content = function(file) { + zip <- file.path(FILES, "exampledata.zip") + file.copy(zip, file) + } + ) + + output$upload_info <- shiny::renderUI({ + upload_info <- "

    User file upload

    Please prepare the data files in CSV format as listed below. It is important to name the files exactly as shown. The file format must be comma-separated-values (CSV) text. Be sure the dimensions, rownames and column names match for all files. You can download a zip file with example files here: EXAMPLEZIP. You can upload a maximum of LIMITS." + DLlink <- shiny::downloadLink(ns("downloadExampleData"), "exampledata.zip") + upload_info <- sub("EXAMPLEZIP", DLlink, upload_info) + + limits0 <- paste( + limits["datasets"], "datasets (with each up to", + limits["samples"], "samples and", + limits["comparisons"], "comparisons)" + ) + upload_info <- sub("LIMITS", limits0, upload_info) + shiny::HTML(upload_info) + }) + + ## ===================================================================== + ## ========================= SUBMODULES/SERVERS ======================== + ## ===================================================================== + + ## correctedX <- shiny::reactive({ + normalized_counts <- NormalizeCountsServerRT( + id = "normalize", + counts = shiny::reactive(uploaded$counts.csv), + height = height + ) + + ## correctedX <- shiny::reactive({ + correctedX <- BatchCorrectServer( + id = "batchcorrect", + X = shiny::reactive(uploaded$counts.csv), + ## X = normalized_counts, ## NOT YET!!!! + is.count = TRUE, + pheno = shiny::reactive(uploaded$samples.csv), + height = height + ) + + corrected_counts <- shiny::reactive({ + counts <- NULL + dbg("[UploadModule::corrected_counts] reacted!\n") + advanced_mode <- (length(input$advanced_mode) > 0 && + input$advanced_mode[1] == 1) + if (advanced_mode) { + message("[UploadModule::corrected_counts] using CORRECTED counts\n") + out <- correctedX() + counts <- pmax(2**out$X - 1, 0) + } else { + message("[UploadModule::corrected_counts] using UNCORRECTED counts\n") + counts <- uploaded$counts.csv + } + counts + }) + + ## mkContrast <- shiny::reactive({ + modified_ct <- MakeContrastServerRT( + id = "makecontrast", + phenoRT = shiny::reactive(uploaded$samples.csv), + contrRT = shiny::reactive(uploaded$contrasts.csv), + ## countsRT = shiny::reactive(uploaded$counts.csv), + countsRT = corrected_counts, + height = height + ) + + shiny::observeEvent(modified_ct(), { + ## Monitor for changes in the contrast matrix and if + ## so replace the uploaded reactive values. + ## + dbg("[observe:modified_ct()] reacted...") + modct <- modified_ct() + dbg("[observe:modified_ct()] dim(modct$contr) = ", dim(modct$contr)) + uploaded$contrasts.csv <- modct$contr + uploaded$samples.csv <- modct$pheno + }) + + upload_ok <- shiny::reactive({ + dbg("[UploadModule] upload_ok reactive") + check <- checkTables() + all(check[, "status"] == "OK") + all(grepl("ERROR", check[, "status"]) == FALSE) + }) + + batch_vectors <- shiny::reactive({ + dbg("batch_vectors reactive") + correctedX()$B + }) + + ## computed_pgx <- ComputePgxServer( + computed_pgx <- ComputePgxServer( + id = "compute", + ## countsRT = shiny::reactive(uploaded$counts.csv), + countsRT = corrected_counts, + samplesRT = shiny::reactive(uploaded$samples.csv), + contrastsRT = shiny::reactive(uploaded$contrasts.csv), + batchRT = batch_vectors, + metaRT = shiny::reactive(uploaded$meta), + enable_button = upload_ok, + alertready = FALSE, + FILES = FILES, + pgx.dirRT = shiny::reactive(pgx.dirRT()), + max.genes = as.integer(limits["genes"]), + max.genesets = as.integer(limits["genesets"]), + max.datasets = as.integer(limits["datasets"]), + height = height + ) + + uploaded_pgx <- shiny::reactive({ + dbg("[uploaded_pgx] reacted!") + if (!is.null(uploaded$pgx)) { + pgx <- uploaded$pgx + ## pgx <- pgx.initialize(pgx) + } else { + pgx <- computed_pgx() + } + return(pgx) + }) + + ## ===================================================================== + ## ===================== PLOTS AND TABLES ============================== + ## ===================================================================== + + output$countStats <- shiny::renderPlot({ + dbg("[countStats] renderPlot called") + + check <- checkTables() + status.ok <- check["counts.csv", "status"] + dbg("[countStats] status.ok = ", status.ok) + + if (status.ok != "OK") { + frame() + status.ds <- check["counts.csv", "description"] + msg <- paste( + toupper(status.ok), "\n", "(Required) Upload 'counts.csv'", + tolower(status.ds) + ) + graphics::text(0.5, 0.5, paste(strwrap(msg, 30), collapse = "\n"), col = "grey25") + graphics::box(lty = 2, col = "grey60") + return(NULL) + } + + counts <- uploaded[["counts.csv"]] + xx <- log2(1 + counts) + if (nrow(xx) > 1000) xx <- xx[sample(1:nrow(xx), 1000), , drop = FALSE] + ## dc <- reshape::melt(xx) + suppressWarnings(dc <- data.table::melt(xx)) + dc$value[dc$value == 0] <- NA + tt2 <- paste(nrow(counts), "genes x", ncol(counts), "samples") + ggplot2::ggplot(dc, ggplot2::aes(x = value, color = Var2)) + + ggplot2::geom_density() + + ggplot2::xlab("log2(1+counts)") + + ggplot2::theme(legend.position = "none") + + ggplot2::ggtitle("COUNTS", subtitle = tt2) + }) + + output$phenoStats <- shiny::renderPlot({ + dbg("[phenoStats] renderPlot called \n") + ## req(uploaded$samples.csv) + + check <- checkTables() + status.ok <- check["samples.csv", "status"] + if (status.ok != "OK") { + frame() + status.ds <- check["samples.csv", "description"] + msg <- paste( + toupper(status.ok), "\n", "(Required) Upload 'samples.csv'", + tolower(status.ds) + ) + graphics::text(0.5, 0.5, paste(strwrap(msg, 30), collapse = "\n"), col = "grey25") + graphics::box(lty = 2, col = "grey60") + return(NULL) + } + + pheno <- uploaded[["samples.csv"]] + px <- head(colnames(pheno), 20) ## show maximum?? + + df <- type.convert(pheno[, px, drop = FALSE]) + vt <- df %>% inspectdf::inspect_types() + vt + + ## discretized continuous variable into 10 bins + ii <- unlist(vt$col_name[c("numeric", "integer")]) + ii + if (!is.null(ii) && length(ii)) { + cat("[UploadModule::phenoStats] discretizing variables:", ii, "\n") + df[, ii] <- apply(df[, ii, drop = FALSE], 2, function(x) { + if (any(is.infinite(x))) x[which(is.infinite(x))] <- NA + cut(x, breaks = 10) }) + } + + p1 <- df %>% + inspectdf::inspect_cat() %>% + inspectdf::show_plot() + tt2 <- paste(nrow(pheno), "samples x", ncol(pheno), "phenotypes") + ## tt2 <- paste(ncol(pheno),"phenotypes") + p1 <- p1 + ggplot2::ggtitle("PHENOTYPES", subtitle = tt2) + + ggplot2::theme( + ## axis.text.x = ggplot2::element_text(size=8, vjust=+5), + axis.text.y = ggplot2::element_text( + size = 12, + margin = ggplot2::margin(0, 0, 0, 25), + hjust = 1 + ) + ) + + dbg("[UploadModule::phenoStats] done!") + + p1 + }) + + output$contrastStats <- shiny::renderPlot({ + ## req(uploaded$contrasts.csv) + ct <- uploaded$contrasts.csv + has.contrasts <- !is.null(ct) && NCOL(ct) > 0 + check <- checkTables() + status.ok <- check["contrasts.csv", "status"] + + dbg("[output$contrastStats] status.ok = ", status.ok) + dbg("[output$contrastStats] has.contrasts = ", has.contrasts) + dbg( + "[output$contrastStats] dim(uploaded$contrasts.csv) = ", + dim(uploaded$contrasts.csv) + ) + + if (status.ok != "OK" || !has.contrasts) { + frame() + status.ds <- check["contrasts.csv", "description"] + msg <- paste( + toupper(status.ok), "\n", "(Optional) Upload 'contrasts.csv'", + tolower(status.ds) + ) + ## text(0.5,0.5,"Please upload contrast file 'contrast.csv' with conditions on rows, contrasts as columns") + graphics::text(0.5, 0.5, paste(strwrap(msg, 30), collapse = "\n"), col = "grey25") + graphics::box(lty = 2, col = "grey60") + return(NULL) + } + + dbg("[output$contrastStats] 2 : ") + contrasts <- uploaded$contrasts.csv + + dbg("[output$contrastStats] 3 : ") + + ## contrasts <- sign(contrasts) + ## df <- contrastAsLabels(contrasts) + df <- contrasts + px <- head(colnames(df), 20) ## maximum to show?? + df <- data.frame(df[, px, drop = FALSE], check.names = FALSE) + tt2 <- paste(nrow(contrasts), "samples x", ncol(contrasts), "contrasts") + ## tt2 <- paste(ncol(contrasts),"contrasts") + dbg("[output$contrastStats] 4a : dim.df=", dim(df)) + + p1 <- df %>% + inspectdf::inspect_cat() %>% + inspectdf::show_plot() + dbg("[output$contrastStats] 4b : ") + + p1 <- p1 + ggplot2::ggtitle("CONTRASTS", subtitle = tt2) + + ggplot2::theme( + ## axis.text.x = ggplot2::element_text(size=8, vjust=+5), + axis.text.y = ggplot2::element_text( + size = 12, + margin = ggplot2::margin(0, 0, 0, 25), + hjust = 1 + ) + ) + + dbg("[output$contrastStats] 5 : ") + + p1 + }) + + sel.conditions <- shiny::reactive({ + message("[MakeContrastServer] sel.conditions : reacted") + shiny::req(phenoRT(),corrected_counts()) + df <- phenoRT() + message("[MakeContrastServer] sel.conditions : dim.df = ", + paste(dim(df),collapse='x')) + + if("" %in% input$param) { + df$"" <- rownames(df) + } + if("" %in% input$param) { + gene <- input$gene + if(gene %in% rownames(corrected_counts())) { + gx <- log2(1 + corrected_counts()[gene,]) + ##df$"" <- c("low","high")[1 + 1*(gx >= mean(gx,na.rm=TRUE))] + df$"" <- gx + } else { + return(NULL) + } + } + + df <- type.convert(df) + ii <- which(sapply(type.convert(df),class) %in% c("numeric","integer")) + ii + if(length(ii)) { + for(i in ii) { + x = df[,i] + df[,i] <- c("low","high")[1 + 1*(x >= mean(x,na.rm=TRUE))] + } + } + + pp <- intersect(input$param, colnames(df)) + ss <- colnames(corrected_counts()) + cond <- apply(df[ss,pp,drop=FALSE],1,paste,collapse="_") + cond <- gsub("^_|_$","",cond) + cond + }) + + shiny::observeEvent( input$addcontrast, { + + message("[MakeContrastServer:addcontrast] reacted") + + cond <- sel.conditions() + message("[MakeContrastServer:addcontrast] len.cond = ",length(cond)) + message("[MakeContrastServer:addcontrast] cond = ",paste(cond,collapse=' ')) + if(length(cond)==0 || is.null(cond)) return(NULL) + + group1 <- input$group1 + group2 <- input$group2 + in.main <- 1*(cond %in% group1) + in.ref1 <- 1*(cond %in% group2) + in.ref2 <- ("" %in% group2) & (!cond %in% group1) + in.ref <- in.ref1 | in.ref2 + + message("[MakeContrastServer:addcontrast] 1 : ") + + ## ctx <- 1*(in.main) - 1*(in.ref) + ##ct.name <- paste0(input$group1name,"_vs_",input$group2name) + ct.name <- input$newname + gr1 <- gsub(".*:|_vs_.*","",ct.name) ## first is MAIN group!!! + gr2 <- gsub(".*_vs_|@.*","",ct.name) + ctx <- c(NA,gr1, gr2)[1 + 1*in.main + 2*in.ref] + + if( sum(in.main)==0 || sum(in.ref)==0 ) { + shinyalert::shinyalert("ERROR","Both groups must have samples") + return(NULL) + } + if(ct.name %in% c(NA,""," ")) { + shinyalert::shinyalert("ERROR","You must give a contrast name") + return(NULL) + } + if(1 && gr1 == gr2) { + shinyalert::shinyalert("ERROR","Invalid contrast name") + return(NULL) + } + if(!is.null(rv$contr) && ct.name %in% colnames(rv$contr)) { + shinyalert::shinyalert("ERROR","Contrast name already exists.") + return(NULL) + } + if(!grepl('_vs_',ct.name)) { + shinyalert::shinyalert("ERROR","Contrast must include _vs_ in name") + return(NULL) + } + + message("[MakeContrastServer:addcontrast] update reactive values : 1") + + ## update reactive value + samples = colnames(corrected_counts()) + + message("[MakeContrastServer:addcontrast] 1 : samples = ",samples) + message("[MakeContrastServer:addcontrast] 1 : ct.name = ",ct.name) + message("[MakeContrastServer:addcontrast] 1 : len.ctx = ",length(ctx)) + + ctx1 <- matrix(ctx, ncol=1, dimnames=list(samples,ct.name)) + if(is.null(rv$contr)) { + rv$contr <- ctx1 + } else { + rv$contr <- cbind(rv$contr, ctx1) + } + + message("[MakeContrastServer:addcontrast] update reactive values : 2") + message("[MakeContrastServer:addcontrast] ct.name in pheno = ",ct.name %in% colnames(rv$pheno)) + + ##if(any(input$param %in% c('',''))) { + if(any(input$param %in% c(''))) { + if(is.null(rv$pheno) || NCOL(rv$pheno)==0 ) { + rv$pheno <- ctx1 + } else { + message("[MakeContrastServer:addcontrast] add to cond : dim(ctx1) = ",dim(ctx1)) + if(!ct.name %in% colnames(rv$pheno)) { + rv$pheno <- cbind(rv$pheno, ctx1) + } + } + } + + message("[MakeContrastServer:addcontrast] done!") + + }) + + output$createcomparison <- shiny::renderUI({ + + shiny::req(input$param) + cond <- sel.conditions() + if(length(cond)==0 || is.null(cond)) return(NULL) + + items <- c("",sort(unique(cond))) + message("[MakeContrastServer:createcomparison] items=",items) + + shiny::tagList( + shiny::tags$head(shiny::tags$style(".default-sortable .rank-list-item {padding: 2px 15px;}")), + sortable::bucket_list( + ##header = shiny::h4("Create comparison:"), + header = NULL, + sortable::add_rank_list( + text = "Conditions:", + labels = items + ), + sortable::add_rank_list( + input_id = ns("group1"), + text = "Main group:" + ), + sortable::add_rank_list( + input_id = ns("group2"), + text = "Control group:" + ), + group_name = "cmpbucket" + ) + ) + }) + + buttonInput <- function(FUN, len, id, ...) { + inputs <- character(len) + for (i in seq_len(len)) { + inputs[i] <- as.character(FUN(paste0(id, i), ...)) + } + inputs } - + + output$contrastTable <- DT::renderDataTable({ + + message("[MakeContrastServer:contrastTable] called!") + + ct <- rv$contr + + message("[contrastTable] is.null(ct) = ",is.null(ct)) + message("[contrastTable] dim.ct = ",dim(ct)) + message("[contrastTable] dim.contrRT = ",dim(contrRT())) + + if(is.null(ct) || NCOL(ct)==0) { + df <- data.frame( + delete = 0, + comparison = "", + n1 = 0, + n0 = 0, + "main.group" = "", + "control.group" = "" + )[0,] + } else { + message("[contrastTable] ct.rownames= ",paste(rownames(ct),collapse=' ')) + message("[contrastTable] ct.colnames= ",paste(colnames(ct),collapse=' ')) + + paste.max <- function(x,n=6) { + ##x <- unlist(x) + if(length(x)>n) { + x <- c(x[1:n], paste("+",length(x)-n,"others")) + } + paste(x,collapse=" ") + } + + ct1 <- makeContrastsFromLabelMatrix(ct) + ct1[is.na(ct1)] <- 0 + + if(NCOL(ct)==1) { + ss1 <- names(which(ct1[,1] > 0)) + ss2 <- names(which(ct1[,1] < 0)) + ss1 <- paste.max(ss1,6) + ss2 <- paste.max(ss2,6) + } else { + ss0 <- rownames(ct) + ss1 <- apply(ct1,2,function(x) paste.max(ss0[which(x > 0)])) + ss2 <- apply(ct1,2,function(x) paste.max(ss0[which(x < 0)])) + } + + deleteButtons <- buttonInput( + FUN = actionButton, + len = ncol(ct), + ##id = 'contrast_delete_', + id = paste0('contrast_delete_',sample(99999,1),"_"), ## hack to allow double click + label = "", + ##size = "mini", + width = "50px", + inline = TRUE, + icon = shiny::icon("trash-alt"), + class = "btn-inline btn-outline-danger-hover", + style='padding:2px; margin:2px; font-size:95%; color: #B22222;', + ##onclick = 'Shiny.onInputChange(\"contrast_delete\",this.id)' + onclick = paste0('Shiny.onInputChange(\"',ns("contrast_delete"),'\",this.id)') + ) + + df <- data.frame( + delete = deleteButtons, + comparison = colnames(ct1), + n1 = colSums(ct1 > 0), + n0 = colSums(ct1 < 0 ), + "main.group" = ss1, + "control.group" = ss2 + ) + + } + rownames(df) <- NULL + + DT::datatable( + df, rownames=FALSE, + escape = c(-1), + selection = 'none', + class="compact cell-border", + options = list( + dom = 't', + pageLength = 999, + ## autoWidth = TRUE, ## scrollX=TRUE, + columnDefs = list( + list(width='20px', targets=c(0,2,3)), + list(width='150px', targets=c(1)), + list(width='400px', targets=c(4,5)) + ) + ) + ) %>% + DT::formatStyle(0, target='row', fontSize='12px', lineHeight='99%') + }, server=FALSE) + + shiny::observeEvent( input$contrast_delete, { + ## Observe if a contrast is to be deleted + ## + id <- as.numeric(gsub(".*_","",input$contrast_delete)) + message('[contrast_delete] clicked on delete contrast',id) + if(length(id)==0) return(NULL) + ##updateActionButton(session, paste0("contrast_delete_",id),label="XXX") + if(!is.null(rv$contr) && NCOL(rv$contr) <= 1) { + rv$contr <- rv$contr[,0,drop=FALSE] + } else { + rv$contr <- rv$contr[,-id,drop=FALSE] + } + }) + + output$checkTablesOutput <- DT::renderDataTable({ + ## Render the upload status table + ## + if (!input$advanced_mode) { + return(NULL) + } + df <- checkTables() + dt <- DT::datatable( + df, + rownames = FALSE, + selection = "none", + class = "compact cell-border", + options = list( + dom = "t" + ) + ) %>% + DT::formatStyle(0, target = "row", fontSize = "12px", lineHeight = "100%") + }) + + upload_plot_pcaplot_server( + "pcaplot", + phenoRT = phenoRT, + countsRT = corrected_counts, + sel.conditions = sel.conditions, + watermark = FALSE + ) + ##------------------------------------------------ ## Board return object ##------------------------------------------------ res <- list( - loaded = loadedDataset + loaded = loadedDataset ) return(res) }) diff --git a/components/board.upload/R/upload_ui.R b/components/board.upload/R/upload_ui.R index bb489d98a..ef60a9722 100644 --- a/components/board.upload/R/upload_ui.R +++ b/components/board.upload/R/upload_ui.R @@ -4,16 +4,187 @@ ## UploadInputs <- function(id) { - ns <- shiny::NS(id) ## namespace + ns <- shiny::NS(id) ## namespace bigdash::tabSettings( - ## shiny::actionLink(ns("module_info"), "Tutorial", icon = shiny::icon("youtube")) + shiny::hr(), shiny::br(), + withTooltip(shiny::selectInput(ns("fa_contrast"), "Contrast:", + choices = NULL), + "Select the contrast corresponding to the comparison of interest.", + placement = "top" + ), + withTooltip(shiny::actionLink(ns("fa_options"), "Options", + icon = icon("cog", lib = "glyphicon")), + "Show/hide advanced options", + placement = "top" + ), + shiny::br(), + shiny::conditionalPanel( + "input.fa_options % 2 == 1", + ns = ns, + shiny::tagList( + withTooltip( + shiny::checkboxInput(ns("fa_filtertable"), + "filter signficant (tables)", + FALSE), + "Click to filter the significant entries in the tables." + ) + ) + ) ) } UploadUI <- function(id) { - ns <- shiny::NS(id) ## namespace - shiny::tagList( - uiOutput(ns("navheader")), - UploadModuleUI(ns("upload_panel")) + ns <- shiny::NS(id) ## namespace + + tabs <- shiny::tabsetPanel( + id = ns("tabs"), + shiny::tabPanel( + "Upload", + div( + class = "row", + div( + class = "col-md-3", + shiny::sidebarPanel( + width = "100%", + fileInput2(ns("upload_files"), + shiny::h4("Choose files"), + multiple = TRUE, accept = c(".csv", ".pgx") + ), + shinyWidgets::prettySwitch(ns("load_example"), "Load example data"), + shinyWidgets::prettySwitch(ns("advanced_mode"), "Batch correction (beta)") + ) + ), + div( + class = "col-md-9", + shiny::HTML( + "

    User file upload

    Please prepare the data files + in CSV format as listed below. It is important to name the files + exactly as shown. The file format must be comma-separated-values + (CSV) text. Be sure the dimensions, rownames and column names match + for all files. You can download a zip file with example files here: + EXAMPLEZIP. You can upload a maximum of LIMITS." + ) + ) + ), + div( + class = "row", + div( + class = "col-md-4", + shiny::plotOutput(ns("countStats")) %>% shinycssloaders::withSpinner() + ), + div( + class = "col-md-4", + shiny::plotOutput(ns("phenoStats")) %>% shinycssloaders::withSpinner() + ), + div( + class = "col-md-4", + shiny::plotOutput(ns("contrastStats")) %>% shinycssloaders::withSpinner() + ) + ) + ), + shiny::tabPanel( + "BatchCorrect", + shiny::fillCol( + height = height, + BatchCorrectUI(ns("batchcorrect")) + ) + ), + shiny::tabPanel( + "Contrasts", + shiny::fillCol( + height = 750, + flex = c(1,NA,NA,1), + shiny::fillRow( + flex = c(3,0.06,1.0), + shiny::fillCol( + flex = c(NA,NA,1.0), + shiny::h4("Create comparisons"), + ##p(help_text), + shiny::fillRow( + flex = c(1,4), + shiny::fillCol( + flex = c(NA,NA,NA,NA,1), + tipifyL( + shiny::selectInput(ns("param"), "Phenotype:", + choices = NULL, + multiple = TRUE), + "Select phenotype(s) to create conditions for your groups. Select if you want to split by high/low expression of some gene. Select if you want to group manually on sample names. You can select multiple phenotypes to create combinations." + ), + shiny::conditionalPanel( + "input.param == ''", ns=ns, + ##tipifyL( + shiny::selectizeInput(ns("gene"), "Gene:", choices=NULL, + multiple=FALSE), + ##"Select gene to divide your samples into high and low expression of that gene.") + ), + shiny::br(), + tipifyL( + shiny::textInput(ns("newname"), "Comparison name:", + placeholder="e.g. MAIN_vs_CONTROL"), + "Give a name for your contrast as MAIN_vs_CONTROL, with the name of the main group first. You must keep _vs_ in the name to separate the names of the two groups."), + shiny::br(), + ## tipifyL( + shiny::actionButton(ns("addcontrast"), + "add comparison", + icon=icon("plus"), + class = "btn-outline-primary"), + ##"After creating the groups, press this button to add the comparison to the table."a), + shiny::br() + ), + withTooltip( + shiny::uiOutput(ns("createcomparison"), + style="font-size:13px; height: 280px; overflow-y: scroll;"), + "Create comparisons by dragging conditions into the main or control groups on the right. Then press add comparison to add the contrast to the table.", + placement="top", options = list(container = "body")) + ) + ), + shiny::br(), + ##plotOutput(ns("pcaplot"), height="330px") + upload_plot_pcaplot_ui( + ns("pcaplot"), + height = c(320,700), + width = c("auto",800) + ) + + # plotWidget(ns("pcaplot")) + ), + shiny::h4("Contrast table"), + shiny::fillRow( + height = 24, + flex = c(NA,0.05,NA,NA,1), + withTooltip( + shiny::actionButton(ns("autocontrast"), + "add auto-contrasts", + icon=icon("plus"), + class="small-button btn-outline-primary"), + "If you are feeling lucky, try this to automatically create contrasts.", + placement="top", options = list(container = "body") + ), + shiny::br(), + shiny::div( shiny::HTML("Strata:"), style="padding: 4px 4px;"), + shiny::selectInput(ns("strata"), NULL, choices=NULL, width="120px"), + shiny::br() + ), + # shiny::br(), + ##shiny::tags$head(shiny::tags$style("table.dataTable.compact tbody th, table.dataTable.compact tbody td {padding: 0px 10px;}")), + ## this.style(ns("contrastTable"), "table.dataTable.compact tbody th, table.dataTable.compact tbody td {padding: 0px 10px;}"), + shiny::div(DT::dataTableOutput(ns("contrastTable")), + style="font-size:13px; height: 300px; margin-top: 20px;overflow-y: scroll;") + ) + # shiny::uiOutput(ns("contrasts_UI")) + ), + shiny::tabPanel( + "Compute", + shiny::fillCol( + height = height, ## width = 1200, + ComputePgxUI(ns("compute")) + ) + ) + ) + + page_ui <- div( + boardHeader(title = "Upload data", info_link = ns("module_info")), + tabs ) + return(page_ui) }