|
23
|
1 #################################################################################################
|
|
|
2 # CORRELATION TABLE #
|
|
|
3 # #
|
|
|
4 # #
|
|
|
5 # Input : 2 tables with common samples #
|
|
|
6 # Output : Correlation table ; Heatmap (pdf) #
|
|
|
7 # #
|
|
|
8 # Dependencies : Libraries "ggplot2" and "reshape2" #
|
|
|
9 # #
|
|
|
10 #################################################################################################
|
|
|
11
|
|
|
12
|
|
|
13 # Parameters (for dev)
|
|
|
14 if(FALSE){
|
|
|
15
|
|
|
16 tab1.name <- "test/ressources/inputs/CT/CT2_DM.tabular"
|
|
|
17 tab2.name <- "test/ressources/inputs/CT/CT2_base_Diapason_14ClinCES_PRIN.txt"
|
|
|
18 param1.samples <- "column"
|
|
|
19 param2.samples <- "row"
|
|
|
20 corr.method <- "pearson"
|
|
|
21 test.corr <- "yes"
|
|
|
22 alpha <- 0.05
|
|
|
23 multi.name <- "none"
|
|
|
24 filter <- "yes"
|
|
|
25 filters.choice <- "filters_0_thr"
|
|
|
26 threshold <- 0.2
|
|
|
27 reorder.var <- "yes"
|
|
|
28 plot.choice <- "auto"
|
|
|
29 color.heatmap <- "yes"
|
|
|
30 type.classes <-"irregular"
|
|
|
31 reg.value <- 1/3
|
|
|
32 irreg.vect <- c(-0.3, -0.2, -0.1, 0, 0.3, 0.4)
|
|
|
33 output1 <- "Correlation_table.txt"
|
|
|
34 output2 <- "Heatmap.pdf"
|
|
|
35
|
|
|
36 }
|
|
|
37
|
|
|
38
|
|
|
39
|
|
|
40 correlation.tab <- function(tab1.name, tab2.name, param1.samples, param2.samples, corr.method, test.corr, alpha,
|
|
|
41 multi.name, filter, filters.choice, threshold, reorder.var, plot.choice, color.heatmap,
|
|
|
42 type.classes, reg.value, irreg.vect, output1, output2){
|
|
|
43
|
|
|
44 # This function allows to visualize the correlation between two tables
|
|
|
45 #
|
|
|
46 # Parameters:
|
|
|
47 # - tab1.name: table 1 file's access
|
|
|
48 # - tab2.name: table 2 file's access
|
|
|
49 # - param1.samples ("row" or "column"): where the samples are in tab1
|
|
|
50 # - param2.samples ("row" or "column"): where the samples are in tab2
|
|
|
51 # - corr.method ("pearson", "spearman", "kendall"):
|
|
|
52 # - test.corr ("yes" or "no"): test the significance of a correlation coefficient
|
|
|
53 # - alpha (value between 0 and 1): risk for the correlation significance test
|
|
|
54 # - multi.name ("holm", "hochberg", "hommel", "bonferroni", "BH", "BY", "fdr", "none"): correction of multiple tests
|
|
|
55 # - filter ("yes", "no"): use filter.0 or/and filter.threshold
|
|
|
56 # - filters.choice ("filter_0" or "filters_0_thr"): zero filter removes variables with all their correlation coefficients = 0
|
|
|
57 # and threshold filter remove variables with all their correlation coefficients in abs < threshold
|
|
|
58 # - threshold (value between 0 and 1): threshold for filter threshold
|
|
|
59 # - reorder.var ("yes" or "no"): reorder variables in the correlation table thanks to the HCA
|
|
|
60 # - plot.choice ("auto", "forced" or "none"): determine whether a heatmap is plotted
|
|
|
61 # - color.heatmap ("yes" or "no"): color the heatmap with classes defined by the user
|
|
|
62 # - type.classes ("regular" or "irregular"): choose to color the heatmap with regular or irregular classes
|
|
|
63 # - reg.value (value between 0 and 1): value for regular classes
|
|
|
64 # - irreg.vect (vector with values between -1 and 1): vector which indicates values for intervals (irregular classes)
|
|
|
65 # - output1: correlation table file's access
|
|
|
66 # - output2: heatmap (colored correlation table) file's access
|
|
|
67
|
|
|
68
|
|
|
69 # Input ----------------------------------------------------------------------------------------------
|
|
|
70
|
|
|
71 tab1 <- read.table(tab1.name, sep = "\t", header = TRUE, check.names = FALSE, row.names = 1)
|
|
|
72 tab2 <- read.table(tab2.name, sep = "\t", header = TRUE, check.names = FALSE, row.names = 1)
|
|
|
73
|
|
|
74 # Transpose tables according to the samples
|
|
|
75 if(param1.samples == "column"){
|
|
|
76 tab1 <- t(tab1)
|
|
|
77 }
|
|
|
78
|
|
|
79 if(param2.samples == "column"){
|
|
|
80 tab2 <- t(tab2)
|
|
|
81 }
|
|
|
82
|
|
|
83 # Sorting tables in alphabetical order of the samples
|
|
|
84 tab1 <- tab1[order(rownames(tab1)),]
|
|
|
85 tab2 <- tab2[order(rownames(tab2)),]
|
|
|
86
|
|
|
87
|
|
|
88 # Checks ---------------------------------------------------------------------------------------------
|
|
|
89
|
|
|
90 # Check if the 2 datasets match regarding samples identifiers
|
|
|
91 # Adapt from functions "check.err" and "match2", RcheckLibrary.R
|
|
|
92
|
|
|
93 err.stock <- NULL
|
|
|
94
|
|
|
95 id1 <- rownames(tab1)
|
|
|
96 id2 <- rownames(tab2)
|
|
|
97
|
|
|
98 if(sum(id1 != id2) > 0){
|
|
|
99 err.stock <- c("\nThe two tables do not match regarding sample identifiers.\n")
|
|
|
100
|
|
|
101 if(length(which(id1%in%id2)) != length(id1)){
|
|
|
102 identif <- id1[which(!(id1%in%id2))]
|
|
|
103 if (length(identif) < 4){
|
|
|
104 err.stock <- c(err.stock, "\nThe following identifier(s) found in the first table do not appear in the second table:\n")
|
|
|
105 }
|
|
|
106 else {
|
|
|
107 err.stock <- c(err.stock, "\nFor example, the following identifiers found in the first table do not appear in the second table:\n")
|
|
|
108 }
|
|
|
109 identif <- identif[1:min(3,length(which(!(id1%in%id2))))]
|
|
|
110 err.stock <- c(err.stock," ",paste(identif,collapse="\n "),"\n")
|
|
|
111 }
|
|
|
112
|
|
|
113 if(length(which(id2%in%id1)) != length(id2)){
|
|
|
114 identif <- id2[which(!(id2%in%id1))]
|
|
|
115 if (length(identif) < 4){
|
|
|
116 err.stock <- c(err.stock, "\nThe following identifier(s) found in the second table do not appear in the first table:\n")
|
|
|
117 }
|
|
|
118 else{
|
|
|
119 err.stock <- c(err.stock, "\nFor example, the following identifiers found in the second table do not appear in the first table:\n")
|
|
|
120 }
|
|
|
121 identif <- identif[1:min(3,length(which(!(id2%in%id1))))]
|
|
|
122 err.stock <- c(err.stock," ",paste(identif,collapse="\n "),"\n")
|
|
|
123 }
|
|
|
124 err.stock <- c(err.stock,"\nPlease check your data.\n")
|
|
|
125 }
|
|
|
126
|
|
|
127 if(length(err.stock)!=0){
|
|
|
128 stop("\n- - - - - - - - -\n",err.stock,"\n- - - - - - - - -\n\n")
|
|
|
129 }
|
|
|
130
|
|
|
131
|
|
|
132 # Check whether tab1=tab2
|
|
|
133
|
|
|
134 err.msg <- NULL
|
|
|
135
|
|
|
136 if((ncol(tab1)==ncol(tab2))&&(sum(tab1!=tab2,na.rm=TRUE)==0)){
|
|
|
137 autocor <- TRUE
|
|
|
138 err.msg <- c(err.msg, "\nYou chose the same table for the two dataset inputs. \nTo allow filtering options,",
|
|
27
|
139 "we will turn the diagonal to 0 in the correlation matrix during the filtering process.\n")
|
|
23
|
140 }else{
|
|
|
141 autocor <- FALSE
|
|
|
142 }
|
|
|
143
|
|
|
144
|
|
|
145 # Check qualitative variables in each input tables
|
|
|
146
|
|
|
147 var1.quali <- vector()
|
|
|
148 var2.quali <- vector()
|
|
|
149
|
|
|
150 for (i in 1:dim(tab1)[2]){
|
|
|
151 if(class(tab1[,i]) != "numeric" & class(tab1[,i]) != "integer"){
|
|
|
152 var1.quali <- c(var1.quali,i)
|
|
|
153 }
|
|
|
154 }
|
|
|
155
|
|
|
156 for (j in 1:dim(tab2)[2]){
|
|
|
157 if(class(tab2[,j]) != "numeric" & class(tab2[,j]) != "integer"){
|
|
|
158 var2.quali <- c(var2.quali, j)
|
|
|
159 }
|
|
|
160 }
|
|
|
161
|
|
|
162 if (length(var1.quali) != 0 | length(var2.quali) != 0){
|
|
|
163 err.msg <- c(err.msg, "\nThere are qualitative variables in your input tables which have been removed to compute the correlation table.\n\n")
|
|
|
164
|
|
|
165 if(length(var1.quali) != 0 && length(var1.quali) < 4){
|
|
|
166 err.msg <- c(err.msg, "In table 1, the following qualitative variables have been removed:\n",
|
|
|
167 " ",paste(colnames(tab1)[var1.quali],collapse="\n "),"\n")
|
|
|
168 } else if(length(var1.quali) != 0 && length(var1.quali) > 3){
|
|
|
169 err.msg <- c(err.msg, "For example, in table 1, the following qualitative variables have been removed:\n",
|
|
|
170 " ",paste(colnames(tab1)[var1.quali[1:3]],collapse="\n "),"\n")
|
|
|
171 }
|
|
|
172
|
|
|
173 if(length(var2.quali) != 0 && length(var2.quali) < 4){
|
|
|
174 err.msg <- c(err.msg, "In table 2, the following qualitative variables have been removed:\n",
|
|
|
175 " ",paste(colnames(tab2)[var2.quali],collapse="\n "),"\n")
|
|
|
176 } else if(length(var2.quali) != 0 && length(var2.quali) > 3){
|
|
|
177 err.msg <- c(err.msg, "For example, in table 2, the following qualitative variables have been removed:\n",
|
|
|
178 " ",paste(colnames(tab2)[var2.quali[1:3]],collapse="\n "),"\n")
|
|
|
179 }
|
|
|
180 }
|
|
|
181
|
|
|
182 if(length(var1.quali) != 0){
|
|
|
183 tab1 <- tab1[,-var1.quali,drop=FALSE]
|
|
|
184 }
|
|
|
185 if(length(var2.quali) != 0){
|
|
|
186 tab2 <- tab2[,-var2.quali,drop=FALSE]
|
|
|
187 }
|
|
|
188
|
|
|
189
|
|
|
190 # Check whether there are constant variables
|
|
|
191
|
|
|
192 var1.cons <- vector()
|
|
|
193 var2.cons <- vector()
|
|
|
194
|
|
|
195 for (i in 1:dim(tab1)[2]){
|
|
|
196 if(length(levels(as.factor(tab1[,i])))==1){ var1.cons <- c(var1.cons,i) }
|
|
|
197 }
|
|
|
198
|
|
|
199 for (j in 1:dim(tab2)[2]){
|
|
|
200 if(length(levels(as.factor(tab2[,j])))==1){ var2.cons <- c(var2.cons, j) }
|
|
|
201 }
|
|
|
202
|
|
|
203 if (length(var1.cons) != 0 | length(var2.cons) != 0){
|
|
|
204 err.msg <- c(err.msg, "\nThere are constant variables in your input tables which have been removed to compute the correlation table.\n\n")
|
|
|
205
|
|
|
206 if(length(var1.cons) != 0 && length(var1.cons) < 4){
|
|
|
207 err.msg <- c(err.msg, "In table 1, the following constant variables have been removed:\n",
|
|
|
208 " ",paste(colnames(tab1)[var1.cons],collapse="\n "),"\n")
|
|
|
209 } else if(length(var1.cons) != 0 && length(var1.cons) > 3){
|
|
|
210 err.msg <- c(err.msg, "For example, in table 1, the following constant variables have been removed:\n",
|
|
|
211 " ",paste(colnames(tab1)[var1.cons[1:3]],collapse="\n "),"\n")
|
|
|
212 }
|
|
|
213
|
|
|
214 if(length(var2.cons) != 0 && length(var2.cons) < 4){
|
|
|
215 err.msg <- c(err.msg, "In table 2, the following constant variables have been removed:\n",
|
|
|
216 " ",paste(colnames(tab2)[var2.cons],collapse="\n "),"\n")
|
|
|
217 } else if(length(var2.cons) != 0 && length(var2.cons) > 3){
|
|
|
218 err.msg <- c(err.msg, "For example, in table 2, the following constant variables have been removed:\n",
|
|
|
219 " ",paste(colnames(tab2)[var2.cons[1:3]],collapse="\n "),"\n")
|
|
|
220 }
|
|
|
221 }
|
|
|
222
|
|
|
223 if(length(var1.cons) != 0){
|
|
|
224 tab1 <- tab1[,-var1.cons,drop=FALSE]
|
|
|
225 }
|
|
|
226 if(length(var2.cons) != 0){
|
|
|
227 tab2 <- tab2[,-var2.cons,drop=FALSE]
|
|
|
228 }
|
|
|
229
|
|
|
230
|
|
|
231 # Print info message
|
|
|
232
|
|
|
233 if(length(err.msg) != 0){
|
|
|
234 cat("\n- - - - - - - - -\n",err.msg,"\n- - - - - - - - -\n\n")
|
|
|
235 }
|
|
|
236
|
|
|
237 rm(err.stock,var1.quali,var2.quali,var1.cons,var2.cons,err.msg)
|
|
|
238
|
|
|
239
|
|
|
240 # Correlation table ---------------------------------------------------------------------------------
|
|
|
241
|
|
|
242 tab.corr <- matrix(nrow = dim(tab2)[2], ncol = dim(tab1)[2])
|
|
|
243 for (i in 1:dim(tab2)[2]){
|
|
|
244 for (j in 1:dim(tab1)[2]){
|
|
|
245 tab.corr[i,j] <- cor(tab2[,i], tab1[,j], method = corr.method, use = "pairwise.complete.obs")
|
|
|
246 }
|
|
|
247 }
|
|
|
248
|
|
|
249 colnames(tab.corr) <- colnames(tab1)
|
|
|
250 rownames(tab.corr) <- colnames(tab2)
|
|
|
251
|
|
|
252
|
|
|
253 # Significance of correlation test ------------------------------------------------------------------
|
|
|
254
|
|
|
255 if (test.corr == "yes"){
|
|
|
256
|
|
|
257 pvalue <- vector()
|
|
|
258 for (i in 1:dim(tab.corr)[1]){
|
|
|
259 for (j in 1:dim(tab.corr)[2]){
|
|
|
260 suppressWarnings(corrtest <- cor.test(tab2[,i], tab1[,j], method = corr.method))
|
|
|
261 pvalue <- c(pvalue, corrtest$p.value)
|
|
|
262 if (multi.name == "none"){
|
|
|
263 if (corrtest$p.value > alpha){
|
|
|
264 tab.corr[i,j] <- 0
|
|
|
265 }
|
|
|
266 }
|
|
|
267 }
|
|
|
268 }
|
|
|
269
|
|
|
270 if(multi.name != "none"){
|
|
|
271 adjust <- matrix(p.adjust(pvalue, method = multi.name), nrow = dim(tab.corr)[1], ncol = dim(tab.corr)[2], byrow = T)
|
|
|
272 tab.corr[adjust > alpha] <- 0
|
|
|
273 }
|
|
|
274 }
|
|
|
275
|
|
|
276
|
|
|
277 # Filter settings ------------------------------------------------------------------------------------
|
|
|
278
|
|
|
279 if (filter == "yes"){
|
|
|
280
|
|
|
281 # Turn diagonal from 1 to 0 if autocorrelation
|
|
|
282 if(autocor){
|
|
|
283 for(i in 1:(ncol(tab.corr))){ tab.corr[i,i] <- 0 }
|
|
|
284 }
|
|
|
285
|
|
|
286 # Remove variables with all their correlation coefficients = 0 :
|
|
|
287 if (filters.choice == "filter_0"){
|
|
|
288 threshold <- 0
|
|
|
289 }
|
|
|
290
|
|
|
291 var2.thres <- vector()
|
|
|
292 for (i in 1:dim(tab.corr)[1]){
|
|
|
293 if (length(which(abs(tab.corr[i,]) <= threshold)) == dim(tab.corr)[2]){
|
|
|
294 var2.thres <- c(var2.thres, i)
|
|
|
295 }
|
|
|
296 }
|
|
|
297
|
|
|
298 if (length(var2.thres) != 0){
|
|
|
299 tab.corr <- tab.corr[-var2.thres,,drop=FALSE]
|
|
|
300 tab2 <- tab2[, -var2.thres,drop=FALSE]
|
|
|
301 }
|
|
|
302
|
|
|
303 var1.thres <- vector()
|
|
|
304 for (i in 1:dim(tab.corr)[2]){
|
|
|
305 if (length(which(abs(tab.corr[,i]) <= threshold)) == dim(tab.corr)[1]){
|
|
|
306 var1.thres <- c(var1.thres, i)
|
|
|
307 }
|
|
|
308 }
|
|
|
309
|
|
|
310 if (length(var1.thres) != 0){
|
|
|
311 tab.corr <- tab.corr[,-var1.thres,drop=FALSE]
|
|
|
312 tab1 <- tab1[,-var1.thres,drop=FALSE]
|
|
|
313 }
|
|
|
314
|
|
|
315 # Turn diagonal from 0 back to 1 if autocorrelation
|
|
|
316 if(autocor){
|
|
|
317 for(i in 1:(ncol(tab.corr))){ tab.corr[i,i] <- 1 }
|
|
|
318 }
|
|
|
319
|
|
|
320 }
|
|
|
321
|
|
|
322
|
|
|
323 # Reorder variables in the correlation table (with the HCA) ------------------------------------------
|
|
|
324 if (reorder.var == "yes"){
|
|
|
325
|
|
|
326 cormat.tab2 <- cor(tab2, method = corr.method, use = "pairwise.complete.obs")
|
|
|
327 dist.tab2 <- as.dist(1 - cormat.tab2)
|
|
|
328 hc.tab2 <- hclust(dist.tab2, method = "ward.D2")
|
|
|
329 tab.corr <- tab.corr[hc.tab2$order,]
|
|
|
330
|
|
|
331 cormat.tab1 <- cor(tab1, method = corr.method, use = "pairwise.complete.obs")
|
|
|
332 dist.tab1 <- as.dist(1 - cormat.tab1)
|
|
|
333 hc.tab1 <- hclust(dist.tab1, method = "ward.D2")
|
|
|
334 tab.corr <- tab.corr[,hc.tab1$order]
|
|
|
335
|
|
|
336 }
|
|
|
337
|
|
|
338
|
|
|
339 # Output 1 : Correlation table -----------------------------------------------------------------------
|
|
|
340
|
|
|
341
|
|
|
342 # Export correlation table
|
|
|
343 write.table(x = data.frame(name = rownames(tab.corr), tab.corr), file = output1, sep = "\t", quote = FALSE, row.names = FALSE)
|
|
|
344
|
|
|
345
|
|
|
346
|
|
|
347 # Create the heatmap ---------------------------------------------------------------------------------
|
|
|
348
|
|
|
349 #### conditions de creation de heatmap
|
|
|
350
|
|
|
351
|
|
|
352 # A message if no variable kept
|
|
|
353 if(length(tab.corr)==0){
|
|
|
354 pdf(output2)
|
|
|
355 plot.new()
|
|
|
356 legend("center","Filtering leads to no remaining correlation coefficient.")
|
|
|
357 dev.off()
|
|
|
358 } else {
|
|
|
359
|
|
|
360
|
|
|
361 library(ggplot2)
|
|
|
362 library(reshape2)
|
|
|
363
|
|
|
364 # Melt the correlation table :
|
|
|
365 melted.tab.corr <- melt(tab.corr)
|
|
|
366
|
|
|
367 if (color.heatmap == "yes") {
|
|
|
368
|
|
|
369 # Add a column for the classes of each correlation coefficient
|
|
|
370 classe <- rep(0, dim(melted.tab.corr)[1])
|
|
|
371 melted <- cbind(melted.tab.corr, classe)
|
|
|
372
|
|
|
373 if (type.classes == "regular"){
|
|
|
374
|
|
|
375 vect <- vector()
|
|
|
376 if (seq(-1,0,reg.value)[length(seq(-1,0,reg.value))] == 0){
|
|
|
377 vect <- c(seq(-1,0,reg.value)[-length(seq(-1,0,reg.value))],
|
|
|
378 rev(seq(1,0,-reg.value)))
|
|
|
379 } else {
|
|
|
380 vect <- c(seq(-1,0,reg.value), 0, rev(seq(1,0,-reg.value)))
|
|
|
381 }
|
|
|
382
|
|
|
383 } else if (type.classes == "irregular") {
|
|
|
384
|
|
|
385 irreg.vect <- c(-1, irreg.vect, 1)
|
|
|
386 vect <- irreg.vect
|
|
|
387
|
|
|
388 }
|
|
|
389
|
|
|
390 # Color palette :
|
|
|
391 myPal <- colorRampPalette(c("#00CC00", "white", "red"), space = "Lab", interpolate = "spline")
|
|
|
392
|
|
|
393 # Create vector intervals
|
|
|
394 cl <- vector()
|
|
|
395 cl <- paste("[", vect[1], ";", round(vect[2],3), "]", sep = "")
|
|
|
396
|
|
|
397 for (x in 2:(length(vect)-1)) {
|
|
|
398 if (vect[x+1] == 0) {
|
|
|
399 cl <- c(cl, paste("]", round(vect[x],3), ";", round(vect[x+1],3), "[", sep = ""))
|
|
|
400 } else {
|
|
|
401 cl <- c(cl, paste("]", round(vect[x],3), ";",
|
|
|
402 round(vect[x+1],3), "]", sep = ""))
|
|
|
403 }
|
|
|
404 }
|
|
|
405
|
|
|
406 # Assign an interval to each correlation coefficient
|
|
|
407 for (i in 1:dim(melted.tab.corr)[1]){
|
|
|
408 for (j in 1:(length(cl))){
|
|
|
409 if (vect[j] == -1){
|
|
|
410 melted$classe[i][melted$value[i] >= vect[j]
|
|
|
411 && melted$value[i] <= vect[j+1]] <- cl[j]
|
|
|
412 } else {
|
|
|
413 melted$classe[i][melted$value[i] > vect[j]
|
|
|
414 && melted$value[i] <= vect[j+1]] <- cl[j]
|
|
|
415 }
|
|
|
416 }
|
|
|
417 }
|
|
|
418
|
|
|
419 # Find the 0 and assign it the white as name
|
|
|
420 if (length(which(vect == 0)) == 1) {
|
|
|
421 melted$classe[melted$value == 0] <- "0"
|
|
|
422 indic <- which(vect == 0)
|
|
|
423 cl <- c(cl[1:(indic-1)], 0, cl[indic:length(cl)])
|
|
|
424 names(cl)[indic] <- "#FFFFFF"
|
|
|
425 } else if (length(which(vect == 0)) == 0) {
|
|
|
426 indic <- 0
|
|
|
427 for (x in 1:(length(vect)-1)) {
|
|
|
428 if (0 > vect[x] && 0 <= vect[x+1]) {
|
|
|
429 names(cl)[x] <- "#FFFFFF"
|
|
|
430 indic <- x
|
|
|
431 }
|
|
|
432 }
|
|
|
433 }
|
|
|
434
|
|
|
435 indic <- length(cl) - indic + 1
|
|
|
436 cl <- rev(cl)
|
|
|
437
|
|
|
438 # Assign the colors of each intervals as their name
|
|
|
439 names(cl)[1:(indic-1)] <- myPal(length(cl[1:indic])*2-1)[1:indic-1]
|
|
|
440 names(cl)[(indic+1):length(cl)] <- myPal(length(cl[indic:length(cl)])*2-1)[(ceiling(length(myPal(length(cl[indic:length(cl)])*2-1))/2)+1):length(myPal(length(cl[indic:length(cl)])*2-1))]
|
|
|
441
|
|
|
442
|
|
|
443 melted$classe <- factor(melted$classe)
|
|
|
444 melted$classe <- factor(melted$classe, levels = cl[cl%in%levels(melted$classe)])
|
|
|
445
|
|
|
446 # Heatmap if color.heatmap = yes :
|
|
|
447 ggplot(melted, aes(Var2, Var1, fill = classe)) +
|
|
|
448 ggtitle("Colored correlation table" ) + xlab("Table 1") + ylab("Table 2") +
|
|
|
449 geom_tile(color ="ghostwhite") +
|
|
|
450 scale_fill_manual( breaks = levels(melted$classe),
|
|
|
451 values = names(cl)[cl%in%levels(melted$classe)],
|
|
|
452 name = paste(corr.method, "correlation", sep = "\n")) +
|
|
|
453 theme_classic() +
|
|
|
454 theme(axis.text.x = element_text(angle = 90, vjust = 0.5),
|
|
|
455 plot.title = element_text(hjust = 0.5))
|
|
|
456
|
|
|
457 } else {
|
|
|
458
|
|
|
459 # Heatmap if color.heatmap = no :
|
|
|
460 ggplot(melted.tab.corr, aes(Var2, Var1, fill = value)) +
|
|
|
461 ggtitle("Colored correlation table" ) + xlab("Table 1") + ylab("Table 2") +
|
|
|
462 geom_tile(color ="ghostwhite") +
|
|
|
463 scale_fill_gradient2(low = "red", high = "#00CC00", mid = "white", midpoint = 0, limit = c(-1,1),
|
|
|
464 name = paste(corr.method, "correlation", sep = "\n")) +
|
|
|
465 theme_classic() +
|
|
|
466 theme(axis.text.x = element_text(angle = 90, vjust = 0.5),
|
|
|
467 plot.title = element_text(hjust = 0.5))
|
|
|
468 }
|
|
|
469
|
|
|
470
|
|
|
471 ggsave(output2, device = "pdf", width = 10+0.075*dim(tab.corr)[2], height = 5+0.075*dim(tab.corr)[1], limitsize = FALSE)
|
|
|
472
|
|
|
473
|
|
|
474 } # End if(length(tab.corr)==0)else
|
|
|
475
|
|
|
476 } # End of correlation.tab
|
|
|
477
|
|
|
478
|
|
|
479 # Function call
|
|
|
480 # correlation.tab(tab1.name, tab2.name, param1.samples, param2.samples, corr.method, test.corr, alpha, multi.name, filter,
|
|
|
481 # filters.choice, threshold, reorder.var, color.heatmap, type.classes,
|
|
|
482 # reg.value, irreg.vect, output1, output2)
|
