Commit e102708a authored by dmattek's avatar dmattek

Added: ribbon plot with averages

parent eef7cc31
......@@ -4,6 +4,7 @@ source('modules/downCellIDsCls.R')
source('modules/dispStats.R')
source('modules/dispTrackStats.R')
source('modules/trajPlot.R')
source('modules/trajRibbonPlot.R')
source('modules/boxPlot.R')
source('modules/tabAUC.R')
source('modules/clDistPlot.R')
......
......@@ -36,13 +36,24 @@ downPlotUI <- function(id, label = "Download Plot") {
)
),
column(6,
downloadButton(ns('downPlot'), 'PDF'))
uiOutput(ns('uiDownButton')))
)
)
}
downPlot <- function(input, output, session, in.fname, in.plot, in.gg = FALSE) {
output$uiDownButton = renderUI({
ns <- session$ns
if (in.fname %like% 'pdf') {
downloadButton(ns('downPlot'), 'PDF')
} else {
downloadButton(ns('downPlot'), 'PNG')
}
})
output$downPlot <- downloadHandler(
filename = function() {
in.fname
......
......@@ -151,6 +151,9 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") {
tabPanel('Time-courses',
modTrajPlotUI(ns('modPlotHierTraj'))),
tabPanel('Averages',
modTrajRibbonPlotUI(ns('modPlotHierTrajRibbon'))),
tabPanel('Cluster dist.',
modClDistPlotUI(ns('hierClDistPlot'), 'xxx'))
......@@ -411,6 +414,15 @@ clustHier <- function(input, output, session, in.data4clust, in.data4trajPlot) {
'_',
s.cl.linkage[as.numeric(input$selectPlotHierLinkage)], '.pdf'))
callModule(modTrajRibbonPlot, 'modPlotHierTrajRibbon',
in.data = data4trajPlotCl,
in.facet = 'cl',
in.facet.color = getClColHier,
in.fname = paste0('clust_hierch_tCoursesMeans_',
s.cl.diss[as.numeric(input$selectPlotHierDiss)],
'_',
s.cl.linkage[as.numeric(input$selectPlotHierLinkage)], '.pdf'))
callModule(modClDistPlot, 'hierClDistPlot',
in.data = data4clDistPlot,
in.cols = getClColHier,
......
......@@ -455,7 +455,14 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo
'_',
s.cl.spar.linkage[as.numeric(input$selectPlotHierSparLinkage)], '.pdf'))
callModule(modTrajRibbonPlot, 'modPlotHierSparTrajRibbon',
in.data = data4trajPlotClSpar,
in.facet = 'cl',
in.facet.color = getClColHierSpar,
in.fname = paste0('clust_hierchSparse_tCoursesMeans_',
s.cl.diss[as.numeric(input$selectPlotHierSparDiss)],
'_',
s.cl.linkage[as.numeric(input$selectPlotHierSparLinkage)], '.pdf'))
callModule(modClDistPlot, 'hierClSparDistPlot',
......
require(DT)
require(tca)
modTrajRibbonPlotUI = function(id, label = "Plot Individual Time Series") {
ns <- NS(id)
tagList(
fluidRow(
column(
3,
checkboxInput(ns('chBplotTrajInt'), 'Interactive Plot?'),
actionButton(ns('butPlotTraj'), 'Plot!')
),
column(
3,
sliderInput(ns('sliPlotTrajSkip'), 'Plot every n-th point:', min = 1, max = 10, value = 1, step = 1)
),
column(
3,
numericInput(
ns('inPlotTrajWidth'),
'Width [%]:',
value = 100,
min = 10,
max = 100,
width = '100px',
step = 10
),
numericInput(
ns('inPlotTrajHeight'),
'Height [px]:',
value = 800,
min = 100,
width = '100px',
step = 50
)
)
),
uiOutput(ns('uiPlotTraj')),
br(),
modTrackStatsUI(ns('dispTrackStats')),
downPlotUI(ns('downPlotTraj'), "Download PDF")
)
}
modTrajRibbonPlot = function(input, output, session, in.data, in.facet = 'group', in.facet.color = NULL, in.fname = 'tCourses.pdf') {
ns <- session$ns
output$uiPlotTraj = renderUI({
if (input$chBplotTrajInt)
plotlyOutput(
ns("outPlotTrajInt"),
width = paste0(input$inPlotTrajWidth, '%'),
height = paste0(input$inPlotTrajHeight, 'px')
) else
plotOutput(
ns("outPlotTraj"),
width = paste0(input$inPlotTrajWidth, '%'),
height = paste0(input$inPlotTrajHeight, 'px')
)
})
callModule(modTrackStats, 'dispTrackStats',
in.data = in.data)
output$outPlotTraj <- renderPlot({
loc.p = plotTraj()
if(is.null(loc.p))
return(NULL)
return(loc.p)
})
output$outPlotTrajInt <- renderPlotly({
# 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)
loc.p = plotTraj()
if(is.null(loc.p))
return(NULL)
return(plotly_build(loc.p))
})
# Trajectory plot - download pdf
callModule(downPlot, "downPlotTraj", in.fname, plotTraj, TRUE)
plotTraj <- function() {
cat(file = stderr(), 'plotTraj: in\n')
locBut = input$butPlotTraj
if (locBut == 0) {
cat(file = stderr(), 'plotTraj: Go button not pressed\n')
return(NULL)
}
loc.dt = isolate(in.data())
cat("plotTraj: on to plot\n\n")
if (is.null(loc.dt)) {
cat(file = stderr(), 'plotTraj: dt is NULL\n')
return(NULL)
}
cat(file = stderr(), 'plotTraj: dt not NULL\n')
# Future: change such that a column with colouring status is chosen by the user
# colour trajectories, if dataset contains mid.in column
# with filtering status of trajectory
if (sum(names(loc.dt) %in% 'mid.in') > 0)
loc.line.col.arg = 'mid.in'
else
loc.line.col.arg = NULL
# select every other point for plotting
loc.dt = loc.dt[, .SD[seq(1, .N, input$sliPlotTrajSkip)], by = id]
# check if columns with XY positions are present
if (sum(names(loc.dt) %like% 'pos') == 2)
locPos = TRUE
else
locPos = FALSE
# check if column with ObjectNumber is present
if (sum(names(loc.dt) %like% 'obj.num') == 1)
locObjNum = TRUE
else
locObjNum = FALSE
# If in.facet.color present,
# make sure to include the same number of colours in the palette,
# as the number of groups in dt.
# in.facet.color is typically used when plotting time series within clusters.
# Then, the number of colours in the palette has to be equal to the number of clusters (facetted according to in.facet variable).
# This might differ if the user selects manually clusters to display.
if (is.null(in.facet.color))
loc.facet.col = NULL
else {
# get group numbers in dt;
# loc.dt[, c(in.facet), with = FALSE] returns a data table with a single column
# [[1]] at the end extracts the first column and returns as a vector
loc.groups = unique(loc.dt[, c(in.facet), with = FALSE][[1]])
# get colour palette
# the length is equal to the number of groups in the original dt.
# When plotting time series within clusters, the length equals the number of clusters.
loc.facet.col = in.facet.color()$cl.col
loc.facet.col = loc.facet.col[loc.groups]
}
loc.dt.aggr = calcTrajCI(in.dt = loc.dt,
in.col.meas = 'y',
in.col.by = c(in.facet, 'realtime'),
in.type = 'normal')
loc.dt.aggr[, (in.facet) := as.factor(get(in.facet))]
p.out = tca::plotTrajRibbon(dt.arg = loc.dt.aggr,
x.arg = 'realtime',
y.arg = 'Mean',
col.arg = loc.facet.col,
group.arg = in.facet,
xlab.arg = 'Time (min)',
ylab.arg = '')
# p.out = myGgplotTraj(
# 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,
# xlab.arg = 'Time (min)',
# line.col.arg = loc.line.col.arg,
# aux.label1 = if (locPos) 'pos.x' else NULL,
# aux.label2 = if (locPos) 'pos.y' else NULL,
# aux.label3 = if (locObjNum) 'obj.num' else NULL,
# stat.arg = input$chBPlotTrajStat
# )
return(p.out)
}
}
\ No newline at end of file
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