nuno-agostinho / cTRAP
Showing 8 of 57 files from the diff.
Newly tracked file
R/floweRy.R created.
Other files ignored by Codecov
Dockerfile has changed.
.Rbuildignore has changed.
man/cTRAP.Rd has changed.
NAMESPACE has changed.
_pkgdown.yml has changed.
DESCRIPTION has changed.
NEWS.md has changed.
man/counts.Rd has changed.
R/cTRAP-package.r has changed.

@@ -0,0 +1,516 @@
Loading
1 +
# Set size limit for user-uploaded files
2 +
.setFileSizeLimit <- function(limitMiB) {
3 +
    options(shiny.maxRequestSize = limitMiB * 1024^2)
4 +
    message("cTRAP: file upload size limit set to ", limitMiB, " MiB")
5 +
}
6 +
7 +
# Generate random string of given length
8 +
.genRandomString <- function(len=10) {
9 +
    pool <- list(LETTERS, letters, 0:9)
10 +
    size <- sapply(pool, length)
11 +
    prob <- rep(1/size, size)
12 +
    pool <- unlist(pool)
13 +
    
14 +
    rand <- sample(pool, len, replace=TRUE, prob=prob)
15 +
    str  <- paste(rand, collapse="")
16 +
    return(str)
17 +
}
18 +
19 +
# Create unique token
20 +
# Avoids creating a token that matches the name of a local folder
21 +
.createToken <- function(len=10, path=".") {
22 +
    repeat {
23 +
        token <- .genRandomString(len)
24 +
        # Token is available if no existing folder is named after the token
25 +
        isTokenAvailable <- !dir.exists(file.path(path, token))
26 +
        if (isTokenAvailable) break
27 +
    }
28 +
    return(token)
29 +
}
30 +
31 +
# Add elements to a named list (ensures unique names for each element)
32 +
.addToList <- function(x, data, name=NULL) {
33 +
    if (is.null(name)) name <- attr(data, "name")
34 +
    if (is.null(name) || name == "") name <- "Dataset"
35 +
    
36 +
    # Unique names for each data element
37 +
    uniqName <- make.unique(c(names(x), name))
38 +
    name <- uniqName[[length(uniqName)]]
39 +
    
40 +
    x[[name]] <- data
41 +
    return(x)
42 +
}
43 +
44 +
# Save session data in token-named directory
45 +
#' @importFrom qs qsave
46 +
.saveSession <- function(data, token) {
47 +
    if (is.null(token) || is.null(data)) return(NULL)
48 +
    if (!dir.exists(token)) dir.create(token)
49 +
    sessionQS <- file.path(token, "session.qs")
50 +
    qsave(data, sessionQS)
51 +
    message("     Session saved to ", sessionQS)
52 +
}
53 +
54 +
#' @importFrom shiny textInput tags tabsetPanel fileInput
55 +
.prepareSessionModal <- function(title=NULL, createSession=TRUE,
56 +
                                 footer=modalButton("Dismiss"), ...) {
57 +
    newSessionUI <- tagList(
58 +
        tags$h2("New session", style="margin-top: 0px;"),
59 +
        actionButton("createSession", "Create new session",
60 +
                     width="100%", icon=icon("plus"), class="btn-info"),
61 +
        tags$hr())
62 +
    
63 +
    loadTokenUI <- tagList(
64 +
        textInput("token", "Insert token of a previous session:"),
65 +
        actionButton("loadToken", "Load session with token",
66 +
                     width="100%", icon=icon("history"), class="btn-info"))
67 +
    loadDataUI <- tagList(
68 +
        fileInput("sessionFile", width="100%", multiple=TRUE, accept=".rds",
69 +
                  "Upload RDS file of a previous session:"),
70 +
        actionButton("loadData", "Load session from RDS file", width="100%",
71 +
                     icon=icon("history"), class="btn-info"))
72 +
    pills <- tabsetPanel(
73 +
        type="pills",
74 +
        tabPanel("Session token", loadTokenUI),
75 +
        tabPanel("Session data", loadDataUI))
76 +
    pills <- tagAppendAttributes(pills, class="nav-justified",
77 +
                                 .cssSelector=".nav")
78 +
    modalDialog(
79 +
        title=title, size="s", footer=footer,
80 +
        if (createSession) newSessionUI,
81 +
        tags$h2("Load session", style="margin-top: 0px;"), pills, ...)
82 +
}
83 +
84 +
#' Find an item in list of lists and return its coordinates
85 +
#' @keywords internal
86 +
.traceInList <- function(ll, item) {
87 +
    if (is.list(ll)) {
88 +
        for (elem in seq(ll)) {
89 +
            res <- .traceInList(ll[[elem]], item)
90 +
            if (!is.null(res)) return(c(elem, res))
91 +
        }
92 +
    } else if (is.character(ll)) {
93 +
        if (any(grepl(item, ll, fixed=TRUE))) return(numeric(0))
94 +
    }
95 +
}
96 +
97 +
# Add context menu to session button in navigation bar
98 +
#' @importFrom purrr pluck pluck<-
99 +
#' @importFrom rlang !!!
100 +
#' @importFrom shiny actionLink downloadLink
101 +
.modifySessionUI <- function(ui, expire) {
102 +
    # Modify session
103 +
    pos     <- .traceInList(ui, "session")
104 +
    pos     <- head(pos, -4)
105 +
    session <- pluck(ui, !!!pos)
106 +
    pluck(ui, !!!pos) <- NULL
107 +
    
108 +
    # Add session buttons
109 +
    expireTxt <- NULL
110 +
    if (!is.null(expire)) {
111 +
        expireTxt <- helpText(style="margin: 0px; padding: 3px 0px;",
112 +
                              paste("Session expires in", expire, "days"))
113 +
    }
114 +
    
115 +
    copyTokenButton <- actionLink("copyToken", onclick="copyToken()", tagList(
116 +
        "Copy session token to clipboard", expireTxt))
117 +
    pluck(session, 3, 2, 3) <- tagList(
118 +
        tags$li(role="presentation", copyTokenButton),
119 +
        tags$li(role="presentation", class="divider"),
120 +
        tags$li(role="presentation",
121 +
                downloadLink("downloadSession", "Download session data")),
122 +
        tags$li(role="presentation",
123 +
                actionLink("loadSessionModal", "Load another session")))
124 +
    pluck(session, 3, 2) <- tagAppendAttributes(
125 +
        pluck(session, 3, 2), class="pull-right")
126 +
    
127 +
    # Place session in the right side of the navigation bar
128 +
    pos <- head(pos, -3)
129 +
    pluck(ui, !!!pos)[[3]] <- tags$ul(
130 +
        class="nav navbar-nav pull-right", session)
131 +
    return(ui)
132 +
}
133 +
134 +
# Add loading status in navigation bar
135 +
#' @importFrom shiny tagAppendChildren
136 +
.addLoadingStatus <- function(ui) {
137 +
    loading <- conditionalPanel(condition="$('html').hasClass('shiny-busy')",
138 +
                                icon("circle-notch", "fa-spin"))
139 +
    loading$name <- "a"
140 +
    loading <- tags$li(loading)
141 +
    
142 +
    pos <- .traceInList(ui, "session")
143 +
    pluck(ui, !!!head(pos, -5)) <- tagList(
144 +
        loading, pluck(ui, !!!head(pos, -5), 1))
145 +
    return(ui)
146 +
}
147 +
148 +
#' @importFrom shiny navbarMenu icon span textOutput tags includeScript
149 +
#' includeCSS
150 +
globalUI <- function(elems, idList, expire) {
151 +
    elemClasses       <- sapply(lapply(elems, class), "[[", 1)
152 +
    hasSimilarPerts   <- "similarPerturbations" %in% elemClasses
153 +
    hasTargetingDrugs <- "targetingDrugs" %in% elemClasses
154 +
    showTwoKindPlot   <- hasSimilarPerts && hasTargetingDrugs
155 +
    
156 +
    ui <- .prepareNavPage(
157 +
        id="tab",
158 +
        # a non-dropdown tab needs to be selected (bug)
159 +
        # https://github.com/rstudio/shiny/issues/3519
160 +
        .metadataViewerUI(idList$metadata, icon=icon("layer-group")),
161 +
        navbarMenu("Load", icon=icon("table"),
162 +
                   "Differential gene expression data",
163 +
                   .diffExprLoadUI(idList$diffExpr),
164 +
                   .diffExprENCODEloaderUI(idList$encode),
165 +
                   "----",
166 +
                   .cmapDataLoaderUI(idList$cmap, globalUI=TRUE)),
167 +
        navbarMenu("Analyse", icon=icon("cogs"),
168 +
                   .rankSimilarPerturbationsUI(idList$rankPerts),
169 +
                   .predictTargetingDrugsUI(idList$predictDrugs)),
170 +
        navbarMenu("Visualise", icon=icon("chart-bar"),
171 +
                   .dataPlotterUI(idList$data),
172 +
                   .datasetComparisonUI(idList$compare),
173 +
                   .targetingDrugsVSsimilarPerturbationsPlotterUI(
174 +
                       idList$comparePlot),
175 +
                   .drugSetEnrichmentAnalyserUI(idList$drugSet)),
176 +
        navbarMenu(span("Session", span(class="badge",
177 +
                                        textOutput("token", inline=TRUE))),
178 +
                   icon=icon("compass"), menuName="session"))
179 +
    ui <- .modifySessionUI(ui, expire=expire)
180 +
    ui <- .addLoadingStatus(ui)
181 +
    
182 +
    # Add JS and CSS in header
183 +
    header <- tags$head(
184 +
        includeScript(system.file("shiny", "www", "cTRAP.js", package="cTRAP")),
185 +
        includeCSS(system.file("shiny", "www", "cTRAP.css", package="cTRAP")))
186 +
    ui <- tagList(header, ui)
187 +
    return(ui)
188 +
}
189 +
190 +
# Set app data and add tags
191 +
.setAppData <- function(appData, elems) {
192 +
    appData$elems <- .addDatasetTags(elems)
193 +
    return(appData)
194 +
}
195 +
196 +
#' @importFrom shiny downloadHandler renderText req
197 +
#' @importFrom qs qread
198 +
.sessionManagementServer <- function(input, output, session, appData) {
199 +
    # Show welcome screen when no token is set (e.g. new cTRAP sessions)
200 +
    observe({
201 +
        if (!is.null(appData$token)) return(NULL)
202 +
        showModal(.prepareSessionModal("Welcome to cTRAP!", footer=NULL))
203 +
    })
204 +
    
205 +
    # Create new session
206 +
    observeEvent(input$createSession, {
207 +
        .setAppData(appData, NULL)
208 +
        appData$token <- .createToken()
209 +
        removeModal()
210 +
    })
211 +
    
212 +
    # Update token badge
213 +
    output$token <- renderText({
214 +
        token <- appData$token
215 +
        if (is.null(token)) token <- "?"
216 +
        return(token)
217 +
    })
218 +
    
219 +
    # Load session based on a token
220 +
    observeEvent(input$loadToken, {
221 +
        token <- isolate(input$token)
222 +
        if (dir.exists(token)) {
223 +
            file <- file.path(token, "session")
224 +
            rds  <- paste0(file, ".rds")
225 +
            qs   <- paste0(file, ".qs")
226 +
            if (file.exists(qs)) {
227 +
                .setAppData(appData, qread(qs))
228 +
            } else if (file.exists(rds)) {
229 +
                .setAppData(appData, readRDS(rds))
230 +
            }
231 +
            appData$token <- token
232 +
            removeModal()
233 +
        } else {
234 +
            msg <- tagList("Token", span(class="badge", token),
235 +
                           "does not exist")
236 +
            showNotification(type="error", msg)
237 +
        }
238 +
    })
239 +
    
240 +
    # Load session based on a RDS file
241 +
    observeEvent(input$loadData, {
242 +
        file <- input$sessionFile
243 +
        
244 +
        if (is.null(file)) {
245 +
            showNotification("File input cannot be empty", type="error")
246 +
        }
247 +
        req(file)
248 +
        
249 +
        data <- tryCatch(readRDS(file$datapath), error=function(e) e)
250 +
        if (is(data, "error")) {
251 +
            showNotification(paste("Error loading data:", data),
252 +
                             type="error")
253 +
        } else {
254 +
            .setAppData(appData, data)
255 +
            appData$token <- token <- .createToken()
256 +
            removeModal()
257 +
            .saveSession(data, token)
258 +
        }
259 +
    })
260 +
    
261 +
    observeEvent(input$loadSessionModal, {
262 +
        modal <- .prepareSessionModal(createSession=TRUE, easyClose=TRUE)
263 +
        showModal(modal)
264 +
    })
265 +
    
266 +
    # Notify when copying token
267 +
    observeEvent(input$copyToken, {
268 +
        msg <- tagList("Token", span(class="badge", appData$token),
269 +
                       "copied to your clipboard!")
270 +
        showNotification(msg, duration=3, closeButton=FALSE, type="message")
271 +
    })
272 +
    
273 +
    # Download objects in current session in a single RDS file
274 +
    output$downloadSession <- downloadHandler(
275 +
        filename=function() paste0("cTRAP-", appData$token, ".rds"),
276 +
        content=function(file) saveRDS(appData$elems, file))
277 +
}
278 +
279 +
.newDataNotification <- function(names, total, expected=NULL, ...,
280 +
                                 type="message", auto=FALSE) {
281 +
    plural <- ifelse(total == 1, "", "s")
282 +
    totalTxt <- sprintf("Total: %s dataset%s", total, plural)
283 +
    if (!is.null(expected) && expected > 0) {
284 +
        totalTxt <- paste(totalTxt, sprintf("(%s running)", expected))
285 +
    }
286 +
    message(sprintf("  -> %s (%s)",
287 +
                    paste(paste(names, collapse=" + "), "loaded"),
288 +
                    tolower(totalTxt)))
289 +
    
290 +
    len <- length(names)
291 +
    auto <- ifelse(auto, "automatically ", "")
292 +
    head <- "New %sloaded dataset:"
293 +
    if (len != 1) head <- paste(length(names), "new %sloaded datasets:")
294 +
    head <- sprintf(head, auto)
295 +
    
296 +
    names <- do.call(tags$ul, lapply(names, tags$li))
297 +
    showNotification(tagList(tags$b(head), names, totalTxt), type=type, ...)
298 +
}
299 +
300 +
# Continually check if the output files from Celery tasks are ready to be loaded
301 +
#' @importFrom shiny reactivePoll
302 +
.loadCeleryOutputServer <- function(input, output, session, appData) {
303 +
    getExpectedAppDataTasks <- function(elems) {
304 +
        if (is.null(elems) || length(elems) == 0) return(NULL)
305 +
        expected <- .filterDatasetsByClass(elems, "expected")
306 +
        return(expected)
307 +
    }
308 +
    
309 +
    checkExpectedCeleryTasks <- function(elems) {
310 +
        expectedAppTasks <- getExpectedAppDataTasks(elems)
311 +
        if (is.null(expectedAppTasks)) return(NULL)
312 +
         
313 +
        expectedTaskID <- sapply(expectedAppTasks, "[[", "task-id")
314 +
        if (length(expectedTaskID) == 0) return(NULL)
315 +
        
316 +
        tasks <- taskList()
317 +
        tasks <- tasks[tasks$uuid %in% expectedTaskID, ]
318 +
        if (is.null(tasks)) return(NULL)
319 +
        return(tasks)
320 +
    }
321 +
    
322 +
    getExpectedCeleryTasks <- reactivePoll(
323 +
        5000, session,
324 +
        checkFunc=function() checkExpectedCeleryTasks(appData$elems),
325 +
        valueFunc=function() checkExpectedCeleryTasks(appData$elems))
326 +
    
327 +
    observe({
328 +
        tasks    <- req(getExpectedCeleryTasks())
329 +
        
330 +
        elems    <- isolate(appData$elems)
331 +
        token    <- isolate(appData$token)
332 +
        
333 +
        added <- character(0)
334 +
        updatedState <- FALSE
335 +
        for (id in names( getExpectedAppDataTasks(elems) )) {
336 +
            outputFile <- elems[[id]]$outputFile
337 +
            if (file.exists(outputFile)) {
338 +
                # Read output RDS file
339 +
                message(sprintf("Updating '%s' with data from %s...",
340 +
                                id, outputFile))
341 +
                obj <- try(readRDS(outputFile), silent=TRUE)
342 +
                if (is(obj, "try-error")) {
343 +
                    warning(obj)
344 +
                    return(NULL)
345 +
                }
346 +
                
347 +
                # Replace data accordingly
348 +
                attr(obj, "formInput") <- attr(elems[[id]], "formInput")
349 +
                elems[[id]] <- obj
350 +
                added <- c(added, id)
351 +
                
352 +
                # Remove output file
353 +
                unlink(outputFile)
354 +
            } else {
355 +
                # Skip if task state is not found
356 +
                if (!"state" %in% colnames(tasks)) next
357 +
                
358 +
                # Update state of tasks if needed
359 +
                taskID   <- elems[[id]][["task-id"]]
360 +
                matched  <- tasks$uuid == taskID
361 +
                if (!any(matched)) {
362 +
                    message("cTRAP task not found in Celery/Flower history...")
363 +
                    newState <- "Not found"
364 +
                } else {
365 +
                    newState <- tasks[matched, "state"]
366 +
                }
367 +
                newState <- tolower(newState)
368 +
                oldState <- tolower(elems[[id]]$state)
369 +
                
370 +
                if (newState != oldState) {
371 +
                    message(sprintf("Updating %s from '%s' to '%s'...",
372 +
                                    id, oldState, newState))
373 +
                    elems[[id]]$state <- capitalize(newState)
374 +
                    updatedState <- TRUE
375 +
                }
376 +
            }
377 +
        }
378 +
        newDatasets <- length(added) > 0
379 +
        if (!newDatasets && !updatedState) {
380 +
            return(NULL)
381 +
        } else if (newDatasets) {
382 +
            expected <- length(.filterDatasetsByClass(elems, "expected"))
383 +
            .newDataNotification(added, length(elems) - expected, duration=30,
384 +
                                 auto=TRUE)
385 +
        }
386 +
        .setAppData(appData, elems)
387 +
        .saveSession(elems, token)
388 +
    })
389 +
}
390 +
391 +
# Update data shared across the app
392 +
updateAppData <- function(appData, x) {
393 +
    observe({
394 +
        obj <- x()
395 +
        elems <- .addToList(isolate(appData$elems), obj)
396 +
        .setAppData(appData, elems)
397 +
        token <- isolate(appData$token)
398 +
        
399 +
        dataset <- tail(names(elems), 1)
400 +
        if (is(obj, "expected")) {
401 +
            msg <- tagList(
402 +
                sprintf("'%s' is being calculated", dataset),
403 +
                tags$br(), tags$br(), tags$b("You may close the browser"),
404 +
                "and use the session token", span(class="badge", token),
405 +
                "to load your data later")
406 +
            showNotification(msg, type="warning", duration=10)
407 +
        } else {
408 +
            expected <- length(.filterDatasetsByClass(elems, "expected"))
409 +
            .newDataNotification(dataset, length(elems) - expected,
410 +
                                 type="default")
411 +
        }
412 +
        .saveSession(elems, token)
413 +
    })
414 +
}
415 +
416 +
#' Complete visual interface with support for sessions
417 +
#' 
418 +
#' Optimised to run in ShinyProxy with Celery/Flower backend with argument
419 +
#' \code{shinyproxy = TRUE}.
420 +
#'
421 +
#' @param ... Objects
422 +
#' @param commonPath Character: path where to store data common to all sessions
423 +
#' @param expire Character: days until a session expires (message purposes only)
424 +
#' @param fileSizeLimitMiB Numeric: file size limit in MiB
425 +
#' @param flowerURL Character: Flower REST API's URL (\code{NULL} to avoid using
426 +
#' Celery/Flower backend)
427 +
#' @inheritParams shiny::runApp
428 +
#'
429 +
#' @importFrom shiny tagList showModal modalButton modalDialog removeModal
430 +
#' reactiveValues tagAppendAttributes showNotification
431 +
#'
432 +
#' @return Launches result viewer and plotter (returns \code{NULL})
433 +
#' @family visual interface functions
434 +
#' @export
435 +
cTRAP <- function(..., commonPath="data", expire=14, fileSizeLimitMiB=50,
436 +
                  flowerURL=NULL, port=getOption("shiny.port"),
437 +
                  host=getOption("shiny.host", "127.0.0.1")) {
438 +
    .setFileSizeLimit(fileSizeLimitMiB)
439 +
    elems <- .prepareEllipsis(...)
440 +
    
441 +
    # if in ShinyProxy, use Celery/Flower backend via floweRy
442 +
    if (!is.null(flowerURL)) {
443 +
        # if (!requireNamespace("floweRy")) {
444 +
        #     remotes::install_github("nuno-agostinho/floweRy")
445 +
        # }
446 +
        options(floweRy.url=flowerURL)
447 +
        flower <- TRUE
448 +
    } else {
449 +
        flower <- FALSE
450 +
    }
451 +
    
452 +
    idList              <- list()
453 +
    idList$diffExpr     <- "diffExprLoader"
454 +
    idList$encode       <- "encodeDataLoader"
455 +
    idList$cmap         <- "cmapDataLoader"
456 +
    idList$compare      <- "datasetComparison"
457 +
    idList$comparePlot  <- "comparePlotter"
458 +
    idList$data         <- "dataPlotter"
459 +
    idList$metadata     <- "metadataViewer"
460 +
    idList$rankPerts    <- "rankPerts"
461 +
    idList$predictDrugs <- "predictDrugs"
462 +
    idList$drugSet      <- "drugSetAnalyser"
463 +
    ui <- globalUI(elems, idList, expire)
464 +
    
465 +
    # Get common data from specific folder
466 +
    loadCommonData <- function(x, path=commonPath) file.path(path, x)
467 +
    
468 +
    server <- function(input, output, session) {
469 +
        appData       <- reactiveValues()
470 +
        .setAppData(appData, elems)
471 +
        elems <- reactive(appData$elems)
472 +
        
473 +
        # load data
474 +
        diffExpr <- .diffExprLoadServer(idList$diffExpr, elems)
475 +
        updateAppData(appData, diffExpr)
476 +
477 +
        encodeDiffExpr <- .diffExprENCODEloaderServer(
478 +
            idList$encode, globalUI=TRUE, path=reactive(appData$token),
479 +
            metadata=downloadENCODEknockdownMetadata(
480 +
                file=loadCommonData("ENCODEmetadata.rds")))
481 +
        updateAppData(appData, encodeDiffExpr)
482 +
483 +
        cmapData <- .cmapDataLoaderServer(
484 +
            idList$cmap, globalUI=TRUE, tab=reactive(session$input$tab),
485 +
            metadata=loadCommonData("cmapMetadata.txt"),
486 +
            zscores=loadCommonData("cmapZscores.gctx"),
487 +
            geneInfo=loadCommonData("cmapGeneInfo.txt"),
488 +
            compoundInfo=loadCommonData("cmapCompoundInfo.txt"))
489 +
        updateAppData(appData, cmapData)
490 +
491 +
        # analyse
492 +
        ranking <- .rankSimilarPerturbationsServer(
493 +
            idList$rankPerts, elems, globalUI=TRUE, flower=flower,
494 +
            token=reactive(appData$token))
495 +
        updateAppData(appData, ranking)
496 +
        
497 +
        predicted <- .predictTargetingDrugsServer(
498 +
            idList$predictDrugs, elems, globalUI=TRUE, flower=flower,
499 +
            path=commonPath, token=reactive(appData$token))
500 +
        updateAppData(appData, predicted)
501 +
502 +
        .drugSetEnrichmentAnalyserServer(idList$drugSet, elems, path=commonPath)
503 +
504 +
        # visualise
505 +
        .dataPlotterServer(idList$data, elems)
506 +
        .targetingDrugsVSsimilarPerturbationsPlotterServer(
507 +
            idList$comparePlot, elems)
508 +
        .datasetComparisonServer(idList$compare, elems)
509 +
        .metadataViewerServer(idList$metadata, elems)
510 +
511 +
        .sessionManagementServer(input, output, session, appData)
512 +
        if (flower) .loadCeleryOutputServer(input, output, session, appData)
513 +
    }
514 +
    app <- runApp(shinyApp(ui, server), port=port, host=host)
515 +
    return(app)
516 +
}

