Commit c7c0bb8d authored by dmattek's avatar dmattek

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
parent b70dcf1a
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
......@@ -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
......
# 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
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
# 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)
}
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
This diff is collapsed.
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment