tabScatter.R 7.91 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
    ),
dmattek's avatar
dmattek committed
25
    actionLink(ns("alScatter"), "Learn more"),
dmattek's avatar
dmattek committed
26
27
28
29
    br(),
    
    fluidRow(
      column(
30
31
32
        4,
        uiOutput(ns('uiSelTptX')),
        uiOutput(ns('uiSelTptY')),
dmattek's avatar
dmattek committed
33
34
35
36
37
        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),
dmattek's avatar
dmattek committed
38
39
        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
40
41
42
      ),
      column(
        4, 
dmattek's avatar
dmattek committed
43
44
        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)
dmattek's avatar
dmattek committed
45
46
      ),
      column(
47
        4,
dmattek's avatar
dmattek committed
48
49
        numericInput(
          ns('inPlotHeight'),
dmattek's avatar
dmattek committed
50
          'Height [px]',
Maciej Dobrzynski's avatar
Maciej Dobrzynski committed
51
          value = PLOTSCATTERHEIGHT,
dmattek's avatar
dmattek committed
52
          min = 100,
dmattek's avatar
dmattek committed
53
54
          step = 100,
          width = "100px"
dmattek's avatar
dmattek committed
55
56
57
        ),
        numericInput(
          ns('inPlotNcolFacet'),
dmattek's avatar
dmattek committed
58
          '#columns',
59
          value = PLOTNFACETDEFAULT,
dmattek's avatar
dmattek committed
60
          min = 1,
dmattek's avatar
dmattek committed
61
62
63
          step = 1,
          width = "100px"
          
dmattek's avatar
dmattek committed
64
65
66
67
68
69
70
71
        )
      )
    ),
    
    br(),
    checkboxInput(ns('plotInt'), 
                  'Interactive Plot?',
                  value = FALSE),
dmattek's avatar
Added:    
dmattek committed
72
    actionButton(ns('butGoScatter'), 'Plot!'),
dmattek's avatar
dmattek committed
73
74
75
76
77
    uiOutput(ns("plotInt_ui")),
    downPlotUI(ns('downPlotScatter'), "Download PDF")
  )
}

dmattek's avatar
dmattek committed
78
# SERVER ----
79
tabScatterPlot <- function(input, output, session, in.data, in.fname) {
dmattek's avatar
dmattek committed
80
  
dmattek's avatar
dmattek committed
81
82
  ns <- session$ns
  
dmattek's avatar
dmattek committed
83
84
85
86
87
88
89
90
91
92
# 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
93
    return(unique(loc.dt[[COLRT]]))
dmattek's avatar
dmattek committed
94
95
})

96
97
output$uiSelTptX = renderUI({
  cat(file = stderr(), 'UI uiSelTptX\n')
dmattek's avatar
dmattek committed
98
99
100
101
102
103
104
  
  ns <- session$ns
  
  loc.v = getDataTpts()
  if (!is.null(loc.v)) {
    selectInput(
      ns('inSelTptX'),
dmattek's avatar
dmattek committed
105
      'Time point for X-axis',
dmattek's avatar
dmattek committed
106
      loc.v,
dmattek's avatar
dmattek committed
107
      width = '200px',
dmattek's avatar
dmattek committed
108
109
110
111
112
113
      selected = 0,
      multiple = FALSE
    )
  }
})

114
115
output$uiSelTptY = renderUI({
  cat(file = stderr(), 'UI uiSelTptY\n')
dmattek's avatar
dmattek committed
116
117
118
119
120
121
122
  
  ns <- session$ns
  
  loc.v = getDataTpts()
  if (!is.null(loc.v)) {
    selectInput(
      ns('inSelTptY'),
dmattek's avatar
dmattek committed
123
      'Time point for Y-axis',
dmattek's avatar
dmattek committed
124
      loc.v,
dmattek's avatar
dmattek committed
125
126
      width = '200px',
      selected = 1,
dmattek's avatar
dmattek committed
127
128
129
130
131
132
133
134
135
136
137
138
      multiple = FALSE
    )
  }
})

