-
Notifications
You must be signed in to change notification settings - Fork 2
/
oncoprint_module.R
366 lines (305 loc) · 20.4 KB
/
oncoprint_module.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
# UI function for the waterfall plot module, the id is a unique identifier for this module
oncoprintUI <- function(id, label = "oncoprint") {
# Setting a unique namespace for this module
ns <- NS(id)
# Creating a fluid page that will move with window adjustments
fluidPage(
# Having a sidebar positioned on the left
sidebarLayout(
position = "left",
# Adjusting the panel
sidebarPanel(
# Instructions for uploading a CSV file
helpText("Upload a CSV file with a single column of gene symbols. Do not include a column title or header.
Do not include any rows/columns other than 1 single column of gene symbols.
If the gene list is > 30, only the first 30 will be taken."),
# Line breaks for readability
br(),
# File input for uploading gene list in CSV format
fileInput(ns("gene_list"),
label = "Upload gene list here (.csv only)",
multiple = FALSE,
accept = c(".csv"),
placeholder = " No file selected",
buttonLabel = "Upload"),
# Slider input for setting the minimum TPMs, this starts at 2 by default
sliderInput(ns("tpms"), "Minimum TPMs", min = 0, max = 50, value = 2),
# Checkbox group input for selecting fusions
checkboxGroupInput(ns("fusions"),
label = "Fusions:",
choices = c("CBFA2T3-GLIS2",
"CBFB-MYH11",
"DEK-NUP214",
"ETV6-MNX1",
"FUS-ERG",
"KAT6A-CREBBP",
"KMT2A-X",
"NUP98-KDM5A",
"NUP98-NSD1",
"RBM15-MKL1",
"RUNX1-CBFA2T3",
"RUNX1-RUNX1T1",
"None",
"Other AML")),
# Action button for (de)selecting all fusions
actionButton(ns("selectall"), "(De)Select All", class = "btn-primary btn-sm"),
br(),
br(),
# Additional annotation options
helpText("Additional Annotation Options:"),
# Checkbox inputs for various annotation options
checkboxInput(ns("cnv"), "Primary CNV"),
checkboxInput(ns("age"), "Age Category"),
checkboxInput(ns("efs"), "Event Type ID"),
checkboxInput(ns("flt3"), "FLT3-ITD"),
checkboxInput(ns("wt1"), "WT1 Mutation"),
# Select input for splitting heatmap by different options (dropdown menu)
selectInput(ns("split"), label = "Split Heatmap By:", choices = c("No Split", "Fusion", "CNV", "Age", "EFS", "FLT3-ITD", "WT1")),
br(),
br(),
# Download button for downloading the plot
downloadButton(ns("plot_download"),
label = "plot",
class = "plotdwnld"),
# Tooltip for download button
shinyBS::bsTooltip(ns("plot_download"),
title = "Click here to download a copy of the plot",
placement = "right",
trigger = "hover"),
width = 3, height = 800),
#|---------------------------------------------------------------------------------------------------------------------------|#
# Main panel for displaying the oncoprint plot
mainPanel(width = 9, height = 900, position = "right",
tabsetPanel(
tabPanel("Figures",
br(),
fluidRow(
column(10, offset = 0, align = "left",
plotOutput(ns("plot"), height = 600)
)
)
)
)
)
)
)
}
#|---------------------------------------------------------------------------------------------------------------------------|#
# server function for the oncoprint module
oncoprint <- function(input, output, session, clinData, expData, gene, dataset) {
# This is a handy function that will add a select all or deselect all button
observe({
if(is.null(input$selectall)) return(NULL)
else if (input$selectall%%2 == 0){
updateCheckboxGroupInput(session, "fusions", "Fusions:", choices = c("CBFA2T3-GLIS2",
"CBFB-MYH11",
"DEK-NUP214",
"ETV6-MNX1",
"FUS-ERG",
"KAT6A-CREBBP",
"KMT2A-X",
"NUP98-KDM5A",
"NUP98-NSD1",
"RBM15-MKL1",
"RUNX1-CBFA2T3",
"RUNX1-RUNX1T1",
"None",
"Other AML"))
}
else {
updateCheckboxGroupInput(session, "fusions", "Fusions:", choices = c("CBFA2T3-GLIS2",
"CBFB-MYH11",
"DEK-NUP214",
"ETV6-MNX1",
"FUS-ERG",
"KAT6A-CREBBP",
"KMT2A-X",
"NUP98-KDM5A",
"NUP98-NSD1",
"RBM15-MKL1",
"RUNX1-CBFA2T3",
"RUNX1-RUNX1T1",
"None",
"Other AML"),
selected = c("CBFA2T3-GLIS2",
"CBFB-MYH11",
"DEK-NUP214",
"ETV6-MNX1",
"FUS-ERG",
"KAT6A-CREBBP",
"KMT2A-X",
"NUP98-KDM5A",
"NUP98-NSD1",
"RBM15-MKL1",
"RUNX1-CBFA2T3",
"RUNX1-RUNX1T1",
"None",
"Other AML"))
}
})
# Reading in the gene list from the csv input file
readGeneList <- reactive({
validate(need(input$gene_list, "Please upload a list of genes to get started.")) # Checking to make sure the gene list is there
file <- input$gene_list
ext <- tools::file_ext(file$datapath)
req(file)
validate(need(ext == "csv", "Please upload a .csv file.")) # Checking to make sure the extension is correct
read.csv(file$datapath, header = F, blank.lines.skip = T, strip.white = T)[,1]
})
# Creating a dataframe that is subsetted by the input file genelist
oncoMatrix <- reactive({
gene_list <- readGeneList() # reads the gene list in
gene_list <- unique(gene_list) # makes sure they're unique
mat <- filter(expData(), rownames(expData()) %in% gene_list) # filtering the counts file for the gene list
return(mat)
})
# filtering the matrix by fusion group (samples)
fusionSubset <- reactive({
mat <- oncoMatrix() # the last function returns the dataframe so this reads it in again
updatedclinical <- filter(clinData(), clinData()$Primary.Fusion %in% input$fusions) # filters the cde by the checked fusions
mat <- mat[,which(colnames(mat) %in% updatedclinical$PatientID)] # filtering the dataframe for only the patients we have CDE for
mat <- mat[,colSums(is.na(mat)) == 0] # removing NAs
# this is a function for counting which patients have greater or equal to the chosen tpm cutoff for each gene (in %)
percentage_expressed <- function(x) {
return(sum(x >= input$tpms) / length(x) * 100)
}
# Applying the function to the dataframe
mat$percentage <- apply(mat, 1, percentage_expressed)
mat <- mat[order(-mat$percentage),] # ordering the matrix by highest percent expression
mat <- mat[1:(length(mat)-1)] # removing the percent expressed column
# ifelse conditionals for limiting the input gene list to 30 genes max, otherwise it would not be readable
if (length(rownames(mat)) > 30) {
mat <- mat[c(1:30),]
}
else {
mat <- mat
}
# the actual function for determining whether a patient "expresses" the gene at the TPM cutoff and
# will also label the gene intracellular or transmembrane based on Ensembl data (may need updating)
mat <- apply(mat, c(1,2), function(x) ifelse(x >= input$tpms, "yes", ""))
mat <- mat[, order(colnames(mat))] # making sure the colnames are ordered correctly
common_rows <- intersect(rownames(mat), transmembrane_genelist$Gene.name)
mat[common_rows, ] <- ifelse(mat[common_rows, ] == "yes", "Transmembrane", "")
mat[setdiff(rownames(mat), common_rows), ] <- ifelse(mat[setdiff(rownames(mat), common_rows), ] == "yes", "Intracellular", "")
mat <- as.matrix(mat)
return(mat)
})
# this function is for the heatmap annotation which will react to the checked input boxes
oncoAnnotation <- reactive({
mat <- fusionSubset() # once again rereading the matrix
updatedclinical <- clinData()[which(clinData()$PatientID %in% colnames(mat)),] # which patients in the CDE are in the matrix
updatedclinical <- filter(updatedclinical, updatedclinical$Primary.Fusion %in% input$fusions) # this is the reactionary code which will subset the cde for the checked fusions
updatedclinical <- updatedclinical[order(updatedclinical$PatientID),] # ordering the patients alphabetically to match the matrix
# custom color palettes based on colorbrewer that make the oncoprint look cleaner and also make sense with the displayed annotations:
colorlist <- c("#4E79A7", "#E15759", "#EDc948", "#B07AA1", "#F28E2B", "#59A14F", "#9C755F",
"#a5bcd5", "#f0abac", '#f6e4a3', "#d7bcd0", "#f8c695", "#aad3a4", "#cebaae")
cnvcolorlist <- c("#4E79A7", "#E15759", "#EDc948", "#B07AA1", "#F28E2B", "#59A14F", "#9C755F", "#a5bcd5", "#f2f2f2")
efscolorlist <- c("#4E79A7", "#E15759", "#EDc948", "#B07AA1", "#F28E2B", "#f2f2f2")
gradcolorlist <- c("#c4d0e1", "#89a1c4", "#4E79A7", "#344967", "#161f2c", "#f2f2f2")
yesnocolorlist <- c("#4E79A7", "#f0abac", "#f2f2f2")
# creating levels in each of the clinical data elements columns so that the information is ordered nicely
updatedclinical$Primary.Fusion <- factor(updatedclinical$Primary.Fusion, levels = c("CBFA2T3-GLIS2", "CBFB-MYH11", "DEK-NUP214", "ETV6-MNX1", "FUS-ERG",
"KAT6A-CREBBP", "KMT2A-X", "NUP98-KDM5A", "NUP98-NSD1", "RBM15-MKL1",
"RUNX1-CBFA2T3", "RUNX1-RUNX1T1", "None", "Other AML"))
updatedclinical$Primary.CNV <- factor(updatedclinical$Primary.CNV, levels = c("CBL deletion", "del5q", "monosomy7", "trisomy8", "trisomy21", "trisomy8/trisomy21", "-Y", "No Relevant CNV", "Unknown"))
updatedclinical$Age.Category <- factor(updatedclinical$Age.Category, levels = c("Less than 3 years", "Between 3 and 5 years", "Between 5 and 10 years", "Between 10 and 18 years", "Greater than 18 years", "Unknown"))
updatedclinical$`EFS event type ID` <- factor(updatedclinical$`EFS event type ID`, levels = c("Censored", "Relapse", "Death", "Death without remission", "Induction failure", "Unknown"))
updatedclinical$FLT3.ITD <- factor(updatedclinical$FLT3.ITD, levels = c("Yes", "No", "Unknown"))
updatedclinical$WT1.Mutation <- factor(updatedclinical$WT1.Mutation, levels = c("Yes", "No", "Unknown"))
# create a color palette for each annotation, ensuring all levels are covered, flexible based on the number of levels included
color_palette1 <- setNames(colorlist[1:length(levels(updatedclinical$Primary.Fusion))], levels(updatedclinical$Primary.Fusion))
color_palette2 <- setNames(cnvcolorlist[1:length(levels(updatedclinical$Primary.CNV))], levels(updatedclinical$Primary.CNV))
color_palette3 <- setNames(gradcolorlist[1:length(levels(updatedclinical$Age.Category))], levels(updatedclinical$Age.Category))
color_palette4 <- setNames(efscolorlist[1:length(levels(updatedclinical$`EFS event type ID`))], levels(updatedclinical$`EFS event type ID`))
color_palette5 <- setNames(yesnocolorlist[1:length(levels(updatedclinical$FLT3.ITD))], levels(updatedclinical$FLT3.ITD))
color_palette6 <- setNames(yesnocolorlist[1:length(levels(updatedclinical$WT1.Mutation))], levels(updatedclinical$WT1.Mutation))
# count the number of annotations based on user input
num_annotations <- sum(c(input$cnv, input$age, input$efs, input$flt3, input$wt1))
# set up a vector of annotation heights with a default height
annotation_heights <- c(unit(1.5, "cm"), rep(unit(0.8, "cm"), num_annotations+1))
# create annotations based on user input that is flexible with the annotations added
ha <- HeatmapAnnotation(
column_bar = anno_oncoprint_barplot(),
Fusion = updatedclinical$Primary.Fusion,
CNV = if (input$cnv) updatedclinical$Primary.CNV else NULL,
Age = if (input$age) updatedclinical$Age.Category else NULL,
EFS = if (input$efs) updatedclinical$`EFS event type ID` else NULL,
FLT3_ITD = if (input$flt3) updatedclinical$FLT3.ITD else NULL,
WT1 = if (input$wt1) updatedclinical$WT1.Mutation else NULL,
col = list(
Fusion = color_palette1,
CNV = if (input$cnv) color_palette2 else NULL,
Age = if (input$age) color_palette3 else NULL,
EFS = if (input$efs) color_palette4 else NULL,
FLT3_ITD = if (input$flt3) color_palette5 else NULL,
WT1 = if (input$wt1) color_palette6 else NULL
),
annotation_height = annotation_heights,
annotation_name_gp = gpar(fontsize = 10),
gp = gpar(fontsize = 8)
)
return(ha)
})
# this provides the choices in the drop down menu and maps them to the clinical data elements column names
radio_choices <- c("No Split", "Fusion", "CNV", "Age", "EFS", "FLT3-ITD", "WT1")
column_names <- c("", "Primary.Fusion", "Primary.CNV", "Age.Category", "EFS event type ID", "FLT3.ITD", "WT1.Mutation")
column_mapping <- setNames(column_names, radio_choices)
# plotting the oncoprint (finally!)
plotOncoprint <- reactive({
mat <- fusionSubset() # reading in the matrix
ha <- oncoAnnotation() # reading in the heatmap annotation
updatedclinical <- clinData()[which(clinData()$PatientID %in% colnames(mat)),] # which patients in the CDE are in the matrix
updatedclinical <- filter(updatedclinical, updatedclinical$Primary.Fusion %in% input$fusions) # this is the reactionary code which will subset the cde for the checked fusions
updatedclinical <- updatedclinical[order(updatedclinical$PatientID),]
# doing the levelling again so that on the actual oncoprint they get ordered correctly (from left to right) when split
updatedclinical$Primary.Fusion <- factor(updatedclinical$Primary.Fusion, levels = c("CBFA2T3-GLIS2", "CBFB-MYH11", "DEK-NUP214", "ETV6-MNX1", "FUS-ERG",
"KAT6A-CREBBP", "KMT2A-X", "NUP98-KDM5A", "NUP98-NSD1", "RBM15-MKL1",
"RUNX1-CBFA2T3", "RUNX1-RUNX1T1", "None", "Other AML"))
updatedclinical$Primary.CNV <- factor(updatedclinical$Primary.CNV, levels = c("CBL deletion", "del5q", "monosomy7", "trisomy8", "trisomy21", "trisomy8/trisomy21", "-Y", "No Relevant CNV", "Unknown"))
updatedclinical$Age.Category <- factor(updatedclinical$Age.Category, levels = c("Less than 3 years", "Between 3 and 5 years", "Between 5 and 10 years", "Between 10 and 18 years", "Greater than 18 years", "Unknown"))
updatedclinical$`EFS event type ID` <- factor(updatedclinical$`EFS event type ID`, levels = c("Censored", "Relapse", "Death", "Death without remission", "Induction failure", "Unknown"))
updatedclinical$FLT3.ITD <- factor(updatedclinical$FLT3.ITD, levels = c("Yes", "No", "Unknown"))
updatedclinical$WT1.Mutation <- factor(updatedclinical$WT1.Mutation, levels = c("Yes", "No", "Unknown"))
# setting a color for the bars
col = c(Transmembrane = "#4E79A7", Intracellular = "#E15759")
# this sets the oncoprint dimensions and rules (how tall the bars are compared to the background, etc.)
# the grid.rect(w*0.9, h*0.9) is important for setting the bar height
alter_fun = list(
Transmembrane = function(x, y, w, h) grid.rect(x, y, w*0.9, h*0.9, gp = gpar(fill = col["Transmembrane"], col = NA)),
Intracellular = function(x, y, w, h) grid.rect(x, y, w*0.9, h*0.9, gp = gpar(fill = col["Intracellular"], col = NA))
)
# the oncoprint plotting recipe
d1 <- oncoPrint(mat, # the matrix
alter_fun_is_vectorized = TRUE, # critical otherwise it'll take forever to plot
alter_fun = alter_fun, # the function above
col = col, # the color above
row_names_gp = gpar(fontsize = 10), # gene fontsize
pct_gp = gpar(fontsize = 10), # % fontsize
column_title = NULL, # don't need a title
top_annotation = ha, # heatmap annotation from the previous function
column_split = if (!is.null(input$split) && input$split != "No Split") updatedclinical[[column_mapping[input$split]]] else NULL, # splits based on the dropdown menu for splitting
remove_empty_columns = FALSE, # can turn to TRUE if you want to get rid of empty columns (harder to visualize the % though)
heatmap_legend_param = list(title = "Domain"))
d1 <- draw(d1, merge_legend = TRUE) # this keeps the legends clean
})
#################################################################
#-------------------- FINAL MODULE OUTPUTS ---------------------#
#################################################################
output$plot <- renderPlot({
validate(
need(input$fusions, 'Please select at least one fusion')) # this validation makes sure that a box is checked
plotOncoprint()
})
# Adding a download button widget for the plot
output$plot_download <- downloadHandler(
filename = function() {
paste0("oncoprint_", format(Sys.time(), "%m.%d.%Y"), ".pdf")
},
content = function(file) {
pdf(file = file, width = 10, height = 8)
d1 <- plotOncoprint()
print(d1)
dev.off()
}
)
}