Commit ⋅ nuno-agostinho/cTRAP

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 @@

#' @importFrom qs qread
loadRemotePreProcessedData <- function(default, file=NULL, path=NULL) {
    link <- file.path("https://compbio.imm.medicina.ulisboa.pt/public/cTRAP",
                      default)
    if (is.null(file)) file <- default
    if (!is.null(path)) file <- file.path(path, file)
    file  <- downloadIfNotFound(link, file)
    table <- qread(file)
    return(table)
}

#' Load table with drug descriptors
#'
#' @param source Character: molecular descriptors for compounds in \code{NCI60}
#'   or \code{CMap}
#' @param source Character: source of compounds used to calculate molecular
#'   descriptors (\code{NCI60} or \code{CMap})
#' @param type Character: load \code{2D} or \code{3D} molecular descriptors
#' @param file Character: filepath to drug descriptors (automatically downloaded
#'   if file does not exist)
#' @inheritParams loadExpressionDrugSensitivityAssociation
#'
#' @family functions for drug set enrichment analysis
#' @return Data table with drug descriptors

@@ -13,27 +25,24 @@

#' @examples
#' loadDrugDescriptors()
loadDrugDescriptors <- function(source=c("NCI60", "CMap"), type=c("2D", "3D"),
                                file=NULL) {
    source <- match.arg(source)
    type   <- match.arg(type)
    if (source == "NCI60" && type == "2D") {
        link <- "599ok2w9ahysdga/compound_descriptors_NCI60_2D.rds"
    } else if (source == "NCI60" && type == "3D") {
        link <- "c2hbmk8qi3tyrh4/compound_descriptors_NCI60_3D.rds"
    } else if (source == "CMap" && type == "2D") {
        link <- "u1ath10e753x6en/compound_descriptors_CMap_2D.rds"
    } else if (source == "CMap" && type == "3D") {
        link <- "tpu3sq53mpy5fvt/compound_descriptors_CMap_3D.rds"
    } else {
        stop("selected 'source' and 'type' are not supported")
    }
                                file=NULL, path=NULL) {
    source  <- match.arg(source)
    type    <- match.arg(type)
    default <- "compound_descriptors_%s_%s.qs"
    default <- sprintf(default, source, type)
    
    loadRemotePreProcessedData(default, file, path)
}

    link  <- sprintf("https://www.dropbox.com/s/%s?raw=1", link)
    if (is.null(file))
        file  <- sprintf("molecular_descriptors_%s_%s.rds", source, type)
    file  <- downloadIfNotFound(link, file)
    table <- readRDS(file)
    return(table)
# Load drug set prepared from compound descriptors
loadDrugSet <- function(source=c("NCI60", "CMap"), type=c("2D", "3D"),
                        file=NULL, path=NULL) {
    source  <- match.arg(source)
    type    <- match.arg(type)
    default <- "drug_set_%s_%s.qs"
    default <- sprintf(default, source, type)
    
    loadRemotePreProcessedData(default, file, path)
}

#' Calculate evenly-distributed bins

@@ -128,6 +137,7 @@

    # Inherit input attributes
    attributes(res) <- c(attributes(res),
                         attributes(table)[c("compoundInfo", "source", "type")])
    class(res) <- c("drugSets", class(res))
    return(res)
}


@@ -207,9 +217,14 @@


    # Return statistical values with corresponding identifier (or original
    # identifier if no match is found)
    df  <- mergeDatasets(setsCompoundInfo, statsInfo, key1=keyColSets,
                         key2=keyColStats, all.y=TRUE, removeKey2ColNAs=TRUE)
    df  <- mergeDatasets(data1=statsInfo, key1=keyColStats,
                         data2=setsCompoundInfo, key2=keyColSets,
                         all.y=TRUE, removeKey2ColNAs=TRUE)

    if (!setsIDcol %in% colnames(df))  setsIDcol <- paste0(setsIDcol, ".1")
    res <- setNames(df[[col]], df[[setsIDcol]])
    
    if (!statsIDcol %in% colnames(df)) statsIDcol <- paste0(statsIDcol, ".2")
    statsIDcol <- checkIfIDwasReplacedAfterMerging(statsIDcol, df)
    names(res)[is.na(names(res))] <- df[[statsIDcol]][is.na(names(res))]
    return(res)

@@ -285,7 +285,7 @@

    colnames(gext2) <- c("cellLine", geneExpr[[1]])

    # Convert from ENSEMBL to gene symbols
    colnames(gext2) <- convertENSEMBLtoGeneSymbols(colnames(gext2))
    colnames(gext2) <- convertGeneIdentifiers(colnames(gext2))
    return(gext2)
}


@@ -445,11 +445,11 @@