data4scatterPlot <- reactive({
  cat(file = stderr(), 'data4scatterPlot\n')
  
  loc.dt.in = in.data()
  if(is.null(loc.dt.in))
    return(NULL)
  
dmattek's avatar
dmattek committed
139
140
141
  # obtain selected time points from UI
  loc.tpts.x = as.integer(input$inSelTptX)
  loc.tpts.y = as.integer(input$inSelTptY)
dmattek's avatar
dmattek committed
142
  
dmattek's avatar
dmattek committed
143
144
145
146
147
148
149
150
151
152
  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
153
  if (input$inNeighTpts > 0) {
dmattek's avatar
dmattek committed
154
    # get all time points in the dataset
dmattek's avatar
dmattek committed
155
    loc.dt.in.tpts = unique(loc.dt.in[[COLRT]])
156
    
dmattek's avatar
dmattek committed
157
    # get indices of time points around selected time points
158
159
160
    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)
    
dmattek's avatar
dmattek committed
161
    # get only indices of time points that are greater than 0
162
163
164
    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]
    
dmattek's avatar
dmattek committed
165
    # update time points used for aggregation
166
167
    loc.tpts.x = loc.dt.in.tpts[loc.tpts.x.id]
    loc.tpts.y = loc.dt.in.tpts[loc.tpts.y.id]
dmattek's avatar
dmattek committed
168
169
170
171

    # 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)]
172
    
dmattek's avatar
dmattek committed
173
174
175
176
177
    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'))

178
179
180
    #cat(loc.tpts.x.id, '\n')
    #cat(loc.tpts.y.id, '\n')
  } else {
dmattek's avatar
dmattek committed
181
182
183
184
185
186
187
188
189
    # 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"))
190
191
  }

dmattek's avatar
dmattek committed
192
193
  

dmattek's avatar
dmattek committed
194
  if (input$rBfoldChange == "diff") {
195
    loc.dt[ , y := y - x]
196
  }
dmattek's avatar
dmattek committed
197
198
199
200
201
202
203
204
205
206
207
208
209
210
  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
211

dmattek's avatar
dmattek committed
212
213
214
215
216
217
218
219
220
221
222
223
224
  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
225
  p.out = LOCggplotScat(
dmattek's avatar
dmattek committed
226
227
    dt.arg = loc.dt,
    plotlab.arg = NULL,
dmattek's avatar
dmattek committed
228
    facet.arg = COLGR,
dmattek's avatar
dmattek committed
229
    facet.ncol.arg = input$inPlotNcolFacet,
dmattek's avatar
dmattek committed
230
231
232
    alpha.arg = 0.5,
    trend.arg = input$chBregression,
    ci.arg = 0.95
dmattek's avatar
dmattek committed
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
  )
  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
257
  
258
  locBut = input$butGoScatter
259
260
261
262
263
  if (locBut == 0) {
    cat(file=stderr(), 'plotScatterInt Go button not pressed\n')
    return(NULL)
  }
  
dmattek's avatar
dmattek committed
264
265
266
  if (names(dev.cur()) != "null device") dev.off()
  pdf(NULL)

dmattek's avatar
dmattek committed
267
  return(plotly_build(plotScatter()))
dmattek's avatar
dmattek committed
268
269
270
271
  
})

  # download pdf
272
  callModule(downPlot, "downPlotScatter", in.fname, plotScatter, TRUE)
dmattek's avatar
dmattek committed
273
  
dmattek's avatar
dmattek committed
274
  # Scatter plot - choose to display regular or interactive plot
dmattek's avatar
dmattek committed
275
276
277
  output$plotInt_ui <- renderUI({
    ns <- session$ns
    if (input$plotInt)
dmattek's avatar
dmattek committed
278
      tagList( withSpinner(plotlyOutput(ns("outPlotScatterInt"), height = paste0(input$inPlotHeight, "px"))))
dmattek's avatar
dmattek committed
279
    else
dmattek's avatar
dmattek committed
280
      tagList( withSpinner(plotOutput(ns('outPlotScatter'), height = paste0(input$inPlotHeight, "px"))))
dmattek's avatar
dmattek committed
281
282
  })
  
dmattek's avatar
dmattek committed
283
284
285
286
287
288
289
290
  addPopover(session, 
             id = ns("alScatter"), 
             title = "Scatter plot",
             content = "Display measurement values from two different time points as a scatter plot.",
             trigger = "click")
  
  
  
dmattek's avatar
dmattek committed
291
}