server.R 15.1 KB
Newer Older
dmattek's avatar
dmattek committed
1

2

dmattek's avatar
dmattek committed
3 4 5 6 7 8 9 10 11 12 13 14
# This is the server logic for a Shiny web application.
# You can find out more about building applications with Shiny here:
#
# http://shiny.rstudio.com
#

library(shiny)
library(shinyjs) #http://deanattali.com/shinyjs/
library(data.table)
library(ggplot2)
library(plotly)

15 16
# increase file upload limit
options(shiny.maxRequestSize = 30 * 1024 ^ 2)
dmattek's avatar
dmattek committed
17 18
source('auxfunc.R')

19
shinyServer(function(input, output, session) {
20
  useShinyjs()
dmattek's avatar
dmattek committed
21
  
22 23 24 25 26 27 28 29
  # This is only set at session start
  # we use this as a way to determine which input was
  # clicked in the dataInBoth reactive
  counter <- reactiveValues(
    # The value of inDataGen1,2 actionButton is the number of times they were pressed
    dataGen1     = isolate(input$inDataGen1),
    dataLoadNuc  = isolate(input$inButLoadNuc)
    #dataLoadStim = isolate(input$inButLoadStim)
dmattek's avatar
dmattek committed
30 31
  )
  
dmattek's avatar
dmattek committed
32 33 34
  ####
  ## UI for side panel
  
35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
  # This button will reset the inFileLoad
  observeEvent(input$inButReset, {
    reset("inFileLoadNuc")  # reset is a shinyjs function
    #reset("inButLoadStim")  # reset is a shinyjs function
  })
  
  # generate random dataset 1
  dataGen1 <- eventReactive(input$inDataGen1, {
    cat("dataGen1\n")
    
    return(userDataGen())
  })
  
  # load main data file
  dataLoadNuc <- eventReactive(input$inButLoadNuc, {
    cat("dataLoadNuc\n")
    locFilePath = input$inFileLoadNuc$datapath
    
    counter$dataLoadNuc <- input$inButLoadNuc - 1
    
    if (is.null(locFilePath) || locFilePath == '')
      return(NULL)
    else {
      return(fread(locFilePath))
    }
  })
  
dmattek's avatar
dmattek committed
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191
  # This button will reset the inFileLoad
  observeEvent(input$butReset, {
    reset("inFileLoadNuc")  # reset is a shinyjs function
    #    reset("inFileStimLoad")  # reset is a shinyjs function
    
  })
  

  output$varSelTrackLabel = renderUI({
    cat(file = stderr(), 'UI varSelTrackLabel\n')
    locCols = getDataNucCols()
    locColSel = locCols[locCols %like% 'rack'][1] # index 1 at the end in case more matches; select 1st
    
    cat(locColSel, '\n')
    selectInput(
      'inSelTrackLabel',
      'Select Track Label (e.g. objNuc_Track_ObjectsLabel):',
      locCols,
      width = '100%',
      selected = locColSel
    )
  })
  
  output$varSelTime = renderUI({
    cat(file = stderr(), 'UI varSelTime\n')
    locCols = getDataNucCols()
    locColSel = locCols[locCols %like% 'RealTime'][1] # index 1 at the end in case more matches; select 1st
    
    cat(locColSel, '\n')
    selectInput(
      'inSelTime',
      'Select time column (e.g. RealTime):',
      locCols,
      width = '100%',
      selected = locColSel
    )
  })
  
  # This is main field to select plot facet grouping
  # It's typically a column with the entire experimental description,
  # e.g. in Yannick's case it's Stim_All_Ch or Stim_All_S.
  # In Coralie's case it's a combination of 3 columns called Stimulation_...
  output$varSelGroup = renderUI({
    cat(file = stderr(), 'UI varSelGroup\n')
    locCols = getDataNucCols()
    
    if (!is.null(locCols)) {
      locColSel = locCols[locCols %like% 'ite']
      if (length(locColSel) == 0)
        locColSel = locCols[locCols %like% 'eries'][1] # index 1 at the end in case more matches; select 1st
      else if (length(locColSel) > 1) {
        locColSel = locColSel[1]
      }
      #    cat('UI varSelGroup::locColSel ', locColSel, '\n')
      selectInput(
        'inSelGroup',
        'Select one or more facet groupings (e.g. Site, Well, Channel):',
        locCols,
        width = '100%',
        selected = locColSel,
        multiple = TRUE
      )
    }
    
  })
  
  output$varSelSite = renderUI({
    cat(file = stderr(), 'UI varSelSite\n')
    locCols = getDataNucCols()
    locColSel = locCols[locCols %like% 'ite'][1] # index 1 at the end in case more matches; select 1st
    
    cat(locColSel, '\n')
    selectInput(
      'inSelSite',
      'Select FOV (e.g. Metadata_Site or Metadata_Series):',
      locCols,
      width = '100%',
      selected = locColSel
    )
  })
  
  
  
  
  output$varSelMeas1 = renderUI({
    cat(file = stderr(), 'UI varSelMeas1\n')
    locCols = getDataNucCols()
    
    if (!is.null(locCols)) {
      locColSel = locCols[locCols %like% 'objCyto_Intensity_MeanIntensity_imErkCor.*' | locCols %like% 'Ratio'][1] # index 1 at the end in case more matches; select 1st
      #    cat(locColSel, '\n')
      selectInput(
        'inSelMeas1',
        'Select 1st measurement:',
        locCols,
        width = '100%',
        selected = locColSel
      )
    }
  })
  
  
  output$varSelMeas2 = renderUI({
    cat(file = stderr(), 'UI varSelMeas2\n')
    locCols = getDataNucCols()
    
    if (!is.null(locCols) &&
        !(input$inSelMath %in% c('', '1 / '))) {
      locColSel = locCols[locCols %like% 'objNuc_Intensity_MeanIntensity_imErkCor.*'][1] # index 1 at the end in case more matches; select 1st
      #    cat(locColSel, '\n')
      selectInput(
        'inSelMeas2',
        'Select 2nd measurement',
        locCols,
        width = '100%',
        selected = locColSel
      )
    }
  })
  
  
  ####
  ## data processing
  
  # generate random dataset 1
  dataGen1 <- eventReactive(input$inDataGen1, {
    cat("dataGen1\n")
    
    return(userDataGen())
  })
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240
  
  dataInBoth <- reactive({
    # Without direct references to inDataGen1,2 and inFileLoad, inDataGen2
    #    does not trigger running this reactive once inDataGen1 is used.
    # This is one of the more nuanced areas of reactive programming in shiny
    #    due to the if else logic, it isn't fetched once inDataGen1 is available
    # The morale is use direct retrieval of inputs to guarantee they are available
    #    for if else logic checks!
    
    locInGen1 = input$inDataGen1
    locInLoadNuc = input$inButLoadNuc
    #locInLoadStim = input$inButLoadStim
    
    cat(
      "dataInBoth\ninGen1: ",
      locInGen1,
      "   prev=",
      isolate(counter$dataGen1),
      "\ninDataNuc: ",
      locInLoadNuc,
      "   prev=",
      isolate(counter$dataLoadNuc),
      # "\ninDataStim: ",
      # locInLoadStim,
      # "   prev=",
      # isolate(counter$dataLoadStim),
      "\n"
    )
    
    # isolate the checks of counter reactiveValues
    # as we set the values in this same reactive
    if (locInGen1 != isolate(counter$dataGen1)) {
      cat("dataInBoth if inDataGen1\n")
      dm = dataGen1()
      # no need to isolate updating the counter reactive values!
      counter$dataGen1 <- locInGen1
    } else if (locInLoadNuc != isolate(counter$dataLoadNuc)) {
      cat("dataInBoth if inDataLoadNuc\n")
      dm = dataLoadNuc()
      # no need to isolate updating the counter reactive values!
      counter$dataLoadNuc <- locInLoadNuc
    } else {
      cat("dataInBoth else\n")
      dm = NULL
    }
    return(dm)
  })
  
  # return column names of the main dt
dmattek's avatar
dmattek committed
241
  getDataNucCols <- reactive({
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261
    cat(file = stderr(), 'getDataNucCols: in\n')
    loc.dt = dataInBoth()
    
    if (is.null(loc.dt))
      return(NULL)
    else
      return(colnames(loc.dt))
  })
  
  # return dt with an added column with unique track object label
  dataMod <- reactive({
    cat(file=stderr(), 'dataMod\n')
    loc.dt = dataInBoth()
    
    if(is.null(loc.dt))
      return(NULL)
    
    loc.dt[, trackObjectsLabelUni := paste(sprintf("%03d", get(input$inSelSite)),
                                           sprintf("%04d", get(input$inSelTrackLabel)),
                                           sep = "_")]
dmattek's avatar
dmattek committed
262
    
263 264 265
    return(loc.dt)
  })
  
dmattek's avatar
dmattek committed
266 267 268 269 270
  # return all unique track object labels (created in dataMod)
  # This will be used to display in UI for trajectory highlighting
  getDataTrackObjLabUni <- reactive({
    cat(file = stderr(), 'getDataTrackObjLabUni\n')
    loc.dt = dataMod()
271
    
dmattek's avatar
dmattek committed
272 273 274 275
    if (is.null(loc.dt))
      return(NULL)
    else
      return(unique(loc.dt$trackObjectsLabelUni))
276 277
  })
  
dmattek's avatar
dmattek committed
278 279 280 281 282
  # return all unique time points (real time)
  # This will be used to display in UI for trajectory highlighting
  getDataTpts <- reactive({
    cat(file = stderr(), 'getDataTpts\n')
    loc.dt = dataMod()
283
    
dmattek's avatar
dmattek committed
284 285 286 287
    if (is.null(loc.dt))
      return(NULL)
    else
      return(unique(loc.dt[[input$inSelTime]]))
288 289 290 291 292
  })
  
  
  # prepare data for plotting time courses
  # returns dt with these columns:
dmattek's avatar
dmattek committed
293 294 295 296 297 298 299
  #    realtime - selected from input
  #    y        - measurement selected from input 
  #               (can be a single column or result of an operation on two cols)
  #    id       - trackObjectsLabelUni (created in dataMod)
  #    group    - grouping variable for facetting from input
  #    mid.in   - column with trajectory selection status from the input file or
  #               highlight status from UI
300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321
  data4trajPlot <- reactive({
    cat(file=stderr(), 'data4trajPlot\n')
    
    loc.dt = dataMod()
    if(is.null(loc.dt))
      return(NULL)
    
    
    if(input$inSelMath == '')
      loc.s.y = input$inSelMeas1
    else if (input$inSelMath == '1 / ')
      loc.s.y = paste0(input$inSelMath, input$inSelMeas1)
    else
      loc.s.y = paste0(input$inSelMeas1, input$inSelMath, input$inSelMeas2)
    
    # create expression for parsing
    # creates a merged column based on other columns from input
    # used for grouping of plot facets
    loc.s.gr = sprintf("paste(%s, sep=';')", paste(input$inSelGroup, sep = '', collapse = ','))
    
    loc.s.rt = input$inSelTime
    
dmattek's avatar
dmattek committed
322 323 324 325
    # Assign tracks selected for highlighting in UI
    loc.tracks.highlight = input$inSelHighlight
    locBut = input$chBhighlightTraj
    
326 327 328 329 330 331 332 333 334 335
    # if dataset contains column mid.in with trajectory filtering status,
    # then, include it in plotting
    if (sum(names(loc.dt) %in% 'mid.in') > 0) {
      loc.out = loc.dt[, .(
        y = eval(parse(text = loc.s.y)),
        id = trackObjectsLabelUni,
        group = eval(parse(text = loc.s.gr)),
        realtime = eval(parse(text = loc.s.rt)),
        mid.in = mid.in
      )]
dmattek's avatar
dmattek committed
336 337 338 339 340 341 342
      
      # add 3rd level with status of track selection
      # to a column with trajectory filtering status
      if (locBut) {
        loc.out[, mid.in := ifelse(id %in% loc.tracks.highlight, 'SELECTED', mid.in)]
      }
      
343 344 345 346 347 348 349
    } else {
      loc.out = loc.dt[, .(
        y = eval(parse(text = loc.s.y)),
        id = trackObjectsLabelUni,
        group = eval(parse(text = loc.s.gr)),
        realtime = eval(parse(text = loc.s.rt))
      )]
dmattek's avatar
dmattek committed
350 351 352 353 354
      
      # add a column with status of track selection
      if (locBut) {
        loc.out[, mid.in := ifelse(id %in% loc.tracks.highlight, 'SELECTED', 'NOT SEL')]
      }
355
    }
356 357 358
    
    # remove rows with NA
    return(loc.out[complete.cases(loc.out)])
dmattek's avatar
dmattek committed
359 360
  })
  
dmattek's avatar
dmattek committed
361 362 363 364 365
  # prepare data for plotting boxplots
  # uses the same dt as for trajectory plotting
  # returns dt with these columns:
  data4boxPlot <- reactive({
    cat(file=stderr(), 'data4trajPlot\n')
dmattek's avatar
dmattek committed
366
    
dmattek's avatar
dmattek committed
367 368 369
    loc.dt = data4trajPlot()
    if(is.null(loc.dt))
      return(NULL)
370
    
dmattek's avatar
dmattek committed
371
    loc.out = loc.dt[realtime %in% input$inSelTpts]
372 373
  })
  
dmattek's avatar
dmattek committed
374 375
  ####
  ## UI for trajectory plot
376
  
dmattek's avatar
dmattek committed
377 378
  output$varSelHighlight = renderUI({
    cat(file = stderr(), 'UI varSelHighlight\n')
dmattek's avatar
dmattek committed
379
    
dmattek's avatar
dmattek committed
380 381 382
    locBut = input$chBhighlightTraj
    if (!locBut)
      return(NULL)
dmattek's avatar
dmattek committed
383
    
dmattek's avatar
dmattek committed
384 385
    loc.v = getDataTrackObjLabUni()
    if(!is.null(loc.v)) {
386
      selectInput(
dmattek's avatar
dmattek committed
387 388 389
        'inSelHighlight',
        'Select one or more rajectories:',
        loc.v,
390
        width = '100%',
dmattek's avatar
dmattek committed
391
        multiple = TRUE
392
      )
dmattek's avatar
dmattek committed
393 394 395 396
    }
  })
  
  
dmattek's avatar
dmattek committed
397
  output$uiPlotTraj = renderUI({
dmattek's avatar
dmattek committed
398
    
dmattek's avatar
dmattek committed
399
    plotlyOutput("plotTraj", width = paste0(input$inPlotTrajWidth, '%'), height = paste0(input$inPlotTrajHeight, 'px'))
dmattek's avatar
dmattek committed
400 401
  })
  
402 403
  output$plotTraj <- renderPlotly({
    cat(file=stderr(), 'plotTraj: in\n')
dmattek's avatar
dmattek committed
404
    locBut = input$butPlotTraj
dmattek's avatar
dmattek committed
405 406
    
    if (locBut == 0) {
407
      cat(file=stderr(), 'plotTraj: Go button not pressed\n')
dmattek's avatar
dmattek committed
408 409 410 411
      
      return(NULL)
    }
    
412
    loc.dt = isolate(data4trajPlot())
dmattek's avatar
dmattek committed
413
    
414 415 416
    cat("plotScatter on to plot\n\n")
    if (is.null(loc.dt)) {
      cat(file=stderr(), 'plotTraj: dt is NULL\n')
dmattek's avatar
dmattek committed
417
      return(NULL)
418 419
    }
    
420
    cat(file=stderr(), 'plotTraj:dt not NULL\n')
421
    
422 423 424 425 426 427
    # colour trajectories, if dataset contains mi.din column
    # with filtering status of trajectory
    if(sum(names(loc.dt) %in% 'mid.in') > 0)
      loc.line.col.arg = 'mid.in'
    else
      loc.line.col.arg = NULL
dmattek's avatar
dmattek committed
428 429
    
    p.out = myGgplotTraj(
430 431 432 433 434 435
      dt.arg = loc.dt,
      x.arg = 'realtime',
      y.arg = 'y',
      group.arg = "id",
      facet.arg = 'group',
      facet.ncol.arg = input$inPlotTrajFacetNcol,
436 437
      xlab.arg = 'Time (min)',
      line.col.arg = loc.line.col.arg
dmattek's avatar
dmattek committed
438
    )
dmattek's avatar
dmattek committed
439
    
dmattek's avatar
dmattek committed
440
    
441 442 443 444
    # 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
dmattek's avatar
dmattek committed
445 446 447
    if (names(dev.cur()) != "null device") dev.off()
    pdf(NULL)
    
448 449
    p.out.ly = plotly_build(p.out)
    return(p.out.ly)
dmattek's avatar
dmattek committed
450 451
  })
  
dmattek's avatar
dmattek committed
452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542

  ####
  ## 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
  output$downPlotBox <- downloadHandler(
    filename = 'boxplot.pdf',
    
    content = function(file) {
      cat(file = stderr(), input$inPlotBoxWidth, input$inPlotBoxHeight, "\n")
      ggsave(file, limitsize = FALSE,
             plotBox(), 
             width  = input$inPlotBoxWidth,
             height = input$inPlotBoxHeight)
    }
  )
  
  
  # 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 = ifelse(input$inPlotBoxOutliers, 'red', 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
      )
  }
dmattek's avatar
dmattek committed
543
})