#' @examples
#' listExpressionDrugSensitivityAssociation()
listExpressionDrugSensitivityAssociation <- function(url=FALSE) {
    options <- c(
        "GDSC 7"="5q0dazbtnpojw2m/expressionDrugSensitivityCorGDSC7.rds",
        "CTRP 2.1"="zj53pxwiwdwo133/expressionDrugSensitivityCorCTRP2.1.rds",
        "NCI60"="20ko9lyyyoilfz6/expressionDrugSensitivityCorNCI60.h5")
    link <- sprintf("https://www.dropbox.com/s/%s?raw=1", options)
    options <- c("GDSC 7"="expressionDrugSensitivityCorGDSC7.qs",
                 "CTRP 2.1"="expressionDrugSensitivityCorCTRP2.1.qs",
                 "NCI60"="expressionDrugSensitivityCorNCI60.h5")
    link <- file.path("https://compbio.imm.medicina.ulisboa.pt/public/cTRAP",
                      options)
    names(link) <- names(options)

    res <- link

@@ -587,6 +587,8 @@

#'   \code{\link{listExpressionDrugSensitivityAssociation}}
#' @param file Character: filepath to gene expression and drug sensitivity
#'   association dataset (automatically downloaded if file does not exist)
#' @param path Character: folder where to find files (optional; \code{file} may
#'   contain the full filepath if preferred)
#' @param rows Character or integer: rows
#' @param cols Character or integer: columns
#' @param loadValues Boolean: load data values (if available)? If \code{FALSE},

@@ -599,31 +601,38 @@

#' @export
#'
#' @importFrom tools file_ext
#' @importFrom qs qread
#'
#' @examples
#' gdsc <- listExpressionDrugSensitivityAssociation()[[1]]
#' loadExpressionDrugSensitivityAssociation(gdsc)
loadExpressionDrugSensitivityAssociation <- function(source, file=NULL,
                                                     rows=NULL, cols=NULL,
                                                     loadValues=FALSE) {
loadExpressionDrugSensitivityAssociation <- function(
    source, file=NULL, path=NULL, rows=NULL, cols=NULL, loadValues=FALSE) {
    
    available <- listExpressionDrugSensitivityAssociation(url=TRUE)
    source    <- match.arg(source, names(available))
    link      <- available[source]

    if (is.null(file)) file <- gsub("\\?.*", "", basename(link))
    if (!is.null(path)) file <- file.path(path, file)
    downloadIfNotFound(link, file)
    message(sprintf("Loading data from %s...", file))
    if (file_ext(file) == "rds") {
    if (file_ext(file) == "h5") {
        cor <- readExpressionDrugSensitivityCorHDF5(file, rows=rows, cols=cols,
                                                    loadValues=loadValues)
    } else {
        if (is.null(cols)) cols <- TRUE
        if (is.null(rows)) rows <- TRUE
        res <- readRDS(file)
        
        if (file_ext(file) == "rds") {
            res <- readRDS(file)
        } else if (file_ext(file) == "qs") {
            res <- qread(file)
        } 
        cor <- res[rows, cols, drop=FALSE]
        attrs <- attributes(res)
        attrs <- attrs[!names(attrs) %in% names(attributes(cor))]
        attributes(cor) <- c(attributes(cor), attrs)
    } else {
        cor <- readExpressionDrugSensitivityCorHDF5(file, rows=rows, cols=cols,
                                                    loadValues=loadValues)
    }
    attr(cor, "filename") <- normalizePath(file)
    class(cor) <- c("expressionDrugSensitivityAssociation", class(cor))

@@ -303,9 +303,9 @@

#'   expression and drug sensitivity association (see
#'   \code{\link{loadExpressionDrugSensitivityAssociation}()})
#' @param cellLines Integer: number of unique cell lines
#' @param cellLineMean Boolean: add a column with the mean score across cell
#'   lines? If \code{cellLineMean = "auto"} (default), the mean score will be
#'   added when data for more than one cell line is available.
#' @param cellLineMean Boolean: add rows with the mean of \code{method} across
#'   cell lines? If \code{cellLineMean = "auto"} (default), rows will be added
#'   when data for more than one cell line is available.
#' @param rankByAscending Boolean: rank values based on their ascending
#'   (\code{TRUE}) or descending (\code{FALSE}) order?
#' @param rankPerCellLine Boolean: rank results based on both individual cell

@@ -530,9 +530,9 @@

    return(keys)
}

compareDatasetIds <- function(key1, key2, data1, data2) {
    values1 <- stripStr(data1[[key1]])
    values2 <- stripStr(data2[[key2]])
compareDatasetIds <- function(data1, data2, key1, key2) {
    values1 <- stripStr(tolower(data1[[key1]]))
    values2 <- stripStr(tolower(data2[[key2]]))
    matches <- which(values1 %in% na.omit(values2)) # Avoid matching NAs
    return(data1[[key1]][matches])
}

@@ -566,7 +566,7 @@

    res <- list(key1=NULL, key2=NULL, commonCompounds=NULL)
    for (col1 in keys1) {
        for (col2 in keys2) {
            cmp <- compareDatasetIds(col1, col2, data1, data2)
            cmp <- compareDatasetIds(data1, data2, col1, col2)
            if (length(cmp) >= length(res$commonCompounds)) {
                # Save params if number of matching compounds is same or larger
                res$key1 <- col1

@@ -618,7 +618,14 @@

    if (removeKey2ColNAs) data2 <- data2[!is.na(data2[[key2]]), ]

    # Merge data based on intersecting compounds
    df <- merge(data2, data1, by.x=key2, by.y=key1, suffixes=rev(suffixes), ...)
    data1[["matched_terms"]] <- stripStr(tolower(data1[[key1]]))
    data2[["matched_terms"]] <- stripStr(tolower(data2[[key2]]))
    df <- merge(data2, data1, by="matched_terms", suffixes=rev(suffixes), ...)
    
    id <- key1
    if (!key1 %in% colnames(df)) id <- paste0(key1, suffixes[[2]])
    df[["matched_terms"]] <- df[[id]]
    
    attr(df, "keys") <- keys
    return(df)
}

@@ -1,10 +1,45 @@

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 @@

        }
        title <- div(class="panel-heading", h3(class="panel-title", title))
    }

    
    body <- list(...)
    if (length(body) > 0) body <- div(class="panel-body", ...)
    if (collapse) {

@@ -39,10 +74,10 @@

.plotBubbles <- function(data, title, colour="orange") {
    if (!is.table(data)) data <- table(data)
    df <- as.data.frame(data)
    names(df) <- c("data", "Freq")
    if (nrow(df) == 0) {
        hc <- highchart()
    } else {
        names(df) <- c("data", "Freq")
        tooltip <- paste0("function() {",
                          "return '<b>' + this.series.name + '</b><br/>'",
                          "+ this.y + ' perturbations'; }")

@@ -85,7 +120,7 @@

.prepareDT <- function(table, suffixes=NULL, ..., columnDefs=NULL,
                       scrollX=TRUE, pagingType="simple_numbers") {
    if (is.null(table)) return(NULL)

    
    cols <- NULL
    if (nrow(table) > 0) {
        # Prepare columns whose significant digits will be rounded

@@ -95,10 +130,10 @@

        cols <- lapply(cols, function(i) endsWith(colnames(table), i))
        cols <- which(Reduce("|", cols))
        cols <- cols[!sapply(table, class)[cols] %in% c("character", "logical")]

        
        # Convert to factor if there are low number of unique values
        if (!all(c("Key", "Value") %in% colnames(table))) {
            lenUniqValuesPerCol <- sapply(sapply(table, unique), length)
            lenUniqValuesPerCol <- sapply(lapply(table, unique), length)
            for (col in names(lenUniqValuesPerCol[lenUniqValuesPerCol < 50])) {
                if (!col %in% names(table)[cols]) { # Ignore columns to round
                    table[[col]] <- as.factor(table[[col]])

@@ -106,13 +141,13 @@

            }
        }
    }

    
    # # Fix specific bug with targetingDrugs columns when using NCI-60 data
    # if (all(c("PubChem SID", "PubChem CID") %in% colnames(table))) {
    #     table$`PubChem CID` <- as.numeric(table$`PubChem CID`)
    #     table$`PubChem SID` <- as.numeric(table$`PubChem SID`)
    # }

    
    dt <- datatable(
        table, rownames=FALSE, ..., escape=FALSE,
        selection="single", extensions="Buttons", filter="top",

@@ -124,7 +159,38 @@

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 @@

        attr(x, "geneset") <- data.frame("Element"=unname(unlist(geneset)),
                                         "Category"=category)
    }

    
    tables <- sapply(attributes(x), is, "data.frame")
    tables <- attributes(x)[tables]

    
    if (is(x, "perturbationChanges")) {
        data <- rbind(
            cbind("Z-scores filename", prepareWordBreak(x)),

@@ -147,17 +213,35 @@

            cbind("Gene size", length(attr(x, "genes"))),
            cbind("Perturbation number",
                  length(attr(x, "perturbations"))))
        
        filter <- attr(attr(x, "metadata"), "filter")
        if (!is.null(filter)) {
            key <- c("cellLine"="cell line",
                     "timepoint"="time point",
                     "dosage"="dosage",
                     "perturbationType"="perturbation type")
            key <- paste("Filtered by", key[names(filter)])
            filter <- cbind(key, lapply(filter, paste, collapse=", "))
            data <- rbind(data, filter)
        }
        
        colnames(data) <- c("Key", "Value")
        dataName <- "Object summary"
    } else {
        data <- tryCatch(as.table(x, clean=FALSE), error=return)
        if (is(data, "error")) data <- data.frame("Value"=x)
        data <- tryCatch(as.table(x, clean=FALSE), error=function(e) e)
        if (is(data, "error") || !is.data.frame(data)) {
            if (!is.null(names(x))) {
                data <- data.frame("Element"=names(x), "Value"=x)
            } else {
                data <- data.frame("Value"=x)
            }
        }
        dataName <- "Data"
    }

    
    tables <- c(list(data), tables)
    names(tables)[[1]] <- dataName

    
    # Improve names of common tables
    name <- c("metadata"="Metadata",
              "geneInfo"="Gene information",

@@ -174,172 +258,392 @@

.prepareEllipsis <- function(...) {
    elems <- list(...)
    names(elems) <- sapply(substitute(list(...))[-1], deparse)
    if (length(elems) == 0 && length(names(elems)) == 0) elems <- NULL
    return(elems)
}

# Internal interface server and UI ---------------------------------------------
# Add tags to datasets in "display" attribute
.addDatasetTags <- function(elems) {
    # Only edit data with no "display" attribute
    noDisplay <- sapply(lapply(elems, attr, "display"), is.null)
    if (!any(noDisplay)) return(elems)
    
    getDatasetTags <- function(name, data) {
        dataset <- data[[name]]
        if (is.null(dataset)) return(dataset)
        class  <- class(dataset)[[1]]
        source <- attr(dataset, "source")
        tags   <- paste0("#", c(class, source), collapse=" ")
        
        html   <- convertTaskState2HTML(getTaskState(dataset), label=TRUE)
        attr(dataset, "display") <- paste(name, tags, html)
        return(dataset)
    }
    dataset          <- names(elems[noDisplay])
    elems[noDisplay] <- lapply(dataset, getDatasetTags, elems[noDisplay])
    return(elems)
}

# Update dataset choices (optionally, filter datasets by class)
.updateDatasetChoices <- function(session, id, data, class=NULL) {
    if (!is.null(class)) data <- .filterDatasetsByClass(data, class)
    if (is.null(data) || length(data) == 0) {
        choices <- list()
    } else {
        data    <- .addDatasetTags(data)
        choices <- setNames(names(data), sapply(data, attr, "display"))
    }
    render  <- I('{ option: renderSelectizeTags, item: renderSelectizeTags }')
    
    # Keep previous selection if possible
    selected <- isolate(session$input[[id]])
    if (is.null(selected) || !selected %in% choices) selected <- NULL
    
    updateSelectizeInput(session, id, choices=choices, selected=selected,
                         options=list(render=render))
}

# Data input -------------------------------------------------------------------

.getENCODEconditions <- function(metadata) {
    cellLines <- sort(unique(metadata$`Biosample term name`))
    genes     <- sort(unique(metadata$`Experiment target`))
    genes     <- genes[genes != ""]

    
    res <- list(genes=genes, cellLines=cellLines)
    return(res)
}

#' @importFrom shiny NS sidebarPanel selectizeInput mainPanel tabPanel
#' sidebarLayout
#' @importFrom DT DTOutput
.diffExprENCODEloaderUI <- function(id, metadata, cellLine=NULL, gene=NULL,
                                    title="ENCODE Knockdown Data Loader") {
#' @importFrom shiny textAreaInput
.diffExprLoadUI <- function(id, title="User data") {
    ns <- NS(id)

    conditions <- .getENCODEconditions(metadata)
    cellLines  <- conditions$cellLines
    genes      <- conditions$genes

    onInitializeCellLine <- NULL
    if (is.null(cellLine)) {
        onInitializeCellLine <- I('function() { this.setValue(""); }')
    }

    onInitializeGene <- NULL
    if (is.null(gene)) {
        onInitializeGene <- I('function() { this.setValue(""); }')
    }

    
    diffExpr <- tags$span(
        "data-toggle"="tooltip", "data-placement"="right",
        title="Gene symbols and respective differential expression values (e.g. t-statistics)",
        "Differential gene expression", icon("question-circle"))
    
    sidebar <- sidebarPanel(
        selectizeInput(ns("cellLine"), "Cell line", cellLines, cellLine,
                       options=list(placeholder='Please select a cell line',
                                    onInitialize=onInitializeCellLine)),
        selectizeInput(ns("gene"), "Gene", genes, gene,
                       options=list(placeholder='Please select a gene',
                                    onInitialize=onInitializeGene)),
        textAreaInput(ns("diffExpr"), diffExpr, height="300px"),
        selectizeInput(
            ns("sep"), "Separator",
            c("Automatic"="auto", "Tab (\\t)"="\t", "Space"=" ", ",", ";")),
        textInput(ns("name"), "Dataset name", "Differential expression"),
        actionButton(ns("load"), "Load data", class="btn-primary"))

    mainPanel <- mainPanel(DTOutput(ns("table")))
    mainPanel <- mainPanel(
        .alert("No differential gene expression dataset loaded/selected",
               condition="input.dataset == ''", ns=ns),
        selectizeInput(ns("dataset"), "Differential gene expression dataset",
                       choices=NULL, width="100%"),
        DTOutput(ns("table")))
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
    return(ui)
}

#' @importFrom shiny moduleServer stopApp
#' @importFrom data.table fread
#' @importFrom DT renderDT
.diffExprENCODEloaderServer <- function(id, metadata) {
    moduleServer(
        id, function(input, output, session) {
            output$table <- renderDT({
                .prepareDT(downloadENCODEknockdownMetadata())
            })
            proxy <- dataTableProxy("table")
            observe({
                cellLine <- input$cellLine
                if (cellLine == "") cellLine <- NULL

                gene <- input$gene
                if (gene == "") gene <- NULL
                data <- downloadENCODEknockdownMetadata(cellLine, gene)
                observe(replaceData(proxy, data, rownames=FALSE))
.diffExprLoadServer <- function(id, x) {
    x <- .convertToFunction(x)
    server <- function(input, output, session) {
        loadData <- eventReactive(input$load, {
            diffExpr <- input$diffExpr
            req(diffExpr)
            
            # Remove comments
            diffExpr <- gsub("[(^|\n)]{0,1}#.*?\n", "\n", diffExpr)
            diffExpr <- gsub("\n+", "\n", diffExpr)
            
            withProgress(message="Loading differential expression", value=2, {
                data <- fread(text=diffExpr, sep=input$sep, data.table=FALSE,
                              header=FALSE)
                incProgress(1)
                
                if (ncol(data) == 1) {
                    data <- data[[1]]
                } else if (ncol(data) == 2) {
                    data <- setNames(data[[2]], data[[1]])
                } else {
                    showNotification(
                        tagList(tags$b("Input requires 1 or 2 columns."),
                                ncol(data), "columns are not supported."),
                        type="error")
                    return(NULL)
                }
                data <- .prepareDiffExprDataset(data, input$name)
                incProgress(2)
            })
            return(data)
        })
        
        observe(.updateDatasetChoices(session, "dataset", x(), "diffExpr"))
        
        output$table <- renderDT({
            req(input$dataset)
            data <- x()[[input$dataset]]
            if (!is.null(names(data))) {
                df <- data.frame("Genes"=names(data), "Score"=data)
            } else {
                df <- data.frame("Genes"=data)
            }
            return(df)
        }, rownames=FALSE)
        return(loadData)
    }
    moduleServer(id, server)
}

            observeEvent(input$load, {
                message("Filtering data...")
                ENCODEmetadata <- downloadENCODEknockdownMetadata(
                    input$cellLine, input$gene)
#' @importFrom shiny NS sidebarPanel selectizeInput mainPanel tabPanel
#' sidebarLayout
#' @importFrom DT DTOutput
.diffExprENCODEloaderUI <- function(id, title="ENCODE knockdown data") {
    ns <- NS(id)
    
    nullStrJS <- I('function() { this.setValue(""); }')
    sidebar <- sidebarPanel(
        selectizeInput(ns("cellLine"), "Cell line", choices=NULL, width="100%",
                       options=list(placeholder='Select a cell line',
                                    onInitialize=nullStrJS)),
        selectizeInput(ns("gene"), "Gene", choices=NULL, width="100%",
                       options=list(placeholder='Select a gene',
                                    onInitialize=nullStrJS)),
        actionButton(ns("load"), "Load data", class="btn-primary"))
    main <- mainPanel(DTOutput(ns("table")))
    ui <- tabPanel(title, sidebarLayout(sidebar, main))
    return(ui)
}

#' @importFrom shiny moduleServer stopApp withProgress incProgress
#' @importFrom DT renderDT
.diffExprENCODEloaderServer <- function(id, metadata, cellLine=NULL, gene=NULL,
                                        path=".", globalUI=FALSE) {
    server <- function(input, output, session) {
        output$table <- renderDT({
            hiddenCols <- c(
                "File format", "File type", "File format type", "Donors",
                "Biosample treatments", "Biosample treatments amount",
                "Biosample treatments duration",
                "Biosample genetic modifications targets",
                "Biosample genetic modifications gene targets",
                "Biosample genetic modifications site coordinates",
                "Biosample genetic modifications zygosity",
                "Library lysis method", "Library crosslinking method",
                "Project", "RBNS protein concentration",
                "Read length", "Mapped read length", "Run type",
                "Paired end", "Paired with", "Index of", "md5sum", "dbxrefs",
                "File download URL", "File analysis status",
                "Platform", "Controlled by", "s3_uri",
                "Audit ERROR", "Audit WARNING")
            hiddenCols <- match(hiddenCols, colnames(metadata))
            columnDefs <- list(list(visible=FALSE, targets=hiddenCols - 1))
            .prepareDT(metadata, columnDefs=columnDefs)
        })
        proxy <- dataTableProxy("table")
        
        observe({
            conditions <- .getENCODEconditions(metadata)
            updateSelectizeInput(
                session, "gene", choices=conditions$genes, selected=gene)
            updateSelectizeInput(
                session, "cellLine", choices=conditions$cellLines,
                selected=cellLine)
        })
        
        observe({
            cellLine <- input$cellLine
            if (is.null(cellLine) || cellLine == "") cellLine <- NULL
            
            gene <- input$gene
            if (is.null(gene) || gene == "") gene <- NULL
            data <- filterENCONDEmetadata(metadata, cellLine, gene)
            observe(replaceData(proxy, data, rownames=FALSE))
        })
        
        loadData <- eventReactive(input$load, {
            withProgress(message="Preparing differential expression", {
                steps <- 3
                
                incProgress(1/steps, detail="Downloading ENCODE data")
                message("Downloading data...")
                ENCODEmetadata <- filterENCONDEmetadata(
                    metadata, input$cellLine, input$gene)
                
                if (nrow(ENCODEmetadata) == 0) {
                    stopApp()
                    stop("No samples match the selected criteria")
                    showNotification("No samples match the selected criteria",
                                     type="error")
                    return(NULL)
                }
                ENCODEsamples <- loadENCODEsamples(ENCODEmetadata)[[1]]
                if (is.function(path)) path <- path()
                ENCODEsamples <- loadENCODEsamples(ENCODEmetadata, path=path)
                ENCODEsamples <- ENCODEsamples[[1]]
                counts <- prepareENCODEgeneExpression(ENCODEsamples)

                # Remove low coverage (at least 10 counts shared by 2 samples)
                
                # Remove low coverage (>= 10 counts shared by 2 samples)
                minReads   <- 10
                minSamples <- 2
                filter <- rowSums(counts[ , -c(1, 2)] >= minReads) >= minSamples
                filter <- rowSums(
                    counts[ , -c(1:2)] >= minReads) >= minSamples
                counts <- counts[filter, ]

                
                # Convert ENSEMBL identifier to gene symbol
                message("Converting ENSEMBL identifiers to gene symbols...")
                counts$gene_id <- convertENSEMBLtoGeneSymbols(counts$gene_id)

                msg <- "Converting ENSEMBL identifiers to gene symbols"
                incProgress(1/steps, detail=msg)
                message(paste0(msg, "..."))
                counts$gene_id <- convertGeneIdentifiers(counts$gene_id)
                
                # Perform differential gene expression analysis
                message("Performing differential gene expression analysis...")
                msg <- "Performing differential gene expression analysis"
                incProgress(1/steps, detail=msg)
                message(paste0(msg, "..."))
                diffExpr <- performDifferentialExpression(counts)

                
                diffExprStat <- diffExpr$t
                names(diffExprStat) <- diffExpr$Gene_symbol
                stopApp(diffExprStat)
                
                msg <- sprintf("%s vs control DGE in %s (ENCODE)",
                               input$gene, input$cellLine)
                diffExprStat <- .prepareDiffExprDataset(diffExprStat, msg)
                
                message(paste(msg, "data loaded"))
                return(diffExprStat)
            })
        }
    )
        })
        
        if (!globalUI) observeEvent(input$load, stopApp(loadData()))
        return(loadData)
    }
    moduleServer(id, server)
}

.findMatch <- function(what, where, ignore.case=TRUE) {
    if (is.null(what)) return(NULL)
    if (is.list(where)) where <- unlist(where)
    what <- paste0("^", what, "$") # exact match
    unname(sapply(what, grep, where, ignore.case=ignore.case, value=TRUE))
}

#' @importFrom shiny NS selectizeInput checkboxGroupInput sidebarPanel helpText
.cmapDataLoaderUI <- function(id, metadata, zscores, geneInfo, compoundInfo,
                              cellLine, timepoint, dosage, perturbationType,
                              title="CMap Data Loader") {
#' @importFrom shinycssloaders withSpinner
#' @importFrom htmltools tagQuery
.cmapDataLoaderUI <- function(id, cellLine=NULL, timepoint=NULL, dosage=NULL,
                              perturbationType=NULL, title="CMap perturbations",
                              globalUI=FALSE) {
    ns <- NS(id)
    dataTypes <- c("Perturbation metadata"="metadata",
                   "Perturbation z-scores"="zscores",
                   "Gene information"="geneInfo",
                   "Compound information"="compoundInfo")
    selectizeCondition <- function(id, label, choices, selected, ...) {
        selected <- .findMatch(selected, choices)
        plugins  <- list("remove_button")
        selected    <- .findMatch(selected, choices)
        plugins     <- list("remove_button")
        placeholder <- paste("Select one or more", tolower(label))
        return(selectizeInput(id, label, choices, selected, ...,
                              options=list(plugins=plugins)))
                              options=list(plugins=plugins,
                                           placeholder=placeholder)))
    }

    
    colChart <- function(id) column(3, highchartOutput(id, height="200px"))
    plots <- fluidRow(
        column(3, highchartOutput(ns("perturbationPlot"), height="200px")),
        column(3, highchartOutput(ns("cellLinePlot"), height="200px")),
        column(3, highchartOutput(ns("dosagePlot"), height="200px")),
        column(3, highchartOutput(ns("timepointPlot"), height="200px")))
    conditions <- getCMapConditions(metadata, control=TRUE)
        colChart(ns("pertPlot")),
        colChart(ns("cellLinePlot")),
        colChart(ns("dosagePlot")),
        colChart(ns("timepointPlot")))
    
    dataToLoad <- checkboxGroupInput(ns("data"), "Data to load",
                                     dataTypes, dataTypes)
    if (globalUI) {
        # Disable check boxes
        dataToLoad <- tagQuery(dataToLoad)
        dataToLoad <- dataToLoad$find("input")$addAttrs("disabled"=NA)$allTags()
    }
    
    sidebar <- sidebarPanel(
        selectizeCondition(ns("type"), "Perturbation type", multiple=TRUE,
                           conditions$perturbationType, perturbationType),
        selectizeCondition(ns("type"), "Perturbation types", multiple=TRUE,
                           choices=perturbationType, perturbationType),
        selectizeCondition(ns("cellLine"), "Cell lines", multiple=TRUE,
                           conditions$cellLine, cellLine),
                           choices=cellLine, cellLine),
        selectizeCondition(ns("dosage"), "Dosages", multiple=TRUE,
                           conditions$dosage, dosage),
                           choices=dosage, dosage),
        selectizeCondition(ns("timepoint"), "Time points", multiple=TRUE,
                           conditions$timepoint, timepoint),
        checkboxGroupInput(ns("data"), "Data to load", dataTypes, dataTypes),
        helpText("By default, data will be downloaded if not found."),
        actionButton(ns("cancel"), "Cancel"),
        actionButton(ns("load"), "Load data", class="btn-primary"))
    mainPanel <- mainPanel(DTOutput(ns("table")))

    ui <- tabPanel(title, sidebar, mainPanel)
                           choices=timepoint, timepoint),
        dataToLoad,
        if (globalUI) textInput(ns("name"), "Dataset name", value="cmapData"),
        if (!globalUI)
            helpText("By default, data will be downloaded if not found."),
        if (!globalUI) actionButton(ns("cancel"), "Cancel"),
        actionButton(ns("load"), "Load data", class="btn-primary"),
        convertTaskState2HTML("Loaded", toStr=FALSE, id=ns("loaded"),
                              style="margin-left: 10px; opacity: 0;"))
    mainPanel <- mainPanel( withSpinner(DTOutput(ns("table")), type=6) )
    
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
    ui[[3]] <- c(list(plots), ui[[3]])
    return(ui)
}

#' @importFrom shiny isolate updateSelectizeInput moduleServer stopApp
#' observeEvent
#' observeEvent eventReactive updateTextInput reactiveVal
#' @importFrom DT dataTableProxy replaceData
.cmapDataLoaderServer <- function(id, metadata, zscores, geneInfo, compoundInfo,
                                  cellLine, timepoint, dosage) {
    updateSelectizeCondition <- function(session, input, id, choices, ...) {
        selected <- isolate(input[[id]])
        selected <- .findMatch(selected, choices)
        return(updateSelectizeInput(session, id, choices=choices,
                                    selected=selected, ...))
    }

.cmapDataLoaderServer <- function(id, metadata="cmapMetadata.txt",
                                  zscores="cmapZscores.gctx",
                                  geneInfo="cmapGeneInfo.txt",
                                  compoundInfo="cmapCompoundInfo.txt",
                                  cellLine=NULL, timepoint=NULL, dosage=NULL,
                                  globalUI=FALSE, tab=NULL) {
    server <- function(input, output, session) {
        updateSelectizeCondition <- function(session, input, id, choices, ...) {
            selected <- isolate(input[[id]])
            selected <- .findMatch(selected, choices)
            return(updateSelectizeInput(session, id, choices=choices,
                                        selected=selected, ...))
        }
        loadCMapMetadata <- reactive({
            withProgress(message="Loading CMap metadata", {
                metadata <- loadCMapData(metadata, "metadata")
                incProgress(1)
                return(metadata)
            })
        })
        
        happened <- reactiveVal(FALSE)
        checkTab <- reactive({
            load <- TRUE
            if (!isolate(happened())) {
                if (is.null(tab)) {
                    load <- TRUE
                } else {
                    tab  <- tab()
                    load <- !is.null(tab) && tab == "CMap perturbations"
                }
            }
            happened(load)
            if (!load) return(NULL)
            return(load)
        })
        
        getCMapMetadata <- eventReactive(checkTab(), {
            if (!is.data.frame(metadata)) metadata <- loadCMapMetadata()
            return(metadata)
        })
        
        # Update conditions based on selected perturbation type
        observe({
            available <- getCMapConditions(metadata,
                                           perturbationType=input$type)
            isolate({
                pertType  <- input$type
                cellLine  <- input$cellLine
                dosage    <- input$dosage
                timepoint <- input$timepoint
            })
            
            metadata <- getCMapMetadata()
            req(metadata)
            available <- getCMapConditions(metadata, control=TRUE)
            
            # Prepare perturbation types
            perts <- available$perturbationType
            controls <- startsWith(perts, "Controls")
            choices <- list("Perturbations"=perts[!controls],
                            "Controls"=perts[controls])
            updateSelectizeCondition(session, input, "type", choices=choices)
            updateSelectizeCondition(session, input, "cellLine",
                                     choices=available$cellLine)
            updateSelectizeCondition(session, input, "dosage",

@@ -347,29 +651,32 @@

            updateSelectizeCondition(session, input, "timepoint",
                                     choices=available$timepoint)
        })

        
        # Filter metadata based on selected inputs
        getFilteredMetadata <- reactive({
            metadata <- getCMapMetadata()
            req(metadata)
            filterCMapMetadata(
                metadata, perturbationType=input$type,
                cellLine=input$cellLine,
                dosage=input$dosage,
                timepoint=input$timepoint)
                metadata, perturbationType=input$type, cellLine=input$cellLine,
                dosage=input$dosage, timepoint=input$timepoint)
        })

        # Show plots
        output$perturbationPlot <- renderHighchart({
            subset <- getFilteredMetadata()
            labels <- getCMapPerturbationTypes(control=TRUE)
            types  <- table(subset$pert_type)
            names(types) <- names(labels)[match(names(types), labels)]
            .plotBubbles(types, "Perturbations", "red")
        })

        
        renderBubbleChart <- function(subset, title, colour) {
            renderHighchart({
                data <- getFilteredMetadata()[[subset]]
                data[is.na(data)] <- "NA"
                filt <- getFilteredMetadata()
                req(filt)
                if (nrow(filt) != 0) {
                    data <- filt[[subset]]
                    if (subset == "pert_type") {
                        label <- getCMapPerturbationTypes(control=TRUE)
                        data  <- table(data)
                        names(data) <- names(label)[match(names(data), label)]
                    } else {
                        data[is.na(data)] <- "NA"
                    }
                } else {
                    data <- NULL
                }
                .plotBubbles(data, title, colour)
            })
        }

@@ -378,24 +685,26 @@

        output$dosagePlot    <- renderBubbleChart("pert_idose", "Dosages",
                                                  "green")
        output$timepointPlot <- renderBubbleChart("pert_itime", "Time points",
                                                "purple")

                                                  "purple")
        output$pertPlot      <- renderBubbleChart("pert_type", "Perturbations",
                                                  "red")
        
        # Show table
        output$table <- renderDT({
            hiddenCols <- c("pert_dose", "pert_dose_unit", "pert_time",
                            "pert_time_unit")
            hiddenCols <- match(hiddenCols, colnames(metadata))
            hiddenCols <- match(hiddenCols, colnames(getCMapMetadata()))
            columnDefs <- list(list(visible=FALSE, targets=hiddenCols - 1))
            .prepareDT(isolate(getFilteredMetadata()), columnDefs=columnDefs,
                               scrollX=TRUE)
        })
                       scrollX=TRUE)
        }, server=TRUE)
        proxy <- dataTableProxy("table")
        observe(replaceData(proxy, getFilteredMetadata(), rownames=FALSE))

        
        # Load data
        observeEvent(input$load, {
            types <- isolate(input$data)

        loadData <- eventReactive(input$load, {
            types <- input$data
            
            returnIf <- function(bool, val) {
                res <- NULL
                if (bool) res <- val

@@ -406,43 +715,85 @@

            zscores      <- returnIf("zscores" %in% types, zscores)
            geneInfo     <- returnIf("geneInfo" %in% types, geneInfo)
            compoundInfo <- returnIf("compoundInfo" %in% types, compoundInfo)

            perturbations <- prepareCMapPerturbations(
                metadata=metadata, zscores=zscores,
                geneInfo=geneInfo, compoundInfo=compoundInfo)
            stopApp(perturbations)
            
            withProgress(message="Loading CMap perturbations", {
                perturbations <- prepareCMapPerturbations(
                    metadata=metadata, zscores=zscores,
                    geneInfo=geneInfo, compoundInfo=compoundInfo)
                attr(perturbations, "name") <- input$name
                incProgress(1)
            })
            session$sendCustomMessage("brieflyShowElem", session$ns("loaded"))
            return(perturbations)
        })

        # Cancel
        
        observe({
            txt <- "CMap"
            
            type <- input$type
            kd <- "Consensus signature from shRNAs targeting the same gene"
            oe <- "cDNA for overexpression of wild-type gene"
            
            if (length(input$cellLine) == 1) txt <- paste(txt, input$cellLine)
            if (length(type) == 1) {
                txtType <- NULL
                if (type == "Compound") txtType <- "compounds"
                if (type == kd) txtType <- "knockdowns"
                if (type == oe) txtType <- "overexpressions"
                txt <- paste(txt, txtType)
            }
            
            if (txt == "cmap") txt <- "CMap data"
            updateTextInput(session, "name", value=txt)
        })
        
        if (!globalUI) observeEvent(input$load, stopApp(loadData()))
        observeEvent(input$cancel, stopApp(stop("User cancel", call.=FALSE)))
        return(loadData)
    }

    
    moduleServer(id, server)
}

# Result plotting and viewing --------------------------------------------------

#' @importFrom shiny NS sidebarPanel mainPanel tabPanel sidebarLayout
#' selectizeInput
.metadataViewerUI <- function(id, x, title="Metadata Viewer") {
#' selectizeInput fluidRow column
.metadataViewerUI <- function(id, title="Data", icon=NULL) {
    ns <- NS(id)
    sidebar <- sidebarPanel(
        selectizeInput(ns("object"), "Dataset", names(x)),
        selectizeInput(ns("attr"), "Table", choices=NULL))
    main    <- mainPanel(DTOutput(ns("table")))
    ui      <- tabPanel(title, sidebarLayout(sidebar, main))
        selectizeInput(ns("object"), "Dataset", choices=NULL, width="100%"),
        # DTOutput(ns("selection")),
        selectizeInput(ns("attr"), "Table", choices=NULL, width="100%"))
    main <- mainPanel(
        .alert("No dataset loaded/selected",
               condition="input.object == ''", ns=ns),
        DTOutput(ns("table")))
    ui <- tabPanel(title, icon=icon, sidebarLayout(sidebar, main))
    return(ui)
}

#' @importFrom shiny moduleServer observe
#' @importFrom DT renderDT
.metadataViewerServer <- function(id, x) {
    x <- .convertToFunction(x)
    moduleServer(
        id,
        function(input, output, session) {
            getSelectedObject <- reactive(.prepareMetadata(x[[input$object]]))

            observe(updateSelectizeInput(session, "attr",
                                         choices=names(getSelectedObject())))

            getSelectedObject <- reactive(.prepareMetadata(x()[[input$object]]))
            
            observe( .updateDatasetChoices(session, "object", x()) )
            
            observe({
                selected <- isolate(input$attr)
                choices  <- names(getSelectedObject())
                anyChoiceSelected <- !is.null(selected) && !is.null(choices) &&
                    selected %in% choices
                if (!anyChoiceSelected) selected <- NULL
                updateSelectizeInput(session, "attr", selected=selected,
                                     choices=choices)
            })
            
            output$table <- renderDT(
                .prepareDT(getSelectedObject()[[input$attr]]))
        }

@@ -452,63 +803,93 @@

#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
#' tabPanel
#' @importFrom DT DTOutput
.dataPlotterUI <- function(id, x, title="Data Plotter") {
.dataPlotterUI <- function(id, title="Plot Data") {
    ns <- NS(id)
    sidebar <- sidebarPanel(
        selectizeInput(ns("object"), "Dataset", names(x)),
        selectizeInput(ns("object"), "Dataset", choices=NULL),
        selectizeInput(ns("method"), "Method", choices=NULL))
    sidebar[[3]][[2]] <- tagList(
        selectizeInput(ns("element"), "Row ID to plot", choices=NULL,
                       width="100%"),
        plotOutput(ns("plot"), brush=ns("brush")),
        DTOutput(ns("pointTable")))

    
    mainPanel <- mainPanel(DTOutput(ns("table")))
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
    return(ui)
}

.comparisonMethods <- function() {
    c("Spearman's correlation"="spearman",
      "Pearson's correlation"="pearson",
      "GSEA"="gsea")
}

#' @importFrom shiny renderPlot observeEvent observe
#' @importFrom DT renderDT formatSignif dataTableProxy replaceData
.dataPlotterServer <- function(id, x) {
    x <- .convertToFunction(x)
    isValid <- function(e) !is.null(e) && e != ""
    moduleServer(
        id,
        function(input, output, session) {
            getSelectedObject <- reactive(x[[input$object]])

            getSelectedObject <- reactive(x()[[input$object]])
            
            observe({
                .updateDatasetChoices(session, "object", x(),
                                      "referenceComparison")
            })
            
            # Update element and methods choices depending on selected object
            observeEvent(input$object, {
                obj <- getSelectedObject()
                if (is.null(obj)) return(NULL)
                
                updateSelectizeInput(session, "element", choices=obj[[1]],
                                     selected=list(), server=TRUE)
                # Update methods depending on selected object
                methods <- c("Spearman's correlation"="spearman",
                             "Pearson's correlation"="pearson",
                             "GSEA"="gsea")
                methods <- .comparisonMethods()
                isPresent <- sapply(methods, function(i)
                    any(grepl(i, colnames(obj), ignore.case=TRUE)))
                methods <- methods[isPresent]
                updateSelectizeInput(session, "method", choices=methods)
                
                selected <- isolate(input$method)
                if (!selected %in% methods) selected <- NULL
                updateSelectizeInput(session, "method", choices=methods,
                                     selected=selected)
            })

            
            # Update selected element
            observe({
                selected <- getSelectedObject()[[1]][input$table_rows_selected]
                obj <- getSelectedObject()
                if (is.null(obj) || !is(obj, "referenceComparison")) {
                    return(NULL)
                }
                
                selected <- obj[[1]][input$table_rows_selected]
                updateSelectizeInput(session, "element", selected=selected)
            })

            
            output$table <- renderDT({
                data <- as.table(getSelectedObject(), clean=FALSE)
                obj <- getSelectedObject()
                if (is.null(obj) || !is(obj, "referenceComparison")) {
                    return(NULL)
                }
                data <- as.table(obj, clean=FALSE)
                .prepareDT(data)
            })

            
            # Filter table based on overall plot
            proxy <- dataTableProxy("table")
            observe({
                elem <- input$element
                if (is.null(elem) || elem == "") {
                    obj   <- as.table(getSelectedObject(), clean=FALSE)
                    obj <- getSelectedObject()
                    if (is.null(obj) || !is(obj, "referenceComparison")) {
                        return(NULL)
                    }
                    
                    obj   <- as.table(obj, clean=FALSE)
                    brush <- input$brush
                    if (!is.null(brush)) {
                        val  <- obj[[brush$mapping$y]]

@@ -518,9 +899,13 @@

                    replaceData(proxy, obj, rownames=FALSE)
                }
            })

            
            plotData <- reactive({
                obj <- getSelectedObject()
                if (is.null(obj) || !is(obj, "referenceComparison")) {
                    return(NULL)
                }
                
                method <- input$method
                if (!isValid(method)) return(NULL)
                element <- input$element

@@ -528,7 +913,7 @@

                if (!is.null(element) && !element %in% obj[[1]]) return(NULL)
                plot(obj, element, method=method, n=6)
            })

            
            output$plot <- renderPlot(plotData())
            output$pointTable <- renderDT({
                data <- attr(plotData(), "data")

@@ -547,18 +932,18 @@

#' @importFrom shiny NS sidebarPanel plotOutput selectizeInput mainPanel
#' tabPanel hr
#' @importFrom DT DTOutput
.datasetComparisonUI <- function(id, x, title="Dataset Comparison") {
.datasetComparisonUI <- function(id, title="Dataset Comparison") {
    ns <- NS(id)
    sidebar <- sidebarPanel(
        selectizeInput(ns("data1"), "Dataset 1", names(x)),
        selectizeInput(ns("data1"), "Dataset 1", choices=NULL),
        selectizeInput(ns("col1"), "Column to plot in X axis", choices=NULL),
        hr(),
        selectizeInput(ns("data2"), "Dataset 2", names(x), selected=2),
        selectizeInput(ns("data2"), "Dataset 2", choices=NULL),
        selectizeInput(ns("col2"), "Column to plot in Y axis", choices=NULL))
    sidebar[[3]][[2]] <- tagList(
        plotOutput(ns("plot"), brush=ns("brush")),
        helpText("Click-and-drag points in the plot to filter the table."))

    
    mainPanel <- mainPanel(DTOutput(ns("table")))
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
    return(ui)

@@ -568,69 +953,83 @@

#' @importFrom DT renderDT
#' @importFrom ggplot2 theme_bw geom_density_2d geom_rug geom_point
.datasetComparisonServer <- function(id, x) {
    x <- .convertToFunction(x)
    getNumericCols <- function(x) colnames(x)[vapply(x, is.numeric, logical(1))]

    
    moduleServer(
        id,
        function(input, output, session) {
            getSelectedDataset1 <- reactive(x[[input$data1]])
            getSelectedDataset2 <- reactive(x[[input$data2]])

            getSelectedDataset1 <- reactive(x()[[input$data1]])
            getSelectedDataset2 <- reactive(x()[[input$data2]])
            
            observe({
                .updateDatasetChoices(session, "data1", x(),
                                      "referenceComparison")
                .updateDatasetChoices(session, "data2", x(),
                                      "referenceComparison")
            })
            
            observe({
                dataset1 <- getSelectedDataset1()
                numericCols <- getNumericCols(dataset1)
                updateSelectizeInput(session, "col1", choices=numericCols)
            })

            
            observe({
                dataset2 <- getSelectedDataset2()
                numericCols <- getNumericCols(dataset2)
                updateSelectizeInput(session, "col2", choices=numericCols)
            })

            
            output$plot <- renderPlot({
                isColValid <- function(col, dataset) {
                    !is.null(col) && col != "" && col %in% colnames(dataset)
                }

                
                dataset1 <- getSelectedDataset1()
                col1 <- input$col1
                if (!isColValid(col1, dataset1)) return(NULL)

                
                dataset2 <- getSelectedDataset2()
                col2 <- input$col2
                if (!isColValid(col2, dataset2)) return(NULL)

                
                if (any(dataset1[[1]] %in% dataset2[[1]])) {
                    plot <- ggplot(data=NULL, aes(x=dataset1[[col1]],
                                                  y=dataset2[[col2]])) +
                        geom_rug(alpha=0.1) +
                        geom_abline(slope=1, intercept=0, colour="orange") +
                        geom_point(size=0.1, alpha=0.3) +
                        geom_density_2d(alpha=0.3) +
                        xlab(paste(input$data1, input$col1, sep="_")) +
                        ylab(paste(input$data2, input$col2, sep="_")) +
                        theme_bw()
                    
                    # Avoid showing density instead of calculating an error
                    qd1 <- quantile(dataset1[[col1]], c(0.25, 0.75))
                    qd2 <- quantile(dataset2[[col2]], c(0.25, 0.75))
                    if (diff(qd1) != 0 && diff(qd2) != 0) {
                        plot <- plot + geom_density_2d(alpha=0.3)
                    }
                    return(plot)
                } else {
                    stop("no common identifiers between datasets")
                }
            })

            
            output$table <- renderDT({
                isColValid <- function(col, dataset) {
                    !is.null(col) && col != "" && col %in% colnames(dataset)
                }

                
                dataset1 <- getSelectedDataset1()
                col1 <- input$col1
                if (!isColValid(col1, dataset1)) return(NULL)

                
                dataset2 <- getSelectedDataset2()
                col2 <- input$col2
                if (!isColValid(col2, dataset2)) return(NULL)
                common <- dataset1[[1]] %in% dataset2[[1]]

                
                if (any(common)) {
                    df <- data.frame(dataset1[[1]][common],
                                     getSelectedDataset1()[[col1]][common],

@@ -638,14 +1037,14 @@

                    colnames(df) <- c("id",
                                      paste(input$data1, input$col1, sep="_"),
                                      paste(input$data2, input$col2, sep="_"))

                    
                    brush <- input$brush
                    if (!is.null(brush)) {
                        df <- brushedPoints(df, brush,
                                            xvar=names(df)[[2]],
                                            yvar=names(df)[[3]])
                    }

                    
                    return(.prepareDT(df))
                } else {
                    stop("no common identifiers between datasets")

@@ -656,21 +1055,15 @@

}

.targetingDrugsVSsimilarPerturbationsPlotterUI <- function(
    id, x, elemClasses, title="Dataset Comparison") {
    if (!all(c("targetingDrugs", "similarPerturbations") %in% elemClasses)) {
        return(NULL)
    }
    id, title="Targeting Drugs vs Similar Perturbations") {
    
    ns <- NS(id)
    sidebar <- sidebarPanel(
        selectizeInput(
            ns("data1"), "Dataset with predicted targeting drugs",
            names(x)[elemClasses == "targetingDrugs"]),
        selectizeInput(
            ns("data2"), "Dataset with similar CMap perturbations",
            names(x)[elemClasses == "similarPerturbations"]),
        selectizeInput(ns("data1"), "Predicted targeting drugs", NULL),
        selectizeInput(ns("data2"), "Similar CMap perturbations", NULL),
        selectizeInput(ns("col"), "Column to plot in both axes", choices=NULL))
    sidebar[[3]][[2]] <- plotOutput(ns("plot"), brush=ns("brush"))

    
    mainPanel <- mainPanel(DTOutput(ns("table")))
    ui <- tabPanel(title, sidebarLayout(sidebar, mainPanel))
    return(ui)

@@ -679,12 +1072,22 @@

#' @importFrom shiny moduleServer reactive observe renderPlot brushedPoints
#' @importFrom DT renderDT
.targetingDrugsVSsimilarPerturbationsPlotterServer <- function(id, x) {
    x <- .convertToFunction(x)
    moduleServer(
        id,
        function(input, output, session) {
            getSelectedDataset1 <- reactive(x[[input$data1]])
            getSelectedDataset2 <- reactive(x[[input$data2]])

            getDataset <- function(obj, item) {
                if (length(obj) > 0 && !is.null(item)) obj[[item]]
            }
            getSelectedDataset1 <- reactive(getDataset(x(), input$data1))
            getSelectedDataset2 <- reactive(getDataset(x(), input$data2))
            
            observe({
                .updateDatasetChoices(session, "data1", x(), "targetingDrugs")
                .updateDatasetChoices(session, "data2", x(),
                                      "similarPerturbations")
            })
            
            observe({
                data1 <- getSelectedDataset1()
                data2 <- getSelectedDataset2()

@@ -693,30 +1096,32 @@

                # Select first ranked column
                rankCol <- grep("rank$", cols, value=TRUE)[1]
                if (is.na(rankCol)) rankCol <- NULL

                
                updateSelectizeInput(session, "col", choices=cols,
                                     selected=rankCol)
            })

            
            observe({
                data1 <- getSelectedDataset1()
                data2 <- getSelectedDataset2()
                if (is.null(data1) || is.null(data2)) return(NULL)
                
                col <- input$col
                isColValid <- !is.null(col) && col != ""
                if (is.null(data1) || is.null(data2) || !isColValid) {
                    return(NULL)
                }

                
                plot <- suppressMessages(
                    plotTargetingDrugsVSsimilarPerturbations(
                        data1, data2, column=col, labelBy=NULL) + theme_bw(16))

                
                output$plot  <- renderPlot(plot)
                output$table <- renderDT({
                    data  <- attr(plot, "data")
                    brush <- input$brush
                    if (!is.null(brush)) data <- brushedPoints(data, brush)

                    
                    hiddenCols <- grep("^pearson|GSEA|spearman", colnames(data))
                    columnDefs <- list(list(visible=FALSE,
                                            targets=hiddenCols - 1))

@@ -728,116 +1133,498 @@

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 @@

                    })
                    isValid <- function(e) !is.null(e) && e != ""
                    if (!isValid(statsKey) || !isValid(setsKey)) return(NULL)
                    plotDrugSetEnrichment(sets, obj, col=sort,
                                          selectedSets=element,
                                          keyColStats=statsKey,
                                          keyColSets=setsKey)[[1]]
                    suppressMessages(
                        plotDrugSetEnrichment(sets, obj, col=sort,
                                              selectedSets=element,
                                              keyColStats=statsKey,
                                              keyColSets=setsKey)[[1]])
                })
            })

            
            # Update selected element
            observeEvent(input$table_rows_selected, {
                selected <- getDSEAresult()[[1]][input$table_rows_selected]

@@ -868,17 +1656,18 @@

#' Currently only supports loading data from ENCODE knockdown experiments
#'
#' @inheritParams downloadENCODEknockdownMetadata
#' @inheritParams loadENCODEsamples
#'
#' @return Differential expression data
#' @family visual interface functions
#' @export
launchDiffExprLoader <- function(cellLine=NULL, gene=NULL) {
    metadata <- downloadENCODEknockdownMetadata()
launchDiffExprLoader <- function(cellLine=NULL, gene=NULL,
                                 file="ENCODEmetadata.rds", path=".") {
    metadata <- downloadENCODEknockdownMetadata(file=file)
    id       <- "diffExpr"
    ui       <- .prepareNavPage(
        .diffExprENCODEloaderUI(id, metadata, cellLine, gene))
    ui       <- .prepareNavPage(.diffExprENCODEloaderUI(id))
    server   <- function(input, output, session) {
        .diffExprENCODEloaderServer(id, metadata)
        .diffExprENCODEloaderServer(id, metadata, cellLine, gene, path=path)
    }
    app    <- runApp(shinyApp(ui, server))
    return(app)

@@ -907,8 +1696,7 @@

    metadata <- loadCMapData(metadata, type="metadata")
    id <- "cmapDataLoader"
    ui <- .prepareNavPage(
        .cmapDataLoaderUI(id, metadata, zscores, geneInfo, compoundInfo,
                          cellLine, timepoint, dosage, perturbationType))
        .cmapDataLoaderUI(id, cellLine, timepoint, dosage, perturbationType))
    server <- function(input, output, session) {
        .cmapDataLoaderServer(id, metadata, zscores, geneInfo, compoundInfo,
                              cellLine, timepoint, dosage)

@@ -929,7 +1717,7 @@

launchMetadataViewer <- function(...) {
    elems  <- .prepareEllipsis(...)
    id     <- "metadataViewer"
    ui     <- .prepareNavPage(.metadataViewerUI(id, elems))
    ui     <- .prepareNavPage(.metadataViewerUI(id))
    server <- function(input, output, session) .metadataViewerServer(id, elems)
    app    <- runApp(shinyApp(ui, server))
    return(app)

@@ -950,21 +1738,20 @@

    comparePlotId <- "comparePlotter"
    dataId        <- "dataPlotter"
    metadataId    <- "metadataViewer"

    
    elemClasses       <- sapply(lapply(list(...), class), "[[", 1)
    hasSimilarPerts   <- "similarPerturbations" %in% elemClasses
    hasTargetingDrugs <- "targetingDrugs" %in% elemClasses
    showTwoKindPlot   <- hasSimilarPerts && hasTargetingDrugs

    
    uiList <- tagList(
        .dataPlotterUI(dataId, elems),
        .targetingDrugsVSsimilarPerturbationsPlotterUI(
            comparePlotId, elems, elemClasses),
        .datasetComparisonUI(compareId, elems),
        .metadataViewerUI(metadataId, elems))
        .dataPlotterUI(dataId),
        .targetingDrugsVSsimilarPerturbationsPlotterUI(comparePlotId),
        .datasetComparisonUI(compareId),
        .metadataViewerUI(metadataId))
    uiList <- Filter(length, uiList)
    ui     <- do.call(.prepareNavPage, uiList)

    
    server <- function(input, output, session) {
        .dataPlotterServer(dataId, elems)
        if (showTwoKindPlot) {

@@ -992,18 +1779,19 @@

    dataId     <- "dataPlotter"
    metadataId <- "metadataViewer"
    dseaId     <- "drugSetAnalyser"

    
    elems <- .prepareEllipsis(...)

    
    uiList <- tagList(
        .drugSetEnrichmentAnalyserUI(dseaId, sets, elems),
        .dataPlotterUI(dataId, elems),
        .metadataViewerUI(metadataId, elems))
        .drugSetEnrichmentAnalyserUI(dseaId),
        .dataPlotterUI(dataId),
        .metadataViewerUI(metadataId))
    uiList <- Filter(length, uiList)
    ui     <- do.call(.prepareNavPage, uiList)

    
    server <- function(input, output, session) {
        .drugSetEnrichmentAnalyserServer(dseaId, sets, elems)
        .drugSetEnrichmentAnalyserServer(dseaId,
                                         c(elems, list("Custom drug set"=sets)))
        .dataPlotterServer(dataId, elems)
        .metadataViewerServer(metadataId, elems)
    }

@@ -0,0 +1,86 @@

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 @@

    return(exp)
}

filterENCONDEmetadata <- function(table, cellLine=NULL, gene=NULL) {
    if (!is.null(gene)) table <- table[table$`Experiment target` == gene, ]
    if (!is.null(cellLine)) table <- table[
        tolower(table$`Biosample term name`) == tolower(cellLine), ]
    return(table)
}

#' Download metadata for ENCODE knockdown experiments
#'
#' @param cellLine Character: cell line
#' @param gene Character: target gene
#' @param file Character: RDS file with metadata (if file doesn't exist, it will
#' be created)
#' @param file Character: RDS filepath with metadata (if file doesn't exist, it
#' will be created)
#'
#' @importFrom httr content GET
#' @importFrom data.table fread

@@ -86,11 +93,7 @@

    } else {
        table <- readRDS(file)
    }

    if (!is.null(gene)) table <- table[table$`Experiment target` == gene, ]
    if (!is.null(cellLine)) table <- table[
        tolower(table$`Biosample term name`) == tolower(cellLine), ]

    table <- filterENCONDEmetadata(table, cellLine, gene)
    return(table)
}


@@ -99,11 +102,12 @@

#' @param metadata Data frame: ENCODE metadata
#' @param replicate Number: replicate
#' @param control Boolean: load control experiment?
#' @inheritParams loadENCODEsamples
#'
#' @importFrom data.table fread
#' @return Data table with ENCODE sample data
#' @keywords internal
loadENCODEsample <- function (metadata, replicate, control=FALSE) {
loadENCODEsample <- function (metadata, replicate, control=FALSE, path=".") {
    metadata <- metadata[metadata$`Biological replicate(s)` == replicate, ]

    if (control) {

@@ -114,7 +118,7 @@

    }
    sample <- paste0(sample)

    outfile <- paste0(sample, ".tsv")
    outfile <- file.path(path, paste0(sample, ".tsv"))
    link <- sprintf("https://www.encodeproject.org/files/%s/@@download/%s.tsv",
                    sample, sample)
    downloadIfNotFound(link, outfile)

@@ -127,6 +131,7 @@

#' working directory.
#'
#' @param metadata Character: ENCODE metadata
#' @param path Character: path where to download files
#'
#' @importFrom pbapply pblapply
#'

@@ -144,13 +149,14 @@

#'   # Load samples based on filtered ENCODE metadata
#'   loadENCODEsamples(ENCODEmetadata)
#' }
loadENCODEsamples <- function(metadata) {
    loadENCODEsamplePerGene <- function(metadata) {
loadENCODEsamples <- function(metadata, path=".") {
    loadENCODEsamplePerGene <- function(metadata, path) {
        gene <- list()
        reps <- as.numeric(metadata$`Biological replicate(s)`)
        for (rep in reps) {
            sample  <- loadENCODEsample(metadata, replicate=rep)
            control <- loadENCODEsample(metadata, replicate=rep, control=TRUE)
            sample  <- loadENCODEsample(metadata, replicate=rep, path=path)
            control <- loadENCODEsample(metadata, replicate=rep, path=path,
                                        control=TRUE)
            gene <- c(gene, rep=list(sample), control=list(control))
        }
        names(gene) <- paste0(names(gene), rep(reps, each=max(reps)))

@@ -161,7 +167,7 @@

                                               metadata$`Biosample term name`,
                                               metadata$`Experiment target`,
                                               metadata$`Experiment accession`))
    res <- pblapply(metadataPerGene, loadENCODEsamplePerGene)
    res <- pblapply(metadataPerGene, loadENCODEsamplePerGene, path=path)
    return(res)
}


@@ -169,7 +175,7 @@

#'
#' @param samples List of loaded ENCODE samples
#'
#' @seealso \code{\link{convertENSEMBLtoGeneSymbols}()}
#' @seealso \code{\link{convertGeneIdentifiers}()}
#'
#' @family functions related with using ENCODE expression data
#' @return Data frame containing gene read counts

@@ -234,7 +240,7 @@

#'   counts <- counts[filter, ]
#'
#'   # Convert ENSEMBL identifier to gene symbol
#'   counts$gene_id <- convertENSEMBLtoGeneSymbols(counts$gene_id)
#'   counts$gene_id <- convertGeneIdentifiers(counts$gene_id)
#'
#'   # Perform differential gene expression analysis
#'   diffExpr <- performDifferentialExpression(counts)

@@ -45,7 +45,8 @@

        }

        isBinary <- function(file) {
            formats <- c("gz", "bz2", "xz", "tgz", "zip", "rda", "rds", "RData")
            formats <- c("gz", "bz2", "xz", "tgz", "zip", "rda", "rds", "RData",
                         "qs")
            return(any(file_ext(file) %in% formats))
        }


@@ -84,18 +85,15 @@

#' @param dataset Character: \code{biomaRt} dataset name
#' @param mart Character: \code{biomaRt} database name
#'
#' @importFrom biomaRt useDataset useMart getBM
#'
#' @return Named character vector where names are the input ENSEMBL gene
#'   identifiers and the values are the matching gene symbols
#' @export
#' @examples
#' convertENSEMBLtoGeneSymbols(c("ENSG00000112742", "ENSG00000130234"))
convertENSEMBLtoGeneSymbols <- function(genes, dataset="hsapiens_gene_ensembl",
                                        mart="ensembl") {
    mart      <- useDataset(dataset, useMart(mart))
    .Deprecated("convertGeneIdentifiers")
    mart      <- biomaRt::useDataset(dataset, biomaRt::useMart(mart))
    processed <- sapply(strsplit(genes, "\\."), `[`, 1)
    geneConversion <- getBM(
    geneConversion <- biomaRt::getBM(
        filters="ensembl_gene_id", values=processed, mart=mart,
        attributes=c("ensembl_gene_id", "hgnc_symbol"))
    converted <- geneConversion$hgnc_symbol[

@@ -104,6 +102,99 @@

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	3,510	941	0	2,569	26.81%
Project Totals (11 files)	3,510	941	0	2,569	26.81%

View CI Build Download

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	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	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	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))

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]

	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	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	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	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	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	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	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	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	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	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		}

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

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	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		}

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	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	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	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	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",

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	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	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",

Updating our web app

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	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	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	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]]

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	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	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],

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	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	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)