Mercurial > repos > iuc > charts

comparison heatmap.r @ 1:344ac3ca7557 draft default tip

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
"planemo upload for repository https://github.com/galaxyproject/tools-iuc/tree/master/tools/charts/ commit 4494db13b69987fbc97d47177d2a5956e46e927b"
author iuc
date Wed, 17 Nov 2021 09:06:59 +0000
parents a87a3773d8ed
children
comparison
equal deleted inserted replaced
0:a87a3773d8ed 1:344ac3ca7557
1 # load sparse matrix package 1 # load sparse matrix package
2 suppressPackageStartupMessages(library('Matrix')) 2 suppressPackageStartupMessages(library("Matrix"))
3 3
4 # access a numeric column 4 # access a numeric column
5 get_numeric <- function(table, column_key) { 5 get_numeric <- function(table, column_key) {
6 column <- as.numeric(column_key) 6 column <- as.numeric(column_key)
7 column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]]))) 7 column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))
8 return (c(column_data)) 8 return(c(column_data))
9 } 9 }
10 10
11 # access a label column 11 # access a label column
12 get_label <- function(table, column_key) { 12 get_label <- function(table, column_key) {
13 column <- as.numeric(column_key) 13 column <- as.numeric(column_key)
14 column_data <- as.character(table[column][[1]]) 14 column_data <- as.character(table[column][[1]])
15 return (c(column_data)) 15 return(c(column_data))
16 } 16 }
17 17
18 # inflate three columns into matrix 18 # inflate three columns into matrix
19 matrify <- function (data) { 19 matrify <- function(data) {
20 if (ncol(data) != 3) 20 if (ncol(data) != 3)
21 stop('Data frame must have three column format') 21 stop("Data frame must have three column format")
22 plt <- data[, 1] 22 plt <- data[, 1]
23 spc <- data[, 2] 23 spc <- data[, 2]
24 abu <- data[, 3] 24 abu <- data[, 3]
25 plt.codes <- levels(factor(plt)) 25 plt_codes <- levels(factor(plt))
26 spc.codes <- levels(factor(spc)) 26 spc_codes <- levels(factor(spc))
27 taxa <- Matrix(0, nrow=length(plt.codes), ncol=length(spc.codes), sparse=TRUE) 27 taxa <- Matrix(0, nrow = length(plt_codes), ncol = length(spc_codes), sparse = TRUE)
28 row <- match(plt, plt.codes) 28 row <- match(plt, plt_codes)
29 col <- match(spc, spc.codes) 29 col <- match(spc, spc_codes)
30 for (i in 1:length(abu)) { 30 for (i in seq_len(length(abu))) {
31 taxa[row[i], col[i]] <- abu[i] 31 taxa[row[i], col[i]] <- abu[i]
32 } 32 }
33 colnames(taxa) <- spc.codes 33 colnames(taxa) <- spc_codes
34 rownames(taxa) <- plt.codes 34 rownames(taxa) <- plt_codes
35 taxa 35 taxa
36 } 36 }
37 37
38 # flatten data.frame into three column format 38 # flatten data.frame into three column format
39 flatten <- function(my_matrix) { 39 flatten <- function(my_matrix) {
40 summ <-summary(my_matrix) 40 summ <- summary(my_matrix)
41 summ <- data.frame(i=rownames(my_matrix)[summ$i], j=colnames(my_matrix)[summ$j], x=summ$x) 41 summ <- data.frame(i = rownames(my_matrix)[summ$i], j = colnames(my_matrix)[summ$j], x = summ$x)
42 summ 42 summ
43 } 43 }
44 44
45 # wrapper 45 # wrapper
46 wrapper <- function(table, columns, options) { 46 wrapper <- function(table, columns, options) {
47 47
48 # initialize output list 48 # initialize output list
49 l <- list() 49 l <- list()
50 50
51 # get number of columns 51 # get number of columns
52 n = length(columns) 52 n <- length(columns)
53 53
54 # consistency check 54 # consistency check
55 if (n %% 3 != 0) { 55 if (n %% 3 != 0) {
56 print ('heatmap::wrapper() - Data not consistent (n mod 3 != 0)') 56 print("heatmap::wrapper() - Data not consistent (n mod 3 != 0)")
57 return (l) 57 return(l)
58 } 58 }
59 59
60 # create index sequence 60 # create index sequence
61 index = seq(1, n, by=3) 61 index <- seq(1, n, by = 3)
62 62
63 # get keys 63 # get keys
64 keys = names(columns) 64 keys <- names(columns)
65 65
66 # loop through blocks 66 # loop through blocks
67 for (i in index) { 67 for (i in index) {
68 # create columns 68 # create columns
69 ci <- get_label(table, columns[keys[i]]) 69 ci <- get_label(table, columns[keys[i]])
70 cj <- get_label(table, columns[keys[i+1]]) 70 cj <- get_label(table, columns[keys[i + 1]])
71 cx <- get_numeric(table, columns[keys[i+2]]) 71 cx <- get_numeric(table, columns[keys[i + 2]])
72 72
73 # create a frame from columns 73 # create a frame from columns
74 my_frame <- data.frame(ci=ci, cj=cj, cx=cx) 74 my_frame <- data.frame(ci = ci, cj = cj, cx = cx)
75 75
76 # create matrix out of the frame 76 # create matrix out of the frame
77 my_matrix <- matrify(my_frame) 77 my_matrix <- matrify(my_frame)
78 78
79 # create/cluster matrix 79 # create/cluster matrix
80 row_order <- hclust(dist(my_matrix))$order 80 row_order <- hclust(dist(my_matrix))$order
81 col_order <- hclust(dist(t(my_matrix)))$order 81 col_order <- hclust(dist(t(my_matrix)))$order
82 82
83 # reorder matrix 83 # reorder matrix
84 my_matrix <- my_matrix[row_order, col_order] 84 my_matrix <- my_matrix[row_order, col_order]
85 85
86 # transform back to three columns 86 # transform back to three columns
87 my_flatmatrix = flatten(my_matrix) 87 my_flatmatrix <- flatten(my_matrix)
88 88
89 # append to result list 89 # append to result list
90 l <- append(l, list(my_flatmatrix$i)) 90 l <- append(l, list(my_flatmatrix$i))
91 l <- append(l, list(my_flatmatrix$j)) 91 l <- append(l, list(my_flatmatrix$j))
92 l <- append(l, list(my_flatmatrix$x)) 92 l <- append(l, list(my_flatmatrix$x))
93 } 93 }
94 94
95 # return 95 # return
96 return (l) 96 return(l)
97 } 97 }