Added:

- option to upload cell IDs for removal
- option to calculate boxplots at particular time points with respect to a preceding point

Changed:
- hierarchical clustering made into a module

global.R

 source('modules/auxfunc.R')
 source('modules/downPlot.R')
 source('modules/downCellIDsCls.R')
+source('modules/dispStats.R')
 source('modules/trajPlot.R')
+source('modules/boxPlot.R')
+source('modules/tabAUC.R')
 source('modules/clDistPlot.R')
 source('modules/tabScatter.R')
 source('modules/tabBoxPlot.R')
-source('modules/tabClBay.R')
\ No newline at end of file
+source('modules/tabClHier.R')
+source('modules/tabClHierSpar.R')
\ No newline at end of file

modules/auxfunc.R

@@ -42,7 +42,7 @@ s.cl.spar.linkage = c("average",
                       "single",
                       "centroid")
 
-s.cl.diss = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski")
+s.cl.diss = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "DTW")
 s.cl.spar.diss = c("squared.distance","absolute.value")
 
 l.col.pal = list(
@@ -55,6 +55,65 @@ l.col.pal = list(
   "Spectral" = 'Spectral'
 )
 
+# Creates a popup with help text
+# From: https://gist.github.com/jcheng5/5913297
+helpPopup <- function(title, content,
+                      placement=c('right', 'top', 'left', 'bottom'),
+                      trigger=c('click', 'hover', 'focus', 'manual')) {
+  tagList(
+    singleton(
+      tags$head(
+        tags$script("$(function() { $(\"[data-toggle='popover']\").popover(); })")
+      )
+    ),
+    tags$a(
+      href = "#", class = "btn btn-mini", `data-toggle` = "popover",
+      title = title, `data-content` = content, `data-animation` = TRUE,
+      `data-placement` = match.arg(placement, several.ok=TRUE)[1],
+      `data-trigger` = match.arg(trigger, several.ok=TRUE)[1],
+      #tags$i(class="icon-question-sign")
+      # changed based on http://stackoverflow.com/questions/30436013/info-bubble-text-in-a-shiny-interface
+      icon("question")
+    )
+  )
+}
+
+help.text = c(
+  'Accepts CSV file with a column of cell IDs for removal. 
+                   IDs should correspond to those used for plotting. 
+  Say, the main data file contains columns Metadata_Site and TrackLabel. 
+  These two columns should be then selected in UI to form a unique cell ID, e.g. 001_0001 where former part corresponds to Metadata_Site and the latter to TrackLabel.',
+  '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, check this box and select a single column only.'
+)
+
+
+#####
+## Function for clustering 
+
+# get cell IDs with cluster assignments depending on dendrogram cut
+getDataCl = function(in.dend, in.k, in.ids) {
+  cat(file = stderr(), 'getDataCl \n')
+  
+  loc.dt.cl = data.table(id = in.ids,
+                         cl = cutree(as.dendrogram(in.dend), k = in.k))
+}
+
+# prepares a table with cluster numbers in 1st column and colour assignments in 2nd column
+# the number of rows is determined by dendrogram cut
+getClCol <- function(in.dend, in.k) {
+  
+  loc.col_labels <- get_leaves_branches_col(in.dend)
+  loc.col_labels <- loc.col_labels[order(order.dendrogram(in.dend))]
+  
+  return(unique(
+    data.table(cl.no = dendextend::cutree(in.dend, k = in.k, order_clusters_as_data = TRUE),
+               cl.col = loc.col_labels)))
+}
+
+
+#####
+## Common plotting functions
 
 myGgplotTraj = function(dt.arg, # data table
                         x.arg,  # string with column name for x-axis

modules/boxPlot.R

+# Module for plotting a choice of box/violin/dot-plots
+# Assumes in.data contains columns:
+# realtime
+# y
+# group
+# id
+
+modBoxPlotUI =  function(id, label = "Plot Box-plots") {
+  ns <- NS(id)
+  
+  tagList(
+    fluidRow(
+      column(
+        4,
+        checkboxGroupInput(ns('inPlotType'), 'Plot type:', list('Dot-plot' = 'dot', 
+                                                                'Violin-plot' = 'viol',
+                                                                'Box-plot' = 'box', 
+                                                                'Line-plot' = 'line'), selected = 'box'),
+        checkboxInput(ns('chBPlotBoxInt'), 'Interactive Plot?'),
+        actionButton(ns('butPlotBox'), 'Plot!')
+      ),
+      column(
+        4,
+        selectInput(
+          ns('selPlotBoxLegendPos'),
+          label = 'Select legend position',
+          choices = list(
+            "Top" = 'top',
+            "Right" = 'right',
+            "Bottom" = 'bottom'
+          ),
+          selected = 'top'
+        ),
+        checkboxInput(ns('chBxAxisLabelsRotate'), 'Rotate x-axis labels?'),
+        uiOutput(ns('uiPlotBoxNotches')),
+        uiOutput(ns('uiPlotBoxOutliers')),
+        uiOutput(ns('uiPlotBoxDodge')),
+        #uiOutput(ns('uiPlotBoxWidth')),
+        uiOutput(ns('uiPlotBoxAlpha')),
+        uiOutput(ns('uiPlotDotNbins'))
+      ),
+      column(
+        4,
+        numericInput(
+          ns('inPlotBoxWidth'),
+          'Width [%]:',
+          value = 100,
+          min = 10,
+          width = '100px',
+          step = 10
+        ),
+        numericInput(
+          ns('inPlotBoxHeight'),
+          'Height [px]:',
+          value = 800,
+          min = 100,
+          width = '100px',
+          step = 50
+        )
+      )
+    ),
+    
+    uiOutput(ns('uiPlotBox')),
+    downPlotUI(ns('downPlotBox'), "Download PDF")
+  )
+}
+
+
+modBoxPlot = function(input, output, session, 
+                      in.data, 
+                      in.cols = list(meas.x = 'realtime',
+                                     meas.y = 'y',
+                                     group = 'group',
+                                     id = 'id'), 
+                      in.fname = 'boxplot.pdf') {
+  
+  ns <- session$ns
+ 
+  output$uiPlotBoxNotches = renderUI({
+    cat(file = stderr(), 'UI uiPlotBoxNotches\n')
+    
+    ns <- session$ns
+    
+    if('box' %in% input$inPlotType)
+      checkboxInput(ns('inPlotBoxNotches'), 'Box plot notches?', FALSE)
+  })
+  
+  output$uiPlotBoxOutliers = renderUI({
+    cat(file = stderr(), 'UI uiPlotBoxNotches\n')
+    
+    ns <- session$ns
+    
+    if('box' %in% input$inPlotType)
+      checkboxInput(ns('inPlotBoxOutliers'), 'Box plot outliers?', FALSE)
+  })
+  
+  output$uiPlotBoxDodge = renderUI({
+    cat(file = stderr(), 'UI uiPlotBoxDodge\n')
+    
+    ns <- session$ns
+    
+    if(!( 'line' %in% input$inPlotType  ))
+      sliderInput(ns('inPlotBoxDodge'), 'Dodge series:', min = 0, max = 1, value = .4, step = 0.05)
+  })
+  
+  output$uiPlotBoxWidth = renderUI({
+    cat(file = stderr(), 'UI uiPlotBoxWidth\n')
+    
+    ns <- session$ns
+    
+    if('box' %in% input$inPlotType)
+      sliderInput(ns('inPlotBoxWidth'), 'Box plot width:', min = 0, max = 1, value = .2, step = 0.1)
+  })
+  
+  output$uiPlotBoxAlpha = renderUI({
+    cat(file = stderr(), 'UI uiPlotBoxAlpha\n')
+    
+    ns <- session$ns
+    
+    if('box' %in% input$inPlotType)
+      sliderInput(ns('inPlotBoxAlpha'), 'Box plot transparency:', min = 0, max = 1, value = 1, step = 0.05)
+  })
+  
+  output$uiPlotDotNbins = renderUI({
+    cat(file = stderr(), 'UI uiPlotDotNbins\n')
+    
+    ns <- session$ns
+    
+    if('dot' %in% input$inPlotType)
+      sliderInput(ns('inPlotDotNbins'), 'Dot-plot bin size (10^x):', min = -4, max = 4, value = -1.5, step = 0.1)
+  })
+  
+  # Boxplot - display
+  output$outPlotBox = renderPlot({
+    locBut = input$butPlotBox
+    
+    if (locBut == 0) {
+      cat(file = stderr(), 'plotBox: Go button not pressed\n')
+      return(NULL)
+    }
+    
+    plotBox()
+    
+  })
+  
+  
+  output$outPlotBoxInt = renderPlotly({
+    locBut = input$butPlotBox
+    
+    if (locBut == 0) {
+      cat(file = stderr(), 'plotBox: Go button not pressed\n')
+      return(NULL)
+    }
+    
+    # This is required to avoid 
+    # "Warning: Error in <Anonymous>: cannot open file 'Rplots.pdf'"
+    # When running on a server. Based on:
+    # https://github.com/ropensci/plotly/issues/494
+    if (names(dev.cur()) != "null device") dev.off()
+    pdf(NULL)
+    
+    return( ggplotly(plotBox())  %>% layout(boxmode = 'group', width = '100%', height = '100%'))
+    
+  })
+  
+  
+  output$uiPlotBox <- renderUI({
+    ns <- session$ns
+    
+    if (input$chBPlotBoxInt)
+      plotlyOutput(ns("outPlotBoxInt"), 
+                   width = paste0(input$inPlotBoxWidth, '%'),
+                   height = paste0(input$inPlotBoxHeight, 'px'))
+    else
+      plotOutput(ns('outPlotBox'),
+                 width = paste0(input$inPlotBoxWidth, '%'),
+                 height = paste0(input$inPlotBoxHeight, 'px'))
+  })
+  
+  # Boxplot - download pdf
+  callModule(downPlot, "downPlotBox", in.fname, 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 = in.data()
+    
+    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')
+    
+    loc.par.dodge <- position_dodge(width = input$inPlotBoxDodge)
+    p.out = ggplot(loc.dt, aes_string(x = sprintf("factor(%s)", in.cols[['meas.x']]), y = in.cols[['meas.y']])) 
+    
+    if('dot' %in% input$inPlotType)
+      p.out = p.out + geom_dotplot(aes_string(fill = in.cols[['group']]), 
+                                   binaxis = "y", 
+                                   stackdir = "center", 
+                                   position = loc.par.dodge, 
+                                   binwidth = 10^(input$inPlotDotNbins), 
+                                   method = 'histodot')
+    
+    if('viol' %in% input$inPlotType)
+      p.out = p.out + geom_violin(aes_string(fill = in.cols[['group']]),
+                                  position = loc.par.dodge,
+                                  width = 0.2)
+    
+    if('line' %in% input$inPlotType)
+      p.out = p.out + 
+      geom_path(aes_string(color = in.cols[['group']], group = in.cols[['id']])) +
+      facet_wrap(as.formula(paste("~", in.cols[['group']])))
+    
+    if ('box' %in% input$inPlotType)
+      p.out = p.out + geom_boxplot(
+        aes_string(fill = in.cols[['group']]), 
+        position = loc.par.dodge,
+        #width = 0.2, #input$inPlotBoxWidth,
+        notch = input$inPlotBoxNotches, 
+        alpha = input$inPlotBoxAlpha,
+        outlier.colour = if (input$inPlotBoxOutliers)
+          'red'
+        else
+          NA
+      ) 
+    
+    p.out = p.out +
+      scale_fill_discrete(name = '') +
+      xlab('') +
+      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.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
+      )
+    
+    if (input$chBxAxisLabelsRotate)
+      p.out = p.out +
+      theme(axis.text.x = element_text(size = 12, angle = 45, hjust = 1))
+    else
+      p.out = p.out +
+      theme(axis.text.x = element_text(size = 12))
+    
+    
+    return(p.out)
+  }
+  
+}
\ No newline at end of file

modules/dispStats.R

+require(DT)
+require(data.table)
+
+modStatsUI =  function(id, label = "Comparing t-points") {
+  ns <- NS(id)
+  
+  tagList(
+    checkboxInput(ns('chbTabStats'), 'Show stats', FALSE),
+    uiOutput(ns('uiTabStats')),
+    uiOutput(ns('uiDownSingleCellData'))
+  )
+}
+
+
+modStats = function(input, output, session, 
+                   in.data, 
+                   in.meascol = 'meas.y', 
+                   in.bycols = c('meas.x', 'group'),
+                   in.fname = 'data4boxplot.csv') {
+  
+  ns <- session$ns
+  
+  output$uiTabStats = renderUI({
+    cat(file = stderr(), 'UI uiTabStats\n')
+    ns <- session$ns
+    
+    if(input$chbTabStats) {
+      DT::dataTableOutput(ns('outTabStats'))
+    }
+  })
+  
+  output$uiDownSingleCellData = renderUI({
+    cat(file = stderr(), 'UI uiDownSingleCellData\n')
+    ns <- session$ns
+    
+    if(input$chbTabStats) {
+      downloadButton(ns('downloadData4BoxPlot'), 'Download single-cell data')
+    }
+  })
+  
+  
+  
+  calcStats = reactive({
+    cat(file = stderr(), 'tabBoxPlot: calsStats\n')
+    loc.dt = in.data()
+    
+    if (is.null(loc.dt))
+      return(NULL)
+
+    loc.dt.aggr = loc.dt[, sapply(.SD, function(x) list('N' = .N, 
+                                                        'Mean' = mean(x), 
+                                                        'CV' = sd(x)/mean(x), 
+                                                        'Median' = median(x), 
+                                                        'rCV (IQR)' = IQR(x)/median(x), 
+                                                        'rCV (MAD)'= mad(x)/median(x))), .SDcols = in.meascol, by = in.bycols]
+    
+    setnames(loc.dt.aggr, c(in.bycols, 'N', 'Mean', 'CV', 'Median', 'rCV IQR', 'rCV MAD'))
+    
+    return(loc.dt.aggr)
+  })
+  
+  output$downloadData4BoxPlot <- downloadHandler(
+    filename = in.fname,
+    content = function(file) {
+      loc.dt = in.data()
+      
+      if (is.null(loc.dt))
+        return(NULL)
+      else
+        write.csv(loc.dt, file, row.names = FALSE)
+    }
+  )
+  
+  output$outTabStats = DT::renderDataTable(server = FALSE, {
+    cat(file = stderr(), 'tabBoxPlot: outTabStats\n')
+    loc.dt = calcStats()
+    
+    if (is.null(loc.dt))
+      return(NULL)
+    
+    loc.n.bycols = length(in.bycols)
+    
+    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(seq(loc.n.bycols + 2, loc.n.bycols + 1 + 5), 3)
+  })
+  
+}
\ No newline at end of file

modules/tabAUC.R

+# Calculates area under curve (AUC) for every single time course provided in the input
+
+require(pracma) # for trapz
+
+modAUCplotUI =  function(id, label = "Plot Area Under Curves") {
+  ns <- NS(id)
+  
+  tagList(
+      uiOutput(ns('uiSlTimeTrim')),
+      modStatsUI(ns('dispStats')),
+      br(),
+      modBoxPlotUI(ns('boxPlot')
+    )
+  )
+}
+
+modAUCplot = function(input, output, session, in.data, in.fname = 'boxplotAUC.pdf') {
+  
+  ns <- session$ns
+  
+  # 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']]))
+  })
+  
+  # UI for trimming x-axis (time)
+  output$uiSlTimeTrim = renderUI({
+    cat(file = stderr(), 'UI uiSlTimeTrim\n')
+    
+      locTpts  = getDataTpts()
+      
+      if(is.null(locTpts))
+        return(NULL)
+      
+      locRTmin = min(locTpts)
+      locRTmax = max(locTpts)
+      
+      sliderInput(
+        ns('slTimeTrim'),
+        label = 'Select time range for AUC calculation',
+        min = locRTmin,
+        max = locRTmax,
+        value = c(locRTmin, locRTmax),
+        step = 1
+      )
+      
+  })
+  
+  AUCcells = reactive({
+    cat(file = stderr(), 'AUCcells\n')
+    loc.dt = in.data()
+    
+    if (is.null(loc.dt))
+      return(NULL)
+    else {
+      loc.res = loc.dt[realtime >= input$slTimeTrim[1] & realtime <= input$slTimeTrim[2], .(AUC = trapz(realtime, y)), by = .(group, id)]
+      return(loc.res)
+    }
+  })
+
+  callModule(modStats, 'dispStats',
+             in.data = AUCcells,
+             in.meascol = 'AUC',
+             in.bycols = c('group'),
+             in.fname = 'data4boxplotAUC.csv')
+  
+  callModule(modBoxPlot, 'boxPlot', 
+             in.data = AUCcells, 
+             in.cols = list(meas.x = 'group',
+                            meas.y = 'AUC',
+                            group = 'group',
+                            id = 'id'),
+             in.fname = in.fname)
+  
+  
+}
+
+
+
+
+
+