Skip to content

GitLab

S
shiny-timecourse-inspector
Commit 3f2d3136 authored by dmattek's avatar dmattek
Browse files
Options

Bug fixes

parent f78cdc1a
Hide whitespace changes
Inline Side-by-side
Showing with 444 additions and 426 deletions
modules/auxfunc.R
View file @ 3f2d3136
......@@ -45,7 +45,7 @@ PLOTWIDTH = 85 # in percent
PLOTNFACETDEFAULT = 3
# internal column names
COLRT = 'realtime'
COLRT = 'time'
COLY = 'y'
COLID = 'id'
COLIDUNI = 'trackObjectsLabelUni'
......@@ -96,13 +96,14 @@ md_cols <- c(
# list of palettes for the heatmap
l.col.pal = list(
"White-Orange-Red" = 'OrRd',
"Yellow-Orange-Red" = 'YlOrRd',
"Spectral" = 'Spectral',
"Red-Yellow-Green" = 'RdYlGn',
"Red-Yellow-Blue" = 'RdYlBu',
"Greys" = "Greys",
"Reds" = "Reds",
"Oranges" = "Oranges",
"Greens" = "Greens",
"Blues" = "Blues",
"Spectral" = 'Spectral'
"Blues" = "Blues"
)
# list of palettes for the dendrogram
......@@ -115,23 +116,40 @@ l.col.pal.dend = list(
"Diverge HSV" = 'diverge_hsv'
)
# list of palettes for the dendrogram
l.col.pal.dend.2 = list(
"Colorblind 10" = 'Color Blind',
"Tableau 10" = 'Tableau 10',
"Tableau 20" = 'Tableau 20',
"Classic 10" = "Classic 10",
"Classic 20" = "Classic 20",
"Traffic 9" = 'Traffic',
"Seattle Grays 5" = 'Seattle Grays'
)
# Clustering algorithms ----
s.cl.linkage = c("ward.D",
"ward.D2",
"single",
s.cl.linkage = c("average",
"complete",
"average",
"mcquitty",
"centroid")
"single",
"centroid",
"ward.D",
"ward.D2",
"mcquitty")
s.cl.spar.linkage = c("average",
"complete",
"single",
"centroid")
s.cl.diss = c("euclidean", "maximum", "manhattan", "canberra", "binary", "minkowski", "DTW")
s.cl.spar.diss = c("squared.distance","absolute.value")
s.cl.diss = c("euclidean",
"maximum",
"manhattan",
"canberra",
"DTW")
s.cl.spar.diss = c("squared.distance",
"absolute.value")
# Help text ----
......@@ -159,20 +177,24 @@ helpPopup <- function(title, content,
}
help.text.short = c(
'Load CSV file with a column of track IDs for removal. IDs should correspond to those used for plotting.',
'If the track ID is unique only within a group, make it unique globally by combining with the grouping column.',
'Interpolate missing time points and pre-existing NAs. The interval of the time column must be provided!',
'Load CSV file with 5 columns: grouping, start and end tpts of stimulation, start and end of y-position, dummy column with ID.',
'Select columns to group data according to treatment, condition, etc.',
'Select math operation to perform on a single or two columns,',
'Select range of time for further processing.',
'Divide measurments by the mean/median or calculate z-score with respect to selected time span.',
'Download time series after modification in this section.',
'Long format: a row is a single data point. Wide format: a row is a time series with columns as time points.',
'Fold-change or z-score with respect to selected time span.',
'Normalise with respect to this time span.',
'Calculate fold-change and z-score using the median and Median Absolute Deviation, instead of the mean and sd.',
'Normalise to mean/median of selected time calculated globally, per group, or for individual time series.'
'Load CSV file with a column of track IDs for removal. IDs should correspond to those used for plotting.', #1
'If the track ID is unique only within a group, make it unique globally by combining with the grouping column.', #2
'Interpolate missing time points and pre-existing NAs. The interval of the time column must be provided!', #3
'Load CSV file with 5 columns: grouping, start and end tpts of stimulation, start and end of y-position, dummy column with ID.', #4
'Select columns to group data according to treatment, condition, etc.', #5
'Select math operation to perform on a single or two columns,', #6
'Select range of time for further processing.', #7
'Divide measurments by the mean/median or calculate z-score with respect to selected time span.', #8
'Download time series after modification in this section.', #9
'Long format: a row is a single data point. Wide format: a row is a time series with columns as time points.', #10
'Fold-change or z-score with respect to selected time span.', #11
'Normalise with respect to this time span.', #12
'Calculate fold-change and z-score using the median and Median Absolute Deviation, instead of the mean and sd.', #13
'Normalise to mean/median of selected time calculated globally, per group, or for individual time series.', #14
'Instead of the value at a selected time point, y-axis can display a difference between values at time points on y- and x-axis.',#15
'Add a line with linear regression and regions of 95% confidence interval.', #16
'A number of time points left & right of selected time points; use the mean/min/max of values from these time points for the scatterplot.', #17
'Operations to perform on values at time points selected in the field above.' #18
)
# Functions for data processing ----
......@@ -765,60 +787,41 @@ LOCplotPSD <- function(dt.arg, # input data table
return(p.tmp)
}
# Plots a scatter plot with marginal histograms
# Points are connected by a line (grouping by cellID)
#
# Assumes an input of data.table with
# x, y - columns with x and y coordinates
# id - a unique point identifier (here corresponds to cellID)
# mid - a (0,1) column by which points are coloured (here corresponds to whether cells are within bounds)
LOCggplotScat = function(dt.arg,
band.arg = NULL,
#' Plot a scatter plot with an optional linear regression
#'
#' @param dt.arg input of data.table with 2 columns with x and y coordinates
#' @param facet.arg
#' @param facet.ncol.arg
#' @param xlab.arg
#' @param ylab.arg
#' @param plotlab.arg
#' @param alpha.arg
#' @param trend.arg
#' @param ci.arg
LOCggplotScat = function(dt.arg,
facet.arg = NULL,
facet.ncol.arg = 2,
xlab.arg = NULL,
ylab.arg = NULL,
plotlab.arg = NULL,
alpha.arg = 1,
group.col.arg = NULL) {
p.tmp = ggplot(dt.arg, aes(x = x, y = y))
trend.arg = T,
ci.arg = 0.95) {
if (is.null(group.col.arg)) {
p.tmp = p.tmp +
geom_point(alpha = alpha.arg, aes(group = id))
} else {
p.tmp = p.tmp +
geom_point(aes(colour = as.factor(get(group.col.arg)), group = id), alpha = alpha.arg) +
geom_path(aes(colour = as.factor(get(group.col.arg)), group = id), alpha = alpha.arg) +
scale_color_manual(name = group.col.arg, values =c("FALSE" = rhg_cols[7], "TRUE" = rhg_cols[3], "SELECTED" = 'green'))
}
if (is.null(band.arg))
p.tmp = ggplot(dt.arg, aes(x = x, y = y)) +
geom_point(alpha = alpha.arg)
if (trend.arg) {
p.tmp = p.tmp +
stat_smooth(
# method = function(formula, data, weights = weight)
# rlm(formula, data, weights = weight, method = 'MM'),
method = "lm",
fullrange = FALSE,
level = 0.95,
level = ci.arg,
colour = 'blue'
)
else {
p.tmp = p.tmp +
geom_abline(slope = band.arg$a, intercept = band.arg$b) +
geom_abline(
slope = band.arg$a,
intercept = band.arg$b + abs(band.arg$b)*band.arg$width,
linetype = 'dashed'
) +
geom_abline(
slope = band.arg$a,
intercept = band.arg$b - abs(band.arg$b)*band.arg$width,
linetype = 'dashed'
)
}
if (!is.null(facet.arg)) {
p.tmp = p.tmp +
facet_wrap(as.formula(paste("~", facet.arg)),
......@@ -826,7 +829,6 @@ LOCggplotScat = function(dt.arg,
}
if (!is.null(xlab.arg))
p.tmp = p.tmp +
xlab(paste0(xlab.arg, "\n"))
......@@ -839,8 +841,6 @@ LOCggplotScat = function(dt.arg,
p.tmp = p.tmp +
ggtitle(paste0(plotlab.arg, "\n"))
p.tmp = p.tmp +
LOCggplotTheme(in.font.base = PLOTFONTBASE,
in.font.axis.text = PLOTFONTAXISTEXT,
......@@ -849,10 +849,6 @@ LOCggplotScat = function(dt.arg,
in.font.legend = PLOTFONTLEGEND) +
theme(legend.position = "none")
# Marginal distributions don;t work with plotly...
# if (is.null(facet.arg))
# ggExtra::ggMarginal(p.scat, type = "histogram", bins = 100)
# else
return(p.tmp)
}
......
modules/boxPlot.R
View file @ 3f2d3136
......@@ -28,7 +28,7 @@ modBoxPlotUI = function(id, label = "Plot Box-plots") {
4,
selectInput(
ns('selPlotBoxLegendPos'),
label = 'Select legend position',
label = 'Legend position',
choices = list(
"Top" = 'top',
"Right" = 'right',
......@@ -76,10 +76,10 @@ modBoxPlotUI = function(id, label = "Plot Box-plots") {
# SERVER ----
modBoxPlot = function(input, output, session,
in.data,
in.cols = list(meas.x = 'realtime',
meas.y = 'y',
group = 'group',
id = 'id'),
in.cols = list(meas.x = COLRT,
meas.y = COLY,
group = COLGR,
id = COLID),
in.fname) {
ns <- session$ns
......@@ -108,7 +108,7 @@ modBoxPlot = function(input, output, session,
ns <- session$ns
if(!( 'line' %in% input$inPlotType ))
sliderInput(ns('inPlotBoxDodge'), 'Dodge series:', min = 0, max = 1, value = .4, step = 0.05)
sliderInput(ns('inPlotBoxDodge'), 'Space between groups:', min = 0, max = 1, value = .4, step = 0.05)
})
output$uiPlotBoxWidth = renderUI({
......@@ -135,7 +135,7 @@ modBoxPlot = function(input, output, session,
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)
sliderInput(ns('inPlotDotNbins'), '#Bins for dot-plot:', min = 2, max = 50, value = 30, step = 1)
})
# Boxplot - display
......@@ -206,30 +206,30 @@ modBoxPlot = function(input, output, session,
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']]))
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']]),
p.out = p.out + geom_dotplot(aes_string(fill = in.cols[[COLGR]]),
color = NA,
binaxis = "y",
binaxis = in.cols$meas.y,
stackdir = "center",
position = loc.par.dodge,
binwidth = 10^(input$inPlotDotNbins),
binwidth = abs(max(loc.dt[[ in.cols$meas.y ]], na.rm = T) - min(loc.dt[[ in.cols$meas.y ]], na.rm = T)) / (input$inPlotDotNbins - 1),
method = 'histodot')
if('viol' %in% input$inPlotType)
p.out = p.out + geom_violin(aes_string(fill = in.cols[['group']]),
p.out = p.out + geom_violin(aes_string(fill = in.cols[[COLGR]]),
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']])))
geom_path(aes_string(color = in.cols[[COLGR]], group = in.cols[[COLID]])) +
facet_wrap(as.formula(paste("~", in.cols[[COLGR]])))
if ('box' %in% input$inPlotType)
p.out = p.out + geom_boxplot(
aes_string(fill = in.cols[['group']]),
aes_string(fill = in.cols[[COLGR]]),
position = loc.par.dodge,
#width = 0.2, #input$inPlotBoxWidth,
notch = input$inPlotBoxNotches,
......
modules/clDistPlot.R
View file @ 3f2d3136
......@@ -6,14 +6,14 @@
#
# UI ----
modClDistPlotUI = function(id, label = "Plot Fractions Within Clusters") {
modClDistPlotUI = function(id, label = "Plot distribution of clusters per groupd") {
ns <- NS(id)
tagList(
radioButtons(ns("rBAxisLabelsRotate"), "X-axis labels:",
c("horizontal" = 0,
"45 deg" = 45,
"90 deg" = 90)),
"90 deg" = 90), inline = T),
actionButton(ns('butPlotClDist'), 'Plot!'),
plotOutput(ns('outPlotClDist'), height = PLOTBOXHEIGHT, width = 'auto'),
downPlotUI(ns('downPlotClDist'), "Download PDF")
......@@ -66,7 +66,7 @@ modClDistPlot = function(input, output, session, in.data, in.cols = NULL, in.fna
p.out = p.out +
scale_y_continuous(labels = percent) +
ylab("Percentage of time-series\n") +
xlab("") +
xlab("Groups") +
LOCggplotTheme(in.font.base = PLOTFONTBASE,
in.font.axis.text = PLOTFONTAXISTEXT,
in.font.axis.title = PLOTFONTAXISTITLE,
......
modules/dispStats.R
View file @ 3f2d3136
......@@ -10,7 +10,7 @@ modStatsUI = function(id, label = "Comparing t-points") {
ns <- NS(id)
tagList(
checkboxInput(ns('chbTabStats'), 'Show stats', FALSE),
checkboxInput(ns('chbTabStats'), 'Show statistics', FALSE),
uiOutput(ns('uiTabStats')),
uiOutput(ns('uiDownSingleCellData'))
)
......@@ -25,6 +25,8 @@ modStats = function(input, output, session,
ns <- session$ns
output$uiTabStats = renderUI({
cat(file = stderr(), 'modStats:uiTabStats\n')
ns <- session$ns
......@@ -34,12 +36,13 @@ modStats = function(input, output, session,
}
})
output$uiDownSingleCellData = renderUI({
cat(file = stderr(), 'modStats:uiDownSingleCellData\n')
ns <- session$ns
if(input$chbTabStats) {
downloadButton(ns('downloadData4BoxPlot'), 'Download single-cell data')
downloadButton(ns('downloadData4BoxPlot'), 'Download stats for individual time series')
}
})
......@@ -56,10 +59,9 @@ modStats = function(input, output, session,
'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]
'rCV' = IQR(x)/median(x))), .SDcols = in.meascol, by = in.bycols]
setnames(loc.dt.aggr, c(in.bycols, 'N', 'Mean', 'CV', 'Median', 'rCV IQR', 'rCV MAD'))
setnames(loc.dt.aggr, c(in.bycols, 'nPoints', 'Mean', 'CV', 'Median', 'rCV'))
return(loc.dt.aggr)
})
......
modules/dispTrackStats.R
View file @ 3f2d3136
......@@ -74,7 +74,7 @@ modTrackStats = function(input, output, session,
'measMean' = mean(x, na.rm = T),
'measSD' = sd(x, na.rm = T),
'measCV' = sd(x, na.rm = T)/mean(x, na.rm = T),
'measMedian' = median(x, na.rm = T),
'measMedian' = median(as.double(x), na.rm = T),
'measIQR' = IQR(x, na.rm = T),
'meas_rCV_IQR' = IQR(x, na.rm = T)/median(x, na.rm = T))), .SDcols = COLY, by = c(in.bycols)]
......@@ -96,10 +96,10 @@ modTrackStats = function(input, output, session,
by = c(in.bycols, COLID)][, .(tracksN = .N,
tracksLenMean = mean(nTpts),
tracksLenSD = sd(nTpts),
tracksLenMedian = median(nTpts),
tracksLenMedian = median(as.double(nTpts)),
tracksLenIQR = IQR(nTpts)), by = c(in.bycols)]
setnames(loc.dt.aggr, c(in.bycols, '#Tracks', 'Mean', 'SD', 'Median', 'IQR'))
setnames(loc.dt.aggr, c(in.bycols, 'nTracks', 'Mean', 'SD', 'Median', 'IQR'))
return(loc.dt.aggr)
})
......
modules/tabAUC.R
View file @ 3f2d3136
......@@ -39,7 +39,7 @@ modAUCplot = function(input, output, session, in.data, in.fname) {
if (is.null(loc.dt))
return(NULL)
else
return(unique(loc.dt[['realtime']]))
return(unique(loc.dt[[COLRT]]))
})
# UI for trimming x-axis (time)
......@@ -72,7 +72,7 @@ modAUCplot = function(input, output, session, in.data, in.fname) {
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)]
loc.res = loc.dt[get(COLRT) >= input$slTimeTrim[1] & get(COLRT) <= input$slTimeTrim[2], .(AUC = trapz(get(COLRT), get(COLY))), by = c(COLGR, COLID)]
return(loc.res)
}
})
......@@ -80,15 +80,15 @@ modAUCplot = function(input, output, session, in.data, in.fname) {
callModule(modStats, 'dispStats',
in.data = AUCcells,
in.meascol = 'AUC',
in.bycols = c('group'),
in.bycols = COLGR,
in.fname = 'data4boxplotAUC.csv')
callModule(modBoxPlot, 'boxPlot',
in.data = AUCcells,
in.cols = list(meas.x = 'group',
in.cols = list(meas.x = COLGR,
meas.y = 'AUC',
group = 'group',
id = 'id'),
group = COLGR,
id = COLID),
in.fname = in.fname)
......
modules/tabBoxPlot.R
View file @ 3f2d3136
......@@ -6,19 +6,22 @@
#
# UI ----
tabBoxPlotUI = function(id, label = "Comparing t-points") {
tabBoxPlotUI = function(id, label = "Snapshots at time points") {
ns <- NS(id)
tagList(
h4(
"Box-/dot-/violin plot at selected t-points"
"Box-/dot-/violin plots at selected time points"
),
br(),
uiOutput(ns('varSelTpts')),
checkboxInput(ns('chBfoldCh'), 'Fold change w.r.t. t-point:'),
uiOutput(ns('uiSlFoldChTp')),
# This is an experimental feature to re-normalise data points with respect to a selected time point
# Current implementation is limited; in the future slider should be replaced by an input field or a choice list.
# currenlty, if the selected time point is larger than the smallest time point for snapshot plotting, error appears.
#checkboxInput(ns('chBfoldCh'), 'Fold change w.r.t. t-point:'),
#uiOutput(ns('uiSlFoldChTp')),
modStatsUI(ns('dispStats')),
br(),
......@@ -33,14 +36,14 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
callModule(modStats, 'dispStats',
in.data = data4boxPlot,
in.meascol = 'y',
in.bycols = c('realtime', 'group'),
in.bycols = c(COLRT, COLGR),
in.fname = 'data4boxplotTP.csv')
callModule(modBoxPlot, 'boxPlot',
in.data = data4boxPlot,
in.cols = list(meas.x = 'realtime',
meas.y = 'y',
group = 'group',
in.cols = list(meas.x = COLRT,
meas.y = COLY,
group = COLGR,
id = 'id'),
in.fname = in.fname)
......@@ -54,7 +57,7 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
if (is.null(loc.dt))
return(NULL)
else
return(unique(loc.dt[, realtime])) # column name specified in data4trajPlot
return(unique(loc.dt[[COLRT]])) # column name specified in data4trajPlot
})
output$uiSlFoldChTp = renderUI({
......@@ -75,23 +78,21 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
if (is.null(loc.dt))
return(NULL)
if(input$chBfoldCh) {
out.dt = loc.dt[realtime %in% input$inSelTpts]
loc.dt.aux = loc.dt[realtime %in% c(as.numeric(input$inSelTpts) - input$slFoldChTp)]
loc.y.prev = loc.dt.aux[, y]
print(nrow(loc.dt.aux))
print(nrow(out.dt))
out.dt[, y.prev := loc.y.prev]
print(out.dt)
out.dt[, y := abs(y / y.prev)]
print(out.dt)
out.dt[, y.prev := NULL]
print(out.dt)
} else
out.dt = loc.dt[realtime %in% input$inSelTpts]
# This is part of re-nromalisation with respect to a time point.
# Test version here; works but needs improvements; see UI section
# if(input$chBfoldCh) {
# out.dt = loc.dt[get(COLRT) %in% input$inSelTpts]
# loc.dt.aux = loc.dt[get(COLRT) %in% c(as.numeric(input$inSelTpts) - input$slFoldChTp)]
# loc.y.prev = loc.dt.aux[, y]
#
# out.dt[, y.prev := loc.y.prev]
#
# out.dt[, y := abs(y / y.prev)]
#
# out.dt[, y.prev := NULL]
#
# } else
out.dt = loc.dt[get(COLRT) %in% input$inSelTpts]
return(out.dt)
......@@ -103,13 +104,14 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) {
ns <- session$ns
loc.v = getDataTpts()
if (!is.null(loc.v)) {
selectInput(
ns('inSelTpts'),
'Select one or more t-points:',
loc.v,
width = '100%',
selected = 0,
selected = loc.v[[1]],
multiple = TRUE
)
}
......
modules/tabClHier.R
View file @ 3f2d3136
......@@ -9,23 +9,10 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
ns <- NS(id)
tagList(
h4('Hierarchical clustering'),
br(),
fluidRow(
column(4,
selectInput(
ns("selectPlotHierLinkage"),
label = ("Select linkage method:"),
choices = list(
"Ward" = 1,
"Ward D2" = 2,
"Single" = 3,
"Complete" = 4,
"Average" = 5,
"McQuitty" = 6,
"Centroid" = 7
),
selected = 2
),
selectInput(
ns("selectPlotHierDiss"),
label = ("Select type of dissimilarity measure:"),
......@@ -33,10 +20,22 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
"Maximum" = 2,
"Manhattan" = 3,
"Canberra" = 4,
"Binary" = 5,
"Minkowski" = 6,
"DTW" = 7),
"DTW" = 5),
selected = 1
),
selectInput(
ns("selectPlotHierLinkage"),
label = ("Select linkage method:"),
choices = list(
"Average" = 1,
"Complete" = 2,
"Single" = 3,
"Centroid" = 4,
"Ward" = 5,
"Ward D2" = 6,
"McQuitty" = 7
),
selected = 5
)
),
column(4,
......@@ -58,24 +57,24 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
checkboxInput(ns('chBPlotHierClSel'), 'Manually select clusters to display'),
uiOutput(ns('uiPlotHierClSel')),
downloadButton(ns('downCellCl'), 'Download CSV with cell IDs and cluster no.')
downloadButton(ns('downCellCl'), 'Download CSV with cluster assignments')
)
),
br(),
tabsetPanel(
tabPanel('Heat-map',
tabPanel('Heatmap',
br(),
fluidRow(
column(3,
checkboxInput(ns('selectPlotHierDend'), 'Plot dendrogram and re-order samples', TRUE),
selectInput(
ns("selectPlotHierPaletteDend"),