tabScatter.R 7.07 KB
Newer Older
dmattek's avatar
dmattek committed
1 2 3 4 5 6
#
# Time Course Inspector: Shiny app for plotting time series data
# Author: Maciej Dobrzynski
#
# This module is a tab for plotting scatter plots between two time points
#
dmattek's avatar
dmattek committed
7 8 9 10 11 12 13 14 15 16
# 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

dmattek's avatar
dmattek committed
17
# UI ----
dmattek's avatar
dmattek committed
18 19 20 21 22
tabScatterPlotUI <- function(id, label = "Comparing t-points") {
  ns <- NS(id)
  
  tagList(
    h4(
dmattek's avatar
dmattek committed
23
      "Scatter plot between two time points"
dmattek's avatar
dmattek committed
24 25 26 27 28
    ),
    br(),
    
    fluidRow(
      column(
29 30 31
        4,
        uiOutput(ns('uiSelTptX')),
        uiOutput(ns('uiSelTptY')),
dmattek's avatar
dmattek committed
32 33 34 35
        checkboxInput(ns('chBfoldChange'), 'Difference between two time points on Y-axis'),
        bsTooltip(ns('chBfoldChange'), 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)
dmattek's avatar
Added:  
dmattek committed
36 37 38
      ),
      column(
        4, 
dmattek's avatar
dmattek committed
39 40 41 42
        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)
dmattek's avatar
dmattek committed
43 44
      ),
      column(
45
        4,
dmattek's avatar
dmattek committed
46 47
        numericInput(
          ns('inPlotHeight'),
dmattek's avatar
Added:  
dmattek committed
48
          'Display plot height [px]',
Maciej Dobrzynski's avatar
Maciej Dobrzynski committed
49
          value = PLOTSCATTERHEIGHT,
dmattek's avatar
dmattek committed
50 51 52 53 54
          min = 100,
          step = 100
        ),
        numericInput(
          ns('inPlotNcolFacet'),
dmattek's avatar
dmattek committed
55
          '#Columns',
56
          value = PLOTNFACETDEFAULT,
dmattek's avatar
dmattek committed
57 58 59 60 61 62 63 64 65 66
          min = 1,
          step = 1
        )
      )
    ),
    
    br(),
    checkboxInput(ns('plotInt'), 
                  'Interactive Plot?',
                  value = FALSE),
dmattek's avatar
Added:  
dmattek committed
67
    actionButton(ns('butGoScatter'), 'Plot!'),
dmattek's avatar
dmattek committed
68 69 70 71 72
    uiOutput(ns("plotInt_ui")),
    downPlotUI(ns('downPlotScatter'), "Download PDF")
  )
}

dmattek's avatar
dmattek committed
73
# SERVER ----
74
tabScatterPlot <- function(input, output, session, in.data, in.fname) {
dmattek's avatar
dmattek committed
75 76 77 78 79 80 81 82 83 84 85
  
# 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
dmattek's avatar
dmattek committed
86
    return(unique(loc.dt[[COLRT]]))
dmattek's avatar
dmattek committed
87 88
})

89 90
output$uiSelTptX = renderUI({
  cat(file = stderr(), 'UI uiSelTptX\n')
dmattek's avatar
dmattek committed
91 92 93 94 95 96 97
  
  ns <- session$ns
  
  loc.v = getDataTpts()
  if (!is.null(loc.v)) {
    selectInput(
      ns('inSelTptX'),
dmattek's avatar
dmattek committed
98
      'Time point for X-axis:',
dmattek's avatar
dmattek committed
99 100 101 102 103 104 105 106
      loc.v,
      width = '100%',
      selected = 0,
      multiple = FALSE
    )
  }
})

