From 082b907abf07f51cf86319f81ddba3ec68db1a15 Mon Sep 17 00:00:00 2001 From: dmattek Date: Wed, 2 Oct 2019 02:14:28 +0200 Subject: [PATCH] Bug fixes --- global.R | 7 +- modules/{boxPlot.R => aucPlot.R} | 175 ++++++++-------- modules/auxfunc.R | 15 +- modules/clDistPlot.R | 2 +- modules/distPlot.R | 306 ++++++++++++++++++++++++++++ modules/tabAUC.R | 17 +- modules/tabClHier.R | 4 +- modules/tabClHierSpar.R | 51 +++-- modules/{tabBoxPlot.R => tabDist.R} | 13 +- modules/tabScatter.R | 104 ++++++---- modules/trajPlot.R | 4 +- server.R | 8 +- ui.R | 4 +- 13 files changed, 531 insertions(+), 179 deletions(-) rename modules/{boxPlot.R => aucPlot.R} (50%) create mode 100644 modules/distPlot.R rename modules/{tabBoxPlot.R => tabDist.R} (89%) diff --git a/global.R b/global.R index da5fe7b..a3c67c3 100644 --- a/global.R +++ b/global.R @@ -7,10 +7,11 @@ source('modules/dispTrackStats.R') source('modules/trajPlot.R') source('modules/trajRibbonPlot.R') source('modules/trajPsdPlot.R') -source('modules/boxPlot.R') -source('modules/tabAUC.R') +source('modules/aucPlot.R') +source('modules/distPlot.R') source('modules/clDistPlot.R') source('modules/tabScatter.R') -source('modules/tabBoxPlot.R') +source('modules/tabDist.R') +source('modules/tabAUC.R') source('modules/tabClHier.R') source('modules/tabClHierSpar.R') \ No newline at end of file diff --git a/modules/boxPlot.R b/modules/aucPlot.R similarity index 50% rename from modules/boxPlot.R rename to modules/aucPlot.R index 41e91e4..e707029 100644 --- a/modules/boxPlot.R +++ b/modules/aucPlot.R @@ -2,7 +2,7 @@ # Time Course Inspector: Shiny app for plotting time series data # Author: Maciej Dobrzynski # -# This module is for plotting a choice of box/violin/dot-plots +# This module is for plotting AUC as a choice of box/violin/dot-plots # Assumes in.data contains columns: # realtime # y @@ -10,44 +10,46 @@ # id # UI ---- -modBoxPlotUI = function(id, label = "Plot Box-plots") { +modAUCplotUI = function(id, label = "Plot AUC distributions") { 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!') + checkboxInput(ns("chBPlotTypeBox"), "Box-plot", value = T), + checkboxInput(ns("chBPlotTypeDot"), "Dot-plot", value = F), + checkboxInput(ns("chBPlotTypeViol"), "Violin-plot", value = F), + checkboxInput(ns('chBPlotInt'), 'Interactive Plot'), + actionButton(ns('butPlot'), 'Plot!') + ), + column( + 4, + uiOutput(ns('uiPlotBoxNotches')), + uiOutput(ns('uiPlotBoxOutliers')), + uiOutput(ns('uiPlotDotNbins')), + uiOutput(ns('uiPlotDotShade')) ), column( 4, selectInput( - ns('selPlotBoxLegendPos'), + ns('selPlotLegendPos'), label = 'Legend position', choices = list( "Top" = 'top', "Right" = 'right', "Bottom" = 'bottom' - ), + ), + width = "120px", selected = 'top' ), - uiOutput(ns('uiPlotBoxNotches')), - uiOutput(ns('uiPlotBoxOutliers')), - uiOutput(ns('uiPlotBoxDodge')), - #uiOutput(ns('uiPlotBoxWidth')), - uiOutput(ns('uiPlotBoxAlpha')), - uiOutput(ns('uiPlotDotNbins')) - ), - column( - 4, + radioButtons(ns("rBAxisLabelsRotate"), "X-axis labels", + c("horizontal" = 0, + "45 deg" = 45, + "90 deg" = 90)), numericInput( ns('inPlotBoxWidth'), - 'Width [%]:', + 'Width [%]', value = PLOTWIDTH, min = 10, width = '100px', @@ -55,16 +57,12 @@ modBoxPlotUI = function(id, label = "Plot Box-plots") { ), numericInput( ns('inPlotBoxHeight'), - 'Height [px]:', + 'Height [px]', value = PLOTBOXHEIGHT, min = 100, width = '100px', step = 50 - ), - radioButtons(ns("rBAxisLabelsRotate"), "X-axis labels:", - c("horizontal" = 0, - "45 deg" = 45, - "90 deg" = 90)) + ) ) ), @@ -74,76 +72,63 @@ modBoxPlotUI = function(id, label = "Plot Box-plots") { } # SERVER ---- -modBoxPlot = function(input, output, session, - in.data, - in.cols = list(meas.x = COLRT, +modAUCplot = function(input, output, session, + in.data, # input data table in long format + in.cols = list(meas.x = COLRT, # column names meas.y = COLY, group = COLGR, id = COLID), - in.fname) { + in.labels = list(x = "", # plot labels + y = "", + legend = ""), + in.fname) { # file name for saving the plot ns <- session$ns - + + # optional UI depending on the type of the plot chosen output$uiPlotBoxNotches = renderUI({ - cat(file = stderr(), 'UI uiPlotBoxNotches\n') + cat(file = stderr(), 'aucPlot:uiPlotBoxNotches\n') ns <- session$ns - if('box' %in% input$inPlotType) - checkboxInput(ns('inPlotBoxNotches'), 'Box plot notches', FALSE) + if(input$chBPlotTypeBox) + checkboxInput(ns('chBplotBoxNotches'), 'Notches in box-plot', FALSE) }) output$uiPlotBoxOutliers = renderUI({ - cat(file = stderr(), 'UI uiPlotBoxNotches\n') + cat(file = stderr(), 'aucPlot:uiPlotBoxNotches\n') ns <- session$ns - if('box' %in% input$inPlotType) - checkboxInput(ns('inPlotBoxOutliers'), 'Box plot outliers', FALSE) + if(input$chBPlotTypeBox) + checkboxInput(ns('chBplotBoxOutliers'), 'Outliers in box-plot', FALSE) }) - output$uiPlotBoxDodge = renderUI({ - cat(file = stderr(), 'UI uiPlotBoxDodge\n') - - ns <- session$ns - - if(!( 'line' %in% input$inPlotType )) - sliderInput(ns('inPlotBoxDodge'), 'Space between groups:', min = 0, max = 1, value = .4, step = 0.05) - }) - output$uiPlotBoxWidth = renderUI({ - cat(file = stderr(), 'UI uiPlotBoxWidth\n') + output$uiPlotDotShade = renderUI({ + cat(file = stderr(), 'aucPlot:uiPlotDotShade\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) + if(input$chBPlotTypeDot) + sliderInput(ns('slPlotDotShade'), "Shade of grey in dot-plot", min = 0, max = 1, value = 0.5, step = 0.1) }) output$uiPlotDotNbins = renderUI({ - cat(file = stderr(), 'UI uiPlotDotNbins\n') + cat(file = stderr(), 'aucPlot:uiPlotDotNbins\n') ns <- session$ns - if('dot' %in% input$inPlotType) - sliderInput(ns('inPlotDotNbins'), '#Bins for dot-plot:', min = 2, max = 50, value = 30, step = 1) + if(input$chBPlotTypeDot) + sliderInput(ns('slPlotDotNbins'), 'Number of bins in dot-plot', min = 2, max = 50, value = 30, step = 1) }) # Boxplot - display output$outPlotBox = renderPlot({ - locBut = input$butPlotBox + locBut = input$butPlot if (locBut == 0) { - cat(file = stderr(), 'plotBox: Go button not pressed\n') + cat(file = stderr(), 'aucPlot:Go button not pressed\n') return(NULL) } @@ -153,10 +138,10 @@ modBoxPlot = function(input, output, session, output$outPlotBoxInt = renderPlotly({ - locBut = input$butPlotBox + locBut = input$butPlot if (locBut == 0) { - cat(file = stderr(), 'plotBox: Go button not pressed\n') + cat(file = stderr(), 'aucPlot:Go button not pressed\n') return(NULL) } @@ -175,7 +160,7 @@ modBoxPlot = function(input, output, session, output$uiPlotBox <- renderUI({ ns <- session$ns - if (input$chBPlotBoxInt) + if (input$chBPlotInt) plotlyOutput(ns("outPlotBoxInt"), width = paste0(input$inPlotBoxWidth, '%'), height = paste0(input$inPlotBoxHeight, 'px')) @@ -193,7 +178,7 @@ modBoxPlot = function(input, output, session, # This function is used to plot and to downoad a pdf plotBox <- function() { - cat(file = stderr(), 'plotBox\n') + cat(file = stderr(), 'aucPlot:plotBox\n') loc.dt = in.data() @@ -205,54 +190,56 @@ 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[[COLGR]]), + + if(input$chBPlotTypeDot) { + # calculate bin width for dot-plot based on nBins provided in the UI + loc.binwidth = abs(max(loc.dt[[ in.cols$meas.y ]], + na.rm = T) - + min(loc.dt[[ in.cols$meas.y ]], + na.rm = T)) / (input$slPlotDotNbins - 1) + + p.out = p.out + geom_dotplot(fill = grey(input$slPlotDotShade), color = NA, - binaxis = in.cols$meas.y, + binaxis = "y", stackdir = "center", - position = loc.par.dodge, - 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), + binwidth = loc.binwidth, method = 'histodot') + + } - if('viol' %in% input$inPlotType) - p.out = p.out + geom_violin(aes_string(fill = in.cols[[COLGR]]), - position = loc.par.dodge, - width = 0.2) - - if('line' %in% input$inPlotType) + if(input$chBPlotTypeViol) p.out = p.out + - geom_path(aes_string(color = in.cols[[COLGR]], group = in.cols[[COLID]])) + - facet_wrap(as.formula(paste("~", in.cols[[COLGR]]))) + geom_violin(fill = NA, + color = "black", + width = 0.2) - if ('box' %in% input$inPlotType) + if (input$chBPlotTypeBox) p.out = p.out + geom_boxplot( - aes_string(fill = in.cols[[COLGR]]), - position = loc.par.dodge, - #width = 0.2, #input$inPlotBoxWidth, - notch = input$inPlotBoxNotches, - alpha = input$inPlotBoxAlpha, - outlier.colour = if (input$inPlotBoxOutliers) + fill = NA, + color = "black", + notch = input$chBplotBoxNotches, + outlier.colour = if (input$chBplotBoxOutliers) 'red' else NA ) p.out = p.out + - scale_fill_discrete(name = '') + - xlab('') + - ylab('') + + scale_fill_discrete(name = in.labels$legend) + + xlab(in.labels$x) + + ylab(in.labels$y) + LOCggplotTheme(in.font.base = PLOTFONTBASE, in.font.axis.text = PLOTFONTAXISTEXT, in.font.axis.title = PLOTFONTAXISTITLE, in.font.strip = PLOTFONTFACETSTRIP, in.font.legend = PLOTFONTLEGEND) + - theme(legend.position = input$selPlotBoxLegendPos, + theme(legend.position = input$selPlotLegendPos, axis.text.x = LOCrotatedAxisElementText(as.numeric(input$rBAxisLabelsRotate), size = PLOTFONTAXISTEXT)) - + return(p.out) } diff --git a/modules/auxfunc.R b/modules/auxfunc.R index ed1487e..10af4ac 100644 --- a/modules/auxfunc.R +++ b/modules/auxfunc.R @@ -129,16 +129,16 @@ l.col.pal.dend.2 = list( # Clustering algorithms ---- -s.cl.linkage = c("average", - "complete", +s.cl.linkage = c("complete", + "average", "single", "centroid", "ward.D", "ward.D2", "mcquitty") -s.cl.spar.linkage = c("average", - "complete", +s.cl.spar.linkage = c("complete", + "average", "single", "centroid") @@ -191,10 +191,9 @@ help.text.short = c( '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 + 'Instead of the value at a selected time point, y-axis can display a difference between values at two selected time points.', #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 + 'A number of time points left & right of selected time points; use the mean of values from these time points for the scatterplot.' #17 ) # Functions for data processing ---- @@ -809,7 +808,7 @@ LOCggplotScat = function(dt.arg, trend.arg = T, ci.arg = 0.95) { - p.tmp = ggplot(dt.arg, aes(x = x, y = y)) + + p.tmp = ggplot(dt.arg, aes(x = x, y = y, label = id)) + geom_point(alpha = alpha.arg) if (trend.arg) { diff --git a/modules/clDistPlot.R b/modules/clDistPlot.R index 67f4eb8..356e9b0 100644 --- a/modules/clDistPlot.R +++ b/modules/clDistPlot.R @@ -65,7 +65,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") + + ylab("Percentage of time series\n") + xlab("Groups") + LOCggplotTheme(in.font.base = PLOTFONTBASE, in.font.axis.text = PLOTFONTAXISTEXT, diff --git a/modules/distPlot.R b/modules/distPlot.R new file mode 100644 index 0000000..860eecc --- /dev/null +++ b/modules/distPlot.R @@ -0,0 +1,306 @@ +# +# Time Course Inspector: Shiny app for plotting time series data +# Author: Maciej Dobrzynski +# +# This module is for plotting distrubutions at selected time points as a choice of box/violin/dot-plots +# Assumes in.data contains columns: +# realtime +# y +# group +# id + +# UI ---- +modDistPlotUI = function(id, label = "Plot distributions") { + ns <- NS(id) + + tagList( + fluidRow( + column( + 4, + checkboxInput(ns("chBplotTypeBox"), "Box-plot", value = T), + checkboxInput(ns("chBplotTypeDot"), "Dot-plot", value = F), + checkboxInput(ns("chBplotTypeViol"), "Violin-plot", value = F), + checkboxInput(ns("chBplotTypeLine"), "Line-plot", value = F), + checkboxInput(ns('chBplotInt'), 'Interactive Plot'), + actionButton(ns('butPlot'), 'Plot!') + ), + column( + 4, + uiOutput(ns('uiPlotBoxNotches')), + uiOutput(ns('uiPlotBoxOutliers')), + uiOutput(ns('uiPlotBoxDodge')), + uiOutput(ns('uiPlotBoxAlpha')), + uiOutput(ns('uiPlotDotNbins')), + uiOutput(ns('uiPlotDotAlpha')), + uiOutput(ns('uiPlotViolAlpha')), + uiOutput(ns('uiPlotLineAlpha')) + ), + column( + 4, + selectInput( + ns('selPlotBoxLegendPos'), + label = 'Legend position', + choices = list( + "Top" = 'top', + "Right" = 'right', + "Bottom" = 'bottom' + ), + width = "120px", + selected = 'top' + ), + radioButtons(ns("rBAxisLabelsRotate"), "X-axis labels", + c("horizontal" = 0, + "45 deg" = 45, + "90 deg" = 90)), + numericInput( + ns('inPlotBoxWidth'), + 'Width [%]', + value = PLOTWIDTH, + min = 10, + width = '100px', + step = 10 + ), + numericInput( + ns('inPlotBoxHeight'), + 'Height [px]', + value = PLOTBOXHEIGHT, + min = 100, + width = '100px', + step = 50 + ) + ) + ), + + uiOutput(ns('uiPlotBox')), + downPlotUI(ns('downPlotBox'), "Download PDF") + ) +} + +# SERVER ---- +modDistPlot = function(input, output, session, + in.data, # input data table in long format + in.cols = list(meas.x = COLRT, # column names + meas.y = COLY, + group = COLGR, + id = COLID), + in.labels = list(x = "", # plot labels + y = "", + legend = ""), + in.fname) { # file name for saving the plot + + ns <- session$ns + + output$uiPlotBoxNotches = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotBoxNotches\n') + + ns <- session$ns + + if(input$chBplotTypeBox) + checkboxInput(ns('chBplotBoxNotches'), 'Notches in box-plot ', FALSE) + }) + + output$uiPlotBoxOutliers = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotBoxOutliers\n') + + ns <- session$ns + + if(input$chBplotTypeBox) + checkboxInput(ns('chBplotBoxOutliers'), 'Outliers in box-plot', FALSE) + }) + + output$uiPlotBoxDodge = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotBoxDodge\n') + + ns <- session$ns + + # Adjust spacing between box-, violin-, dot-plots. + # Valid only when plotting multiple groups at a time point. + # For line plot, each group is drawn separately per facet, thus no need for dodging.. + + if(!input$chBplotTypeLine) + sliderInput(ns('slPlotBoxDodge'), 'Space between groups', min = 0, max = 1, value = .4, step = 0.05) + }) + + output$uiPlotBoxAlpha = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotBoxAlpha\n') + + ns <- session$ns + + if(input$chBplotTypeBox) + sliderInput(ns('slPlotBoxAlpha'), 'Box-plot transparency', min = 0, max = 1, value = 1, step = 0.1) + }) + + output$uiPlotViolAlpha = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotViolAlpha\n') + + ns <- session$ns + + if(input$chBplotTypeViol) + sliderInput(ns('slPlotViolAlpha'), 'Violin-plot transparency', min = 0, max = 1, value = 1, step = 0.1) + }) + + output$uiPlotDotAlpha = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotDotAlpha\n') + + ns <- session$ns + + if(input$chBplotTypeDot) + sliderInput(ns('slPlotDotAlpha'), 'Dot-plot transparency', min = 0, max = 1, value = 1, step = 0.1) + }) + + output$uiPlotLineAlpha = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotLineAlpha\n') + + ns <- session$ns + + if(input$chBplotTypeLine) + sliderInput(ns('slPlotLineAlpha'), 'Line-plot transparency', min = 0, max = 1, value = 1, step = 0.1) + }) + + output$uiPlotDotNbins = renderUI({ + cat(file = stderr(), 'boxPlot:uiPlotDotNbins\n') + + ns <- session$ns + + if(input$chBplotTypeDot) + sliderInput(ns('slPlotDotNbins'), 'Number of bins in dot-plot', min = 2, max = 50, value = 30, step = 1) + }) + + # Boxplot - display + output$outPlotBox = renderPlot({ + locBut = input$butPlot + + if (locBut == 0) { + cat(file = stderr(), 'boxPlot:Go button not pressed\n') + return(NULL) + } + + plotBox() + + }) + + + output$outPlotBoxInt = renderPlotly({ + locBut = input$butPlot + + if (locBut == 0) { + cat(file = stderr(), 'boxPlot:Go button not pressed\n') + return(NULL) + } + + # This is required to avoid + # "Warning: Error in : 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$chBplotInt) + 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') + + if(!input$chBplotTypeLine) { + # Dodging series only for box-, dot-, and violin-plots + loc.par.dodge <- position_dodge(width = input$slPlotBoxDodge) + + # Color fill for all oplots except line, in which groups are plotted per facet + p.out = ggplot(loc.dt, aes_string(x = sprintf("factor(%s)", in.cols$meas.x), + y = in.cols$meas.y, + fill = in.cols$group)) + + } + else { + loc.par.dodge = position_dodge(width = 1) + p.out = ggplot(loc.dt, aes_string(x = sprintf("factor(%s)", in.cols$meas.x), + y = in.cols$meas.y)) + + } + + + if(input$chBplotTypeDot) + p.out = p.out + geom_dotplot(color = NA, + binaxis = "y", + stackdir = "center", + position = loc.par.dodge, + binwidth = abs(max(loc.dt[[ in.cols$meas.y ]], + na.rm = T) - + min(loc.dt[[ in.cols$meas.y ]], + na.rm = T)) / (input$slPlotDotNbins - 1), + method = 'histodot', + alpha = input$slPlotDotAlpha) + + if(input$chBplotTypeViol) + p.out = p.out + + geom_violin(position = loc.par.dodge, + width = 0.2, + alpha = input$slPlotViolAlpha) + + if(input$chBplotTypeLine) + p.out = p.out + + geom_path(aes_string(group = in.cols$id), + alpha = input$slPlotLineAlpha) + + facet_wrap(as.formula(paste("~", in.cols$group))) + + if (input$chBplotTypeBox) + p.out = p.out + geom_boxplot( + position = loc.par.dodge, + notch = input$chBplotBoxNotches, + alpha = input$slPlotBoxAlpha, + outlier.colour = if (input$chBplotBoxOutliers) + 'red' + else + NA + ) + + p.out = p.out + + scale_fill_discrete(name = in.labels$legend) + + xlab(in.labels$x) + + ylab(in.labels$y) + + LOCggplotTheme(in.font.base = PLOTFONTBASE, + in.font.axis.text = PLOTFONTAXISTEXT, + in.font.axis.title = PLOTFONTAXISTITLE, + in.font.strip = PLOTFONTFACETSTRIP, + in.font.legend = PLOTFONTLEGEND) + + theme(legend.position = input$selPlotBoxLegendPos, + axis.text.x = LOCrotatedAxisElementText(as.numeric(input$rBAxisLabelsRotate), + size = PLOTFONTAXISTEXT)) + + + return(p.out) + } + +} \ No newline at end of file diff --git a/modules/tabAUC.R b/modules/tabAUC.R index 75712d6..a4ae31c 100644 --- a/modules/tabAUC.R +++ b/modules/tabAUC.R @@ -7,25 +7,26 @@ # Calculates area under curve (AUC) for every single time course provided in the input # UI ---- -modAUCplotUI = function(id, label = "Plot Area Under Curves") { +tabAUCplotUI = function(id, label = "Plot Area Under Curves") { ns <- NS(id) tagList( h4( - "Calculate area under curve and plot per group" + "Area under curve (AUC)" ), + actionLink(ns("alAUC"), "Learn more"), br(), uiOutput(ns('uiSlTimeTrim')), modStatsUI(ns('dispStats')), br(), - modBoxPlotUI(ns('boxPlot') + modAUCplotUI(ns('aucPlot') ) ) } # SERVER ---- -modAUCplot = function(input, output, session, in.data, in.fname) { +tabAUCplot = function(input, output, session, in.data, in.fname) { ns <- session$ns @@ -83,14 +84,20 @@ modAUCplot = function(input, output, session, in.data, in.fname) { in.bycols = COLGR, in.fname = 'data4boxplotAUC.csv') - callModule(modBoxPlot, 'boxPlot', + callModule(modAUCplot, 'aucPlot', in.data = AUCcells, in.cols = list(meas.x = COLGR, meas.y = 'AUC', group = COLGR, id = COLID), + in.labels = list(x = "Groups", y = "", legend = ""), in.fname = in.fname) + addPopover(session, + id = ns("alAUC"), + title = "AUC", + content = "Calculate area under curve (AUC) for every time series using trapezoidal rule", + trigger = "click") } diff --git a/modules/tabClHier.R b/modules/tabClHier.R index 51d0105..2dac55c 100644 --- a/modules/tabClHier.R +++ b/modules/tabClHier.R @@ -149,9 +149,9 @@ clustHierUI <- function(id, label = "Hierarchical CLustering") { ) ), - downPlotUI(ns('downPlotHier'), "Download PNG"), actionButton(ns('butPlotHierHeatMap'), 'Plot!'), - withSpinner(plotOutput(ns('outPlotHier'))) + withSpinner(plotOutput(ns('outPlotHier'))), + downPlotUI(ns('downPlotHier'), "Download PNG") ), tabPanel('Averages', diff --git a/modules/tabClHierSpar.R b/modules/tabClHierSpar.R index 6abff56..5723dc0 100644 --- a/modules/tabClHierSpar.R +++ b/modules/tabClHierSpar.R @@ -156,17 +156,13 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical CLustering") { ), br(), - - p('Note: columns in the heatmap labeled according to their \"importance\":'), - tags$ol( - tags$li("Black - not taken into account"), - tags$li("Blue with \"*\" - low importance (weight factor in (0, 0.1]"), - tags$li("Green with \"**\" - medium importance (weight factor in (0.1, 0.5]"), - tags$li("Red with \"***\" - high importance (weight factor in (0.5, 1.0]")), - downPlotUI(ns('downPlotHierSparHM'), "Download PNG"), actionButton(ns('butPlotHierSparHeatMap'), 'Plot!'), + br(), + "Columns in the heatmap labeled according to their ", + actionLink(ns("alImportance"), "importance"), withSpinner(plotOutput(ns('outPlotHierSpar'))) + ), tabPanel('Averages', @@ -179,7 +175,7 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical CLustering") { tabPanel('PSD', br(), - modPSDPlotUI(ns('modPlotHierPsd'))), + modPSDPlotUI(ns('modPlotHierSparPsd'))), tabPanel('Cluster distribution', br(), @@ -189,7 +185,12 @@ clustHierSparUI <- function(id, label = "Sparse Hierarchical CLustering") { } # SERVER ---- -clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlot, in.data4stimPlot) { +clustHierSpar <- function(input, output, session, + in.data4clust, + in.data4trajPlot, + in.data4stimPlot) { + + ns = session$ns # UI for advanced options output$uiPlotHierSparNperms = renderUI({ @@ -384,7 +385,9 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo #cat('rownames: ', rownames(in.data4clust()), '\n') # get cellIDs with cluster assignments based on dendrogram cut - loc.dt.cl = getDataClSpar(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim()) + loc.dt.cl = getDataClSpar(userFitDendHierSpar(), + input$inPlotHierSparNclust, + getDataTrackObjLabUni_afterTrim()) #### ## PROBLEM!!! @@ -426,7 +429,10 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo }, content = function(file) { - write.csv(x = getDataClSpar(userFitDendHierSpar(), input$inPlotHierSparNclust, getDataTrackObjLabUni_afterTrim()), file = file, row.names = FALSE) + write.csv(x = getDataClSpar(userFitDendHierSpar(), + input$inPlotHierSparNclust, + getDataTrackObjLabUni_afterTrim()), + file = file, row.names = FALSE) } ) @@ -617,5 +623,22 @@ clustHierSpar <- function(input, output, session, in.data4clust, in.data4trajPlo plotHierSpar() }, height = getPlotHierSparHeatMapHeight) - -} \ No newline at end of file + + addPopover(session, + ns("alImportance"), + title = "Variable importance", + content = paste0("

