|
37
|
1 # limits
|
|
|
2 min_limit = 20
|
|
|
3
|
|
|
4 # load sparse matrix package
|
|
|
5 suppressPackageStartupMessages(library('Matrix'))
|
|
|
6
|
|
|
7 # access a numeric column
|
|
|
8 get_numeric <- function(table, column_key) {
|
|
|
9 column <- as.numeric(column_key)
|
|
|
10 column_data <- sapply( table[column], as.numeric )
|
|
|
11 return (c(column_data))
|
|
|
12 }
|
|
|
13
|
|
|
14 # access a label column
|
|
|
15 get_label <- function(table, column_key) {
|
|
|
16 column <- as.numeric(column_key)
|
|
|
17 return (c(table[column]))
|
|
|
18 }
|
|
|
19
|
|
|
20 # inflate three columns into matrix
|
|
|
21 matrify <- function (data) {
|
|
|
22 if (ncol(data) != 3)
|
|
|
23 stop('Data frame must have three column format')
|
|
|
24 plt <- data[, 1]
|
|
|
25 spc <- data[, 2]
|
|
|
26 abu <- data[, 3]
|
|
|
27 plt.codes <- levels(factor(plt))
|
|
|
28 spc.codes <- levels(factor(spc))
|
|
|
29 taxa <- Matrix(0, nrow=length(plt.codes), ncol=length(spc.codes), sparse=TRUE)
|
|
|
30 row <- match(plt, plt.codes)
|
|
|
31 col <- match(spc, spc.codes)
|
|
|
32 for (i in 1:length(abu)) {
|
|
|
33 taxa[row[i], col[i]] <- abu[i]
|
|
|
34 }
|
|
|
35 colnames(taxa) <- spc.codes
|
|
|
36 rownames(taxa) <- plt.codes
|
|
|
37 taxa
|
|
|
38 }
|
|
|
39
|
|
|
40 # flatten data.frame into three column format
|
|
|
41 flatten <- function(my_matrix) {
|
|
|
42 summ <-summary(my_matrix)
|
|
|
43 summ <- data.frame(i=rownames(my_matrix)[summ$i], j=colnames(my_matrix)[summ$j], x=summ$x)
|
|
|
44 summ
|
|
|
45 }
|
|
|
46
|
|
|
47 # wrapper
|
|
|
48 wrapper <- function(table, columns, options) {
|
|
|
49
|
|
|
50 # initialize output list
|
|
|
51 l <- list()
|
|
|
52
|
|
|
53 # get number of columns
|
|
|
54 n = length(columns)
|
|
|
55
|
|
|
56 # consistency check
|
|
|
57 if (n %% 3 != 0) {
|
|
|
58 print ('heatmap::wrapper() - Data not consistent (n mod 3 != 0)')
|
|
|
59 return (l)
|
|
|
60 }
|
|
|
61
|
|
|
62 # create index sequence
|
|
|
63 index = seq(1, n, by=3)
|
|
|
64
|
|
|
65 # get keys
|
|
|
66 keys = names(columns)
|
|
|
67
|
|
|
68 # loop through blocks
|
|
|
69 for (i in index) {
|
|
|
70 # create columns
|
|
|
71 ci <- get_label(table, columns[keys[i]])
|
|
|
72 cj <- get_label(table, columns[keys[i+1]])
|
|
|
73 cx <- get_numeric(table, columns[keys[i+2]])
|
|
|
74
|
|
|
75 # create a frame from columns
|
|
|
76 my_frame <- data.frame(ci=ci, cj=cj, cx=cx)
|
|
|
77
|
|
|
78 # create matrix out of the frame
|
|
|
79 my_matrix <- matrify(my_frame)
|
|
|
80
|
|
|
81 # create/cluster matrix
|
|
|
82 row_order <- hclust(dist(my_matrix))$order
|
|
|
83 col_order <- hclust(dist(t(my_matrix)))$order
|
|
|
84
|
|
|
85 # reorder matrix
|
|
|
86 my_matrix <- my_matrix[row_order, col_order]
|
|
|
87
|
|
|
88 # get min size
|
|
|
89 min_limit = max(as.integer(options$limit), min_limit)
|
|
|
90
|
|
|
91 # get max size
|
|
|
92 max_row = min(length(row_order), min_limit)
|
|
|
93 max_col = min(length(col_order), min_limit)
|
|
|
94
|
|
|
95 # transform back to three columns
|
|
|
96 my_flatmatrix = flatten(my_matrix[1:max_row, 1:max_col])
|
|
|
97
|
|
|
98 # append to result list
|
|
|
99 l <- append(l, list(my_flatmatrix$i))
|
|
|
100 l <- append(l, list(my_flatmatrix$j))
|
|
|
101 l <- append(l, list(my_flatmatrix$x))
|
|
|
102 }
|
|
|
103
|
|
|
104 # return
|
|
|
105 return (l)
|
|
|
106 }
|