@@ -1,10 +1,22 @@
Loading
1 +
#' @importFrom qs qread
2 +
loadRemotePreProcessedData <- function(default, file=NULL, path=NULL) {
3 +
    link <- file.path("https://compbio.imm.medicina.ulisboa.pt/public/cTRAP",
4 +
                      default)
5 +
    if (is.null(file)) file <- default
6 +
    if (!is.null(path)) file <- file.path(path, file)
7 +
    file  <- downloadIfNotFound(link, file)
8 +
    table <- qread(file)
9 +
    return(table)
10 +
}
11 +
1 12
#' Load table with drug descriptors
2 13
#'
3 -
#' @param source Character: molecular descriptors for compounds in \code{NCI60}
4 -
#'   or \code{CMap}
14 +
#' @param source Character: source of compounds used to calculate molecular
15 +
#'   descriptors (\code{NCI60} or \code{CMap})
5 16
#' @param type Character: load \code{2D} or \code{3D} molecular descriptors
6 17
#' @param file Character: filepath to drug descriptors (automatically downloaded
7 18
#'   if file does not exist)
19 +
#' @inheritParams loadExpressionDrugSensitivityAssociation
8 20
#'
9 21
#' @family functions for drug set enrichment analysis
10 22
#' @return Data table with drug descriptors
@@ -13,27 +25,24 @@
Loading
13 25
#' @examples
14 26
#' loadDrugDescriptors()
15 27
loadDrugDescriptors <- function(source=c("NCI60", "CMap"), type=c("2D", "3D"),
16 -
                                file=NULL) {
17 -
    source <- match.arg(source)
18 -
    type   <- match.arg(type)
19 -
    if (source == "NCI60" && type == "2D") {
20 -
        link <- "599ok2w9ahysdga/compound_descriptors_NCI60_2D.rds"
21 -
    } else if (source == "NCI60" && type == "3D") {
22 -
        link <- "c2hbmk8qi3tyrh4/compound_descriptors_NCI60_3D.rds"
23 -
    } else if (source == "CMap" && type == "2D") {
24 -
        link <- "u1ath10e753x6en/compound_descriptors_CMap_2D.rds"
25 -
    } else if (source == "CMap" && type == "3D") {
26 -
        link <- "tpu3sq53mpy5fvt/compound_descriptors_CMap_3D.rds"
27 -
    } else {
28 -
        stop("selected 'source' and 'type' are not supported")
29 -
    }
28 +
                                file=NULL, path=NULL) {
29 +
    source  <- match.arg(source)
30 +
    type    <- match.arg(type)
31 +
    default <- "compound_descriptors_%s_%s.qs"
32 +
    default <- sprintf(default, source, type)
33 +
    
34 +
    loadRemotePreProcessedData(default, file, path)
35 +
}
30 36
31 -
    link  <- sprintf("https://www.dropbox.com/s/%s?raw=1", link)
32 -
    if (is.null(file))
33 -
        file  <- sprintf("molecular_descriptors_%s_%s.rds", source, type)
34 -
    file  <- downloadIfNotFound(link, file)
35 -
    table <- readRDS(file)
36 -
    return(table)
37 +
# Load drug set prepared from compound descriptors
38 +
loadDrugSet <- function(source=c("NCI60", "CMap"), type=c("2D", "3D"),
39 +
                        file=NULL, path=NULL) {
40 +
    source  <- match.arg(source)
41 +
    type    <- match.arg(type)
42 +
    default <- "drug_set_%s_%s.qs"
43 +
    default <- sprintf(default, source, type)
44 +
    
45 +
    loadRemotePreProcessedData(default, file, path)
37 46
}
38 47
39 48
#' Calculate evenly-distributed bins
@@ -128,6 +137,7 @@
Loading
128 137
    # Inherit input attributes
129 138
    attributes(res) <- c(attributes(res),
130 139
                         attributes(table)[c("compoundInfo", "source", "type")])
140 +
    class(res) <- c("drugSets", class(res))
131 141
    return(res)
132 142
}
133 143
@@ -207,9 +217,14 @@
Loading
207 217
208 218
    # Return statistical values with corresponding identifier (or original
209 219
    # identifier if no match is found)
210 -
    df  <- mergeDatasets(setsCompoundInfo, statsInfo, key1=keyColSets,
211 -
                         key2=keyColStats, all.y=TRUE, removeKey2ColNAs=TRUE)
220 +
    df  <- mergeDatasets(data1=statsInfo, key1=keyColStats,
221 +
                         data2=setsCompoundInfo, key2=keyColSets,
222 +
                         all.y=TRUE, removeKey2ColNAs=TRUE)
223 +
224 +
    if (!setsIDcol %in% colnames(df))  setsIDcol <- paste0(setsIDcol, ".1")
212 225
    res <- setNames(df[[col]], df[[setsIDcol]])
226 +
    
227 +
    if (!statsIDcol %in% colnames(df)) statsIDcol <- paste0(statsIDcol, ".2")
213 228
    statsIDcol <- checkIfIDwasReplacedAfterMerging(statsIDcol, df)
214 229
    names(res)[is.na(names(res))] <- df[[statsIDcol]][is.na(names(res))]
215 230
    return(res)

@@ -285,7 +285,7 @@
Loading
285 285
    colnames(gext2) <- c("cellLine", geneExpr[[1]])
286 286
287 287
    # Convert from ENSEMBL to gene symbols
288 -
    colnames(gext2) <- convertENSEMBLtoGeneSymbols(colnames(gext2))
288 +
    colnames(gext2) <- convertGeneIdentifiers(colnames(gext2))
289 289
    return(gext2)
