From 04739dbadf25c5c2679a485629bb58eaa16bdc89 Mon Sep 17 00:00:00 2001 From: dmattek Date: Tue, 23 Oct 2018 15:19:36 +0200 Subject: [PATCH] Added: option to upload and display stimulation pattern --- modules/auxfunc.R | 87 +++++++++++++++++++++++++++++++++------- modules/tabClHier.R | 23 ++++++++++- modules/tabClHierSpar.R | 25 +++++++++--- modules/trajPlot.R | 20 ++++++++- modules/trajRibbonPlot.R | 36 ++++++++++++++--- server.R | 81 ++++++++++++++++++++++++++++++------- ui.R | 12 ++++++ 7 files changed, 241 insertions(+), 43 deletions(-) diff --git a/modules/auxfunc.R b/modules/auxfunc.R index 2b33655..15925c7 100644 --- a/modules/auxfunc.R +++ b/modules/auxfunc.R @@ -97,7 +97,8 @@ help.text = c( 'Plotting and data processing requires a unique cell ID across entire dataset. A typical dataset from CellProfiler assigns unique cell ID (TrackLabel) within each field of view (Metadata_Site). Therefore, a unique ID is created by concatenating these two columns. If the dataset already contains a unique ID, UNcheck this box and select a single column only.', 'This option allows to interpolate NAs or missing data. Some rows in the input file might be missing because a particular time point might not had been acquired. - This option, interpolates such missing points as well as points with NAs in the measurement column. When this option is checked, the interval of time column must be provided!' + This option, interpolates such missing points as well as points with NAs in the measurement column. When this option is checked, the interval of time column must be provided!', + 'Accepts CSV file with two columns: grouping, time points of stimulation.' ) @@ -186,6 +187,7 @@ rotatedAxisElementText = function(angle, position='x', size = 12){ element_text(size = 12, angle = angle, vjust = vjust, hjust = hjust) } +# default ggplot theme used in the app myGgplotTheme = theme_bw(base_size = 8, base_family = "Helvetica") + theme( @@ -206,7 +208,9 @@ myGgplotTheme = legend.position = "top" ) -myGgplotTraj = function(dt.arg, # data table + +# Plot individual time series +LOCplotTraj = function(dt.arg, # input data table x.arg, # string with column name for x-axis y.arg, # string with column name for y-axis group.arg, # string with column name for grouping time series (typicaly cell ID) @@ -218,9 +222,10 @@ myGgplotTraj = function(dt.arg, # data table ylab.arg = NULL, # string with y-axis label plotlab.arg = NULL, # string with plot label dt.stim.arg = NULL, # plotting additional dataset; typically to indicate stimulations (not fully implemented yet, not tested!) + x.stim.arg = c('tstart', 'tend'), # column names in stimulation dt with x and xend parameters + y.stim.arg = c('ystart', 'yend'), # column names in stimulation dt with y and yend parameters tfreq.arg = 1, ylim.arg = NULL, - stim.bar.height.arg = 0.1, stim.bar.width.arg = 0.5, aux.label1 = NULL, # 1st point label; used for interactive plotting; displayed in the tooltip; typically used to display values of column holding x & y coordinates aux.label2 = NULL, @@ -313,16 +318,19 @@ myGgplotTraj = function(dt.arg, # data table facet_wrap(as.formula(paste("~", facet.arg)), ncol = facet.ncol.arg, scales = "free_x") - + + # plot stimulation bars underneath time series + # dt.stim.arg is read separately and should contain 4 columns with + # xy positions of beginning and end of the bar if(!is.null(dt.stim.arg)) { p.tmp = p.tmp + geom_segment(data = dt.stim.arg, - aes(x = Stimulation_time - tfreq.arg, - xend = Stimulation_time - tfreq.arg, - y = ylim.arg[1], - yend = ylim.arg[1] + abs(ylim.arg[2] - ylim.arg[1]) * stim.bar.height.arg), + aes_string(x = x.stim.arg[1], + xend = x.stim.arg[2], + y = y.stim.arg[1], + yend = y.stim.arg[2], + group = 'group'), colour = rhg_cols[[3]], - size = stim.bar.width.arg, - group = 1) + size = stim.bar.width.arg) } if (!is.null(ylim.arg)) @@ -338,14 +346,65 @@ myGgplotTraj = function(dt.arg, # data table return(p.tmp) } +# Plot average time series with CI together in one facet +LOCplotTrajRibbon = function(dt.arg, # input data table + x.arg, # string with column name for x-axis + y.arg, # string with column name for y-axis + group.arg = NULL, # string with column name for grouping time series (here, it's a column corresponding to grouping by condition) + col.arg = NULL, # colour pallette for individual time series + dt.stim.arg = NULL, # data table with stimulation pattern + x.stim.arg = c('tstart', 'tend'), # column names in stimulation dt with x and xend parameters + y.stim.arg = c('ystart', 'yend'), # column names in stimulation dt with y and yend parameters + stim.bar.width.arg = 0.5, + ribbon.lohi.arg = c('Lower', 'Upper'), + ribbon.fill.arg = 'grey50', + ribbon.alpha.arg = 0.5, + xlab.arg = NULL, + ylab.arg = NULL, + plotlab.arg = NULL) { + + p.tmp = ggplot(dt.arg, aes_string(x = x.arg, group = group.arg)) + + geom_ribbon(aes_string(ymin = ribbon.lohi.arg[1], ymax = ribbon.lohi.arg[2]), + fill = ribbon.fill.arg, + alpha = ribbon.alpha.arg) + + geom_line(aes_string(y = y.arg, colour = group.arg)) + + + # plot stimulation bars underneath time series + # dt.stim.arg is read separately and should contain 4 columns with + # xy positions of beginning and end of the bar + if(!is.null(dt.stim.arg)) { + p.tmp = p.tmp + geom_segment(data = dt.stim.arg, + aes_string(x = x.stim.arg[1], + xend = x.stim.arg[2], + y = y.stim.arg[1], + yend = y.stim.arg[2]), + colour = rhg_cols[[3]], + size = stim.bar.width.arg, + group = 1) + } -# Fast DTW computation -fastDTW <-function (x) -{ - return(dtw(x, window.type = 'sakoechiba', distance.only = T)$normalizedDistance) + + if (is.null(col.arg)) { + p.tmp = p.tmp + + scale_color_discrete(name = '') + } else { + p.tmp = p.tmp + + scale_colour_manual(values = col.arg, name = '') + } + + if (!is.null(plotlab.arg)) + p.tmp = p.tmp + ggtitle(plotlab.arg) + + p.tmp = p.tmp + + xlab(xlab.arg) + + ylab(ylab.arg) + + return(p.tmp) } + # Plots a scatter plot with marginal histograms # Points are connected by a line (grouping by cellID) # diff --git a/modules/tabClHier.R b/modules/tabClHier.R index 32863a2..04c4f25 100644 --- a/modules/tabClHier.R +++ b/modules/tabClHier.R @@ -172,7 +172,7 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") { } # SERVER -clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) { +clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot, in.data4stimPlot) { output$uiPlotHierClSel = renderUI({ ns <- session$ns @@ -337,6 +337,20 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) { return(loc.dt) }) + data4stimPlotCl <- reactive({ + cat(file = stderr(), 'data4stimPlotCl: in\n') + + loc.dt = in.data4stimPlot() + + if (is.null(loc.dt)) { + cat(file = stderr(), 'data4stimPlotCl: dt is NULL\n') + return(NULL) + } + + cat(file = stderr(), 'data4stimPlotCl: dt not NULL\n') + return(loc.dt) + }) + # download a list of cellIDs with cluster assignments output$downCellCl <- downloadHandler( filename = function() { @@ -495,19 +509,24 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) { # Hierarchical - Heat Map - download pdf callModule(downPlot, "downPlotHier", createFnameHeatMap, plotHier) - + + # plot individual trajectories withina cluster callModule(modTrajPlot, 'modPlotHierTraj', in.data = data4trajPlotCl, + in.data.stim = data4stimPlotCl, in.facet = 'cl', in.facet.color = getClColHier, in.fname = createFnameTrajPlot) + # plot cluster means callModule(modTrajRibbonPlot, 'modPlotHierTrajRibbon', in.data = data4trajPlotCl, + in.data.stim = data4stimPlotCl, in.facet = 'cl', in.facet.color = getClColHier, in.fname = createFnameRibbonPlot) + # plot distribution barplot callModule(modClDistPlot, 'hierClDistPlot', in.data = data4clDistPlot, in.cols = getClColHier, diff --git a/modules/tabClHierSpar.R b/modules/tabClHierSpar.R index ff72b3f..594fb9e 100644 --- a/modules/tabClHierSpar.R +++ b/modules/tabClHierSpar.R @@ -184,7 +184,7 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical CLustering") { } # SERVER -clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlot) { +clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlot, in.data4stimPlot) { # UI for advanced options output$uiPlotHierSparNperms = renderUI({ @@ -391,6 +391,20 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo return(loc.dt) }) + data4stimPlotClSpar <- reactive({ + cat(file = stderr(), 'data4stimPlotClSpar: in\n') + + loc.dt = in.data4stimPlot() + + if (is.null(loc.dt)) { + cat(file = stderr(), 'data4stimPlotClSpar: dt is NULL\n') + return(NULL) + } + + cat(file = stderr(), 'data4stimPlotClSpar: dt not NULL\n') + return(loc.dt) + }) + # download a list of cellIDs with cluster assignments output$downCellClSpar <- downloadHandler( @@ -541,22 +555,23 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo # Sparse Hierarchical - Heat Map - download pdf callModule(downPlot, "downPlotHierSparHM", createFnameHeatMap, plotHierSpar) - - - + # plot individual trajectories withina cluster callModule(modTrajPlot, 'modPlotHierSparTraj', in.data = data4trajPlotClSpar, + in.data.stim = data4stimPlotClSpar, in.facet = 'cl', in.facet.color = getClColHierSpar, in.fname = createFnameTrajPlot) + # plot cluster means callModule(modTrajRibbonPlot, 'modPlotHierSparTrajRibbon', in.data = data4trajPlotClSpar, + in.data.stim = data4stimPlotClSpar, in.facet = 'cl', in.facet.color = getClColHierSpar, in.fname = createFnameRibbonPlot) - + # plot distribution barplot callModule(modClDistPlot, 'hierClSparDistPlot', in.data = data4clSparDistPlot, in.cols = getClColHierSpar, diff --git a/modules/trajPlot.R b/modules/trajPlot.R index 29c016e..aded742 100644 --- a/modules/trajPlot.R +++ b/modules/trajPlot.R @@ -69,6 +69,7 @@ modTrajPlotUI = function(id, label = "Plot Individual Time Series") { modTrajPlot = function(input, output, session, in.data, + in.data.stim, in.fname, in.facet = 'group', in.facet.color = NULL) { @@ -189,6 +190,7 @@ modTrajPlot = function(input, output, session, return(NULL) } + # check main data exists loc.dt = isolate(in.data()) cat("plotTraj: on to plot\n\n") @@ -198,6 +200,17 @@ modTrajPlot = function(input, output, session, } cat(file = stderr(), 'plotTraj: dt not NULL\n') + + + # check if stim data exists + loc.dt.stim = isolate(in.data.stim()) + + if (is.null(loc.dt.stim)) { + cat(file = stderr(), 'plotTraj: dt.stim is NULL\n') + } else { + cat(file = stderr(), 'plotTraj: dt.stim not NULL\n') + } + # Future: change such that a column with colouring status is chosen by the user @@ -247,14 +260,17 @@ modTrajPlot = function(input, output, session, } - p.out = myGgplotTraj( + p.out = LOCplotTraj( dt.arg = loc.dt, x.arg = 'realtime', y.arg = 'y', group.arg = "id", facet.arg = in.facet, facet.ncol.arg = input$inPlotTrajFacetNcol, - facet.color.arg = loc.facet.col, + facet.color.arg = loc.facet.col, + dt.stim.arg = loc.dt.stim, + x.stim.arg = c('tstart', 'tend'), + y.stim.arg = c('ystart', 'yend'), xlab.arg = 'Time (min)', line.col.arg = loc.line.col.arg, aux.label1 = if (locPos) 'pos.x' else NULL, diff --git a/modules/trajRibbonPlot.R b/modules/trajRibbonPlot.R index 11669a9..c862f60 100644 --- a/modules/trajRibbonPlot.R +++ b/modules/trajRibbonPlot.R @@ -48,6 +48,7 @@ modTrajRibbonPlotUI = function(id, label = "Plot Individual Time Series") { modTrajRibbonPlot = function(input, output, session, in.data, + in.data.stim, in.facet = 'group', in.facet.color = NULL, in.fname) { @@ -107,24 +108,44 @@ modTrajRibbonPlot = function(input, output, session, plotTraj, TRUE) plotTraj <- function() { - cat(file = stderr(), 'plotTraj: in\n') + cat(file = stderr(), 'plotTrajRibbon: in\n') locBut = input$butPlotTraj if (locBut == 0) { - cat(file = stderr(), 'plotTraj: Go button not pressed\n') + cat(file = stderr(), 'plotTrajRibbon: Go button not pressed\n') return(NULL) } + # check if main data exists loc.dt = isolate(in.data()) - cat("plotTraj: on to plot\n\n") + cat("plotTrajRibbon: on to plot\n\n") if (is.null(loc.dt)) { - cat(file = stderr(), 'plotTraj: dt is NULL\n') + cat(file = stderr(), 'plotTrajRibbon: dt is NULL\n') return(NULL) } - cat(file = stderr(), 'plotTraj: dt not NULL\n') + cat(file = stderr(), 'plotTrajRibbon: dt not NULL\n') + + + # check if stim data exists + loc.dt.stim = isolate(in.data.stim()) + + if (is.null(loc.dt.stim)) { + cat(file = stderr(), 'plotTrajRibbon: stim is NULL\n') + } else { + cat(file = stderr(), 'plotTrajRibbon: stim not NULL\n') + + # choose only 1st group of stimulation pattern for ribbon plot + + loc.groups = unique(loc.dt.stim[['group']]) + if(length(loc.groups) > 1) { + cat(file = stderr(), 'plotTrajRibbon: more than 1 group in stim; choosing 1st\n') + loc.dt.stim = loc.dt.stim[group == loc.groups[1]] + } + } + # Future: change such that a column with colouring status is chosen by the user @@ -180,11 +201,14 @@ modTrajRibbonPlot = function(input, output, session, loc.dt.aggr[, (in.facet) := as.factor(get(in.facet))] - p.out = tca::plotTrajRibbon(dt.arg = loc.dt.aggr, + p.out = LOCplotTrajRibbon(dt.arg = loc.dt.aggr, x.arg = 'realtime', y.arg = 'Mean', col.arg = loc.facet.col, group.arg = in.facet, + dt.stim.arg = loc.dt.stim, + x.stim.arg = c('tstart', 'tend'), + y.stim.arg = c('ystart', 'yend'), xlab.arg = 'Time (min)', ylab.arg = '') + ggplotTheme() + diff --git a/server.R b/server.R index b82ba70..d351a14 100644 --- a/server.R +++ b/server.R @@ -37,8 +37,8 @@ shinyServer(function(input, output, session) { # The value of inDataGen1,2 actionButton is the number of times they were pressed dataGen1 = isolate(input$inDataGen1), dataLoadNuc = isolate(input$inButLoadNuc), - dataLoadTrajRem = isolate(input$inButLoadTrajRem) - #dataLoadStim = isolate(input$inButLoadStim) + dataLoadTrajRem = isolate(input$inButLoadTrajRem), + dataLoadStim = isolate(input$inButLoadStim) ) #### @@ -78,7 +78,36 @@ shinyServer(function(input, output, session) { # reset("inFileStimLoad") # reset is a shinyjs function }) + + # load data with trajectories to remove + dataLoadTrajRem <- eventReactive(input$inButLoadTrajRem, { + cat(file = stderr(), "dataLoadTrajRem\n") + locFilePath = input$inFileLoadTrajRem$datapath + + counter$dataLoadTrajRem <- input$inButLoadTrajRem - 1 + + if (is.null(locFilePath) || locFilePath == '') + return(NULL) + else { + return(fread(locFilePath)) + } + }) + # load data with stimulation pattern + dataLoadStim <- eventReactive(input$inButLoadStim, { + cat(file = stderr(), "dataLoadStim\n") + locFilePath = input$inFileLoadStim$datapath + + counter$dataLoadStim <- input$inButLoadStim - 1 + + if (is.null(locFilePath) || locFilePath == '') + return(NULL) + else { + return(fread(locFilePath)) + } + }) + + # UI for loading csv with cell IDs for trajectory removal output$uiFileLoadTrajRem = renderUI({ cat(file = stderr(), 'UI uiFileLoadTrajRem\n') @@ -98,20 +127,26 @@ shinyServer(function(input, output, session) { actionButton("inButLoadTrajRem", "Load Data") }) - # load main data file - dataLoadTrajRem <- eventReactive(input$inButLoadTrajRem, { - cat(file = stderr(), "dataLoadTrajRem\n") - locFilePath = input$inFileLoadTrajRem$datapath + # UI for loading csv with stimulation pattern + output$uiFileLoadStim = renderUI({ + cat(file = stderr(), 'UI uiFileLoadStim\n') - counter$dataLoadTrajRem <- input$inButLoadTrajRem - 1 + if(input$chBstim) + fileInput( + 'inFileLoadStim', + 'Select data file (e.g. stim.csv) and press "Load Data"', + accept = c('text/csv', 'text/comma-separated-values,text/plain') + ) + }) + + output$uiButLoadStim = renderUI({ + cat(file = stderr(), 'UI uiButLoadStim\n') - if (is.null(locFilePath) || locFilePath == '') - return(NULL) - else { - return(fread(locFilePath)) - } + if(input$chBstim) + actionButton("inButLoadStim", "Load Data") }) + # COLUMN SELECTION output$varSelTrackLabel = renderUI({ @@ -739,6 +774,22 @@ shinyServer(function(input, output, session) { }) + # prepare data with stimulation pattern + # this dataset is displayed underneath of trajectory plot (modules/trajPlot.R) as geom_segment + data4stimPlot <- reactive({ + cat(file = stderr(), 'data4stimPlot\n') + + if (input$chBstim) { + cat(file = stderr(), 'data4stimPlot: stim not NULL\n') + + loc.dt.stim = dataLoadStim() + return(loc.dt.stim) + } else { + cat(file = stderr(), 'data4stimPlot: stim is NULL\n') + return(NULL) + } + }) + # download data as prepared for plotting # after all modification output$downloadDataClean <- downloadHandler( @@ -751,11 +802,13 @@ shinyServer(function(input, output, session) { ###### Trajectory plotting callModule(modTrajRibbonPlot, 'modTrajRibbon', in.data = data4trajPlot, + in.data.stim = data4stimPlot, in.fname = function() return( "tCoursesMeans.pdf")) ###### Trajectory plotting callModule(modTrajPlot, 'modTrajPlot', in.data = data4trajPlot, + in.data.stim = data4stimPlot, in.fname = function() {return( "tCourses.pdf")}) ## UI for selecting trajectories @@ -789,10 +842,10 @@ shinyServer(function(input, output, session) { callModule(tabScatterPlot, 'tabScatter', data4trajPlot, in.fname = function() return('scatter.pdf')) ##### Hierarchical clustering - callModule(clustHier, 'tabClHier', data4clust, data4trajPlot) + callModule(clustHier, 'tabClHier', data4clust, data4trajPlot, data4stimPlot) ##### Sparse hierarchical clustering using sparcl - callModule(clustHierSpar, 'tabClHierSpar', data4clust, data4trajPlot) + callModule(clustHierSpar, 'tabClHierSpar', data4clust, data4trajPlot, data4stimPlot) }) diff --git a/ui.R b/ui.R index 84e32c3..992cb41 100644 --- a/ui.R +++ b/ui.R @@ -41,6 +41,18 @@ shinyUI(fluidPage( uiOutput('uiFileLoadTrajRem'), uiOutput('uiButLoadTrajRem'), + tags$hr(), + checkboxInput('chBstim', 'Upload stimulation pattern'), + helpPopup( + title = 'Upload stimulations', + content = help.text[4], + placement = 'right', + trigger = 'hover' + ), + + uiOutput('uiFileLoadStim'), + uiOutput('uiButLoadStim'), + tags$hr(), checkboxInput('chBtrajInter', 'Interpolate NAs and missing data?', value = T), helpPopup( -- GitLab