Skip to content

GitLab

S
shiny-timecourse-inspector
Commit 3874ce02 authored by dmattek's avatar dmattek
Browse files
Options

Added: 

- box-/dot-/violin plots at discrete time points
parent e346fce2
Hide whitespace changes
Inline Side-by-side
Showing with 289 additions and 129 deletions
global.R
View file @ 3874ce02
...@@ -2,4 +2,5 @@ source('modules/auxfunc.R') ...@@ -2,4 +2,5 @@ source('modules/auxfunc.R')
source('modules/downPlot.R') source('modules/downPlot.R')
source('modules/downCellIDsCls.R') source('modules/downCellIDsCls.R')
source('modules/tabScatter.R') source('modules/tabScatter.R')
source('modules/tabBoxPlot.R')
source('modules/tabClBay.R') source('modules/tabClBay.R')
\ No newline at end of file
modules/tabBoxPlot.R 0 → 100644
View file @ 3874ce02
require(DT)
tabBoxPlotUI = function(id, label = "Comparing t-points") {
ns <- NS(id)
tagList(
uiOutput(ns('varSelTpts')),
DT::dataTableOutput(ns('outTabStats')),
downloadButton(ns('downloadData4BoxPlot'), 'Download single-cell data'),
fluidRow(
column(
6,
radioButtons(ns('inPlotType'), 'Plot type:', list('Box-plot' = 'box',
'Dot-plot' = 'dot',
'Violin-plot' = 'viol',
'Line-plot' = 'line')),
uiOutput(ns('uiPlotBoxNotches')),
uiOutput(ns('uiPlotBoxOutliers')),
uiOutput(ns('uiPlotDotNbins'))
),
column(
6,
selectInput(
ns('selPlotBoxLegendPos'),
label = 'Select legend position',
choices = list(
"Top" = 'top',
"Right" = 'right',
"Bottom" = 'bottom'
),
selected = 'top'
)
)
),
actionButton(ns('butPlotBox'), 'Plot!'),
plotOutput(ns('outPlotBox'), height = 800),
downPlotUI(ns('downPlotBox'), "Download PDF")
)
}
####
## server box-plot
tabBoxPlot = function(input, output, session, in.data) {
# 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])) # column name specified in data4trajPlot
})
# prepare data for plotting boxplots
# uses the same dt as for trajectory plotting
# returns dt with these columns:
data4boxPlot <- reactive({
cat(file = stderr(), 'data4boxPlot\n')
loc.dt = in.data()
if (is.null(loc.dt))
return(NULL)
loc.out = loc.dt[realtime %in% input$inSelTpts]
})
output$varSelTpts = renderUI({
cat(file = stderr(), 'UI varSelTpts\n')
ns <- session$ns
loc.v = getDataTpts()
if (!is.null(loc.v)) {
selectInput(
ns('inSelTpts'),
'Select one or more timepoints:',
loc.v,
width = '100%',
selected = 0,
multiple = TRUE
)
}
})
output$uiPlotBoxNotches = renderUI({
cat(file = stderr(), 'UI uiPlotBoxNotches\n')
ns <- session$ns
if(input$inPlotType == 'box')
checkboxInput(ns('inPlotBoxNotches'), 'Box plot notches?', FALSE)
})
output$uiPlotBoxOutliers = renderUI({
cat(file = stderr(), 'UI uiPlotBoxNotches\n')
ns <- session$ns
if(input$inPlotType == 'box')
checkboxInput(ns('inPlotBoxOutliers'), 'Box plot outliers?', FALSE)
})
output$uiPlotDotNbins = renderUI({
cat(file = stderr(), 'UI uiPlotDotNbins\n')
ns <- session$ns
if(input$inPlotType == 'dot')
sliderInput(ns('inPlotDotNbins'), 'Dot-plot binsize:', min = 0.01, max = 1, value = .1)
})
calcStats = reactive({
cat(file = stderr(), 'tabBoxPlot: calsStats\n')
loc.dt = data4boxPlot()
if (is.null(loc.dt))
return(NULL)
loc.dt.aggr = loc.dt[, sapply(.SD, function(x) list('Mean' = mean(x), 'CV' = sd(x)/mean(x), 'Median' = median(x), 'rCV (IQR)' = IQR(x)/median(x), 'rCV (MAD)'= mad(x)/median(x))), .SDcols = c('y'), by = .(realtime, group)]
setnames(loc.dt.aggr, c('Time point', 'Group', 'Mean', 'CV', 'Median', 'rCV IQR', 'rCV MAD'))
print(loc.dt.aggr)
return(loc.dt.aggr)
})
output$downloadData4BoxPlot <- downloadHandler(
filename = 'data4boxplot.csv',
content = function(file) {
write.csv(data4boxPlot(), file, row.names = FALSE)
}
)
# output$outTabStats = DT::renderDataTable(calcStats(),
# server = FALSE,
# 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'))))
#
output$outTabStats = DT::renderDataTable(server = FALSE, {
cat(file = stderr(), 'tabBoxPlot: outTabStats\n')
loc.dt = calcStats()
if (is.null(loc.dt))
return(NULL)
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(3:7, 3)
})
# Boxplot - display
output$outPlotBox = renderPlot({
locBut = input$butPlotBox
if (locBut == 0) {
cat(file = stderr(), 'plotBox: Go button not pressed\n')
return(NULL)
}
plotBox()
}, height = 800)
# Boxplot - download pdf
callModule(downPlot, "downPlotBox", 'boxplot.pdf', 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 = data4boxPlot()
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')
p.out = ggplot(loc.dt, aes(x = as.factor(realtime), y = y))
if (input$inPlotType == 'box')
p.out = p.out + geom_boxplot(
aes(fill = group),
#position = position_dodge(width = 1),
notch = input$inPlotBoxNotches,
outlier.colour = if (input$inPlotBoxOutliers)
'red'
else
NA
)
if(input$inPlotType == 'dot')
p.out = p.out + geom_dotplot(aes(fill = group), binaxis = "y", stackdir = "center", position = "dodge", binwidth = input$inPlotDotNbins, method = 'histodot')
if(input$inPlotType == 'viol')
p.out = p.out + geom_violin(aes(fill = group))
if(input$inPlotType == 'line')
p.out = p.out + geom_path(aes(color = group, group = id))
p.out = p.out +
scale_fill_discrete(name = '') +
xlab('\nTime (min)') +
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.x = element_text(size = 12),
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
)
return(p.out)
}
}
\ No newline at end of file
modules/tabScatter.R
View file @ 3874ce02
...@@ -12,6 +12,7 @@ ...@@ -12,6 +12,7 @@
require(plotly) # interactive plot require(plotly) # interactive plot
require(robust) require(robust)
require(MASS)
# UI # UI
tabScatterPlotUI <- function(id, label = "Comparing t-points") { tabScatterPlotUI <- function(id, label = "Comparing t-points") {
......
server.R
View file @ 3874ce02
...@@ -20,7 +20,7 @@ library(sparcl) # sparse hierarchical and k-means ...@@ -20,7 +20,7 @@ library(sparcl) # sparse hierarchical and k-means
library(scales) # for percentages on y scale library(scales) # for percentages on y scale
# increase file upload limit # increase file upload limit
options(shiny.maxRequestSize = 30 * 1024 ^ 2) options(shiny.maxRequestSize = 80 * 1024 ^ 2)
shinyServer(function(input, output, session) { shinyServer(function(input, output, session) {
useShinyjs() useShinyjs()
...@@ -377,9 +377,18 @@ shinyServer(function(input, output, session) { ...@@ -377,9 +377,18 @@ shinyServer(function(input, output, session) {
if (is.null(loc.dt)) if (is.null(loc.dt))
return(NULL) return(NULL)
loc.dt[, trackObjectsLabelUni := paste(sprintf("%03d", get(input$inSelSite)), loc.types = lapply(loc.dt, class)
sprintf("%04d", get(input$inSelTrackLabel)), if(loc.types[[input$inSelTrackLabel]] == 'numeric')
sep = "_")] {
loc.dt[, trackObjectsLabelUni := paste(sprintf("%03d", get(input$inSelSite)),
sprintf("%04d", get(input$inSelTrackLabel)),
sep = "_")]
} else {
loc.dt[, trackObjectsLabelUni := paste(sprintf("%03s", get(input$inSelSite)),
sprintf("%s", get(input$inSelTrackLabel)),
sep = "_")]
}
return(loc.dt) return(loc.dt)
}) })
...@@ -559,18 +568,6 @@ shinyServer(function(input, output, session) { ...@@ -559,18 +568,6 @@ shinyServer(function(input, output, session) {
return(loc.out) return(loc.out)
}) })
# prepare data for plotting boxplots
# uses the same dt as for trajectory plotting
# returns dt with these columns:
data4boxPlot <- reactive({
cat(file = stderr(), 'data4boxPlot\n')
loc.dt = data4trajPlot()
if (is.null(loc.dt))
return(NULL)
loc.out = loc.dt[realtime %in% input$inSelTpts]
})
# prepare data for clustering # prepare data for clustering
...@@ -718,89 +715,9 @@ shinyServer(function(input, output, session) { ...@@ -718,89 +715,9 @@ shinyServer(function(input, output, session) {
} }
###### Box-plot
callModule(tabBoxPlot, 'tabBoxPlot', data4trajPlot)
####
## UI for box-plot
output$varSelTpts = renderUI({
cat(file = stderr(), 'UI varSelTpts\n')
loc.v = getDataTpts()
if (!is.null(loc.v)) {
selectInput(
'inSelTpts',
'Select one or more timepoints:',
loc.v,
width = '100%',
selected = 0,
multiple = TRUE
)
}
})
# Boxplot - display
output$outPlotBox = renderPlot({
locBut = input$butPlotBox
if (locBut == 0) {
cat(file = stderr(), 'plotBox: Go button not pressed\n')
return(NULL)
}
plotBox()
}, height = 800)
# Boxplot - download pdf
callModule(downPlot, "downPlotBox", 'boxplot.pdf', 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 = data4boxPlot()
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')
ggplot(loc.dt, aes(x = as.factor(realtime), y = y)) +
geom_boxplot(
aes(fill = group),
#position = position_dodge(width = 1),
notch = input$inPlotBoxNotches,
outlier.colour = if(input$inPlotBoxOutliers) 'red' else NA
) +
scale_fill_discrete(name = '') +
xlab('\nTime (min)') +
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.x = element_text(size = 12),
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
)
}
###### Scatter plot ###### Scatter plot
......
ui.R
View file @ 3874ce02
...@@ -113,32 +113,9 @@ shinyUI(fluidPage( ...@@ -113,32 +113,9 @@ shinyUI(fluidPage(
downPlotUI('downPlotTraj', "Download PDF") downPlotUI('downPlotTraj', "Download PDF")
), ),
tabPanel("Box-plots", tabPanel(
br(), "Box-plots",
fluidRow( tabBoxPlotUI('tabBoxPlot')
column(
6,
checkboxInput('inPlotBoxNotches', 'Box plot notches?', FALSE),
checkboxInput('inPlotBoxOutliers', 'Box plot outliers?', TRUE)
),
column(
6,
selectInput('selPlotBoxLegendPos',
label = 'Select legend position',
choices = list(
"Top" = 'top',
"Right" = 'right',
"Bottom" = 'bottom'
),
selected = 'top')
)
),
uiOutput('varSelTpts'),
actionButton('butPlotBox', 'Plot!'),
plotOutput('outPlotBox', height = 800),
downPlotUI('downPlotBox', "Download PDF")
), ),
...@@ -475,11 +452,11 @@ shinyUI(fluidPage( ...@@ -475,11 +452,11 @@ shinyUI(fluidPage(
actionButton('butPlotHierSparClDist', 'Plot!'), actionButton('butPlotHierSparClDist', 'Plot!'),
plotOutput('outPlotHierSparClDist')) plotOutput('outPlotHierSparClDist'))
) )
), )
#
tabPanel( # tabPanel(
'Bayesian Cl.', # 'Bayesian Cl.',
clustBayUI('TabClustBay')) # clustBayUI('TabClustBay'))
)) ))
) )
......
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