290 290
}
291 291
@@ -445,11 +445,11 @@
Loading
445 445
#' @examples
446 446
#' listExpressionDrugSensitivityAssociation()
447 447
listExpressionDrugSensitivityAssociation <- function(url=FALSE) {
448 -
    options <- c(
449 -
        "GDSC 7"="5q0dazbtnpojw2m/expressionDrugSensitivityCorGDSC7.rds",
450 -
        "CTRP 2.1"="zj53pxwiwdwo133/expressionDrugSensitivityCorCTRP2.1.rds",
451 -
        "NCI60"="20ko9lyyyoilfz6/expressionDrugSensitivityCorNCI60.h5")
452 -
    link <- sprintf("https://www.dropbox.com/s/%s?raw=1", options)
448 +
    options <- c("GDSC 7"="expressionDrugSensitivityCorGDSC7.qs",
449 +
                 "CTRP 2.1"="expressionDrugSensitivityCorCTRP2.1.qs",
450 +
                 "NCI60"="expressionDrugSensitivityCorNCI60.h5")
451 +
    link <- file.path("https://compbio.imm.medicina.ulisboa.pt/public/cTRAP",
452 +
                      options)
453 453
    names(link) <- names(options)
454 454
455 455
    res <- link
@@ -587,6 +587,8 @@
Loading
587 587
#'   \code{\link{listExpressionDrugSensitivityAssociation}}
588 588
#' @param file Character: filepath to gene expression and drug sensitivity
589 589
#'   association dataset (automatically downloaded if file does not exist)
590 +
#' @param path Character: folder where to find files (optional; \code{file} may
591 +
#'   contain the full filepath if preferred)
590 592
#' @param rows Character or integer: rows
591 593
#' @param cols Character or integer: columns
592 594
#' @param loadValues Boolean: load data values (if available)? If \code{FALSE},
@@ -599,31 +601,38 @@
Loading
599 601
#' @export
600 602
#'
601 603
#' @importFrom tools file_ext
604 +
#' @importFrom qs qread
602 605
#'
603 606
#' @examples
604 607
#' gdsc <- listExpressionDrugSensitivityAssociation()[[1]]
605 608
#' loadExpressionDrugSensitivityAssociation(gdsc)
606 -
loadExpressionDrugSensitivityAssociation <- function(source, file=NULL,
607 -
                                                     rows=NULL, cols=NULL,
608 -
                                                     loadValues=FALSE) {
609 +
loadExpressionDrugSensitivityAssociation <- function(
610 +
    source, file=NULL, path=NULL, rows=NULL, cols=NULL, loadValues=FALSE) {
611 +
    
609 612
    available <- listExpressionDrugSensitivityAssociation(url=TRUE)
610 613
    source    <- match.arg(source, names(available))
611 614
    link      <- available[source]
612 615
613 616
    if (is.null(file)) file <- gsub("\\?.*", "", basename(link))
617 +
    if (!is.null(path)) file <- file.path(path, file)
614 618
    downloadIfNotFound(link, file)
615 619
    message(sprintf("Loading data from %s...", file))
616 -
    if (file_ext(file) == "rds") {
620 +
    if (file_ext(file) == "h5") {
621 +
        cor <- readExpressionDrugSensitivityCorHDF5(file, rows=rows, cols=cols,
622 +
                                                    loadValues=loadValues)
623 +
    } else {
617 624
        if (is.null(cols)) cols <- TRUE
618 625
        if (is.null(rows)) rows <- TRUE
619 -
        res <- readRDS(file)
626 +
        
627 +
        if (file_ext(file) == "rds") {
628 +
            res <- readRDS(file)
629 +
        } else if (file_ext(file) == "qs") {
630 +
            res <- qread(file)
631 +
        } 
620 632
        cor <- res[rows, cols, drop=FALSE]
621 633
        attrs <- attributes(res)
622 634
        attrs <- attrs[!names(attrs) %in% names(attributes(cor))]
623 635
        attributes(cor) <- c(attributes(cor), attrs)
624 -
    } else {
625 -
        cor <- readExpressionDrugSensitivityCorHDF5(file, rows=rows, cols=cols,
626 -
                                                    loadValues=loadValues)
627 636
    }
628 637
    attr(cor, "filename") <- normalizePath(file)
629 638
    class(cor) <- c("expressionDrugSensitivityAssociation", class(cor))

@@ -303,9 +303,9 @@
Loading
303 303
#'   expression and drug sensitivity association (see
304 304
#'   \code{\link{loadExpressionDrugSensitivityAssociation}()})
305 305
#' @param cellLines Integer: number of unique cell lines
306 -
#' @param cellLineMean Boolean: add a column with the mean score across cell
307 -
#'   lines? If \code{cellLineMean = "auto"} (default), the mean score will be
308 -
#'   added when data for more than one cell line is available.
306 +
#' @param cellLineMean Boolean: add rows with the mean of \code{method} across
307 +
#'   cell lines? If \code{cellLineMean = "auto"} (default), rows will be added
308 +
#'   when data for more than one cell line is available.
309 309
#' @param rankByAscending Boolean: rank values based on their ascending
310 310
#'   (\code{TRUE}) or descending (\code{FALSE}) order?
311 311
#' @param rankPerCellLine Boolean: rank results based on both individual cell
@@ -530,9 +530,9 @@
Loading
530 530
    return(keys)
531 531
}
532 532
533 -
compareDatasetIds <- function(key1, key2, data1, data2) {
534 -
    values1 <- stripStr(data1[[key1]])
535 -
    values2 <- stripStr(data2[[key2]])
533 +
compareDatasetIds <- function(data1, data2, key1, key2) {
534 +
    values1 <- stripStr(tolower(data1[[key1]]))
535 +
    values2 <- stripStr(tolower(data2[[key2]]))
536 536
    matches <- which(values1 %in% na.omit(values2)) # Avoid matching NAs
537 537
    return(data1[[key1]][matches])
538 538
}
@@ -566,7 +566,7 @@
Loading
566 566
    res <- list(key1=NULL, key2=NULL, commonCompounds=NULL)
567 567
    for (col1 in keys1) {
568 568
        for (col2 in keys2) {
569 -
            cmp <- compareDatasetIds(col1, col2, data1, data2)
569 +
            cmp <- compareDatasetIds(data1, data2, col1, col2)
570 570
            if (length(cmp) >= length(res$commonCompounds)) {
571 571
                # Save params if number of matching compounds is same or larger
572 572
                res$key1 <- col1
@@ -618,7 +618,14 @@
Loading
618 618
    if (removeKey2ColNAs) data2 <- data2[!is.na(data2[[key2]]), ]
619 619
620 620
    # Merge data based on intersecting compounds
621 -
    df <- merge(data2, data1, by.x=key2, by.y=key1, suffixes=rev(suffixes), ...)
621 +
    data1[["matched_terms"]] <- stripStr(tolower(data1[[key1]]))
622 +
    data2[["matched_terms"]] <- stripStr(tolower(data2[[key2]]))
623 +
    df <- merge(data2, data1, by="matched_terms", suffixes=rev(suffixes), ...)
624 +
    
625 +
    id <- key1
626 +
    if (!key1 %in% colnames(df)) id <- paste0(key1, suffixes[[2]])
627 +
    df[["matched_terms"]] <- df[[id]]
628 +
    
622 629
    attr(df, "keys") <- keys
623 630
    return(df)
624 631
}

@@ -1,10 +1,45 @@
Loading
1 1
# Skeleton for common elements -------------------------------------------------
2 2
3 +
#' @importFrom shiny is.reactive
4 +
.convertToFunction <- function(x) {
5 +
    # Easier to deal with reactives
6 +
    res <- function() x
7 +
    if (is.reactive(x)) res <- x
8 +
    return(res)
9 +
}
10 +
11 +
.filterDatasetsByClass <- function(data, class, expected=FALSE) {
12 +
    selected <- sapply(data, is, class)
13 +
    if (expected) {
14 +
        # Return values that are expected to turn into the given class
15 +
        expected <- sapply(data, is, paste0("expected", capitalize(class)))
16 +
        if (is.list(expected) && length(expected) == 0) return(NULL)
17 +
        selected <- selected | expected
18 +
    }
19 +
    if (!any(selected)) return(NULL)
20 +
    return(data[selected])
21 +
}
22 +
23 +
#' @importFrom shiny tags
24 +
.alert <- function(..., type=c("danger", "success", "info", "warning"),
25 +
                   condition=NULL, ns=NULL) {
26 +
    type <- match.arg(type)
27 +
    alert <- tags$div(class=paste0("alert alert-", type), role="alert", ...)
28 +
    if (!is.null(condition)) alert <- conditionalPanel(condition, alert, ns=ns)
29 +
    return(alert)
30 +
}
31 +
32 +
.prepareDiffExprDataset <- function(data, name) {
33 +
    attr(data, "name") <- name
34 +
    class(data) <- c("diffExpr", class(data))
35 +
    return(data)
36 +
}
37 +
3 38
#' @importFrom shiny div h3 tags
4 39
.panel <- function(
5 40
    title=NULL, ..., footer=NULL, collapse=TRUE,
6 41
    type=c("default", "primary", "success", "info", "warning", "danger")) {
7 -
42 +
    
8 43
    type <- match.arg(type)
9 44
    if (!is.null(title)) {
10 45
        if (collapse) {
@@ -15,7 +50,7 @@
Loading
15 50
        }
16 51
        title <- div(class="panel-heading", h3(class="panel-title", title))
17 52
    }
18 -
53 +
    
19 54
    body <- list(...)
20 55
    if (length(body) > 0) body <- div(class="panel-body", ...)
21 56
    if (collapse) {
@@ -39,10 +74,10 @@
Loading
39 74
.plotBubbles <- function(data, title, colour="orange") {
40 75
    if (!is.table(data)) data <- table(data)
41 76
    df <- as.data.frame(data)
42 -
    names(df) <- c("data", "Freq")
43 77
    if (nrow(df) == 0) {
44 78
        hc <- highchart()
45 79
    } else {
80 +
        names(df) <- c("data", "Freq")
46 81
        tooltip <- paste0("function() {",
47 82
                          "return '<b>' + this.series.name + '</b><br/>'",
48 83
                          "+ this.y + ' perturbations'; }")
@@ -85,7 +120,7 @@
Loading
85 120
.prepareDT <- function(table, suffixes=NULL, ..., columnDefs=NULL,
86 121
                       scrollX=TRUE, pagingType="simple_numbers") {
87 122
    if (is.null(table)) return(NULL)
88 -
123 +
    
89 124
    cols <- NULL
90 125
    if (nrow(table) > 0) {
91 126
        # Prepare columns whose significant digits will be rounded
@@ -95,10 +130,10 @@
Loading
95 130
        cols <- lapply(cols, function(i) endsWith(colnames(table), i))
96 131
        cols <- which(Reduce("|", cols))
97 132
        cols <- cols[!sapply(table, class)[cols] %in% c("character", "logical")]
98 -
133 +
        
99 134
        # Convert to factor if there are low number of unique values
100 135
        if (!all(c("Key", "Value") %in% colnames(table))) {
101 -
            lenUniqValuesPerCol <- sapply(sapply(table, unique), length)
136 +
            lenUniqValuesPerCol <- sapply(lapply(table, unique), length)
102 137
            for (col in names(lenUniqValuesPerCol[lenUniqValuesPerCol < 50])) {
103 138
                if (!col %in% names(table)[cols]) { # Ignore columns to round
104 139
                    table[[col]] <- as.factor(table[[col]])
@@ -106,13 +141,13 @@
Loading
106 141
            }
107 142
        }
108 143
    }
109 -
144 +
    
110 145
    # # Fix specific bug with targetingDrugs columns when using NCI-60 data
111 146
    # if (all(c("PubChem SID", "PubChem CID") %in% colnames(table))) {
112 147
    #     table$`PubChem CID` <- as.numeric(table$`PubChem CID`)
113 148
    #     table$`PubChem SID` <- as.numeric(table$`PubChem SID`)
114 149
    # }
115 -
150 +
    
116 151
    dt <- datatable(
117 152
        table, rownames=FALSE, ..., escape=FALSE,
118 153
        selection="single", extensions="Buttons", filter="top",
@@ -124,7 +159,38 @@
Loading
124 159
    return(dt)
125 160
}
126 161
162 +
.prepareReferenceComparisonDT <- function(data, class) {
163 +
    data <- .filterDatasetsByClass(req(data), class, expected=TRUE)
164 +
    req(data)
165 +
    
166 +
    formInput <- lapply(data, attr, "formInput")
167 +
    ns <- unique(unlist(lapply(formInput, names)))
168 +
    
169 +
    # Add name to avoid issues with data from outside the shiny UI
170 +
    for (i in seq(formInput)) formInput[[i]]$Dataset <- names(data)[[i]]
171 +
    res <- rbindlist(formInput, fill=TRUE)
172 +
    
173 +
    # Return task state if available
174 +
    state     <- sapply(data, getTaskState)
175 +
    isLoaded  <- state == "Loaded"
176 +
    stateHTML <- sapply(state, convertTaskState2HTML)
177 +
    
178 +
    # Create link to data results
179 +
    dataset   <- names(data)
180 +
    js        <- paste("$(\"a[data-value*='Plot']\").click(); ",
181 +
                       "$('#dataPlotter-object')[0].selectize.setValue('%s');")
182 +
    datasetJS <- as.character(tags$a(href="#", onclick=js, "%s"))
183 +
    datasetJS <- sprintf(datasetJS, dataset, dataset)
184 +
    dataset   <- ifelse(isLoaded, datasetJS, dataset)
185 +
    
186 +
    res <- cbind("Dataset"=dataset, "Progress"=stateHTML, res)
187 +
    # Reverse order (so newest datasets are on top)
188 +
    res <- res[rev(seq(nrow(res))), unique(colnames(res)), with=FALSE]
189 +
    return(res)
190 +
}
191 +
127 192
.prepareMetadata <- function(x) {
193 +
    if (is.null(x)) return(NULL)
128 194
    input <- attr(x, "input")
129 195
    if (!is.null(input)) {
130 196
        attr(x, "input") <- data.frame("Element"=names(input), "Value"=input)
@@ -135,10 +201,10 @@
Loading
135 201
        attr(x, "geneset") <- data.frame("Element"=unname(unlist(geneset)),
136 202
                                         "Category"=category)
137 203
    }
138 -
204 +
    
139 205
    tables <- sapply(attributes(x), is, "data.frame")
140 206
    tables <- attributes(x)[tables]
141 -
207 +
    
142 208
    if (is(x, "perturbationChanges")) {
143 209
        data <- rbind(
144 210
            cbind("Z-scores filename", prepareWordBreak(x)),
@@ -147,17 +213,35 @@
Loading
147 213
            cbind("Gene size", length(attr(x, "genes"))),
148 214
            cbind("Perturbation number",
149 215
                  length(attr(x, "perturbations"))))
216 +
        
217 +
        filter <- attr(attr(x, "metadata"), "filter")
218 +
        if (!is.null(filter)) {
219 +
            key <- c("cellLine"="cell line",
220 +
                     "timepoint"="time point",
221 +
                     "dosage"="dosage",
222 +
                     "perturbationType"="perturbation type")
223 +
            key <- paste("Filtered by", key[names(filter)])
224 +
            filter <- cbind(key, lapply(filter, paste, collapse=", "))
225 +
            data <- rbind(data, filter)
226 +
        }
227 +
        
150 228
        colnames(data) <- c("Key", "Value")
151 229
        dataName <- "Object summary"
152 230
    } else {
153 -
        data <- tryCatch(as.table(x, clean=FALSE), error=return)
154 -
        if (is(data, "error")) data <- data.frame("Value"=x)
231 +
        data <- tryCatch(as.table(x, clean=FALSE), error=function(e) e)
232 +
        if (is(data, "error") || !is.data.frame(data)) {
233 +
            if (!is.null(names(x))) {
234 +
                data <- data.frame("Element"=names(x), "Value"=x)
235 +
            } else {
236 +
                data <- data.frame("Value"=x)
237 +
            }
238 +
        }
155 239
        dataName <- "Data"
156 240
    }
157 -
241 +
    
158 242
    tables <- c(list(data), tables)
159 243
    names(tables)[[1]] <- dataName
160 -
244 +
    
161 245
    # Improve names of common tables
162 246
    name <- c("metadata"="Metadata",
163 247
              "geneInfo"="Gene information",
@@ -174,172 +258,392 @@
Loading
174 258
.prepareEllipsis <- function(...) {
175 259
    elems <- list(...)
176 260
    names(elems) <- sapply(substitute(list(...))[-1], deparse)
261 +
    if (length(elems) == 0 && length(names(elems)) == 0) elems <- NULL
177 262
    return(elems)
178 263
}
179 264
180 -
# Internal interface server and UI ---------------------------------------------
265 +
# Add tags to datasets in "display" attribute
266 +
.addDatasetTags <- function(elems) {
267 +
    # Only edit data with no "display" attribute
268 +
    noDisplay <- sapply(lapply(elems, attr, "display"), is.null)
269 +
    if (!any(noDisplay)) return(elems)
270 +
    
271 +
    getDatasetTags <- function(name, data) {
272 +
        dataset <- data[[name]]
273 +
        if (is.null(dataset)) return(dataset)
274 +
        class  <- class(dataset)[[1]]
275 +
        source <- attr(dataset, "source")
276 +
        tags   <- paste0("#", c(class, source), collapse=" ")
277 +
        
278 +
        html   <- convertTaskState2HTML(getTaskState(dataset), label=TRUE)
279 +
        attr(dataset, "display") <- paste(name, tags, html)
280 +
        return(dataset)
281 +
    }
282 +
    dataset          <- names(elems[noDisplay])
283 +
    elems[noDisplay] <- lapply(dataset, getDatasetTags, elems[noDisplay])
284 +
    return(elems)
285 +
}
286 +
287 +
# Update dataset choices (optionally, filter datasets by class)
288 +
.updateDatasetChoices <- function(session, id, data, class=NULL) {
289 +
    if (!is.null(class)) data <- .filterDatasetsByClass(data, class)
290 +
    if (is.null(data) || length(data) == 0) {
291 +
        choices <- list()
292 +
    } else {
293 +
        data    <- .addDatasetTags(data)
294 +
        choices <- setNames(names(data), sapply(data, attr, "display"))
295 +
    }
296 +
    render  <- I('{ option: renderSelectizeTags, item: renderSelectizeTags }')
297 +
    
298 +
    # Keep previous selection if possible
299 +
    selected <- isolate(session$input[[id]])
300 +
    if (is.null(selected) || !selected %in% choices) selected <- NULL
301 +
    
302 +
    updateSelectizeInput(session, id, choices=choices, selected=selected,
303 +
                         options=list(render=render))
304 +
}
305 +
306 +
# Data input -------------------------------------------------------------------
181 307
182 308
.getENCODEconditions <- function(metadata) {
183 309
    cellLines <- sort(unique(metadata$`Biosample term name`))
184 310
    genes     <- sort(unique(metadata$`Experiment target`))
185 311
    genes     <- genes[genes != ""]
186 -
312 +
    
187 313
    res <- list(genes=genes, cellLines=cellLines)
188 314
    return(res)
189 315
}
190 316
191 -
#' @importFrom shiny NS sidebarPanel selectizeInput mainPanel tabPanel
192 -
#' sidebarLayout
193 -
#' @importFrom DT DTOutput
194 -
.diffExprENCODEloaderUI <- function(id, metadata, cellLine=NULL, gene=NULL,
195 -
                                    title="ENCODE Knockdown Data Loader") {
317 +
#' @importFrom shiny textAreaInput
318 +
.diffExprLoadUI <- function(id, title="User data") {
196 319
    ns <- NS(id)
197 -
198 -
    conditions <- .getENCODEconditions(metadata)
199 -
    cellLines  <- conditions$cellLines
200 -
    genes      <- conditions$genes
201 -
202 -
    onInitializeCellLine <- NULL
203 -
    if (is.null(cellLine)) {
204 -
        onInitializeCellLine <- I('function() { this.setValue(""); }')
205 -
    }
206 -
207 -
    onInitializeGene <- NULL
208 -
    if (is.null(gene)) {
209 -
        onInitializeGene <- I('function() { this.setValue(""); }')
210 -
    }
211 -
320 +
    
321 +
    diffExpr <- tags$span(
322 +
        "data-toggle"="tooltip", "data-placement"="right",
323 +
        title="Gene symbols and respective differential expression values (e.g. t-statistics)",
324 +
        "Differential gene expression", icon("question-circle"))
325 +
    
212 326
    sidebar <- sidebarPanel(
213 -
        selectizeInput(ns("cellLine"), "Cell line", cellLines, cellLine,
214 -
                       options=list(placeholder='Please select a cell line',
215 -
                                    onInitialize=onInitializeCellLine)),
216 -
        selectizeInput(ns("gene"), "Gene", genes, gene,
217 -
                       options=list(placeholder='Please select a gene',
218 -
                                    onInitialize=onInitializeGene)),
327 +
        textAreaInput(ns("diffExpr"), diffExpr, height="300px"),
328 +
        selectizeInput(
329 +
            ns("sep"), "Separator",
330 +
            c("Automatic"="auto", "Tab (\\t)"="\t", "Space"=" ", ",", ";")),
331 +
        textInput(ns("name"), "Dataset name", "Differential expression"),
219 332
        actionButton(ns("load"), "Load data", class="btn-primary"))
220 -
221 -
    mainPanel <- mainPanel(DTOutput(ns("table")))
333 +
    mainPanel <- mainPanel(
334 +
        .alert("No differential gene expression dataset loaded/selected",
335 +
               condition="input.dataset == ''", ns=ns),
336 +
        selectizeInput(ns("dataset"), "Differential gene expression dataset",
337 +
                       choices=NULL, width="100%"),
338 +
        DTOutput(ns("table")))
222 339
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
223 340
    return(ui)
224 341
}
225 342
226 -
#' @importFrom shiny moduleServer stopApp
343 +
#' @importFrom data.table fread
227 344
#' @importFrom DT renderDT
228 -
.diffExprENCODEloaderServer <- function(id, metadata) {
229 -
    moduleServer(
230 -
        id, function(input, output, session) {
231 -
            output$table <- renderDT({
232 -
                .prepareDT(downloadENCODEknockdownMetadata())
233 -
            })
234 -
            proxy <- dataTableProxy("table")
235 -
            observe({
236 -
                cellLine <- input$cellLine
237 -
                if (cellLine == "") cellLine <- NULL
238 -
239 -
                gene <- input$gene
240 -
                if (gene == "") gene <- NULL
241 -
                data <- downloadENCODEknockdownMetadata(cellLine, gene)
242 -
                observe(replaceData(proxy, data, rownames=FALSE))
345 +
.diffExprLoadServer <- function(id, x) {
346 +
    x <- .convertToFunction(x)
347 +
    server <- function(input, output, session) {
348 +
        loadData <- eventReactive(input$load, {
349 +
            diffExpr <- input$diffExpr
350 +
            req(diffExpr)
351 +
            
352 +
            # Remove comments
353 +
            diffExpr <- gsub("[(^|\n)]{0,1}#.*?\n", "\n", diffExpr)
354 +
            diffExpr <- gsub("\n+", "\n", diffExpr)
355 +
            
356 +
            withProgress(message="Loading differential expression", value=2, {
357 +
                data <- fread(text=diffExpr, sep=input$sep, data.table=FALSE,
358 +
                              header=FALSE)
359 +
                incProgress(1)
360 +
                
361 +
                if (ncol(data) == 1) {
362 +
                    data <- data[[1]]
363 +
                } else if (ncol(data) == 2) {
364 +
                    data <- setNames(data[[2]], data[[1]])
365 +
                } else {
366 +
                    showNotification(
367 +
                        tagList(tags$b("Input requires 1 or 2 columns."),
368 +
                                ncol(data), "columns are not supported."),
369 +
                        type="error")
370 +
                    return(NULL)
371 +
                }
372 +
                data <- .prepareDiffExprDataset(data, input$name)
373 +
                incProgress(2)
243 374
            })
375 +
            return(data)
376 +
        })
377 +
        
378 +
        observe(.updateDatasetChoices(session, "dataset", x(), "diffExpr"))
379 +
        
380 +
        output$table <- renderDT({
381 +
            req(input$dataset)
382 +
            data <- x()[[input$dataset]]
383 +
            if (!is.null(names(data))) {
384 +
                df <- data.frame("Genes"=names(data), "Score"=data)
385 +
            } else {
386 +
                df <- data.frame("Genes"=data)
387 +
            }
388 +
            return(df)
389 +
        }, rownames=FALSE)
390 +
        return(loadData)
391 +
    }
392 +
    moduleServer(id, server)
393 +
}
244 394
245 -
            observeEvent(input$load, {
246 -
                message("Filtering data...")
247 -
                ENCODEmetadata <- downloadENCODEknockdownMetadata(
248 -
                    input$cellLine, input$gene)
395 +
#' @importFrom shiny NS sidebarPanel selectizeInput mainPanel tabPanel
396 +
#' sidebarLayout
397 +
#' @importFrom DT DTOutput
398 +
.diffExprENCODEloaderUI <- function(id, title="ENCODE knockdown data") {
399 +
    ns <- NS(id)
400 +
    
401 +
    nullStrJS <- I('function() { this.setValue(""); }')
402 +
    sidebar <- sidebarPanel(
403 +
        selectizeInput(ns("cellLine"), "Cell line", choices=NULL, width="100%",
404 +
                       options=list(placeholder='Select a cell line',
405 +
                                    onInitialize=nullStrJS)),
406 +
        selectizeInput(ns("gene"), "Gene", choices=NULL, width="100%",
407 +
                       options=list(placeholder='Select a gene',
408 +
                                    onInitialize=nullStrJS)),
409 +
        actionButton(ns("load"), "Load data", class="btn-primary"))
410 +
    main <- mainPanel(DTOutput(ns("table")))
411 +
    ui <- tabPanel(title, sidebarLayout(sidebar, main))
412 +
    return(ui)
413 +
}
249 414
415 +
#' @importFrom shiny moduleServer stopApp withProgress incProgress
416 +
#' @importFrom DT renderDT
417 +
.diffExprENCODEloaderServer <- function(id, metadata, cellLine=NULL, gene=NULL,
418 +
                                        path=".", globalUI=FALSE) {
419 +
    server <- function(input, output, session) {
420 +
        output$table <- renderDT({
421 +
            hiddenCols <- c(
422 +
                "File format", "File type", "File format type", "Donors",
423 +
                "Biosample treatments", "Biosample treatments amount",
424 +
                "Biosample treatments duration",
425 +
                "Biosample genetic modifications targets",
426 +
                "Biosample genetic modifications gene targets",
427 +
                "Biosample genetic modifications site coordinates",
428 +
                "Biosample genetic modifications zygosity",
429 +
                "Library lysis method", "Library crosslinking method",
430 +
                "Project", "RBNS protein concentration",
431 +
                "Read length", "Mapped read length", "Run type",
432 +
                "Paired end", "Paired with", "Index of", "md5sum", "dbxrefs",
433 +
                "File download URL", "File analysis status",
434 +
                "Platform", "Controlled by", "s3_uri",
435 +
                "Audit ERROR", "Audit WARNING")
436 +
            hiddenCols <- match(hiddenCols, colnames(metadata))
437 +
            columnDefs <- list(list(visible=FALSE, targets=hiddenCols - 1))
438 +
            .prepareDT(metadata, columnDefs=columnDefs)
439 +
        })
440 +
        proxy <- dataTableProxy("table")
441 +
        
442 +
        observe({
443 +
            conditions <- .getENCODEconditions(metadata)
444 +
            updateSelectizeInput(
445 +
                session, "gene", choices=conditions$genes, selected=gene)
446 +
            updateSelectizeInput(
447 +
                session, "cellLine", choices=conditions$cellLines,
448 +
                selected=cellLine)
449 +
        })
450 +
        
451 +
        observe({
452 +
            cellLine <- input$cellLine
453 +
            if (is.null(cellLine) || cellLine == "") cellLine <- NULL
454 +
            
455 +
            gene <- input$gene
456 +
            if (is.null(gene) || gene == "") gene <- NULL
457 +
            data <- filterENCONDEmetadata(metadata, cellLine, gene)
458 +
            observe(replaceData(proxy, data, rownames=FALSE))
459 +
        })
460 +
        
461 +
        loadData <- eventReactive(input$load, {
462 +
            withProgress(message="Preparing differential expression", {
463 +
                steps <- 3
464 +
                
465 +
                incProgress(1/steps, detail="Downloading ENCODE data")
466 +
                message("Downloading data...")
467 +
                ENCODEmetadata <- filterENCONDEmetadata(
468 +
                    metadata, input$cellLine, input$gene)
469 +
                
250 470
                if (nrow(ENCODEmetadata) == 0) {
251 -
                    stopApp()
252 -
                    stop("No samples match the selected criteria")
471 +
                    showNotification("No samples match the selected criteria",
472 +
                                     type="error")
473 +
                    return(NULL)
253 474
                }
254 -
                ENCODEsamples <- loadENCODEsamples(ENCODEmetadata)[[1]]
475 +
                if (is.function(path)) path <- path()
476 +
                ENCODEsamples <- loadENCODEsamples(ENCODEmetadata, path=path)
477 +
                ENCODEsamples <- ENCODEsamples[[1]]
255 478
                counts <- prepareENCODEgeneExpression(ENCODEsamples)
256 -
257 -
                # Remove low coverage (at least 10 counts shared by 2 samples)
479 +
                
480 +
                # Remove low coverage (>= 10 counts shared by 2 samples)
258 481
                minReads   <- 10
259 482
                minSamples <- 2
260 -
                filter <- rowSums(counts[ , -c(1, 2)] >= minReads) >= minSamples
483 +
                filter <- rowSums(
484 +
                    counts[ , -c(1:2)] >= minReads) >= minSamples
261 485
                counts <- counts[filter, ]
262 -
486 +
                
263 487
                # Convert ENSEMBL identifier to gene symbol
264 -
                message("Converting ENSEMBL identifiers to gene symbols...")
265 -
                counts$gene_id <- convertENSEMBLtoGeneSymbols(counts$gene_id)
266 -
488 +
                msg <- "Converting ENSEMBL identifiers to gene symbols"
489 +
                incProgress(1/steps, detail=msg)
490 +
                message(paste0(msg, "..."))
491 +
                counts$gene_id <- convertGeneIdentifiers(counts$gene_id)
492 +
                
267 493
                # Perform differential gene expression analysis
268 -
                message("Performing differential gene expression analysis...")
494 +
                msg <- "Performing differential gene expression analysis"
495 +
                incProgress(1/steps, detail=msg)
496 +
                message(paste0(msg, "..."))
269 497
                diffExpr <- performDifferentialExpression(counts)
270 -
498 +
                
271 499
                diffExprStat <- diffExpr$t
272 500
                names(diffExprStat) <- diffExpr$Gene_symbol
273 -
                stopApp(diffExprStat)
501 +
                
502 +
                msg <- sprintf("%s vs control DGE in %s (ENCODE)",
503 +
                               input$gene, input$cellLine)
504 +
                diffExprStat <- .prepareDiffExprDataset(diffExprStat, msg)
505 +
                
506 +
                message(paste(msg, "data loaded"))
507 +
                return(diffExprStat)
274 508
            })
275 -
        }
276 -
    )
509 +
        })
510 +
        
511 +
        if (!globalUI) observeEvent(input$load, stopApp(loadData()))
512 +
        return(loadData)
513 +
    }
514 +
    moduleServer(id, server)
277 515
}
278 516
279 517
.findMatch <- function(what, where, ignore.case=TRUE) {
280 518
    if (is.null(what)) return(NULL)
519 +
    if (is.list(where)) where <- unlist(where)
520 +
    what <- paste0("^", what, "$") # exact match
281 521
    unname(sapply(what, grep, where, ignore.case=ignore.case, value=TRUE))
282 522
}
283 523
284 524
#' @importFrom shiny NS selectizeInput checkboxGroupInput sidebarPanel helpText
285 -
.cmapDataLoaderUI <- function(id, metadata, zscores, geneInfo, compoundInfo,
286 -
                              cellLine, timepoint, dosage, perturbationType,
287 -
                              title="CMap Data Loader") {
525 +
#' @importFrom shinycssloaders withSpinner
526 +
#' @importFrom htmltools tagQuery
527 +
.cmapDataLoaderUI <- function(id, cellLine=NULL, timepoint=NULL, dosage=NULL,
528 +
                              perturbationType=NULL, title="CMap perturbations",
529 +
                              globalUI=FALSE) {
288 530
    ns <- NS(id)
289 531
    dataTypes <- c("Perturbation metadata"="metadata",
290 532
                   "Perturbation z-scores"="zscores",
291 533
                   "Gene information"="geneInfo",
292 534
                   "Compound information"="compoundInfo")
293 535
    selectizeCondition <- function(id, label, choices, selected, ...) {
294 -
        selected <- .findMatch(selected, choices)
295 -
        plugins  <- list("remove_button")
536 +
        selected    <- .findMatch(selected, choices)
537 +
        plugins     <- list("remove_button")
538 +
        placeholder <- paste("Select one or more", tolower(label))
296 539
        return(selectizeInput(id, label, choices, selected, ...,
297 -
                              options=list(plugins=plugins)))
540 +
                              options=list(plugins=plugins,
541 +
                                           placeholder=placeholder)))
298 542
    }
299 -
543 +
    
544 +
    colChart <- function(id) column(3, highchartOutput(id, height="200px"))
300 545
    plots <- fluidRow(
301 -
        column(3, highchartOutput(ns("perturbationPlot"), height="200px")),
302 -
        column(3, highchartOutput(ns("cellLinePlot"), height="200px")),
303 -
        column(3, highchartOutput(ns("dosagePlot"), height="200px")),
304 -
        column(3, highchartOutput(ns("timepointPlot"), height="200px")))
305 -
    conditions <- getCMapConditions(metadata, control=TRUE)
546 +
        colChart(ns("pertPlot")),
547 +
        colChart(ns("cellLinePlot")),
548 +
        colChart(ns("dosagePlot")),
549 +
        colChart(ns("timepointPlot")))
550 +
    
551 +
    dataToLoad <- checkboxGroupInput(ns("data"), "Data to load",
552 +
                                     dataTypes, dataTypes)
553 +
    if (globalUI) {
554 +
        # Disable check boxes
555 +
        dataToLoad <- tagQuery(dataToLoad)
556 +
        dataToLoad <- dataToLoad$find("input")$addAttrs("disabled"=NA)$allTags()
557 +
    }
558 +
    
306 559
    sidebar <- sidebarPanel(
307 -
        selectizeCondition(ns("type"), "Perturbation type", multiple=TRUE,
308 -
                           conditions$perturbationType, perturbationType),
560 +
        selectizeCondition(ns("type"), "Perturbation types", multiple=TRUE,
561 +
                           choices=perturbationType, perturbationType),
309 562
        selectizeCondition(ns("cellLine"), "Cell lines", multiple=TRUE,
310 -
                           conditions$cellLine, cellLine),
563 +
                           choices=cellLine, cellLine),
311 564
        selectizeCondition(ns("dosage"), "Dosages", multiple=TRUE,
312 -
                           conditions$dosage, dosage),
565 +
                           choices=dosage, dosage),
313 566
        selectizeCondition(ns("timepoint"), "Time points", multiple=TRUE,
314 -
                           conditions$timepoint, timepoint),
315 -
        checkboxGroupInput(ns("data"), "Data to load", dataTypes, dataTypes),
316 -
        helpText("By default, data will be downloaded if not found."),
317 -
        actionButton(ns("cancel"), "Cancel"),
318 -
        actionButton(ns("load"), "Load data", class="btn-primary"))
319 -
    mainPanel <- mainPanel(DTOutput(ns("table")))
320 -
321 -
    ui <- tabPanel(title, sidebar, mainPanel)
567 +
                           choices=timepoint, timepoint),
568 +
        dataToLoad,
569 +
        if (globalUI) textInput(ns("name"), "Dataset name", value="cmapData"),
570 +
        if (!globalUI)
571 +
            helpText("By default, data will be downloaded if not found."),
572 +
        if (!globalUI) actionButton(ns("cancel"), "Cancel"),
573 +
        actionButton(ns("load"), "Load data", class="btn-primary"),
574 +
        convertTaskState2HTML("Loaded", toStr=FALSE, id=ns("loaded"),
575 +
                              style="margin-left: 10px; opacity: 0;"))
576 +
    mainPanel <- mainPanel( withSpinner(DTOutput(ns("table")), type=6) )
577 +
    
578 +
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
322 579
    ui[[3]] <- c(list(plots), ui[[3]])
323 580
    return(ui)
324 581
}
325 582
326 583
#' @importFrom shiny isolate updateSelectizeInput moduleServer stopApp
327 -
#' observeEvent
584 +
#' observeEvent eventReactive updateTextInput reactiveVal
328 585
#' @importFrom DT dataTableProxy replaceData
329 -
.cmapDataLoaderServer <- function(id, metadata, zscores, geneInfo, compoundInfo,
330 -
                                  cellLine, timepoint, dosage) {
331 -
    updateSelectizeCondition <- function(session, input, id, choices, ...) {
332 -
        selected <- isolate(input[[id]])
333 -
        selected <- .findMatch(selected, choices)
334 -
        return(updateSelectizeInput(session, id, choices=choices,
335 -
                                    selected=selected, ...))
336 -
    }
337 -
586 +
.cmapDataLoaderServer <- function(id, metadata="cmapMetadata.txt",
587 +
                                  zscores="cmapZscores.gctx",
588 +
                                  geneInfo="cmapGeneInfo.txt",
589 +
                                  compoundInfo="cmapCompoundInfo.txt",
590 +
                                  cellLine=NULL, timepoint=NULL, dosage=NULL,
591 +
                                  globalUI=FALSE, tab=NULL) {
338 592
    server <- function(input, output, session) {
593 +
        updateSelectizeCondition <- function(session, input, id, choices, ...) {
594 +
            selected <- isolate(input[[id]])
595 +
            selected <- .findMatch(selected, choices)
596 +
            return(updateSelectizeInput(session, id, choices=choices,
597 +
                                        selected=selected, ...))
598 +
        }
599 +
        loadCMapMetadata <- reactive({
600 +
            withProgress(message="Loading CMap metadata", {
601 +
                metadata <- loadCMapData(metadata, "metadata")
602 +
                incProgress(1)
603 +
                return(metadata)
604 +
            })
605 +
        })
606 +
        
607 +
        happened <- reactiveVal(FALSE)
608 +
        checkTab <- reactive({
609 +
            load <- TRUE
610 +
            if (!isolate(happened())) {
611 +
                if (is.null(tab)) {
612 +
                    load <- TRUE
613 +
                } else {
614 +
                    tab  <- tab()
615 +
                    load <- !is.null(tab) && tab == "CMap perturbations"
616 +
                }
617 +
            }
618 +
            happened(load)
619 +
            if (!load) return(NULL)
620 +
            return(load)
621 +
        })
622 +
        
623 +
        getCMapMetadata <- eventReactive(checkTab(), {
624 +
            if (!is.data.frame(metadata)) metadata <- loadCMapMetadata()
625 +
            return(metadata)
626 +
        })
627 +
        
339 628
        # Update conditions based on selected perturbation type
340 629
        observe({
341 -
            available <- getCMapConditions(metadata,
342 -
                                           perturbationType=input$type)
630 +
            isolate({
631 +
                pertType  <- input$type
632 +
                cellLine  <- input$cellLine
633 +
                dosage    <- input$dosage
634 +
                timepoint <- input$timepoint
635 +
            })
636 +
            
637 +
            metadata <- getCMapMetadata()
638 +
            req(metadata)
639 +
            available <- getCMapConditions(metadata, control=TRUE)
640 +
            
641 +
            # Prepare perturbation types
642 +
            perts <- available$perturbationType
643 +
            controls <- startsWith(perts, "Controls")
644 +
            choices <- list("Perturbations"=perts[!controls],
645 +
                            "Controls"=perts[controls])
646 +
            updateSelectizeCondition(session, input, "type", choices=choices)
343 647
            updateSelectizeCondition(session, input, "cellLine",
344 648
                                     choices=available$cellLine)
345 649
            updateSelectizeCondition(session, input, "dosage",
@@ -347,29 +651,32 @@
Loading
347 651
            updateSelectizeCondition(session, input, "timepoint",
348 652
                                     choices=available$timepoint)
349 653
        })
350 -
654 +
        
351 655
        # Filter metadata based on selected inputs
352 656
        getFilteredMetadata <- reactive({
657 +
            metadata <- getCMapMetadata()
658 +
            req(metadata)
353 659
            filterCMapMetadata(
354 -
                metadata, perturbationType=input$type,
355 -
                cellLine=input$cellLine,
356 -
                dosage=input$dosage,
357 -
                timepoint=input$timepoint)
660 +
                metadata, perturbationType=input$type, cellLine=input$cellLine,
661 +
                dosage=input$dosage, timepoint=input$timepoint)
358 662
        })
359 -
360 -
        # Show plots
361 -
        output$perturbationPlot <- renderHighchart({
362 -
            subset <- getFilteredMetadata()
363 -
            labels <- getCMapPerturbationTypes(control=TRUE)
364 -
            types  <- table(subset$pert_type)
365 -
            names(types) <- names(labels)[match(names(types), labels)]
366 -
            .plotBubbles(types, "Perturbations", "red")
367 -
        })
368 -
663 +
        
369 664
        renderBubbleChart <- function(subset, title, colour) {
370 665
            renderHighchart({
371 -
                data <- getFilteredMetadata()[[subset]]
372 -
                data[is.na(data)] <- "NA"
666 +
                filt <- getFilteredMetadata()
667 +
                req(filt)
668 +
                if (nrow(filt) != 0) {
669 +
                    data <- filt[[subset]]
670 +
                    if (subset == "pert_type") {
671 +
                        label <- getCMapPerturbationTypes(control=TRUE)
672 +
                        data  <- table(data)
673 +
                        names(data) <- names(label)[match(names(data), label)]
674 +
                    } else {
675 +
                        data[is.na(data)] <- "NA"
676 +
                    }
677 +
                } else {
678 +
                    data <- NULL
679 +
                }
373 680
                .plotBubbles(data, title, colour)
374 681
            })
375 682
        }
@@ -378,24 +685,26 @@
Loading
378 685
        output$dosagePlot    <- renderBubbleChart("pert_idose", "Dosages",
379 686
                                                  "green")
380 687
        output$timepointPlot <- renderBubbleChart("pert_itime", "Time points",
381 -
                                                "purple")
382 -
688 +
                                                  "purple")
689 +
        output$pertPlot      <- renderBubbleChart("pert_type", "Perturbations",
690 +
                                                  "red")
691 +
        
383 692
        # Show table
384 693
        output$table <- renderDT({
385 694
            hiddenCols <- c("pert_dose", "pert_dose_unit", "pert_time",
386 695
                            "pert_time_unit")
387 -
            hiddenCols <- match(hiddenCols, colnames(metadata))
696 +
            hiddenCols <- match(hiddenCols, colnames(getCMapMetadata()))
388 697
            columnDefs <- list(list(visible=FALSE, targets=hiddenCols - 1))
389 698
            .prepareDT(isolate(getFilteredMetadata()), columnDefs=columnDefs,
390 -
                               scrollX=TRUE)
391 -
        })
699 +
                       scrollX=TRUE)
700 +
        }, server=TRUE)
392 701
        proxy <- dataTableProxy("table")
393 702
        observe(replaceData(proxy, getFilteredMetadata(), rownames=FALSE))
394 -
703 +
        
395 704
        # Load data
396 -
        observeEvent(input$load, {
397 -
            types <- isolate(input$data)
398 -
705 +
        loadData <- eventReactive(input$load, {
706 +
            types <- input$data
707 +
            
399 708
            returnIf <- function(bool, val) {
400 709
                res <- NULL
401 710
                if (bool) res <- val
@@ -406,43 +715,85 @@
Loading
406 715
            zscores      <- returnIf("zscores" %in% types, zscores)
407 716
            geneInfo     <- returnIf("geneInfo" %in% types, geneInfo)
408 717
            compoundInfo <- returnIf("compoundInfo" %in% types, compoundInfo)
409 -
410 -
            perturbations <- prepareCMapPerturbations(
411 -
                metadata=metadata, zscores=zscores,
412 -
                geneInfo=geneInfo, compoundInfo=compoundInfo)
413 -
            stopApp(perturbations)
718 +
            
719 +
            withProgress(message="Loading CMap perturbations", {
720 +
                perturbations <- prepareCMapPerturbations(
721 +
                    metadata=metadata, zscores=zscores,
722 +
                    geneInfo=geneInfo, compoundInfo=compoundInfo)
723 +
                attr(perturbations, "name") <- input$name
724 +
                incProgress(1)
725 +
            })
726 +
            session$sendCustomMessage("brieflyShowElem", session$ns("loaded"))
727 +
            return(perturbations)
414 728
        })
415 -
416 -
        # Cancel
729 +
        
730 +
        observe({
731 +
            txt <- "CMap"
732 +
            
733 +
            type <- input$type
734 +
            kd <- "Consensus signature from shRNAs targeting the same gene"
735 +
            oe <- "cDNA for overexpression of wild-type gene"
736 +
            
737 +
            if (length(input$cellLine) == 1) txt <- paste(txt, input$cellLine)
738 +
            if (length(type) == 1) {
739 +
                txtType <- NULL
740 +
                if (type == "Compound") txtType <- "compounds"
741 +
                if (type == kd) txtType <- "knockdowns"
742 +
                if (type == oe) txtType <- "overexpressions"
743 +
                txt <- paste(txt, txtType)
744 +
            }
745 +
            
746 +
            if (txt == "cmap") txt <- "CMap data"
747 +
            updateTextInput(session, "name", value=txt)
748 +
        })
749 +
        
750 +
        if (!globalUI) observeEvent(input$load, stopApp(loadData()))
417 751
        observeEvent(input$cancel, stopApp(stop("User cancel", call.=FALSE)))
752 +
        return(loadData)
418 753
    }
419 -
754 +
    
420 755
    moduleServer(id, server)
421 756
}
422 757
758 +
# Result plotting and viewing --------------------------------------------------
759 +
423 760
#' @importFrom shiny NS sidebarPanel mainPanel tabPanel sidebarLayout
424 -
#' selectizeInput
425 -
.metadataViewerUI <- function(id, x, title="Metadata Viewer") {
761 +
#' selectizeInput fluidRow column
762 +
.metadataViewerUI <- function(id, title="Data", icon=NULL) {
426 763
    ns <- NS(id)
427 764
    sidebar <- sidebarPanel(
428 -
        selectizeInput(ns("object"), "Dataset", names(x)),
429 -
        selectizeInput(ns("attr"), "Table", choices=NULL))
430 -
    main    <- mainPanel(DTOutput(ns("table")))
431 -
    ui      <- tabPanel(title, sidebarLayout(sidebar, main))
765 +
        selectizeInput(ns("object"), "Dataset", choices=NULL, width="100%"),
766 +
        # DTOutput(ns("selection")),
767 +
        selectizeInput(ns("attr"), "Table", choices=NULL, width="100%"))
768 +
    main <- mainPanel(
769 +
        .alert("No dataset loaded/selected",
770 +
               condition="input.object == ''", ns=ns),
771 +
        DTOutput(ns("table")))
772 +
    ui <- tabPanel(title, icon=icon, sidebarLayout(sidebar, main))
432 773
    return(ui)
433 774
}
434 775
435 776
#' @importFrom shiny moduleServer observe
436 777
#' @importFrom DT renderDT
437 778
.metadataViewerServer <- function(id, x) {
779 +
    x <- .convertToFunction(x)
438 780
    moduleServer(
439 781
        id,
440 782
        function(input, output, session) {
441 -
            getSelectedObject <- reactive(.prepareMetadata(x[[input$object]]))
442 -
443 -
            observe(updateSelectizeInput(session, "attr",
444 -
                                         choices=names(getSelectedObject())))
445 -
783 +
            getSelectedObject <- reactive(.prepareMetadata(x()[[input$object]]))
784 +
            
785 +
            observe( .updateDatasetChoices(session, "object", x()) )
786 +
            
787 +
            observe({
788 +
                selected <- isolate(input$attr)
789 +
                choices  <- names(getSelectedObject())
790 +
                anyChoiceSelected <- !is.null(selected) && !is.null(choices) &&
791 +
                    selected %in% choices
792 +
                if (!anyChoiceSelected) selected <- NULL
793 +
                updateSelectizeInput(session, "attr", selected=selected,
794 +
                                     choices=choices)
795 +
            })
796 +
            
446 797
            output$table <- renderDT(
447 798
                .prepareDT(getSelectedObject()[[input$attr]]))
448 799
        }
@@ -452,63 +803,93 @@
Loading
452 803
#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
453 804
#' tabPanel
454 805
#' @importFrom DT DTOutput
455 -
.dataPlotterUI <- function(id, x, title="Data Plotter") {
806 +
.dataPlotterUI <- function(id, title="Plot Data") {
456 807
    ns <- NS(id)
457 808
    sidebar <- sidebarPanel(
458 -
        selectizeInput(ns("object"), "Dataset", names(x)),
809 +
        selectizeInput(ns("object"), "Dataset", choices=NULL),
459 810
        selectizeInput(ns("method"), "Method", choices=NULL))
460 811
    sidebar[[3]][[2]] <- tagList(
461 812
        selectizeInput(ns("element"), "Row ID to plot", choices=NULL,
462 813
                       width="100%"),
463 814
        plotOutput(ns("plot"), brush=ns("brush")),
464 815
        DTOutput(ns("pointTable")))
465 -
816 +
    
466 817
    mainPanel <- mainPanel(DTOutput(ns("table")))
467 818
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
468 819
    return(ui)
469 820
}
470 821
822 +
.comparisonMethods <- function() {
823 +
    c("Spearman's correlation"="spearman",
824 +
      "Pearson's correlation"="pearson",
825 +
      "GSEA"="gsea")
826 +
}
827 +
471 828
#' @importFrom shiny renderPlot observeEvent observe
472 829
#' @importFrom DT renderDT formatSignif dataTableProxy replaceData
473 830
.dataPlotterServer <- function(id, x) {
831 +
    x <- .convertToFunction(x)
474 832
    isValid <- function(e) !is.null(e) && e != ""
475 833
    moduleServer(
476 834
        id,
477 835
        function(input, output, session) {
478 -
            getSelectedObject <- reactive(x[[input$object]])
479 -
836 +
            getSelectedObject <- reactive(x()[[input$object]])
837 +
            
838 +
            observe({
839 +
                .updateDatasetChoices(session, "object", x(),
840 +
                                      "referenceComparison")
841 +
            })
842 +
            
480 843
            # Update element and methods choices depending on selected object
481 844
            observeEvent(input$object, {
482 845
                obj <- getSelectedObject()
846 +
                if (is.null(obj)) return(NULL)
847 +
                
483 848
                updateSelectizeInput(session, "element", choices=obj[[1]],
484 849
                                     selected=list(), server=TRUE)
485 850
                # Update methods depending on selected object
486 -
                methods <- c("Spearman's correlation"="spearman",
487 -
                             "Pearson's correlation"="pearson",
488 -
                             "GSEA"="gsea")
851 +
                methods <- .comparisonMethods()
489 852
                isPresent <- sapply(methods, function(i)
490 853
                    any(grepl(i, colnames(obj), ignore.case=TRUE)))
491 854
                methods <- methods[isPresent]
492 -
                updateSelectizeInput(session, "method", choices=methods)
855 +
                
856 +
                selected <- isolate(input$method)
857 +
                if (!selected %in% methods) selected <- NULL
858 +
                updateSelectizeInput(session, "method", choices=methods,
859 +
                                     selected=selected)
493 860
            })
494 -
861 +
            
495 862
            # Update selected element
496 863
            observe({
497 -
                selected <- getSelectedObject()[[1]][input$table_rows_selected]
864 +
                obj <- getSelectedObject()
865 +
                if (is.null(obj) || !is(obj, "referenceComparison")) {
866 +
                    return(NULL)
867 +
                }
868 +
                
869 +
                selected <- obj[[1]][input$table_rows_selected]
498 870
                updateSelectizeInput(session, "element", selected=selected)
499 871
            })
500 -
872 +
            
501 873
            output$table <- renderDT({
502 -
                data <- as.table(getSelectedObject(), clean=FALSE)
874 +
                obj <- getSelectedObject()
875 +
                if (is.null(obj) || !is(obj, "referenceComparison")) {
876 +
                    return(NULL)
877 +
                }
878 +
                data <- as.table(obj, clean=FALSE)
503 879
                .prepareDT(data)
504 880
            })
505 -
881 +
            
506 882
            # Filter table based on overall plot
507 883
            proxy <- dataTableProxy("table")
508 884
            observe({
509 885
                elem <- input$element
510 886
                if (is.null(elem) || elem == "") {
511 -
                    obj   <- as.table(getSelectedObject(), clean=FALSE)
887 +
                    obj <- getSelectedObject()
888 +
                    if (is.null(obj) || !is(obj, "referenceComparison")) {
889 +
                        return(NULL)
890 +
                    }
891 +
                    
892 +
                    obj   <- as.table(obj, clean=FALSE)
512 893
                    brush <- input$brush
513 894
                    if (!is.null(brush)) {
514 895
                        val  <- obj[[brush$mapping$y]]
@@ -518,9 +899,13 @@
Loading
518 899
                    replaceData(proxy, obj, rownames=FALSE)
519 900
                }
520 901
            })
521 -
902 +
            
522 903
            plotData <- reactive({
523 904
                obj <- getSelectedObject()
905 +
                if (is.null(obj) || !is(obj, "referenceComparison")) {
906 +
                    return(NULL)
907 +
                }
908 +
                
524 909
                method <- input$method
525 910
                if (!isValid(method)) return(NULL)
526 911
                element <- input$element
@@ -528,7 +913,7 @@
Loading
528 913
                if (!is.null(element) && !element %in% obj[[1]]) return(NULL)
529 914
                plot(obj, element, method=method, n=6)
530 915
            })
531 -
916 +
            
532 917
            output$plot <- renderPlot(plotData())
533 918
            output$pointTable <- renderDT({
534 919
                data <- attr(plotData(), "data")
@@ -547,18 +932,18 @@
Loading
547 932
#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
548 933
#' tabPanel hr
549 934
#' @importFrom DT DTOutput
550 -
.datasetComparisonUI <- function(id, x, title="Dataset Comparison") {
935 +
.datasetComparisonUI <- function(id, title="Dataset Comparison") {
551 936
    ns <- NS(id)
552 937
    sidebar <- sidebarPanel(
553 -
        selectizeInput(ns("data1"), "Dataset 1", names(x)),
938 +
        selectizeInput(ns("data1"), "Dataset 1", choices=NULL),
554 939
        selectizeInput(ns("col1"), "Column to plot in X axis", choices=NULL),
555 940
        hr(),
556 -
        selectizeInput(ns("data2"), "Dataset 2", names(x), selected=2),
941 +
        selectizeInput(ns("data2"), "Dataset 2", choices=NULL),
557 942
        selectizeInput(ns("col2"), "Column to plot in Y axis", choices=NULL))
558 943
    sidebar[[3]][[2]] <- tagList(
559 944
        plotOutput(ns("plot"), brush=ns("brush")),
560 945
        helpText("Click-and-drag points in the plot to filter the table."))
561 -
946 +
    
562 947
    mainPanel <- mainPanel(DTOutput(ns("table")))
563 948
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
564 949
    return(ui)
@@ -568,69 +953,83 @@
Loading
568 953
#' @importFrom DT renderDT
569 954
#' @importFrom ggplot2 theme_bw geom_density_2d geom_rug geom_point
570 955
.datasetComparisonServer <- function(id, x) {
956 +
    x <- .convertToFunction(x)
571 957
    getNumericCols <- function(x) colnames(x)[vapply(x, is.numeric, logical(1))]
572 -
958 +
    
573 959
    moduleServer(
574 960
        id,
575 961
        function(input, output, session) {
576 -
            getSelectedDataset1 <- reactive(x[[input$data1]])
577 -
            getSelectedDataset2 <- reactive(x[[input$data2]])
578 -
962 +
            getSelectedDataset1 <- reactive(x()[[input$data1]])
963 +
            getSelectedDataset2 <- reactive(x()[[input$data2]])
964 +
            
965 +
            observe({
966 +
                .updateDatasetChoices(session, "data1", x(),
967 +
                                      "referenceComparison")
968 +
                .updateDatasetChoices(session, "data2", x(),
969 +
                                      "referenceComparison")
970 +
            })
971 +
            
579 972
            observe({
580 973
                dataset1 <- getSelectedDataset1()
581 974
                numericCols <- getNumericCols(dataset1)
582 975
                updateSelectizeInput(session, "col1", choices=numericCols)
583 976
            })
584 -
977 +
            
585 978
            observe({
586 979
                dataset2 <- getSelectedDataset2()
587 980
                numericCols <- getNumericCols(dataset2)
588 981
                updateSelectizeInput(session, "col2", choices=numericCols)
589 982
            })
590 -
983 +
            
591 984
            output$plot <- renderPlot({
592 985
                isColValid <- function(col, dataset) {
593 986
                    !is.null(col) && col != "" && col %in% colnames(dataset)
594 987
                }
595 -
988 +
                
596 989
                dataset1 <- getSelectedDataset1()
597 990
                col1 <- input$col1
598 991
                if (!isColValid(col1, dataset1)) return(NULL)
599 -
992 +
                
600 993
                dataset2 <- getSelectedDataset2()
601 994
                col2 <- input$col2
602 995
                if (!isColValid(col2, dataset2)) return(NULL)
603 -
996 +
                
604 997
                if (any(dataset1[[1]] %in% dataset2[[1]])) {
605 998
                    plot <- ggplot(data=NULL, aes(x=dataset1[[col1]],
606 999
                                                  y=dataset2[[col2]])) +
607 1000
                        geom_rug(alpha=0.1) +
608 1001
                        geom_abline(slope=1, intercept=0, colour="orange") +
609 1002
                        geom_point(size=0.1, alpha=0.3) +
610 -
                        geom_density_2d(alpha=0.3) +
611 1003
                        xlab(paste(input$data1, input$col1, sep="_")) +
612 1004
                        ylab(paste(input$data2, input$col2, sep="_")) +
613 1005
                        theme_bw()
1006 +
                    
1007 +
                    # Avoid showing density instead of calculating an error
1008 +
                    qd1 <- quantile(dataset1[[col1]], c(0.25, 0.75))
1009 +
                    qd2 <- quantile(dataset2[[col2]], c(0.25, 0.75))
1010 +
                    if (diff(qd1) != 0 && diff(qd2) != 0) {
1011 +
                        plot <- plot + geom_density_2d(alpha=0.3)
1012 +
                    }
614 1013
                    return(plot)
615 1014
                } else {
616 1015
                    stop("no common identifiers between datasets")
617 1016
                }
618 1017
            })
619 -
1018 +
            
620 1019
            output$table <- renderDT({
621 1020
                isColValid <- function(col, dataset) {
622 1021
                    !is.null(col) && col != "" && col %in% colnames(dataset)
623 1022
                }
624 -
1023 +
                
625 1024
                dataset1 <- getSelectedDataset1()
626 1025
                col1 <- input$col1
627 1026
                if (!isColValid(col1, dataset1)) return(NULL)
628 -
1027 +
                
629 1028
                dataset2 <- getSelectedDataset2()
630 1029
                col2 <- input$col2
631 1030
                if (!isColValid(col2, dataset2)) return(NULL)
632 1031
                common <- dataset1[[1]] %in% dataset2[[1]]
633 -
1032 +
                
634 1033
                if (any(common)) {
635 1034
                    df <- data.frame(dataset1[[1]][common],
636 1035
                                     getSelectedDataset1()[[col1]][common],
@@ -638,14 +1037,14 @@
Loading
638 1037
                    colnames(df) <- c("id",
639 1038
                                      paste(input$data1, input$col1, sep="_"),
640 1039
                                      paste(input$data2, input$col2, sep="_"))
641 -
1040 +
                    
642 1041
                    brush <- input$brush
643 1042
                    if (!is.null(brush)) {
644 1043
                        df <- brushedPoints(df, brush,
645 1044
                                            xvar=names(df)[[2]],
646 1045
                                            yvar=names(df)[[3]])
647 1046
                    }
648 -
1047 +
                    
649 1048
                    return(.prepareDT(df))
650 1049
                } else {
651 1050
                    stop("no common identifiers between datasets")
@@ -656,21 +1055,15 @@
Loading
656 1055
}
657 1056
658 1057
.targetingDrugsVSsimilarPerturbationsPlotterUI <- function(
659 -
    id, x, elemClasses, title="Dataset Comparison") {
660 -
    if (!all(c("targetingDrugs", "similarPerturbations") %in% elemClasses)) {
661 -
        return(NULL)
662 -
    }
1058 +
    id, title="Targeting Drugs vs Similar Perturbations") {
1059 +
    
663 1060
    ns <- NS(id)
664 1061
    sidebar <- sidebarPanel(
665 -
        selectizeInput(
666 -
            ns("data1"), "Dataset with predicted targeting drugs",
667 -
            names(x)[elemClasses == "targetingDrugs"]),
668 -
        selectizeInput(
669 -
            ns("data2"), "Dataset with similar CMap perturbations",
670 -
            names(x)[elemClasses == "similarPerturbations"]),
1062 +
        selectizeInput(ns("data1"), "Predicted targeting drugs", NULL),
1063 +
        selectizeInput(ns("data2"), "Similar CMap perturbations", NULL),
671 1064
        selectizeInput(ns("col"), "Column to plot in both axes", choices=NULL))
672 1065
    sidebar[[3]][[2]] <- plotOutput(ns("plot"), brush=ns("brush"))
673 -
1066 +
    
674 1067
    mainPanel <- mainPanel(DTOutput(ns("table")))
675 1068
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
676 1069
    return(ui)
@@ -679,12 +1072,22 @@
Loading
679 1072
#' @importFrom shiny moduleServer reactive observe renderPlot brushedPoints
680 1073
#' @importFrom DT renderDT
681 1074
.targetingDrugsVSsimilarPerturbationsPlotterServer <- function(id, x) {
1075 +
    x <- .convertToFunction(x)
682 1076
    moduleServer(
683 1077
        id,
684 1078
        function(input, output, session) {
685 -
            getSelectedDataset1 <- reactive(x[[input$data1]])
686 -
            getSelectedDataset2 <- reactive(x[[input$data2]])
687 -
1079 +
            getDataset <- function(obj, item) {
1080 +
                if (length(obj) > 0 && !is.null(item)) obj[[item]]
1081 +
            }
1082 +
            getSelectedDataset1 <- reactive(getDataset(x(), input$data1))
1083 +
            getSelectedDataset2 <- reactive(getDataset(x(), input$data2))
1084 +
            
1085 +
            observe({
1086 +
                .updateDatasetChoices(session, "data1", x(), "targetingDrugs")
1087 +
                .updateDatasetChoices(session, "data2", x(),
1088 +
                                      "similarPerturbations")
1089 +
            })
1090 +
            
688 1091
            observe({
689 1092
                data1 <- getSelectedDataset1()
690 1093
                data2 <- getSelectedDataset2()
@@ -693,30 +1096,32 @@
Loading
693 1096
                # Select first ranked column
694 1097
                rankCol <- grep("rank$", cols, value=TRUE)[1]
695 1098
                if (is.na(rankCol)) rankCol <- NULL
696 -
1099 +
                
697 1100
                updateSelectizeInput(session, "col", choices=cols,
698 1101
                                     selected=rankCol)
699 1102
            })
700 -
1103 +
            
701 1104
            observe({
702 1105
                data1 <- getSelectedDataset1()
703 1106
                data2 <- getSelectedDataset2()
1107 +
                if (is.null(data1) || is.null(data2)) return(NULL)
1108 +
                
704 1109
                col <- input$col
705 1110
                isColValid <- !is.null(col) && col != ""
706 1111
                if (is.null(data1) || is.null(data2) || !isColValid) {
707 1112
                    return(NULL)
708 1113
                }
709 -
1114 +
                
710 1115
                plot <- suppressMessages(
711 1116
                    plotTargetingDrugsVSsimilarPerturbations(
712 1117
                        data1, data2, column=col, labelBy=NULL) + theme_bw(16))
713 -
1118 +
                
714 1119
                output$plot  <- renderPlot(plot)
715 1120
                output$table <- renderDT({
716 1121
                    data  <- attr(plot, "data")
717 1122
                    brush <- input$brush
718 1123
                    if (!is.null(brush)) data <- brushedPoints(data, brush)
719 -
1124 +
                    
720 1125
                    hiddenCols <- grep("^pearson|GSEA|spearman", colnames(data))
721 1126
                    columnDefs <- list(list(visible=FALSE,
722 1127
                                            targets=hiddenCols - 1))
@@ -728,116 +1133,498 @@
Loading
728 1133
    )
729 1134
}
730 1135
1136 +
# Data analysis ----------------------------------------------------------------
1137 +
1138 +
getTaskState <- function(dataset) {
1139 +
    if ("state" %in% names(dataset)) {
1140 +
        state <- capitalize(dataset[["state"]])
1141 +
    } else {
1142 +
        state <- "Loaded"
1143 +
    }
1144 +
    return(state)
1145 +
}
1146 +
1147 +
convertTaskState2HTML <- function(state, toStr=TRUE, ..., label=FALSE) {
1148 +
    state <- tolower(state)
1149 +
    if (state %in% c("failure", "revoked")) {
1150 +
        colour <- "red"
1151 +
        icon   <- icon("times-circle")
1152 +
        state  <- "Error"
1153 +
        class  <- "danger"
1154 +
    } else if (state %in% c("not found")) {
1155 +
        colour <- "red"
1156 +
        icon   <- icon("question-circle")
1157 +
        state  <- "Not Found"
1158 +
        class  <- "danger"
1159 +
    } else if (state %in% c("received", "pending", "retry")) {
1160 +
        colour <- "grey"
1161 +
        icon   <- icon("pause-circle")
1162 +
        state  <- "Waiting"
1163 +
        class  <- "default"
1164 +
    } else if (state %in% c("started")) {
1165 +
        colour <- "orange"
1166 +
        icon   <- icon("circle-notch", "fa-spin")
1167 +
        state  <- "Running"
1168 +
        class  <- "warning"
1169 +
    } else if (state %in% c("success", "loaded")) {
1170 +
        colour <- "green"
1171 +
        icon   <- icon("check-circle")
1172 +
        state  <- "Loaded"
1173 +
        class  <- "success"
1174 +
    } else {
1175 +
        return(capitalize(state))
1176 +
    }
1177 +
    
1178 +
    if (!label) {
1179 +
        colour <- sprintf("color: %s;", colour)
1180 +
        class  <- NULL
1181 +
    } else {
1182 +
        colour <- NULL
1183 +
        class  <- paste0(c("label label-"), class)
1184 +
    }
1185 +
    html   <- tags$span(style=colour, icon, state, ..., class=class)
1186 +
    if (toStr) html <- as.character(html)
1187 +
    return(html)
1188 +
}
1189 +
1190 +
# Run rank similar perturbations in Celery
1191 +
celery_rankAgainstRef <- function(..., mode, token) {
1192 +
    # Prepare filenames for input and output
1193 +
    rand       <- .genRandomString()
1194 +
    inputFile  <- file.path(token, sprintf("input_%s.Rda",  rand))
1195 +
    outputFile <- file.path(token, sprintf("output_%s.rds", rand))
1196 +
    
1197 +
    # Save variables in Rda file
1198 +
    save(..., file=inputFile, envir=parent.frame())
1199 +
    
1200 +
    # Rank comparisons via Celery/Flower and save as RDS file
1201 +
    if (mode == "similarPerturbations") {
1202 +
        cmd <- "cTRAP::rankSimilarPerturbations(
1203 +
                    selectedDiffExpr, selectedPerts, method,
1204 +
                    c(upGenes, downGenes), cellLineMean, rankPerCellLine)"
1205 +
    } else if (mode == "targetingDrugs") {
1206 +
        cmd <- "cTRAP::predictTargetingDrugs(
1207 +
                    selectedDiffExpr, selectedCorMatrix, method,
1208 +
                    c(upGenes, downGenes))"
1209 +
    }
1210 +
    cmd <- list(sprintf("load('%s')", inputFile),
1211 +
                paste("ranking <-", cmd),
1212 +
                "attr(ranking, 'name') <- dataset",
1213 +
                sprintf("saveRDS(ranking, '%s')", outputFile),
1214 +
                sprintf("unlink('%s')", inputFile))
1215 +
    cmd <- gsub("\n *", "", paste(cmd, collapse="; "))
1216 +
    taskAsync <- taskAsyncApply("tasks.R", cmd)
1217 +
    
1218 +
    # Prepare object
1219 +
    ranking <- taskAsync
1220 +
    ranking$state <- capitalize(ranking$state)
1221 +
    ranking[["outputFile"]] <- outputFile
1222 +
    class(ranking) <- c(paste0("expected", capitalize(mode)), "expected",
1223 +
                        class(ranking))
1224 +
    return(ranking)
1225 +
}
1226 +
731 1227
#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
732 -
#' tabPanel uiOutput
1228 +
#' tabPanel uiOutput column fluidRow numericInput checkboxInput conditionalPanel
733 1229
#' @importFrom DT DTOutput
734 -
.drugSetEnrichmentAnalyserUI <- function(id, sets, x,
735 -
                                         title="Drug Set Enrichment Analyser") {
1230 +
.rankSimilarPerturbationsUI <- function(
1231 +
    id, title="Rank CMap perturbations by similarity") {
1232 +
    
736 1233
    ns <- NS(id)
737 1234
    sidebar <- sidebarPanel(
738 -
        selectizeInput(ns("object"), "Dataset", names(x)),
739 -
        selectizeInput(ns("sort"), "Sorting metric", choices=NULL), hr(),
740 -
        selectizeInput(ns("statsKey"), "Dataset column to match compounds",
741 -
                       choices=NULL),
742 -
        selectizeInput(ns("setsKey"), "Drug set column to match compounds",
1235 +
        selectizeInput(ns("diffExpr"), "Differential gene expression",
743 1236
                       choices=NULL),
1237 +
        selectizeInput(ns("perts"), "CMap perturbations", choices=NULL),
1238 +
        selectizeInput(ns("method"), "Method", multiple=TRUE,
1239 +
                       .comparisonMethods(), .comparisonMethods(),
1240 +
                       options=list(plugins=list("remove_button"))),
1241 +
        conditionalPanel(
1242 +
            "input.method.includes('gsea')",
1243 +
            fluidRow(
1244 +
                column(6, numericInput(ns("upGenes"), "Top genes", 150)),
1245 +
                column(6, numericInput(ns("downGenes"), "Bottom genes", 150))),
1246 +
            ns=ns),
1247 +
        selectizeInput(ns("cellLineMean"),
1248 +
                       "Calculate mean across cell lines",
1249 +
                       c("For data with \u2265 2 cell lines"="auto",
1250 +
                         "Always"=TRUE,
1251 +
                         "Never"=FALSE)),
1252 +
        conditionalPanel(
1253 +
            "input.cellLineMean != 'FALSE'",
1254 +
            selectizeInput(ns("rankPerCellLine"), "Rank results based on",
1255 +
                           c("Mean scores only"=FALSE,
1256 +
                             "Mean + individual cell lines' scores"=TRUE)),
1257 +
            ns=ns),
1258 +
        textInput(ns("name"), "Dataset name", "Ranked CMap perturbations"),
1259 +
        uiOutput(ns("msg")),
1260 +
        actionButton(ns("analyse"), "Rank by similarity", class="btn-primary"))
1261 +
    
1262 +
    mainPanel <- mainPanel(DTOutput(ns("table")))
1263 +
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
1264 +
    return(ui)
1265 +
}
1266 +
1267 +
#' @importFrom shiny renderPlot observeEvent observe isolate renderUI
1268 +
#' @importFrom DT renderDT
1269 +
#' @importFrom data.table rbindlist
1270 +
.rankSimilarPerturbationsServer <- function(id, x, globalUI=FALSE,
1271 +
                                            flower=FALSE, token=NULL) {
1272 +
    server <- function(input, output, session) {
1273 +
        observe({
1274 +
            .updateDatasetChoices(session, "diffExpr", x(), "diffExpr")
1275 +
            .updateDatasetChoices(session, "perts", x(), "perturbationChanges")
1276 +
        })
1277 +
        
1278 +
        rankData <- eventReactive(input$analyse, {
1279 +
            diffExprDataset <- req(input$diffExpr)
1280 +
            pertsDataset    <- req(input$perts)
1281 +
            method          <- input$method
1282 +
            upGenes         <- input$upGenes
1283 +
            downGenes       <- input$downGenes
1284 +
            cellLineMean    <- input$cellLineMean
1285 +
            rankPerCellLine <- input$rankPerCellLine
1286 +
            dataset         <- input$name
1287 +
            
1288 +
            if (cellLineMean == "TRUE") {
1289 +
                cellLineMean <- TRUE
1290 +
                cellLineMeanTxt <- "Always"
1291 +
            } else if (cellLineMean == "FALSE") {
1292 +
                cellLineMean <- FALSE
1293 +
                cellLineMeanTxt <- "Never"
1294 +
            } else if (cellLineMean == "auto") {
1295 +
                cellLineMeanTxt <- "For data with \u2265 2 cell lines" 
1296 +
            }
1297 +
            
1298 +
            if (rankPerCellLine == "TRUE") {
1299 +
                rankPerCellLine <- TRUE
1300 +
            } else if (rankPerCellLine == "FALSE") {
1301 +
                rankPerCellLine <- FALSE
1302 +
            }
1303 +
            
1304 +
            selectedDiffExpr <- x()[[req(diffExprDataset)]]
1305 +
            selectedPerts    <- x()[[req(pertsDataset)]]
1306 +
            if (!flower) {
1307 +
                withProgress(message="Ranking against CMap perturbations", {
1308 +
                    ranking <- rankSimilarPerturbations(
1309 +
                        selectedDiffExpr, selectedPerts, method,
1310 +
                        c(upGenes, downGenes), cellLineMean, rankPerCellLine)
1311 +
                    incProgress(1)
1312 +
                })
1313 +
            } else {
1314 +
                ranking <- celery_rankAgainstRef(
1315 +
                    selectedDiffExpr, selectedPerts, method, upGenes, downGenes,
1316 +
                    cellLineMean, rankPerCellLine, dataset,
1317 +
                    token=isolate(token()), mode="similarPerturbations")
1318 +
            }
1319 +
            attr(ranking, "name") <- dataset
1320 +
            
1321 +
            rankPerCellLine <- ifelse(
1322 +
                rankPerCellLine,
1323 +
                "Mean + individual cell lines' scores",
1324 +
                "Mean scores only")
1325 +
            attr(ranking, "formInput") <- list(
1326 +
                "Differential expression dataset"=diffExprDataset,
1327 +
                "CMap perturbation dataset"=pertsDataset,
1328 +
                "Methods"=paste(method, collapse=", "),
1329 +
                "Top genes"=upGenes,
1330 +
                "Bottom genes"=downGenes,
1331 +
                "Calculate mean across cell lines"=cellLineMeanTxt,
1332 +
                "Rank results based on"=rankPerCellLine)
1333 +
            return(ranking)
1334 +
        })
1335 +
        
1336 +
        if (!globalUI) observeEvent(input$load, stopApp(rankData()))
1337 +
        
1338 +
        output$table <- renderDT({
1339 +
            .prepareReferenceComparisonDT(x(), "similarPerturbations")
1340 +
        }, rownames=FALSE, escape=FALSE, selection="none")
1341 +
        
1342 +
        return(rankData)
1343 +
    }
1344 +
    moduleServer(id, server)
1345 +
}
1346 +
1347 +
#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
1348 +
#' tabPanel uiOutput column fluidRow numericInput checkboxInput conditionalPanel
1349 +
#' @importFrom DT DTOutput
1350 +
.predictTargetingDrugsUI <- function(id, title="Predict targeting drugs") {
1351 +
    ns <- NS(id)
1352 +
    sidebar <- sidebarPanel(
1353 +
        selectizeInput(ns("diffExpr"), choices=NULL,
1354 +
                       "Differential gene expression"),
1355 +
        selectizeInput(ns("corMatrix"),
1356 +
                       "Gene expression and drug sensitivity association",
1357 +
                       choices=listExpressionDrugSensitivityAssociation()),
1358 +
        selectizeInput(ns("method"), "Method", multiple=TRUE,
1359 +
                       .comparisonMethods(), .comparisonMethods(),
1360 +
                       options=list(plugins=list("remove_button"))),
1361 +
        conditionalPanel(
1362 +
            "input.method.includes('gsea')",
1363 +
            fluidRow(
1364 +
                column(6, numericInput(ns("upGenes"), "Top genes", 150)),
1365 +
                column(6, numericInput(ns("downGenes"), "Bottom genes", 150))),
1366 +
            ns=ns),
1367 +
        textInput(ns("name"), "Dataset name", "Targeting drugs"),
744 1368
        uiOutput(ns("msg")),
745 -
        actionButton(ns("analyse"), "Analyse", class="btn-primary"))
1369 +
        actionButton(ns("analyse"), "Predict targeting drugs",
1370 +
                     class="btn-primary"))
1371 +
    
1372 +
    mainPanel <- mainPanel(DTOutput(ns("table")))
1373 +
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
1374 +
    return(ui)
1375 +
}
1376 +
1377 +
#' @importFrom shiny renderPlot observeEvent observe isolate renderUI
1378 +
#' @importFrom DT renderDT
1379 +
#' @importFrom data.table rbindlist
1380 +
.predictTargetingDrugsServer <- function(id, x, path=".", globalUI=FALSE,
1381 +
                                         flower=FALSE, token=NULL) {
1382 +
    server <- function(input, output, session) {
1383 +
        observe( .updateDatasetChoices(session, "diffExpr", x(), "diffExpr") )
1384 +
        
1385 +
        observe({
1386 +
            dataset <- "Targeting drugs"
1387 +
            
1388 +
            corMatrix <- input$corMatrix
1389 +
            if (!is.null(corMatrix) || corMatrix != "") {
1390 +
                dataset <- paste(corMatrix, tolower(dataset))
1391 +
            }
1392 +
            updateTextInput(session, "name", value=dataset)
1393 +
        })
1394 +
        
1395 +
        rankData <- eventReactive(input$analyse, {
1396 +
            diffExprDataset <- req(input$diffExpr)
1397 +
            corMatrix       <- req(input$corMatrix)
1398 +
            method          <- input$method
1399 +
            upGenes         <- input$upGenes
1400 +
            downGenes       <- input$downGenes
1401 +
            dataset         <- input$name
1402 +
            
1403 +
            selectedDiffExpr  <- x()[[diffExprDataset]]
1404 +
            selectedCorMatrix <- loadExpressionDrugSensitivityAssociation(
1405 +
                corMatrix, path=path)
1406 +
            if (!flower) {
1407 +
                withProgress(message="Predict targeting drugs", {
1408 +
                    ranking <- predictTargetingDrugs(
1409 +
                        selectedDiffExpr, selectedCorMatrix, method,
1410 +
                        c(upGenes, downGenes))
1411 +
                    incProgress(1)
1412 +
                })
1413 +
            } else {
1414 +
                ranking <- celery_rankAgainstRef(
1415 +
                    selectedDiffExpr, selectedCorMatrix, method,
1416 +
                    upGenes, downGenes, dataset, token=isolate(token()),
1417 +
                    mode="targetingDrugs")
1418 +
            }
1419 +
            attr(ranking, "name") <- dataset
1420 +
            
1421 +
            # Prepare form input
1422 +
            attr(ranking, "formInput") <- list(
1423 +
                "Differential expression dataset"=diffExprDataset,
1424 +
                "Gene expression and drug sensitivity association"=corMatrix,
1425 +
                "Methods"=paste(method, collapse=", "),
1426 +
                "Top genes"=upGenes,
1427 +
                "Bottom genes"=downGenes)
1428 +
            return(ranking)
1429 +
        })
1430 +
        
1431 +
        if (!globalUI) observeEvent(input$load, stopApp(rankData()))
1432 +
        
1433 +
        output$table <- renderDT({
1434 +
            .prepareReferenceComparisonDT(x(), "targetingDrugs")
1435 +
        }, rownames=FALSE, escape=FALSE, selection="none")
1436 +
        
1437 +
        return(rankData)
1438 +
    }
1439 +
    moduleServer(id, server)
1440 +
}
1441 +
1442 +
#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
1443 +
#' tabPanel helpText textOutput
1444 +
#' @importFrom shinycssloaders withSpinner
1445 +
#' @importFrom DT DTOutput
1446 +
.drugSetEnrichmentAnalyserUI <- function(id, title="Drug Set Enrichment") {
1447 +
    ns <- NS(id)
1448 +
    sidebar <- sidebarPanel(
1449 +
        selectizeInput(ns("object"), "Dataset", choices=NULL),
1450 +
        selectizeInput(ns("sort"), "Ranked by", choices=NULL), hr(),
1451 +
        selectizeInput(ns("drugSet"), "Drug set", choices=NULL,
1452 +
                       options=list(placeholder="Select a drug set")), hr(),
1453 +
        tags$h4("Match compounds"),
1454 +
        helpText("Select key columns to match compounds between datasets"),
1455 +
        withSpinner(uiOutput(ns("matchCompounds")), type=8,
1456 +
                    proxy.height="150px", hide.ui=TRUE))
746 1457
    sidebar[[3]][[2]] <- tagList(
747 1458
        selectizeInput(ns("element"), "Row ID to plot", choices=NULL,
748 1459
                       width="100%"),
749 1460
        plotOutput(ns("plot")))
750 -
1461 +
    
751 1462
    mainPanel <- mainPanel(DTOutput(ns("table")))
752 1463
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
753 1464
    return(ui)
754 1465
}
755 1466
756 -
#' @importFrom shiny renderPlot observeEvent observe isolate renderUI
1467 +
#' @importFrom shiny renderPlot observeEvent observe isolate renderText
757 1468
#' @importFrom DT renderDT
758 -
.drugSetEnrichmentAnalyserServer <- function(id, sets, x) {
1469 +
.drugSetEnrichmentAnalyserServer <- function(id, x, path=NULL) {
1470 +
    x <- .convertToFunction(x)
759 1471
    moduleServer(
760 1472
        id,
761 1473
        function(input, output, session) {
762 -
            getSelectedObject <- reactive(x[[input$object]])
763 -
            getDSEAresult     <- reactive({
764 -
                obj      <- getSelectedObject()
1474 +
            getExtraDrugSets <- function() {
1475 +
                extraDrugSets <- c("NCI60 2D", "NCI60 3D", "CMap 2D", "CMap 3D")
1476 +
                extraDrugSets <- setNames(
1477 +
                    extraDrugSets,
1478 +
                    paste(extraDrugSets, "molecular descriptors"))
1479 +
                return(extraDrugSets)
1480 +
            }
1481 +
            
1482 +
            getSelectedObject <- reactive(x()[[input$object]])
1483 +
            getSelectedSet <- reactive({
1484 +
                sets <- .filterDatasetsByClass(x(), "drugSets")
1485 +
                drugSet <- input$drugSet
1486 +
                if (drugSet %in% names(sets)) {
1487 +
                    res <- sets[[req(input$drugSet)]]
1488 +
                } else if (drugSet %in% getExtraDrugSets()) {
1489 +
                    drugSet <- strsplit(drugSet, " ")[[1]]
1490 +
                    withProgress(message="Loading drug descriptors", {
1491 +
                        res <- loadDrugSet(drugSet[[1]], drugSet[[2]],
1492 +
                                           path=path)
1493 +
                        incProgress(1)
1494 +
                        return(res)
1495 +
                    })
1496 +
                } else {
1497 +
                    res <- NULL
1498 +
                }
1499 +
                return(res)
1500 +
            })
1501 +
            
1502 +
            # Update available datasets
1503 +
            observe({
1504 +
                .updateDatasetChoices(session, "object", x(),
1505 +
                                      "referenceComparison")
1506 +
            })
1507 +
            
1508 +
            # Update available drug sets
1509 +
            observe({
1510 +
                drugSets <- .filterDatasetsByClass(x(), "drugSets")
1511 +
                drugSets <- names(drugSets)
1512 +
                
1513 +
                # Show all available drug sets from cTRAP
1514 +
                if (is.null(drugSets)) {
1515 +
                    choices <- list(
1516 +
                        "Other available drug sets"=getExtraDrugSets())
1517 +
                    selected <- list()
1518 +
                } else {
1519 +
                    choices <- list(
1520 +
                        "Loaded drug sets"=list(drugSets),
1521 +
                        "Other available drug sets"=getExtraDrugSets())
1522 +
                    selected <- drugSets[[1]]
1523 +
                }
1524 +
                updateSelectizeInput(session, "drugSet", choices=choices,
1525 +
                                     selected=selected)
1526 +
            })
1527 +
            
1528 +
            getDSEAresult <- reactive({
1529 +
                obj      <- req(getSelectedObject())
1530 +
                sets     <- req(getSelectedSet())
765 1531
                sort     <- input$sort
766 1532
                statsKey <- input$statsKey
767 1533
                setsKey  <- input$setsKey
768 -
1534 +
                
769 1535
                isValid <- function(e) !is.null(e) && e != ""
770 1536
                if (is.null(obj) || !isValid(sort)) return(NULL)
771 1537
                if (!isValid(statsKey) || !isValid(setsKey)) return(NULL)
772 -
773 -
                analyseDrugSetEnrichment(
774 -
                    sets, obj, col=sort,
775 -
                    keyColSets=setsKey, keyColStats=statsKey)
1538 +
                
1539 +
                withProgress(message="Analysing drug set enrichment", {
1540 +
                    res <- analyseDrugSetEnrichment(
1541 +
                        sets, obj, col=sort,
1542 +
                        keyColSets=setsKey, keyColStats=statsKey)
1543 +
                    incProgress(1)
1544 +
                    return(res)
1545 +
                })
776 1546
            })
777 -
1547 +
            
778 1548
            observeEvent(input$object, {
779 1549
                obj <- getSelectedObject()
780 1550
                numericCols <- names(obj)[vapply(obj, is.numeric, logical(1))]
781 1551
                updateSelectizeInput(session, "sort", choices=numericCols)
782 1552
            })
783 -
1553 +
            
784 1554
            # Update available keys to select for datasets
785 -
            observe({
786 -
                obj <- getSelectedObject()
787 -
                if (is.null(obj)) return(NULL)
788 -
1555 +
            getCompoundMatchKeys <- function(statsKey=NULL, setsKey=NULL) {
1556 +
                obj <- req(getSelectedObject())
1557 +
                sets <- req(getSelectedSet())
1558 +
                
789 1559
                statsInfo <- prepareStatsCompoundInfo(obj)$statsInfo
790 1560
                setsInfo  <- prepareSetsCompoundInfo(sets)$setsCompoundInfo
791 -
792 -
                probableKey <- findIntersectingCompounds(statsInfo, setsInfo)
793 -
                statsKey    <- probableKey$key2
794 -
                setsKey     <- probableKey$key1
795 -
1561 +
                
1562 +
                probableKey <- findIntersectingCompounds(
1563 +
                    statsInfo, setsInfo, keys1=statsKey, keys2=setsKey)
1564 +
                setsKey     <- probableKey$key2
1565 +
                statsKey    <- probableKey$key1
1566 +
                
796 1567
                keyList      <- getCompoundIntersectingKeyList()
797 1568
                statsOptions <- intersect(names(statsInfo), keyList)
798 1569
                setsOptions  <- intersect(names(setsInfo), keyList)
799 -
800 -
                updateSelectizeInput(session, "statsKey", selected=statsKey,
801 -
                                     choices=statsOptions)
802 -
                updateSelectizeInput(session, "setsKey", selected=setsKey,
803 -
                                     choices=setsOptions)
1570 +
                return(list(probableKey=probableKey,
1571 +
                            setsKey=setsKey, statsKey=statsKey,
1572 +
                            setsOptions=setsOptions, statsOptions=statsOptions))
1573 +
            }
1574 +
            
1575 +
            # Update interface for selecting columns for compound matching
1576 +
            output$matchCompounds <- renderUI({
1577 +
                ns <- session$ns
1578 +
                ui <- tagList(
1579 +
                    fluidRow(
1580 +
                        column(6, selectizeInput(ns("statsKey"), choices=NULL,
1581 +
                                                 "Dataset key")),
1582 +
                        column(6, selectizeInput(ns("setsKey"), choices=NULL,
1583 +
                                                 "Drug set key"))),
1584 +
                    tags$span(class="help-block", style="margin-top: -10px;",
1585 +
                              textOutput(ns("msg"))),
1586 +
                    actionButton(ns("analyse"), "Visualise",
1587 +
                                 class="btn-primary"))
1588 +
                
1589 +
                res <- suppressMessages( getCompoundMatchKeys() )
1590 +
                updateSelectizeInput(session, "statsKey", selected=res$statsKey,
1591 +
                                     choices=res$statsOptions)
1592 +
                updateSelectizeInput(session, "setsKey", selected=res$setsKey,
1593 +
                                     choices=res$setsOptions)
1594 +
                return(ui)
804 1595
            })
805 -
1596 +
            
806 1597
            # Update number of intersecting compounds based on selected keys
807 1598
            observe({
808 -
                obj <- getSelectedObject()
809 -
                if (is.null(obj)) return(NULL)
810 -
811 -
                statsInfo <- prepareStatsCompoundInfo(obj)$statsInfo
812 -
                setsInfo  <- prepareSetsCompoundInfo(sets)$setsCompoundInfo
813 -
814 -
                statsKey <- input$statsKey
815 -
                setsKey  <- input$setsKey
816 -
                isValid <- function(e) !is.null(e) && e != ""
817 -
                if (!isValid(statsKey) || !isValid(setsKey)) return(NULL)
818 -
819 -
                probableKey <- findIntersectingCompounds(statsInfo, setsInfo,
820 -
                                                         statsKey, setsKey)
821 -
                num <- length(probableKey[[3]])
822 -
                msg <- "cross-matches found using the selected keys"
823 -
                output$msg <- renderUI(helpText(paste(num, msg)))
1599 +
                res <- getCompoundMatchKeys(req(input$statsKey),
1600 +
                                            req(input$setsKey))
1601 +
                
1602 +
                num <- length(res$probableKey[[3]])
1603 +
                msg <- "cross-matches with selected columns"
1604 +
                output$msg <- renderText(paste(num, msg))
824 1605
            })
825 -
1606 +
            
826 1607
            observeEvent(input$analyse, {
827 1608
                dsea <- getDSEAresult()
828 1609
                updateSelectizeInput(session, "element", choices=dsea[[1]])
829 -
                output$table <- renderDT(.prepareDT(dsea))
830 -
1610 +
                output$table <- renderDT({
1611 +
                    hiddenCols <- "leadingEdge"
1612 +
                    hiddenCols <- match(hiddenCols, colnames(dsea))
1613 +
                    columnDefs <- list(list(visible=FALSE,
1614 +
                                            targets=hiddenCols - 1))
1615 +
                    .prepareDT(dsea, columnDefs=columnDefs)
1616 +
                })
1617 +
                
831 1618
                output$plot <- renderPlot({
832 -
                    obj <- getSelectedObject()
833 -
                    if (is.null(obj)) return(NULL)
834 -
1619 +
                    obj  <- req(getSelectedObject())
1620 +
                    sets <- req(getSelectedSet())
1621 +
                    
835 1622
                    element <- input$element
836 1623
                    if (element == "") element <- NULL
837 1624
                    if (is.null(element) || !element %in% names(sets)) {
838 1625
                        return(NULL)
839 1626
                    }
840 -
1627 +
                    
841 1628
                    isolate({
842 1629
                        setsKey  <- input$setsKey
843 1630
                        statsKey <- input$statsKey
@@ -845,13 +1632,14 @@
Loading
845 1632
                    })
846 1633
                    isValid <- function(e) !is.null(e) && e != ""
847 1634
                    if (!isValid(statsKey) || !isValid(setsKey)) return(NULL)
848 -
                    plotDrugSetEnrichment(sets, obj, col=sort,
849 -
                                          selectedSets=element,
850 -
                                          keyColStats=statsKey,
851 -
                                          keyColSets=setsKey)[[1]]
1635 +
                    suppressMessages(
1636 +
                        plotDrugSetEnrichment(sets, obj, col=sort,
1637 +
                                              selectedSets=element,
1638 +
                                              keyColStats=statsKey,
1639 +
                                              keyColSets=setsKey)[[1]])
852 1640
                })
853 1641
            })
854 -
1642 +
            
855 1643
            # Update selected element
856 1644
            observeEvent(input$table_rows_selected, {
857 1645
                selected <- getDSEAresult()[[1]][input$table_rows_selected]
@@ -868,17 +1656,18 @@
Loading
868 1656
#' Currently only supports loading data from ENCODE knockdown experiments
869 1657
#'
870 1658
#' @inheritParams downloadENCODEknockdownMetadata
1659 +
#' @inheritParams loadENCODEsamples
871 1660
#'
872 1661
#' @return Differential expression data
873 1662
#' @family visual interface functions
874 1663
#' @export
875 -
launchDiffExprLoader <- function(cellLine=NULL, gene=NULL) {
876 -
    metadata <- downloadENCODEknockdownMetadata()
1664 +
launchDiffExprLoader <- function(cellLine=NULL, gene=NULL,
1665 +
                                 file="ENCODEmetadata.rds", path=".") {
1666 +
    metadata <- downloadENCODEknockdownMetadata(file=file)
877 1667
    id       <- "diffExpr"
878 -
    ui       <- .prepareNavPage(
879 -
        .diffExprENCODEloaderUI(id, metadata, cellLine, gene))
1668 +
    ui       <- .prepareNavPage(.diffExprENCODEloaderUI(id))
880 1669
    server   <- function(input, output, session) {
881 -
        .diffExprENCODEloaderServer(id, metadata)
1670 +
        .diffExprENCODEloaderServer(id, metadata, cellLine, gene, path=path)
882 1671
    }
883 1672
    app    <- runApp(shinyApp(ui, server))
884 1673
    return(app)
@@ -907,8 +1696,7 @@
Loading
907 1696
    metadata <- loadCMapData(metadata, type="metadata")
908 1697
    id <- "cmapDataLoader"
909 1698
    ui <- .prepareNavPage(
910 -
        .cmapDataLoaderUI(id, metadata, zscores, geneInfo, compoundInfo,
911 -
                          cellLine, timepoint, dosage, perturbationType))
1699 +
        .cmapDataLoaderUI(id, cellLine, timepoint, dosage, perturbationType))
912 1700
    server <- function(input, output, session) {
913 1701
        .cmapDataLoaderServer(id, metadata, zscores, geneInfo, compoundInfo,
914 1702
                              cellLine, timepoint, dosage)
@@ -929,7 +1717,7 @@
Loading
929 1717
launchMetadataViewer <- function(...) {
930 1718
    elems  <- .prepareEllipsis(...)
931 1719
    id     <- "metadataViewer"
932 -
    ui     <- .prepareNavPage(.metadataViewerUI(id, elems))
1720 +
    ui     <- .prepareNavPage(.metadataViewerUI(id))
933 1721
    server <- function(input, output, session) .metadataViewerServer(id, elems)
934 1722
    app    <- runApp(shinyApp(ui, server))
935 1723
    return(app)
@@ -950,21 +1738,20 @@
Loading
950 1738
    comparePlotId <- "comparePlotter"
951 1739
    dataId        <- "dataPlotter"
952 1740
    metadataId    <- "metadataViewer"
953 -
1741 +
    
954 1742
    elemClasses       <- sapply(lapply(list(...), class), "[[", 1)
955 1743
    hasSimilarPerts   <- "similarPerturbations" %in% elemClasses
956 1744
    hasTargetingDrugs <- "targetingDrugs" %in% elemClasses
957 1745
    showTwoKindPlot   <- hasSimilarPerts && hasTargetingDrugs
958 -
1746 +
    
959 1747
    uiList <- tagList(
960 -
        .dataPlotterUI(dataId, elems),
961 -
        .targetingDrugsVSsimilarPerturbationsPlotterUI(
962 -
            comparePlotId, elems, elemClasses),
963 -
        .datasetComparisonUI(compareId, elems),
964 -
        .metadataViewerUI(metadataId, elems))
1748 +
        .dataPlotterUI(dataId),
1749 +
        .targetingDrugsVSsimilarPerturbationsPlotterUI(comparePlotId),
1750 +
        .datasetComparisonUI(compareId),
1751 +
        .metadataViewerUI(metadataId))
965 1752
    uiList <- Filter(length, uiList)
966 1753
    ui     <- do.call(.prepareNavPage, uiList)
967 -
1754 +
    
968 1755
    server <- function(input, output, session) {
969 1756
        .dataPlotterServer(dataId, elems)
970 1757
        if (showTwoKindPlot) {
@@ -992,18 +1779,19 @@
Loading
992 1779
    dataId     <- "dataPlotter"
993 1780
    metadataId <- "metadataViewer"
994 1781
    dseaId     <- "drugSetAnalyser"
995 -
1782 +
    
996 1783
    elems <- .prepareEllipsis(...)
997 -
1784 +
    
998 1785
    uiList <- tagList(
999 -
        .drugSetEnrichmentAnalyserUI(dseaId, sets, elems),
1000 -
        .dataPlotterUI(dataId, elems),
1001 -
        .metadataViewerUI(metadataId, elems))
1786 +
        .drugSetEnrichmentAnalyserUI(dseaId),
1787 +
        .dataPlotterUI(dataId),
1788 +
        .metadataViewerUI(metadataId))
1002 1789
    uiList <- Filter(length, uiList)
1003 1790
    ui     <- do.call(.prepareNavPage, uiList)
1004 -
1791 +
    
1005 1792
    server <- function(input, output, session) {
1006 -
        .drugSetEnrichmentAnalyserServer(dseaId, sets, elems)
1793 +
        .drugSetEnrichmentAnalyserServer(dseaId,
1794 +
                                         c(elems, list("Custom drug set"=sets)))
1007 1795
        .dataPlotterServer(dataId, elems)
1008 1796
        .metadataViewerServer(metadataId, elems)
1009 1797
    }

@@ -0,0 +1,86 @@
Loading
1 +
# Temprarily include floweRy functions until approved in CRAN (?)
2 +
# Source code: https://github.com/nuno-agostinho/floweRy
3 +
4 +
getFlowerURL <- function() { getOption("floweRy.url", "http://localhost:5555") }
5 +
6 +
#' @importFrom httr status_code stop_for_status
7 +
simplifyAPIerror <- function(res, errors) {
8 +
    msg <- errors[[as.character(status_code(res))]]
9 +
    if (!is.null(msg)) {
10 +
        stop(msg)
11 +
    } else {
12 +
        stop_for_status(res)
13 +
    }
14 +
}
15 +
16 +
#' @importFrom httr GET content
17 +
getInfo <- function(type, ..., url=getFlowerURL(), errors=NULL) {
18 +
    res <- GET(url=file.path(url, "api", type), query=list(...))
19 +
    simplifyAPIerror(res, errors)
20 +
    return(content(res))
21 +
}
22 +
23 +
taskList <- function(limit=NULL, offset=NULL,
24 +
                     sort_by=c("name", "state", "received", "started"),
25 +
                     workername=NULL, taskname=NULL, state=NULL,
26 +
                     received_start=NULL, received_end=NULL, table=TRUE,
27 +
                     url=getFlowerURL()) {
28 +
    sort_by <- match.arg(sort_by)
29 +
    res <- getInfo(type="tasks", limit=limit, offset=offset, sort_by=sort_by,
30 +
                   workername=workername, taskname=taskname, state=state,
31 +
                   received_start=received_start, received_end=received_end,
32 +
                   url=url)
33 +
    
34 +
    timestamps <- c("received", "started", "succeeded", "timestamp", "revoked")
35 +
    convertTime <- function(x) as.POSIXct(x, origin="1970-01-01")
36 +
    
37 +
    for (task in names(res)) {
38 +
        # Replace NULL with NA
39 +
        nulls <- vapply(res[[task]], is.null, logical(1))
40 +
        res[[task]][nulls] <- NA
41 +
        
42 +
        # Replace Unix timestamp with formatted time
43 +
        res[[task]][timestamps] <- lapply(res[[task]][timestamps], convertTime)
44 +
    }
45 +
    
46 +
    # Create table
47 +
    if (table) {
48 +
        cols <- unique(unlist(lapply(res, names)))
49 +
        df   <- data.frame(matrix(ncol=length(cols), nrow=length(res),
50 +
                                  dimnames=list(names(res), cols)))
51 +
        for (col in cols) {
52 +
            values <- sapply(res, "[[", col)
53 +
            if (col %in% timestamps) values <- convertTime(values)
54 +
            df[[col]] <- values
55 +
        }
56 +
        res <- df
57 +
    }
58 +
    return(res)
59 +
}
60 +
61 +
#' @importFrom httr POST content
62 +
runTask <- function(type="apply", task=NULL,
63 +
                    args=NULL, kwargs=NULL, options=NULL, url=getFlowerURL(),
64 +
                    errors=NULL) {
65 +
    path <- file.path("api", "task", type, task)
66 +
    
67 +
    convert2list <- function (x) if (!is.null(x) && !is.list(x)) list(x) else x
68 +
    args    <- convert2list(args)
69 +
    kwargs  <- convert2list(kwargs)
70 +
    options <- convert2list(options)
71 +
    
72 +
    body <- list(args=args, kwargs=kwargs, options=options)
73 +
    res  <- POST(url=file.path(url, path), body=body, encode="json")
74 +
    simplifyAPIerror(res, errors)
75 +
    return(content(res))
76 +
}
77 +
78 +
taskAsyncApply <- function(task, ..., kwargs=NULL, options=NULL,
79 +
                           url=getFlowerURL()) {
80 +
    args <- list(...)
81 +
    if (length(args) == 0) args <- NULL
82 +
    
83 +
    errors <- list("404"="unknown task")
84 +
    runTask(type="async-apply", task=task, args=prepareArgs(...), kwargs=kwargs,
85 +
            options=options, url=url, errors=errors)
86 +
}

@@ -12,12 +12,19 @@
Loading
12 12
    return(exp)
13 13
}
14 14
15 +
filterENCONDEmetadata <- function(table, cellLine=NULL, gene=NULL) {
16 +
    if (!is.null(gene)) table <- table[table$`Experiment target` == gene, ]
17 +
    if (!is.null(cellLine)) table <- table[
18 +
        tolower(table$`Biosample term name`) == tolower(cellLine), ]
19 +
    return(table)
20 +
}
21 +
15 22
#' Download metadata for ENCODE knockdown experiments
16 23
#'
17 24
#' @param cellLine Character: cell line
18 25
#' @param gene Character: target gene
19 -
#' @param file Character: RDS file with metadata (if file doesn't exist, it will
20 -
#' be created)
26 +
#' @param file Character: RDS filepath with metadata (if file doesn't exist, it
27 +
#' will be created)
21 28
#'
22 29
#' @importFrom httr content GET
23 30
#' @importFrom data.table fread
@@ -86,11 +93,7 @@
Loading
86 93
    } else {
87 94
        table <- readRDS(file)
88 95
    }
89 -
90 -
    if (!is.null(gene)) table <- table[table$`Experiment target` == gene, ]
91 -
    if (!is.null(cellLine)) table <- table[
92 -
        tolower(table$`Biosample term name`) == tolower(cellLine), ]
93 -
96 +
    table <- filterENCONDEmetadata(table, cellLine, gene)
94 97
    return(table)
95 98
}
96 99
@@ -99,11 +102,12 @@
Loading
99 102
#' @param metadata Data frame: ENCODE metadata
100 103
#' @param replicate Number: replicate
101 104
#' @param control Boolean: load control experiment?
105 +
#' @inheritParams loadENCODEsamples
102 106
#'
103 107
#' @importFrom data.table fread
104 108
#' @return Data table with ENCODE sample data
105 109
#' @keywords internal
106 -
loadENCODEsample <- function (metadata, replicate, control=FALSE) {
110 +
loadENCODEsample <- function (metadata, replicate, control=FALSE, path=".") {
107 111
    metadata <- metadata[metadata$`Biological replicate(s)` == replicate, ]
108 112
109 113
    if (control) {
@@ -114,7 +118,7 @@
Loading
114 118
    }
115 119
    sample <- paste0(sample)
116 120
117 -
    outfile <- paste0(sample, ".tsv")
121 +
    outfile <- file.path(path, paste0(sample, ".tsv"))
118 122
    link <- sprintf("https://www.encodeproject.org/files/%s/@@download/%s.tsv",
119 123
                    sample, sample)
120 124
    downloadIfNotFound(link, outfile)
@@ -127,6 +131,7 @@
Loading
127 131
#' working directory.
128 132
#'
129 133
#' @param metadata Character: ENCODE metadata
134 +
#' @param path Character: path where to download files
130 135
#'
131 136
#' @importFrom pbapply pblapply
132 137
#'
@@ -144,13 +149,14 @@
Loading
144 149
#'   # Load samples based on filtered ENCODE metadata
145 150
#'   loadENCODEsamples(ENCODEmetadata)
146 151
#' }
147 -
loadENCODEsamples <- function(metadata) {
148 -
    loadENCODEsamplePerGene <- function(metadata) {
152 +
loadENCODEsamples <- function(metadata, path=".") {
153 +
    loadENCODEsamplePerGene <- function(metadata, path) {
149 154
        gene <- list()
150 155
        reps <- as.numeric(metadata$`Biological replicate(s)`)
151 156
        for (rep in reps) {
152 -
            sample  <- loadENCODEsample(metadata, replicate=rep)
153 -
            control <- loadENCODEsample(metadata, replicate=rep, control=TRUE)
157 +
            sample  <- loadENCODEsample(metadata, replicate=rep, path=path)
158 +
            control <- loadENCODEsample(metadata, replicate=rep, path=path,
159 +
                                        control=TRUE)
154 160
            gene <- c(gene, rep=list(sample), control=list(control))
155 161
        }
156 162
        names(gene) <- paste0(names(gene), rep(reps, each=max(reps)))
@@ -161,7 +167,7 @@
Loading
161 167
                                               metadata$`Biosample term name`,
162 168
                                               metadata$`Experiment target`,
163 169
                                               metadata$`Experiment accession`))
164 -
    res <- pblapply(metadataPerGene, loadENCODEsamplePerGene)
170 +
    res <- pblapply(metadataPerGene, loadENCODEsamplePerGene, path=path)
165 171
    return(res)
166 172
}
167 173
@@ -169,7 +175,7 @@
Loading
169 175
#'
170 176
#' @param samples List of loaded ENCODE samples
171 177
#'
172 -
#' @seealso \code{\link{convertENSEMBLtoGeneSymbols}()}
178 +
#' @seealso \code{\link{convertGeneIdentifiers}()}
173 179
#'
174 180
#' @family functions related with using ENCODE expression data
175 181
#' @return Data frame containing gene read counts
@@ -234,7 +240,7 @@
Loading
234 240
#'   counts <- counts[filter, ]
235 241
#'
236 242
#'   # Convert ENSEMBL identifier to gene symbol
237 -
#'   counts$gene_id <- convertENSEMBLtoGeneSymbols(counts$gene_id)
243 +
#'   counts$gene_id <- convertGeneIdentifiers(counts$gene_id)
238 244
#'
239 245
#'   # Perform differential gene expression analysis
240 246
#'   diffExpr <- performDifferentialExpression(counts)

@@ -45,7 +45,8 @@
Loading
45 45
        }
46 46
47 47
        isBinary <- function(file) {
48 -
            formats <- c("gz", "bz2", "xz", "tgz", "zip", "rda", "rds", "RData")
48 +
            formats <- c("gz", "bz2", "xz", "tgz", "zip", "rda", "rds", "RData",
49 +
                         "qs")
49 50
            return(any(file_ext(file) %in% formats))
50 51
        }
51 52
@@ -84,18 +85,15 @@
Loading
84 85
#' @param dataset Character: \code{biomaRt} dataset name
85 86
#' @param mart Character: \code{biomaRt} database name
86 87
#'
87 -
#' @importFrom biomaRt useDataset useMart getBM
88 -
#'
89 88
#' @return Named character vector where names are the input ENSEMBL gene
90 89
#'   identifiers and the values are the matching gene symbols
91 90
#' @export
92 -
#' @examples
93 -
#' convertENSEMBLtoGeneSymbols(c("ENSG00000112742", "ENSG00000130234"))
94 91
convertENSEMBLtoGeneSymbols <- function(genes, dataset="hsapiens_gene_ensembl",
95 92
                                        mart="ensembl") {
96 -
    mart      <- useDataset(dataset, useMart(mart))
93 +
    .Deprecated("convertGeneIdentifiers")
94 +
    mart      <- biomaRt::useDataset(dataset, biomaRt::useMart(mart))
97 95
    processed <- sapply(strsplit(genes, "\\."), `[`, 1)
98 -
    geneConversion <- getBM(
96 +
    geneConversion <- biomaRt::getBM(
99 97
        filters="ensembl_gene_id", values=processed, mart=mart,
100 98
        attributes=c("ensembl_gene_id", "hgnc_symbol"))
101 99
    converted <- geneConversion$hgnc_symbol[
@@ -104,6 +102,99 @@
Loading
104 102
    return(converted)
105 103
}
106 104
105 +
#' Convert gene identifiers
106 +
#'
107 +
#' @param annotation \code{OrgDb} with genome wide annotation for an organism or
108 +
#'   \code{character} with species name to query \code{OrgDb}, e.g.
109 +
#'   \code{"Homo sapiens"}
110 +
#' @param genes Character: genes to be converted
111 +
#' @param key Character: type of identifier used, e.g. \code{ENSEMBL}; read
112 +
#' \code{?AnnotationDbi::columns}
113 +
#' @param target Character: type of identifier to convert to; read
114 +
#' \code{?AnnotationDbi::columns}
115 +
#' @param ignoreDuplicatedTargets Boolean: if \code{TRUE}, identifiers that
116 +
#' share targets with other identifiers will not be converted
117 +
#'
118 +
#' @importFrom AnnotationDbi select
119 +
#' @importFrom data.table data.table
120 +
#' @importFrom AnnotationHub AnnotationHub query
121 +
#'
122 +
#' @family functions for gene expression pre-processing
123 +
#' @return Character vector of the respective targets of gene identifiers. The
124 +
#' previous identifiers remain other identifiers have the same target (in case
125 +
#' \code{ignoreDuplicatedTargets = TRUE}) or if no target was found.
126 +
#' @export
127 +
#'
128 +
#' @examples
129 +
#' genes <- c("ENSG00000012048", "ENSG00000083093", "ENSG00000141510",
130 +
#'            "ENSG00000051180")
131 +
#' convertGeneIdentifiers(genes)
132 +
#' convertGeneIdentifiers(genes, key="ENSEMBL", target="UNIPROT")
133 +
#' 
134 +
#' # Explicit species name to automatically look for its OrgDb database
135 +
#' sp <- "Homo sapiens"
136 +
#' genes <- c("ENSG00000012048", "ENSG00000083093", "ENSG00000141510",
137 +
#'            "ENSG00000051180")
138 +
#' convertGeneIdentifiers(genes, sp)
139 +
#'
140 +
#' # Alternatively, set the annotation database directly
141 +
#' ah <- AnnotationHub::AnnotationHub()
142 +
#' sp <- AnnotationHub::query(ah, c("OrgDb", "Homo sapiens"))[[1]]
143 +
#' columns(sp) # these attributes can be used to change the attributes
144 +
#'
145 +
#' convertGeneIdentifiers(genes, sp)
146 +
convertGeneIdentifiers <- function(genes, annotation="Homo sapiens",
147 +
                                   key="ENSEMBL", target="SYMBOL",
148 +
                                   ignoreDuplicatedTargets=TRUE) {
149 +
    if (is.character(annotation)) {
150 +
        ah <- AnnotationHub()
151 +
        annotation <- query(ah, c("OrgDb", annotation))[[1]]
152 +
        if (length(annotation) == 0) {
153 +
            stop(sprintf("No query found for species '%s'", annotation))
154 +
        }
155 +
    } else if (!is(annotation, "OrgDb")) {
156 +
        stop("Annotation needs to be a 'character' or 'OrgDb' object")
157 +
    }
158 +
159 +
    if (key == "ENSEMBL") {
160 +
        # Remove ENSEMBL identifiers
161 +
        genesClean <- gsub("\\..*", "", genes)
162 +
        # Keep version for gene identifier containing the string "PAR_Y"
163 +
        par_y <- grep("PAR", genes)
164 +
        genesClean[par_y] <- genes[par_y]
165 +
    } else {
166 +
        genesClean <- genes
167 +
    }
168 +
169 +
    match <- tryCatch(
170 +
        suppressMessages(select(annotation, genesClean, target, key)),
171 +
        error=function(e) e)
172 +
173 +
    if (is(match, "error")) return(setNames(genes, genes))
174 +
    match <- data.table(match, key=key)
175 +
176 +
    # Ignore missing values
177 +
    match <- match[!is.na(match[[target]]), ]
178 +
179 +
    # Collapse genes with more than one matching target
180 +
    colnames(match)[2] <- "target"
181 +
    collapsed <- match[
182 +
        , list(target=paste(unique(target), collapse="/")), by=key]
183 +
184 +
    if (ignoreDuplicatedTargets) {
185 +
        # Ignore genes sharing the same target
186 +
        geneTargets <- collapsed[["target"]]
187 +
        collapsed   <- collapsed[
188 +
            !geneTargets %in% unique(geneTargets[duplicated(geneTargets)]), ]
189 +
    }
190 +
191 +
    # Replace identifiers by their matching targets (if possible)
192 +
    converted <- collapsed[["target"]][match(genesClean, collapsed[[key]])]
193 +
    genes[!is.na(converted)] <- converted[!is.na(converted)]
194 +
    names(genes) <- genesClean
195 +
    return(genes)
196 +
}
197 +
107 198
#' Subset rows or columns based on a given index
108 199
#' @return Subset rows/columns
109 200
#' @keywords internal
Files Coverage
R 26.81%
Project Totals (11 files) 26.81%