|
0
|
1 #!/usr/bin/env Rscript
|
|
|
2 argspec <- c("tab.2.cdt.R converts a data matrix to cdt format
|
|
|
3
|
|
|
4 Usage:
|
|
|
5 tab.2.cdt.R -d <data.file>
|
|
|
6 Optional:
|
|
|
7 -o <output_file>
|
|
|
8 \n\n")
|
|
|
9 args <- commandArgs(TRUE)
|
|
|
10 if ( length( args ) == 1 && args =="--help") {
|
|
|
11 write(argspec, stderr())
|
|
|
12 q();
|
|
|
13 }
|
|
|
14
|
|
|
15 lib.load.quiet <- function( package ) {
|
|
|
16 package <- as.character(substitute(package))
|
|
|
17 suppressPackageStartupMessages( do.call( "library", list( package=package ) ) )
|
|
|
18 }
|
|
|
19
|
|
|
20 lib.load.quiet( getopt )
|
|
|
21 lib.load.quiet( ctc )
|
|
|
22 if ( any( c( 'flashClust', 'fastcluster' ) %in% installed.packages() ) ) {
|
|
|
23 if ( 'flashClust' %in% installed.packages() ) {
|
|
|
24 lib.load.quiet( flashClust )
|
|
|
25 } else {
|
|
|
26 if ( 'fastcluster' %in% installed.packages() ) {
|
|
|
27 lib.load.quiet( fastcluster )
|
|
|
28 }
|
|
|
29 }
|
|
|
30 }
|
|
|
31
|
|
|
32 spec <- matrix( c( "dataset", "d", 1, "character",
|
|
|
33 "dataset2", "D", 2, "character",
|
|
|
34 "output.format", "f", 2, "character",
|
|
|
35 "output.report.dir", "p", 2, "character",
|
|
|
36 "output.fname", "o", 2, "character"
|
|
|
37 ),
|
|
|
38 nc=4,
|
|
|
39 byrow=TRUE
|
|
|
40 )
|
|
|
41
|
|
|
42
|
|
|
43 opt <- getopt( spec=spec )
|
|
|
44 if ( is.null( opt$output.report.dir ) ) { opt$output.report.dir <- "report" }
|
|
|
45 if ( is.null( opt$output.fname ) ) { opt$output.fname <- file.path( opt$output.report.dir, paste( "data", opt$output.format, sep="." ) ) }
|
|
|
46 if ( is.null( opt$output.format ) ) { opt$output.format <- "cdt" }
|
|
|
47
|
|
|
48
|
|
|
49 load( opt$dataset ) ## should load the cl, treecl.res (or partcl.res) and data
|
|
|
50
|
|
|
51 if ( opt$output.format %in% c( "cls-only", "newick" ) ) {
|
|
|
52 if ( opt$output.format == "cls-only" ) {
|
|
|
53
|
|
|
54 cl <- cbind( names( cl ), as.numeric( cl ) )
|
|
|
55 colnames( cl ) <- c( "ID", "Class" )
|
|
|
56
|
|
|
57 opt$output.fname <- gsub( "cls-only$", "tab", opt$output.fname )
|
|
|
58 write.table( cl, opt$output.fname, sep="\t", quote=FALSE, row.names=FALSE, col.names=FALSE )
|
|
|
59 } else {
|
|
|
60 ##if ( opt$output.format == "newick" ) {
|
|
|
61
|
|
|
62 if ( ! exists( "treecl.res" ) ) stop( "no HAC result found in results file proved - necessary to generate a Newick formated file.\n" )
|
|
|
63 write( hc2Newick( treecl.res ), opt$output.fname )
|
|
|
64 }
|
|
|
65 } else {
|
|
|
66 if ( ! exists( 'data' ) ) stop( "No data object in the rdata file provided for", opt$output.format, "format!!\n" )
|
|
|
67 if ( inherits( data, "dist" ) ) stop( "data provided is a distance matrix - not a data matrix. Can't generate TreeView or Tab-delimited files w/distance matrices!\n" )
|
|
|
68
|
|
|
69 ## the rest of this is for the remaining output formats
|
|
|
70 ## pre-set the cluster results for rows & cols to NULL
|
|
|
71 hr <- hr.cl <- hc <- hc.cl <- NULL
|
|
|
72 if ( exists( 'treecl.res' ) ) {
|
|
|
73
|
|
|
74 if ( is.null( treecl.res$dist.method ) ) treecl.res$dist.method <- 'euclidean' # just set it to some stub so that the ctc fn's don't complain
|
|
|
75 if ( all( names( cl ) %in% rownames( data ) ) ) {
|
|
|
76 hr <- treecl.res
|
|
|
77 hr.cl <- cl
|
|
|
78 } else if ( all( names( cl ) %in% colnames( data ) ) ) {
|
|
|
79 hc <- treecl.res
|
|
|
80 hc.cl <- cl
|
|
|
81 } else {
|
|
|
82 stop( "Specified cluster result does not come from this data set\n" )
|
|
|
83 }
|
|
|
84
|
|
|
85 } else {
|
|
|
86 if ( exists( 'partcl.res' ) ) {
|
|
|
87 if ( all( names( cl ) %in% rownames( data ) ) ) {
|
|
|
88 hr <- NA
|
|
|
89 hr.cl <- cl
|
|
|
90 orig.data <- data
|
|
|
91 data <- data[ names( cl ), ] ## partcl.res should now be sorted in order of cluster
|
|
|
92 } else if ( all( names( cl ) %in% colnames( data ) ) ) {
|
|
|
93 hc <- NA
|
|
|
94 hc.cl <- cl
|
|
|
95 orig.data <- data
|
|
|
96 data <- data[ , names( cl ) ] ## partcl.res should now be sorted in order of cluster
|
|
|
97 } else {
|
|
|
98 stop( "Specified cluster result does not come from this data set\n" )
|
|
|
99 }
|
|
|
100 }
|
|
|
101 else {
|
|
|
102 stop( 'could not find a valid cluster result to use for primary direction\n' )
|
|
|
103 }
|
|
|
104 }
|
|
|
105
|
|
|
106
|
|
|
107 if ( ! is.null( opt$dataset2 ) ) {
|
|
|
108
|
|
|
109 ## prep for loading new cluster result
|
|
|
110 if ( ! exists( 'orig.data' ) ) orig.data <- data
|
|
|
111 if ( exists( "treecl.res" ) ) {
|
|
|
112 rm( treecl.res )
|
|
|
113 } else if ( exists( "partcl.res" ) ) {
|
|
|
114 rm( partcl.res )
|
|
|
115 } else stop( "no primary clustering found when generating the 2nd\n" )
|
|
|
116 rm( cl, data )
|
|
|
117
|
|
|
118
|
|
|
119 load( opt$dataset2 ) ## this should bring in the cl obj for the 2nd direction
|
|
|
120
|
|
|
121 ## check the data 1st
|
|
|
122 if ( length( orig.data ) != length( data ) ) stop( "incompatible cluster results in 2nd results file - matrices are diff lengths\n" )
|
|
|
123 if ( nrow( orig.data ) != nrow( data ) ) stop( "incompatible cluster results in 2nd results file - matrices have diff dimensions\n" )
|
|
|
124 if ( sum( orig.data == data ) != length( orig.data ) ) stop( "incompatible cluster results in 2nd results file - matrices contain diff contents\n" )
|
|
|
125 ## looks like data is the same, so drop a copy and start chugging
|
|
|
126 rm( orig.data ); gc()
|
|
|
127
|
|
|
128 if ( exists( 'treecl.res' ) ) {
|
|
|
129 if ( is.null( treecl.res$dist.method ) ) treecl.res$dist.method <- 'euclidean' # just set it to some stub so that the ctc fn's don't complain
|
|
|
130
|
|
|
131 if ( is.null( hr ) ) {
|
|
|
132 if ( all( rownames( cl ) %in% rownames( data ) ) ) {
|
|
|
133 hr <- treecl.res
|
|
|
134 hr.cl <- cl
|
|
|
135 } else {
|
|
|
136 stop( "results file for 2nd direction doesn't contain cluster for 2ndary direction (rows in this case)\n" )
|
|
|
137 }
|
|
|
138 } else if ( is.null( hc ) ) {
|
|
|
139 if ( all( rownames( cl ) %in% colnames( data ) ) ) {
|
|
|
140 hc <- treecl.res
|
|
|
141 hc.cl <- cl
|
|
|
142 } else {
|
|
|
143 stop( "results file for 2nd direction doesn't contain cluster for 2ndary direction (genes in this case)\n" )
|
|
|
144 }
|
|
|
145 } else {
|
|
|
146 stop( "should never get here\n" )
|
|
|
147 }
|
|
|
148 } else if ( exists( 'partcl.res' ) ) {
|
|
|
149 if ( is.null( hr ) ) {
|
|
|
150 if ( all( names( cl ) %in% rownames( data ) ) ) {
|
|
|
151 hr <- NA
|
|
|
152 hr.cl <- cl
|
|
|
153 data <- data[ names( cl ), ] ## partcl.res should now be sorted in order of cluster
|
|
|
154 } else {
|
|
|
155 stop( "results file for 2nd direction doesn't contain cluster for 2ndary direction (rows in this case)\n" )
|
|
|
156 }
|
|
|
157 } else if ( is.null( hc ) ) {
|
|
|
158 if ( all( names( cl ) %in% colnames( data ) ) ) {
|
|
|
159 hc <- NA
|
|
|
160 hc.cl <- cl
|
|
|
161 data <- data[ , names( cl ) ] ## partcl.res should now be sorted in order of cluster
|
|
|
162 } else {
|
|
|
163 stop( "results file for 2nd direction doesn't contain cluster for 2ndary direction (genes in this case)\n" )
|
|
|
164 }
|
|
|
165 } else {
|
|
|
166 stop( "should never get here\n" )
|
|
|
167 }
|
|
|
168 }
|
|
|
169 }
|
|
|
170
|
|
|
171 ## Now, re-set hc & nr to NULL if they were set to NA
|
|
|
172 ## we used NA to signify that they were set by kmeans/pam, but now, we need to reset them
|
|
|
173 ## for the following lines (that generate the dendrograms (if there was an hclust result)
|
|
|
174 if ( ( !is.null( hr ) ) && is.na( hr ) ) hr <- NULL
|
|
|
175 if ( ( !is.null( hc ) ) && is.na( hc ) ) hc <- NULL
|
|
|
176
|
|
|
177 if ( ! exists( 'data' ) ) stop( "No data object in the rdata file provided!!\n" )
|
|
|
178
|
|
|
179 if ( is.null( hc ) ) hc <- list( order=1:ncol( data ) )
|
|
|
180 if ( is.null( hr ) ) hr <- list( order=1:nrow( data ) )
|
|
|
181
|
|
|
182 if ( opt$output.format == "tabular" ) {
|
|
|
183 write.table( data[ hr$order, hc$order ], opt$output.fname, quote=FALSE, sep="\t", col.names=NA )
|
|
|
184 } else if ( opt$output.format == "cdt" ) {
|
|
|
185 if ( !file.exists( opt$output.report.dir ) ){
|
|
|
186 dir.create(opt$output.report.dir, recursive=T)
|
|
|
187 }
|
|
|
188
|
|
|
189 treeview.fname.stem <- file.path( opt$output.report.dir, "cluster.heatmap")
|
|
|
190 fnames <- character()
|
|
|
191 if ( inherits( hr, "hclust" ) ) {
|
|
|
192 fname <- paste( treeview.fname.stem, ".gtr", sep="" )
|
|
|
193 ## we manually specify a 'stub' distance b/c o/w it'll try using the attr(hr,"method")
|
|
|
194 ## and the r2gtr fn's get grumpy if the distance was anything starting with a 'p'
|
|
|
195 r2gtr( hr, file=fname, distance='stub' )
|
|
|
196 fnames <- c( fnames, fname )
|
|
|
197 }
|
|
|
198 if ( inherits( hc, "hclust" ) ) {
|
|
|
199 fname <- paste( treeview.fname.stem, ".atr", sep="" )
|
|
|
200 r2atr( hc, file=fname, distance='stub' )
|
|
|
201 fnames <- c( fnames, fname )
|
|
|
202 }
|
|
|
203
|
|
|
204 fname <- paste( treeview.fname.stem, ".cdt", sep="" )
|
|
|
205 r2cdt( hr, hc, data, file=fname )
|
|
|
206 fnames <- c( fnames, fname )
|
|
|
207
|
|
|
208 ## jtv file now
|
|
|
209 jtv.str <- '<DocumentConfig><UrlExtractor/><ArrayUrlExtractor/><Views><View type="Dendrogram" dock="1"><ColorExtractor contrast="2.0"><ColorSet zero="#FFFFFF" down="#0000FF"/></ColorExtractor><ArrayDrawer/><GlobalXMap current="Fill"><FixedMap type="Fixed"/><FillMap type="Fill"/><NullMap type="Null"/></GlobalXMap><GlobalYMap current="Fill"><FixedMap type="Fixed"/><FillMap type="Fill"/><NullMap type="Null"/></GlobalYMap><ZoomXMap><FixedMap type="Fixed"/><FillMap type="Fill"/><NullMap type="Null"/></ZoomXMap><ZoomYMap><FixedMap type="Fixed"/><FillMap type="Fill"/><NullMap type="Null"/></ZoomYMap><TextView><TextView face="Monospaced" size="14"><GeneSummary/></TextView><TextView face="Monospaced" size="14"><GeneSummary/></TextView><TextView face="Monospaced" size="14"><GeneSummary/></TextView><TextView face="Monospaced" size="14"><GeneSummary/></TextView></TextView><ArrayNameView face="Monospaced" size="14"><ArraySummary included="0"/></ArrayNameView><AtrSummary/><GtrSummary/></View></Views></DocumentConfig>'
|
|
|
210 fname <- paste( treeview.fname.stem, ".jtv", sep="" )
|
|
|
211 cat( jtv.str, file=fname )
|
|
|
212 fnames <- c( fnames, fname )
|
|
|
213
|
|
|
214 cmd <- paste( "tar -zcf",
|
|
|
215 opt$output.fname,
|
|
|
216 paste( "--directory=", opt$output.report.dir, sep="" ),
|
|
|
217 paste( basename( fnames ), collapse=" " ) )
|
|
|
218 system( cmd )
|
|
|
219 }
|
|
|
220 }
|
|
|
221
|
|
|
222
|
|
|
223
|
|
|
224
|