Weight factors (WF) calculated during clustering ", + "reflect the importance of time points in the clustering. ", + "The following labels are used to indicate the importance:", + "

  • Black - time point not taken into account
    • ", + "
  • * - low, WF∈(0, 0.1]

    • ", + "
  • ** - medium, WF∈(0.1, 0.5]

    • ", + "
  • *** - high, WF∈(0.5, 1.0]

    • ", + "

    Witten and Tibshirani (2010): ", + "A framework for feature selection in clustering; ", + "Journal of the American Statistical Association 105(490): 713-726.

    "), + trigger = "click") + +} + + diff --git a/modules/tabBoxPlot.R b/modules/tabDist.R similarity index 89% rename from modules/tabBoxPlot.R rename to modules/tabDist.R index 6eb58c4..5981059 100644 --- a/modules/tabBoxPlot.R +++ b/modules/tabDist.R @@ -6,7 +6,7 @@ # # UI ---- -tabBoxPlotUI = function(id, label = "Snapshots at time points") { +tabDistPlotUI = function(id, label = "Snapshots at time points") { ns <- NS(id) tagList( @@ -26,12 +26,12 @@ tabBoxPlotUI = function(id, label = "Snapshots at time points") { modStatsUI(ns('dispStats')), br(), - modBoxPlotUI(ns('boxPlot')) + modDistPlotUI(ns('distPlot')) ) } # SERVER ---- -tabBoxPlot = function(input, output, session, in.data, in.fname) { +tabDistPlot = function(input, output, session, in.data, in.fname) { callModule(modStats, 'dispStats', in.data = data4boxPlot, @@ -39,12 +39,13 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) { in.bycols = c(COLRT, COLGR), in.fname = 'data4boxplotTP.csv') - callModule(modBoxPlot, 'boxPlot', + callModule(modDistPlot, 'distPlot', in.data = data4boxPlot, in.cols = list(meas.x = COLRT, meas.y = COLY, group = COLGR, - id = 'id'), + id = COLID), + in.labels = list(x = "Time points", y = "", legend = "Groups:"), in.fname = in.fname) # return all unique time points (real time) @@ -108,7 +109,7 @@ tabBoxPlot = function(input, output, session, in.data, in.fname) { if (!is.null(loc.v)) { selectInput( ns('inSelTpts'), - 'Select one or more t-points:', + 'Select one or more time points:', loc.v, width = '100%', selected = loc.v[[1]], diff --git a/modules/tabScatter.R b/modules/tabScatter.R index f2a08ea..a20890a 100644 --- a/modules/tabScatter.R +++ b/modules/tabScatter.R @@ -22,6 +22,7 @@ tabScatterPlotUI <- function(id, label = "Comparing t-points") { h4( "Scatter plot between two time points" ), + actionLink(ns("alScatter"), "Learn more"), br(), fluidRow( @@ -29,33 +30,37 @@ tabScatterPlotUI <- function(id, label = "Comparing t-points") { 4, uiOutput(ns('uiSelTptX')), uiOutput(ns('uiSelTptY')), - checkboxInput(ns('chBfoldChange'), 'Difference between two time points on Y-axis'), - bsTooltip(ns('chBfoldChange'), help.text.short[15], placement = "right", trigger = "hover", options = NULL), + bsAlert("alert2differentTpts"), + radioButtons(ns('rBfoldChange'), 'Y-axis', + choices = c("Y" = "y", "Y-X" = "diff"), + width = "100px", inline = T), + bsTooltip(ns('rBfoldChange'), help.text.short[15], placement = "right", trigger = "hover", options = NULL), checkboxInput(ns('chBregression'), 'Linear regression with 95% CI'), bsTooltip(ns('chBregression'), help.text.short[16], placement = "right", trigger = "hover", options = NULL) ), column( 4, - numericInput(ns('inNeighTpts'), 'Time points left & right:', value = 0, step = 1, min = 0), - bsTooltip(ns('inNeighTpts'), help.text.short[17], placement = "right", trigger = "hover", options = NULL), - radioButtons(ns('rBstats'), 'Operation:', list('Mean' = 1, 'Min' = 2, 'Max' = 3)), - bsTooltip(ns('inNeighTpts'), help.text.short[18], placement = "right", trigger = "hover", options = NULL) + numericInput(ns('inNeighTpts'), 'Smoothing', value = 0, step = 1, min = 0, width = "150px"), + bsTooltip(ns('inNeighTpts'), help.text.short[17], placement = "right", trigger = "hover", options = NULL) ), column( 4, numericInput( ns('inPlotHeight'), - 'Display plot height [px]', + 'Height [px]', value = PLOTSCATTERHEIGHT, min = 100, - step = 100 + step = 100, + width = "100px" ), numericInput( ns('inPlotNcolFacet'), - '#Columns', + '#columns', value = PLOTNFACETDEFAULT, min = 1, - step = 1 + step = 1, + width = "100px" + ) ) ), @@ -73,6 +78,8 @@ tabScatterPlotUI <- function(id, label = "Comparing t-points") { # SERVER ---- tabScatterPlot <- function(input, output, session, in.data, in.fname) { + 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 @@ -95,9 +102,9 @@ output$uiSelTptX = renderUI({ if (!is.null(loc.v)) { selectInput( ns('inSelTptX'), - 'Time point for X-axis:', + 'Time point for X-axis', loc.v, - width = '100%', + width = '200px', selected = 0, multiple = FALSE ) @@ -113,10 +120,10 @@ output$uiSelTptY = renderUI({ if (!is.null(loc.v)) { selectInput( ns('inSelTptY'), - 'Time point for Y-axis:', + 'Time point for Y-axis', loc.v, - width = '100%', - selected = 0, + width = '200px', + selected = 1, multiple = FALSE ) } @@ -129,47 +136,62 @@ data4scatterPlot <- reactive({ if(is.null(loc.dt.in)) return(NULL) - loc.tpts.x = input$inSelTptX - loc.tpts.y = input$inSelTptY + # obtain selected time points from UI + loc.tpts.x = as.integer(input$inSelTptX) + loc.tpts.y = as.integer(input$inSelTptY) - # if neigbbouring points selected + if (loc.tpts.x == loc.tpts.y) { + createAlert(session, "alert2differentTpts", "exampleAlert", title = "", + content = "Select two different time points.", append = FALSE) + return(NULL) + + } else { + closeAlert(session, "exampleAlert") + } + + # if neigbbouring points selected, obtain time points for which the aggregation will be calculated if (input$inNeighTpts > 0) { + # get all time points in the dataset loc.dt.in.tpts = unique(loc.dt.in[[COLRT]]) + # get indices of time points around selected time points loc.tpts.x.id = seq(which(loc.dt.in.tpts == loc.tpts.x) - input$inNeighTpts, which(loc.dt.in.tpts == loc.tpts.x) + input$inNeighTpts, 1) loc.tpts.y.id = seq(which(loc.dt.in.tpts == loc.tpts.y) - input$inNeighTpts, which(loc.dt.in.tpts == loc.tpts.y) + input$inNeighTpts, 1) + # get only indices of time points that are greater than 0 loc.tpts.x.id = loc.tpts.x.id[loc.tpts.x.id > 0] loc.tpts.y.id = loc.tpts.y.id[loc.tpts.y.id > 0] + # update time points used for aggregation loc.tpts.x = loc.dt.in.tpts[loc.tpts.x.id] loc.tpts.y = loc.dt.in.tpts[loc.tpts.y.id] + + # aggregate separately each time point sets + loc.dt.x = loc.dt.in[get(COLRT) %in% loc.tpts.x, .(y.aggr = mean(get(COLY))), by = c(COLGR, COLID)] + loc.dt.y = loc.dt.in[get(COLRT) %in% loc.tpts.y, .(y.aggr = mean(get(COLY))), by = c(COLGR, COLID)] + loc.dt = merge(loc.dt.x, loc.dt.y, by = COLID) + loc.dt[, group.y := NULL] + + setnames(loc.dt, c('group.x', 'y.aggr.x', 'y.aggr.y'), c(COLGR, 'x', 'y')) + #cat(loc.tpts.x.id, '\n') #cat(loc.tpts.y.id, '\n') - - } - - #cat(loc.tpts.x, '\n') - #cat(loc.tpts.y, '\n') - - if (input$rBstats == 1) { - loc.dt.x = loc.dt.in[get(COLRT) %in% loc.tpts.x, .(y.aggr = mean(y)), by = c(COLGR, COLID)] - loc.dt.y = loc.dt.in[get(COLRT) %in% loc.tpts.y, .(y.aggr = mean(y)), by = c(COLGR, COLID)] - } else if (input$rBstats == 2) { - loc.dt.x = loc.dt.in[get(COLRT) %in% loc.tpts.x, .(y.aggr = min(y)), by = c(COLGR, COLID)] - loc.dt.y = loc.dt.in[get(COLRT) %in% loc.tpts.y, .(y.aggr = min(y)), by = c(COLGR, COLID)] } else { - loc.dt.x = loc.dt.in[get(COLRT) %in% loc.tpts.x, .(y.aggr = max(y)), by = c(COLGR, COLID)] - loc.dt.y = loc.dt.in[get(COLRT) %in% loc.tpts.y, .(y.aggr = max(y)), by = c(COLGR, COLID)] + # get data from selected time points + loc.dt = loc.dt.in[get(COLRT) %in% c(loc.tpts.x, loc.tpts.y)] + + # convert to wide, such that two selected time points are in two columns + loc.dt = dcast(loc.dt[, c(COLGR, COLID, COLY, COLRT), with = F], + as.formula(paste0(COLGR, "+", COLID, "~", COLRT)), + value.var = COLY) + + setnames(loc.dt, c(COLGR, COLID, "x", "y")) } - loc.dt = merge(loc.dt.x, loc.dt.y, by = COLID) - loc.dt[, group.y := NULL] - setnames(loc.dt, c('group.x', 'y.aggr.x', 'y.aggr.y'), c(COLGR, 'x', 'y')) - if (input$chBfoldChange) { + if (input$rBfoldChange == "diff") { loc.dt[ , y := y - x] } return(loc.dt) @@ -249,7 +271,7 @@ output$outPlotScatterInt <- renderPlotly({ # download pdf callModule(downPlot, "downPlotScatter", in.fname, plotScatter, TRUE) - # Hierarchical - choose to display regular heatmap.2 or d3heatmap (interactive) + # Scatter plot - choose to display regular or interactive plot output$plotInt_ui <- renderUI({ ns <- session$ns if (input$plotInt) @@ -258,4 +280,12 @@ output$outPlotScatterInt <- renderPlotly({ tagList( withSpinner(plotOutput(ns('outPlotScatter'), height = paste0(input$inPlotHeight, "px")))) }) + addPopover(session, + id = ns("alScatter"), + title = "Scatter plot", + content = "Display measurement values from two different time points as a scatter plot.", + trigger = "click") + + + } \ No newline at end of file diff --git a/modules/trajPlot.R b/modules/trajPlot.R index d670c83..ce44f1f 100644 --- a/modules/trajPlot.R +++ b/modules/trajPlot.R @@ -17,10 +17,10 @@ modTrajPlotUI = function(id, label = "Plot Individual Time Series") { 2, numericInput( ns('inPlotTrajFacetNcol'), - '#Columns', + '#columns', value = PLOTNFACETDEFAULT, min = 1, - width = '80px', + width = '100px', step = 1 ), checkboxInput(ns('chBplotTrajInt'), 'Interactive Plot'), diff --git a/server.R b/server.R index b820340..cf45a24 100644 --- a/server.R +++ b/server.R @@ -208,7 +208,7 @@ shinyServer(function(input, output, session) { if (input$chBtrajInter) { numericInput( 'inSelTimeFreq', - 'Frequency of time units:', + 'Interval between two time points:', min = 1, step = 1, width = '100%', @@ -892,10 +892,10 @@ shinyServer(function(input, output, session) { # Tabs ---- ###### AUC calculation and plotting - callModule(modAUCplot, 'tabAUC', data4trajPlotNoOut, in.fname = function() return(FPDFBOXAUC)) + callModule(tabAUCplot, 'tabAUC', data4trajPlotNoOut, in.fname = function() return(FPDFBOXAUC)) ###### Box-plot - callModule(tabBoxPlot, 'tabBoxPlot', data4trajPlotNoOut, in.fname = function() return(FPDFBOXTP)) + callModule(tabDistPlot, 'tabDistPlot', data4trajPlotNoOut, in.fname = function() return(FPDFBOXTP)) ###### Scatter plot callModule(tabScatterPlot, 'tabScatter', data4trajPlotNoOut, in.fname = function() return(FPDFSCATTER)) @@ -905,6 +905,4 @@ shinyServer(function(input, output, session) { ##### Sparse hierarchical clustering using sparcl callModule(clustHierSpar, 'tabClHierSpar', data4clust, data4trajPlotNoOut, data4stimPlot) - - }) diff --git a/ui.R b/ui.R index cc422c4..a12ce26 100644 --- a/ui.R +++ b/ui.R @@ -133,12 +133,12 @@ shinyUI(fluidPage( tabPanel( "AUC", - modAUCplotUI('tabAUC') + tabAUCplotUI('tabAUC') ), tabPanel( "Distributions", - tabBoxPlotUI('tabBoxPlot') + tabDistPlotUI('tabDistPlot') ), -- GitLab