107 108
output$uiSelTptY = renderUI({
  cat(file = stderr(), 'UI uiSelTptY\n')
dmattek's avatar
dmattek committed
109 110 111 112 113 114 115
  
  ns <- session$ns
  
  loc.v = getDataTpts()
  if (!is.null(loc.v)) {
    selectInput(
      ns('inSelTptY'),
dmattek's avatar
dmattek committed
116
      'Time point for Y-axis:',
dmattek's avatar
dmattek committed
117 118 119 120 121 122 123 124 125 126 127 128 129 130 131
      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)
  
132 133
  loc.tpts.x = input$inSelTptX
  loc.tpts.y = input$inSelTptY
dmattek's avatar
dmattek committed
134
  
135 136
  # if neigbbouring points selected
  if (input$inNeighTpts > 0) {
dmattek's avatar
dmattek committed
137
    loc.dt.in.tpts = unique(loc.dt.in[[COLRT]])
138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154
    
    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)
    
    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]
    
    loc.tpts.x = loc.dt.in.tpts[loc.tpts.x.id]
    loc.tpts.y = loc.dt.in.tpts[loc.tpts.y.id]
    
    #cat(loc.tpts.x.id, '\n')
    #cat(loc.tpts.y.id, '\n')

  } 

  #cat(loc.tpts.x, '\n')
  #cat(loc.tpts.y, '\n')
dmattek's avatar
dmattek committed
155
  
156
  if (input$rBstats == 1) {
dmattek's avatar
dmattek committed
157 158
    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)]
159
  } else if (input$rBstats == 2) {
dmattek's avatar
dmattek committed
160 161
    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)]
162
  } else {
dmattek's avatar
dmattek committed
163 164
    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)]
165 166
  }

dmattek's avatar
dmattek committed
167
  loc.dt = merge(loc.dt.x, loc.dt.y, by = COLID)
dmattek's avatar
dmattek committed
168
  
169
  loc.dt[, group.y := NULL]
dmattek's avatar
dmattek committed
170
  setnames(loc.dt, c('group.x', 'y.aggr.x', 'y.aggr.y'), c(COLGR, 'x', 'y'))
dmattek's avatar
dmattek committed
171

172
  if (input$chBfoldChange) {
173
    loc.dt[ , y := y - x]
174
  }
dmattek's avatar
dmattek committed
175 176 177 178 179 180 181 182 183 184 185 186 187 188
  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())
dmattek's avatar
dmattek committed
189

dmattek's avatar
dmattek committed
190 191 192 193 194 195 196 197 198 199 200 201 202
  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, )

dmattek's avatar
dmattek committed
203
  p.out = LOCggplotScat(
dmattek's avatar
dmattek committed
204 205
    dt.arg = loc.dt,
    plotlab.arg = NULL,
dmattek's avatar
dmattek committed
206
    facet.arg = COLGR,
dmattek's avatar
dmattek committed
207
    facet.ncol.arg = input$inPlotNcolFacet,
dmattek's avatar
dmattek committed
208 209 210
    alpha.arg = 0.5,
    trend.arg = input$chBregression,
    ci.arg = 0.95
dmattek's avatar
dmattek committed
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
  )
  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 <Anonymous>: cannot open file 'Rplots.pdf'"
  # When running on a server. Based on:
  # https://github.com/ropensci/plotly/issues/494
235
  
236
  locBut = input$butGoScatter
237 238 239 240 241
  if (locBut == 0) {
    cat(file=stderr(), 'plotScatterInt Go button not pressed\n')
    return(NULL)
  }
  
dmattek's avatar
dmattek committed
242 243 244
  if (names(dev.cur()) != "null device") dev.off()
  pdf(NULL)

dmattek's avatar
dmattek committed
245
  return(plotly_build(plotScatter()))
dmattek's avatar
dmattek committed
246 247 248 249
  
})

  # download pdf
250
  callModule(downPlot, "downPlotScatter", in.fname, plotScatter, TRUE)
dmattek's avatar
dmattek committed
251 252 253 254 255
  
  # Hierarchical - choose to display regular heatmap.2 or d3heatmap (interactive)
  output$plotInt_ui <- renderUI({
    ns <- session$ns
    if (input$plotInt)
dmattek's avatar
dmattek committed
256
      tagList( withSpinner(plotlyOutput(ns("outPlotScatterInt"), height = paste0(input$inPlotHeight, "px"))))
dmattek's avatar
dmattek committed
257
    else
dmattek's avatar
dmattek committed
258
      tagList( withSpinner(plotOutput(ns('outPlotScatter'), height = paste0(input$inPlotHeight, "px"))))
dmattek's avatar
dmattek committed
259 260 261
  })
  
}