From 3874ce028c2c7a709a8c6694dd9561ab94d9bcb9 Mon Sep 17 00:00:00 2001 From: dmattek Date: Thu, 20 Jul 2017 11:27:06 +0200 Subject: [PATCH] Added: - box-/dot-/violin plots at discrete time points --- global.R | 1 + modules/tabBoxPlot.R | 264 +++++++++++++++++++++++++++++++++++++++++++ modules/tabScatter.R | 1 + server.R | 113 +++--------------- ui.R | 39 ++----- 5 files changed, 289 insertions(+), 129 deletions(-) create mode 100644 modules/tabBoxPlot.R diff --git a/global.R b/global.R index 4002e27..6a1e234 100644 --- a/global.R +++ b/global.R @@ -2,4 +2,5 @@ source('modules/auxfunc.R') source('modules/downPlot.R') source('modules/downCellIDsCls.R') source('modules/tabScatter.R') +source('modules/tabBoxPlot.R') source('modules/tabClBay.R') \ No newline at end of file diff --git a/modules/tabBoxPlot.R b/modules/tabBoxPlot.R new file mode 100644 index 0000000..fac6c6e --- /dev/null +++ b/modules/tabBoxPlot.R @@ -0,0 +1,264 @@ +require(DT) + +tabBoxPlotUI = function(id, label = "Comparing t-points") { + ns <- NS(id) + + tagList( + uiOutput(ns('varSelTpts')), + + DT::dataTableOutput(ns('outTabStats')), + downloadButton(ns('downloadData4BoxPlot'), 'Download single-cell data'), + + fluidRow( + column( + 6, + radioButtons(ns('inPlotType'), 'Plot type:', list('Box-plot' = 'box', + 'Dot-plot' = 'dot', + 'Violin-plot' = 'viol', + 'Line-plot' = 'line')), + uiOutput(ns('uiPlotBoxNotches')), + uiOutput(ns('uiPlotBoxOutliers')), + uiOutput(ns('uiPlotDotNbins')) + ), + column( + 6, + selectInput( + ns('selPlotBoxLegendPos'), + label = 'Select legend position', + choices = list( + "Top" = 'top', + "Right" = 'right', + "Bottom" = 'bottom' + ), + selected = 'top' + ) + ) + ), + + actionButton(ns('butPlotBox'), 'Plot!'), + plotOutput(ns('outPlotBox'), height = 800), + downPlotUI(ns('downPlotBox'), "Download PDF") + ) + +} + +#### +## server box-plot +tabBoxPlot = function(input, output, session, in.data) { + # return all unique time points (real time) + # This will be used to display in UI for box-plot + # These timepoints are from the original dt and aren't affected by trimming of x-axis + getDataTpts <- reactive({ + cat(file = stderr(), 'getDataTpts\n') + loc.dt = in.data() + + if (is.null(loc.dt)) + return(NULL) + else + return(unique(loc.dt[, realtime])) # column name specified in data4trajPlot + }) + + # prepare data for plotting boxplots + # uses the same dt as for trajectory plotting + # returns dt with these columns: + data4boxPlot <- reactive({ + cat(file = stderr(), 'data4boxPlot\n') + + loc.dt = in.data() + if (is.null(loc.dt)) + return(NULL) + + loc.out = loc.dt[realtime %in% input$inSelTpts] + }) + + output$varSelTpts = renderUI({ + cat(file = stderr(), 'UI varSelTpts\n') + + ns <- session$ns + + loc.v = getDataTpts() + if (!is.null(loc.v)) { + selectInput( + ns('inSelTpts'), + 'Select one or more timepoints:', + loc.v, + width = '100%', + selected = 0, + multiple = TRUE + ) + } + }) + + output$uiPlotBoxNotches = renderUI({ + cat(file = stderr(), 'UI uiPlotBoxNotches\n') + + ns <- session$ns + + if(input$inPlotType == 'box') + checkboxInput(ns('inPlotBoxNotches'), 'Box plot notches?', FALSE) + }) + + output$uiPlotBoxOutliers = renderUI({ + cat(file = stderr(), 'UI uiPlotBoxNotches\n') + + ns <- session$ns + + if(input$inPlotType == 'box') + checkboxInput(ns('inPlotBoxOutliers'), 'Box plot outliers?', FALSE) + }) + + output$uiPlotDotNbins = renderUI({ + cat(file = stderr(), 'UI uiPlotDotNbins\n') + + ns <- session$ns + + if(input$inPlotType == 'dot') + sliderInput(ns('inPlotDotNbins'), 'Dot-plot binsize:', min = 0.01, max = 1, value = .1) + }) + + + calcStats = reactive({ + cat(file = stderr(), 'tabBoxPlot: calsStats\n') + loc.dt = data4boxPlot() + + if (is.null(loc.dt)) + return(NULL) + + loc.dt.aggr = loc.dt[, sapply(.SD, function(x) list('Mean' = mean(x), 'CV' = sd(x)/mean(x), 'Median' = median(x), 'rCV (IQR)' = IQR(x)/median(x), 'rCV (MAD)'= mad(x)/median(x))), .SDcols = c('y'), by = .(realtime, group)] + setnames(loc.dt.aggr, c('Time point', 'Group', 'Mean', 'CV', 'Median', 'rCV IQR', 'rCV MAD')) + print(loc.dt.aggr) + return(loc.dt.aggr) + }) + + output$downloadData4BoxPlot <- downloadHandler( + filename = 'data4boxplot.csv', + content = function(file) { + write.csv(data4boxPlot(), file, row.names = FALSE) + } + ) + + + # output$outTabStats = DT::renderDataTable(calcStats(), + # server = FALSE, + # rownames = FALSE, + # extensions = 'Buttons', + # options = list( + # dom = 'Bfrtip', + # buttons = list('copy', + # 'print', + # list(extend = 'collection', + # buttons = list(list(extend='csv', + # filename = 'hitStats'), + # list(extend='excel', + # filename = 'hitStats'), + # list(extend='pdf', + # filename= 'hitStats')), + # text = 'Download')))) + # + output$outTabStats = DT::renderDataTable(server = FALSE, { + cat(file = stderr(), 'tabBoxPlot: outTabStats\n') + loc.dt = calcStats() + + if (is.null(loc.dt)) + return(NULL) + + datatable(loc.dt, + rownames = FALSE, + extensions = 'Buttons', + options = list( + dom = 'Bfrtip', + buttons = list('copy', + 'print', + list(extend = 'collection', + buttons = list(list(extend='csv', + filename = 'hitStats'), + list(extend='excel', + filename = 'hitStats'), + list(extend='pdf', + filename= 'hitStats')), + text = 'Download')))) %>% formatRound(3:7, 3) + }) + + # Boxplot - display + output$outPlotBox = renderPlot({ + locBut = input$butPlotBox + + if (locBut == 0) { + cat(file = stderr(), 'plotBox: Go button not pressed\n') + return(NULL) + } + + plotBox() + + }, height = 800) + + # Boxplot - download pdf + callModule(downPlot, "downPlotBox", 'boxplot.pdf', plotBox, TRUE) + + # Function instead of reactive as per: + # http://stackoverflow.com/questions/26764481/downloading-png-from-shiny-r + # This function is used to plot and to downoad a pdf + + plotBox <- function() { + cat(file = stderr(), 'plotBox\n') + + loc.dt = data4boxPlot() + + cat(file = stderr(), "plotBox: on to plot\n\n") + if (is.null(loc.dt)) { + cat(file = stderr(), 'plotBox: dt is NULL\n') + return(NULL) + } + + cat(file = stderr(), 'plotBox:dt not NULL\n') + + + + p.out = ggplot(loc.dt, aes(x = as.factor(realtime), y = y)) + + if (input$inPlotType == 'box') + p.out = p.out + geom_boxplot( + aes(fill = group), + #position = position_dodge(width = 1), + notch = input$inPlotBoxNotches, + outlier.colour = if (input$inPlotBoxOutliers) + 'red' + else + NA + ) + + if(input$inPlotType == 'dot') + p.out = p.out + geom_dotplot(aes(fill = group), binaxis = "y", stackdir = "center", position = "dodge", binwidth = input$inPlotDotNbins, method = 'histodot') + + if(input$inPlotType == 'viol') + p.out = p.out + geom_violin(aes(fill = group)) + + if(input$inPlotType == 'line') + p.out = p.out + geom_path(aes(color = group, group = id)) + + p.out = p.out + + scale_fill_discrete(name = '') + + xlab('\nTime (min)') + + ylab('') + + theme_bw(base_size = 18, base_family = "Helvetica") + + theme( + panel.grid.minor = element_blank(), + panel.grid.major = element_blank(), + panel.border = element_blank(), + axis.line.x = element_line(color = "black", size = 0.25), + axis.line.y = element_line(color = "black", size = 0.25), + axis.text.x = element_text(size = 12), + axis.text.y = element_text(size = 12), + strip.text.x = element_text(size = 14, face = "bold"), + strip.text.y = element_text(size = 14, face = "bold"), + strip.background = element_blank(), + legend.key = element_blank(), + legend.key.height = unit(1, "lines"), + legend.key.width = unit(2, "lines"), + legend.position = input$selPlotBoxLegendPos + ) + + return(p.out) + } + +} \ No newline at end of file diff --git a/modules/tabScatter.R b/modules/tabScatter.R index 3806f52..acdbd68 100644 --- a/modules/tabScatter.R +++ b/modules/tabScatter.R @@ -12,6 +12,7 @@ require(plotly) # interactive plot require(robust) +require(MASS) # UI tabScatterPlotUI <- function(id, label = "Comparing t-points") { diff --git a/server.R b/server.R index 2ad4a81..55f6199 100644 --- a/server.R +++ b/server.R @@ -20,7 +20,7 @@ library(sparcl) # sparse hierarchical and k-means library(scales) # for percentages on y scale # increase file upload limit -options(shiny.maxRequestSize = 30 * 1024 ^ 2) +options(shiny.maxRequestSize = 80 * 1024 ^ 2) shinyServer(function(input, output, session) { useShinyjs() @@ -377,9 +377,18 @@ shinyServer(function(input, output, session) { if (is.null(loc.dt)) return(NULL) - loc.dt[, trackObjectsLabelUni := paste(sprintf("%03d", get(input$inSelSite)), - sprintf("%04d", get(input$inSelTrackLabel)), - sep = "_")] + loc.types = lapply(loc.dt, class) + if(loc.types[[input$inSelTrackLabel]] == 'numeric') + { + loc.dt[, trackObjectsLabelUni := paste(sprintf("%03d", get(input$inSelSite)), + sprintf("%04d", get(input$inSelTrackLabel)), + sep = "_")] + } else { + loc.dt[, trackObjectsLabelUni := paste(sprintf("%03s", get(input$inSelSite)), + sprintf("%s", get(input$inSelTrackLabel)), + sep = "_")] + } + return(loc.dt) }) @@ -559,18 +568,6 @@ shinyServer(function(input, output, session) { return(loc.out) }) - # prepare data for plotting boxplots - # uses the same dt as for trajectory plotting - # returns dt with these columns: - data4boxPlot <- reactive({ - cat(file = stderr(), 'data4boxPlot\n') - - loc.dt = data4trajPlot() - if (is.null(loc.dt)) - return(NULL) - - loc.out = loc.dt[realtime %in% input$inSelTpts] - }) # prepare data for clustering @@ -718,89 +715,9 @@ shinyServer(function(input, output, session) { } + ###### Box-plot + callModule(tabBoxPlot, 'tabBoxPlot', data4trajPlot) - #### - ## UI for box-plot - - output$varSelTpts = renderUI({ - cat(file = stderr(), 'UI varSelTpts\n') - - loc.v = getDataTpts() - if (!is.null(loc.v)) { - selectInput( - 'inSelTpts', - 'Select one or more timepoints:', - loc.v, - width = '100%', - selected = 0, - multiple = TRUE - ) - } - }) - - # Boxplot - display - output$outPlotBox = renderPlot({ - locBut = input$butPlotBox - - if (locBut == 0) { - cat(file = stderr(), 'plotBox: Go button not pressed\n') - return(NULL) - } - - plotBox() - - }, height = 800) - - # Boxplot - download pdf - callModule(downPlot, "downPlotBox", 'boxplot.pdf', plotBox, TRUE) - - # Function instead of reactive as per: - # http://stackoverflow.com/questions/26764481/downloading-png-from-shiny-r - # This function is used to plot and to downoad a pdf - - plotBox <- function() { - cat(file = stderr(), 'plotBox\n') - - loc.dt = data4boxPlot() - - cat(file = stderr(), "plotBox: on to plot\n\n") - if (is.null(loc.dt)) { - cat(file = stderr(), 'plotBox: dt is NULL\n') - return(NULL) - } - - cat(file = stderr(), 'plotBox:dt not NULL\n') - - - - ggplot(loc.dt, aes(x = as.factor(realtime), y = y)) + - geom_boxplot( - aes(fill = group), - #position = position_dodge(width = 1), - notch = input$inPlotBoxNotches, - outlier.colour = if(input$inPlotBoxOutliers) 'red' else NA - ) + - scale_fill_discrete(name = '') + - xlab('\nTime (min)') + - ylab('') + - theme_bw(base_size = 18, base_family = "Helvetica") + - theme( - panel.grid.minor = element_blank(), - panel.grid.major = element_blank(), - panel.border = element_blank(), - axis.line.x = element_line(color = "black", size = 0.25), - axis.line.y = element_line(color = "black", size = 0.25), - axis.text.x = element_text(size = 12), - axis.text.y = element_text(size = 12), - strip.text.x = element_text(size = 14, face = "bold"), - strip.text.y = element_text(size = 14, face = "bold"), - strip.background = element_blank(), - legend.key = element_blank(), - legend.key.height = unit(1, "lines"), - legend.key.width = unit(2, "lines"), - legend.position = input$selPlotBoxLegendPos - ) - } ###### Scatter plot diff --git a/ui.R b/ui.R index e8cf89f..dd4e4ae 100644 --- a/ui.R +++ b/ui.R @@ -113,32 +113,9 @@ shinyUI(fluidPage( downPlotUI('downPlotTraj', "Download PDF") ), - tabPanel("Box-plots", - br(), - fluidRow( - column( - 6, - checkboxInput('inPlotBoxNotches', 'Box plot notches?', FALSE), - checkboxInput('inPlotBoxOutliers', 'Box plot outliers?', TRUE) - ), - column( - 6, - selectInput('selPlotBoxLegendPos', - label = 'Select legend position', - choices = list( - "Top" = 'top', - "Right" = 'right', - "Bottom" = 'bottom' - ), - selected = 'top') - ) - ), - - uiOutput('varSelTpts'), - - actionButton('butPlotBox', 'Plot!'), - plotOutput('outPlotBox', height = 800), - downPlotUI('downPlotBox', "Download PDF") + tabPanel( + "Box-plots", + tabBoxPlotUI('tabBoxPlot') ), @@ -475,11 +452,11 @@ shinyUI(fluidPage( actionButton('butPlotHierSparClDist', 'Plot!'), plotOutput('outPlotHierSparClDist')) ) - ), - - tabPanel( - 'Bayesian Cl.', - clustBayUI('TabClustBay')) + ) + # + # tabPanel( + # 'Bayesian Cl.', + # clustBayUI('TabClustBay')) )) ) -- GitLab