From 039472238245951ad816a6d15afda563cc40e2d0 Mon Sep 17 00:00:00 2001 From: dmattek Date: Tue, 30 May 2017 16:27:53 +0200 Subject: [PATCH] Added: scatter plot --- global.R | 3 +- modules/auxfunc.R | 99 +++++++++++++++++++ modules/tabScatter.R | 219 +++++++++++++++++++++++++++++++++++++++++++ server.R | 15 +-- ui.R | 13 ++- 5 files changed, 337 insertions(+), 12 deletions(-) create mode 100644 modules/tabScatter.R diff --git a/global.R b/global.R index 1518537..ac3e26b 100644 --- a/global.R +++ b/global.R @@ -1,3 +1,4 @@ source('modules/auxfunc.R') source('modules/downPlot.R') -source('modules/downCellIDsCls.R') \ No newline at end of file +source('modules/downCellIDsCls.R') +source('modules/tabScatter.R') \ No newline at end of file diff --git a/modules/auxfunc.R b/modules/auxfunc.R index d8a9601..fe9b2c3 100644 --- a/modules/auxfunc.R +++ b/modules/auxfunc.R @@ -220,6 +220,105 @@ myNorm = function(in.dt, return(loc.dt) } +# 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) + +myGgplotScat = function(dt.arg, + band.arg = NULL, + 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)) + + 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 = p.tmp + + stat_smooth( + method = function(formula, data, weights = weight) + rlm(formula, data, weights = weight, method = 'MM'), + fullrange = FALSE, + level = 0.95, + 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)), + ncol = facet.ncol.arg) + + } + + + if (!is.null(xlab.arg)) + p.tmp = p.tmp + + xlab(paste0(xlab.arg, "\n")) + + if (!is.null(ylab.arg)) + p.tmp = p.tmp + + ylab(paste0("\n", ylab.arg)) + + if (!is.null(plotlab.arg)) + p.tmp = p.tmp + + ggtitle(paste0(plotlab.arg, "\n")) + + + + p.tmp = p.tmp + + theme_bw(base_size = 18, base_family = "Helvetica") + + theme( + panel.grid.minor = element_blank(), + panel.grid.major = 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 = "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) +} myGgplotTheme = theme_bw(base_size = 18, base_family = "Helvetica") + theme( diff --git a/modules/tabScatter.R b/modules/tabScatter.R new file mode 100644 index 0000000..b6a76fb --- /dev/null +++ b/modules/tabScatter.R @@ -0,0 +1,219 @@ +# RShiny module for performing hierarchical clustering +# Use: +# in ui.R +# tabPanel( +# 'Hierarchical', +# clustHierUI('TabClustHier')) +# +# in server.R +# callModule(clustHier, 'TabClustHier', dataMod) +# where dataMod is the output from a reactive function that returns dataset ready for clustering + + +require(plotly) # interactive plot +require(robust) + +# UI +tabScatterPlotUI <- function(id, label = "Comparing t-points") { + ns <- NS(id) + + tagList( + h4( + "Scatter plot between two time points" + ), + br(), + + fluidRow( + column( + 6, + uiOutput(ns('varSelTptX')), + uiOutput(ns('varSelTptY')) + ), + column( + 6, + numericInput( + ns('inPlotHeight'), + 'Display plot height', + value = 1000, + min = 100, + step = 100 + ), + numericInput( + ns('inPlotNcolFacet'), + '#columns', + value = 2, + min = 1, + step = 1 + ) + ) + ), + + br(), + actionButton(ns('butGoScatter'), 'Plot!'), + checkboxInput(ns('plotInt'), + 'Interactive Plot?', + value = FALSE), + uiOutput(ns("plotInt_ui")), + downPlotUI(ns('downPlotScatter'), "Download PDF") + ) +} + +# SERVER +tabScatterPlot <- 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)) +}) + +output$varSelTptX = renderUI({ + cat(file = stderr(), 'UI varSelTptX\n') + + ns <- session$ns + + loc.v = getDataTpts() + if (!is.null(loc.v)) { + selectInput( + ns('inSelTptX'), + 'Select timepoint for X-axis:', + loc.v, + width = '100%', + selected = 0, + multiple = FALSE + ) + } +}) + +output$varSelTptY = renderUI({ + cat(file = stderr(), 'UI varSelTptY\n') + + ns <- session$ns + + loc.v = getDataTpts() + if (!is.null(loc.v)) { + selectInput( + ns('inSelTptY'), + 'Select timepoint for Y-axis:', + loc.v, + width = '100%', + selected = 0, + multiple = FALSE + ) + } +}) + +data4scatterPlot <- reactive({ + cat(file = stderr(), 'data4scatterPlot\n') + + loc.dt.in = in.data() + if(is.null(loc.dt.in)) + return(NULL) + + loc.dt = data.table(x = loc.dt.in[realtime == input$inSelTptX, y], + y = loc.dt.in[realtime == input$inSelTptY, y], + group = loc.dt.in[realtime == input$inSelTptX, group]) + + + loc.dt.x = loc.dt.in[realtime == input$inSelTptX] + loc.dt.y = loc.dt.in[realtime == input$inSelTptY] + loc.dt = merge(loc.dt.x, loc.dt.y, by = 'id') + + setnames(loc.dt, c('group.x', 'y.x', 'y.y'), c('group', 'x', 'y')) + + return(loc.dt) + +}) + + # 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 + +plotScatter <- function() { + cat(file=stderr(), "plotScatter\n") + + # isolate because calculations & plotting take a while + # re-plotting done upon button press + loc.dt = isolate(data4scatterPlot()) + #loc.fit = isolate(dataFit()) + + cat("plotScatter on to plot\n\n") + if (is.null(loc.dt)) { + cat(file=stderr(), 'plotScatter: dt is NULL\n') + return(NULL) + } + + cat(file=stderr(), 'plotScatter:dt not NULL\n') + + + ## FIX: r.squared is unavailable for lm + + # loc.fit.rsq = ifelse(input$inRobustFit, loc.fit$r.squared, ) + + p.out = myGgplotScat( + dt.arg = loc.dt, + band.arg = NULL, #list(a = loc.fit$coeff.a, b = loc.fit$coeff.b, width = input$inBandWidth), + group.col.arg = NULL, + plotlab.arg = NULL, + # plotlab.arg = sprintf( + # "%s%.2f\n%s%.2f x %.2f", + # ifelse(input$inRobustFit, "lmRob, entire dataset R2=", "lm, entire dataset R2="), + # loc.fit$r.squared, + # 'bandwidth=', + # input$inBandWidth, + # loc.fit$coeff.b + # ), + facet.arg = 'group', + facet.ncol.arg = input$inPlotNcolFacet, + alpha.arg = 0.5 + ) + return(p.out) +} + +# display plot +output$outPlotScatter <- renderPlot({ + locBut = input$butGoScatter + + if (locBut == 0) { + cat(file=stderr(), 'plotScatter: Go button not pressed\n') + + return(NULL) + } + + plotScatter() +}) + + + +output$outPlotScatterInt <- renderPlotly({ + # 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( plotly_build(plotScatter())) + +}) + + # download pdf + callModule(downPlot, "downPlotScatter", "scatter.pdf", plotScatter, TRUE) + + # Hierarchical - choose to display regular heatmap.2 or d3heatmap (interactive) + output$plotInt_ui <- renderUI({ + ns <- session$ns + if (input$plotInt) + tagList(plotlyOutput(ns("outPlotScatterInt"), height = paste0(input$inPlotHeight, "px"))) + else + tagList(plotOutput(ns('outPlotScatter'), height = paste0(input$inPlotHeight, "px"))) + }) + +} \ No newline at end of file diff --git a/server.R b/server.R index ea37aff..321c9e4 100644 --- a/server.R +++ b/server.R @@ -803,6 +803,9 @@ shinyServer(function(input, output, session) { } + ###### Scatter plot + callModule(tabScatterPlot, 'tabScatter', data4trajPlot) + ##### Hierarchical clustering output$uiPlotHierClSel = renderUI({ @@ -972,12 +975,12 @@ shinyServer(function(input, output, session) { # s.cl.linkage[as.numeric(input$selectPlotHierLinkage)], '.csv'), # getDataCl(userFitDendHier, input$inPlotHierNclust, getDataTrackObjLabUni_afterTrim)) # - # output$downloadDataClean <- downloadHandler( - # filename = 'tCoursesSelected_clean.csv', - # content = function(file) { - # write.csv(data4trajPlot(), file, row.names = FALSE) - # } - # ) + output$downloadDataClean <- downloadHandler( + filename = 'tCoursesSelected_clean.csv', + content = function(file) { + write.csv(data4trajPlot(), file, row.names = FALSE) + } + ) diff --git a/ui.R b/ui.R index 7e4773f..aab1102 100644 --- a/ui.R +++ b/ui.R @@ -142,12 +142,17 @@ shinyUI(fluidPage( ), + # scatter plot + tabPanel( + 'Scatter', + tabScatterPlotUI('tabScatter') + ), + tabPanel( 'Hierarchical', br(), fluidRow( - column( - 6, + column(4, selectInput( "selectPlotHierLinkage", label = ("Select linkage method:"), @@ -174,7 +179,7 @@ shinyUI(fluidPage( selected = 1 ) ), - column(6, + column(4, sliderInput( 'inPlotHierNclust', '#dendrogram branches to colour', @@ -191,8 +196,6 @@ shinyUI(fluidPage( downloadButton('downCellCl', 'Download CSV with cell IDs and cluster no.') ) ), - - br(), #checkboxInput('inPlotHierSparInteractive', 'Interactive Plot?', value = FALSE), -- GitLab