[Bio] / FigWebServices / diffsF.cgi Repository:
ViewVC logotype

Annotation of /FigWebServices/diffsF.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (view) (download)

1 : overbeek 1.2 # -*- perl -*-
2 :     #
3 :     # Copyright (c) 2003-2006 University of Chicago and Fellowship
4 :     # for Interpretations of Genomes. All Rights Reserved.
5 :     #
6 :     # This file is part of the SEED Toolkit.
7 :     #
8 :     # The SEED Toolkit is free software. You can redistribute
9 :     # it and/or modify it under the terms of the SEED Toolkit
10 :     # Public License.
11 :     #
12 :     # You should have received a copy of the SEED Toolkit Public License
13 :     # along with this program; if not write to the University of Chicago
14 :     # at info@ci.uchicago.edu or the Fellowship for Interpretation of
15 :     # Genomes at veronika@thefig.info or download a copy from
16 :     # http://www.theseed.org/LICENSE.TXT.
17 :     #
18 :    
19 : overbeek 1.1 use GenoGraphics;
20 :    
21 :     use FIG;
22 :     my $fig = new FIG;
23 :    
24 :     use HTML;
25 :    
26 :     use CGI;
27 :     my $cgi = new CGI;
28 :    
29 :     if (0)
30 :     {
31 :     my $VAR1;
32 :     eval(join("",`cat /tmp/diffsF_parms`));
33 :     $cgi = $VAR1;
34 :     # print STDERR &Dumper($cgi);
35 :     }
36 :    
37 :     if (0)
38 :     {
39 :     print $cgi->header;
40 :     my @params = $cgi->param;
41 :     print "<pre>\n";
42 :     foreach $_ (@params)
43 :     {
44 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
45 :     }
46 :    
47 :     if (0)
48 :     {
49 :     if (open(TMP,">/tmp/diffsF_parms"))
50 :     {
51 :     print TMP &Dumper($cgi);
52 :     close(TMP);
53 :     }
54 :     }
55 :     exit;
56 :     }
57 :    
58 :     use constant FID => 0;
59 :     use constant LOCUS => 1;
60 :     use constant CONTIG => 2;
61 :     use constant START => 3;
62 :     use constant STOP => 4;
63 :     use constant LEN => 5;
64 :     use constant STRAND => 6;
65 :     use constant TYPE => 7;
66 :     use constant TAXID => 8;
67 :    
68 :     my $html = [];
69 :     unshift @$html, "<TITLE>Feature Differences</TITLE>\n";
70 :     $org1 = $cgi->param('org1');
71 :     $org2 = $cgi->param('org2');
72 :     $gene = $cgi->param('gene');
73 :    
74 :     if (!((-d $org1) || (-d $org2)))
75 :     {
76 :     push(@$html,$cgi->h1("bad parms: gene=$gene org1=$org1 org2=$org2"));
77 :     }
78 :     elsif ($gene = $cgi->param('gene'))
79 :     {
80 :     &show_region($fig,$cgi,$html,$org1,$gene);
81 :     }
82 :     else
83 :     {
84 :     &list_diffs($fig,$cgi,$html,$org1,$org2);
85 :     }
86 :     &HTML::show_page($cgi,$html);
87 :    
88 :     sub show_region {
89 :     my($fig,$cgi,$html,$org,$gene) = @_;
90 :     my @feat = &load_tbl2($org,$gene);
91 :     for ($i=0; ($i < @feat) && ($feat[$i]->[FID] ne $gene); $i++) {}
92 :     if ($i < @feat)
93 :     {
94 :     $first = ($i > 4) ? $i-5 : 0;
95 :     $last = ($i < (@feat - 5)) ? $i+5 : @feat - 1;
96 :     my $gg = [];
97 :     my $genes = [];
98 :     $min = 10000000;
99 :     $max = 0;
100 :     while ($first <= $last)
101 :     {
102 :     $f = $feat[$first];
103 :     $beg = $f->[START];
104 :     $end = $f->[STOP];
105 :     $min = &FIG::min($min,$beg);
106 :     $min = &FIG::min($min,$end);
107 :     $max = &FIG::max($max,$beg);
108 :     $max = &FIG::max($max,$end);
109 :     $fid = $f->[FID];
110 :     $fid =~ /\.([a-z]+\.\d+)$/;
111 :     $info = $1;
112 :     push(@$genes,[ &FIG::min($beg,$end),
113 :     &FIG::max($beg,$end),
114 :     ($beg < $end) ? "rightArrow" : "leftArrow",
115 :     ($fid eq $gene) ? "red" : "blue",
116 :     "",
117 :     "",
118 :     "$fid: $beg to $end",
119 :     ""
120 :     ] );
121 :     $first++;
122 :     }
123 :     my $map = ['Region',0,$max+1-$min,&decr_coords($genes,$min)];
124 :     push(@$gg,$map);
125 :     push( @$html, @{ &GenoGraphics::render( $gg, 1000, 4, 1 ) } );
126 :     }
127 :     }
128 :    
129 :     sub decr_coords {
130 :     my($genes,$min) = @_;
131 :     my($gene);
132 :    
133 :     foreach $gene (@$genes)
134 :     {
135 :     $gene->[0] -= $min;
136 :     $gene->[1] -= $min;
137 :     }
138 :     return $genes;
139 :     }
140 :    
141 :     sub list_diffs {
142 : overbeek 1.3 my ($fig, $cgi, $html, $org1, $org2) = @_;
143 :    
144 : overbeek 1.1 $org1T = &load_tbl1($org1);
145 :     $org2T = &load_tbl1($org2);
146 : overbeek 1.3
147 :     my @both;
148 :     my @just1;
149 :     foreach $key (sort { by_locus($org1T->{$a}, $org1T->{$b}) } keys %$org1T)
150 : overbeek 1.1 {
151 :     $type1 = $org1T->{$key}->[TYPE];
152 :     $locus1 = $org1T->{$key}->[LOCUS];
153 :    
154 :     if ($org2T->{$key})
155 :     {
156 :     $type2 = $org2T->{$key}->[TYPE];
157 :     $locus2 = $org2T->{$key}->[LOCUS];
158 :     if (($type1 ne $type2) || ($locus1 ne $locus2))
159 :     {
160 :     $fid1 = $org1T->{$key}->[FID];
161 :     $fid2 = $org2T->{$key}->[FID];
162 :     $link1 = &link($org1,$fid1);
163 :     $link2 = &link($org2,$fid2);
164 : overbeek 1.2
165 :     if (($len1 = $org1T->{$key}->[LEN]) < ($len2 = $org2T->{$key}->[LEN])) {
166 :     $changed = qq(lengthened);
167 :     }
168 :     else {
169 :     $changed = qq(shortened);
170 :     }
171 : overbeek 1.3
172 :     push @both, [ $changed, $link1, $len1, $link2, $len2 ];
173 : overbeek 1.1 }
174 :     }
175 :     else
176 :     {
177 :     $fid1 = $org1T->{$key}->[FID];
178 :     $link1 = &link($org1,$fid1);
179 : overbeek 1.3 push @just2, [ $link1, $org1T->{$key}->[LEN] ];
180 : overbeek 1.1 }
181 :     }
182 : overbeek 1.3
183 :     my @just2;
184 : overbeek 1.1 foreach $key (sort { by_locus($org2T->{$a},$org2T->{$b}) } keys %$org2T)
185 :     {
186 :     if (! $org1T->{$key})
187 :     {
188 :     $type2 = $org2T->{$key}->[TYPE];
189 :     $locus2 = $org2T->{$key}->[LOCUS];
190 :     $fid2 = $org2T->{$key}->[FID];
191 :     $link2 = &link($org2,$fid2);
192 : overbeek 1.3 push @just2, [ $link2, $org2T->{$key}->[LEN] ];
193 : overbeek 1.1 }
194 :     }
195 : overbeek 1.3
196 :     push @$html, map { $cgi->h2("$_->[0]:, $_->[1] ($_->[2] bp) => $_->[3] ($_->[4] bp)")
197 :     }
198 :     sort { abs($b->[4] - $b->[2]) <=> abs($a->[4] - $a->[2])
199 :     } @both;
200 :    
201 :     push @$html, map { $cgi->h2("just2: $_->[0] ($_->[1] bp)")
202 :     }
203 :     sort { $b->[1] <=> $a->[1]
204 :     } @just2;
205 :    
206 :     push @$html, map { $cgi->h2("just1: $_->[0] ($_->[1] bp)")
207 :     }
208 :     sort { $b->[1] <=> $a->[1]
209 :     } @just1;
210 : overbeek 1.1 }
211 :    
212 :     sub load_tbl1
213 :     {
214 :     my ($dir) = @_;
215 :     my ($entry, $id, $locus, $contig, $beg, $end, $len, $strand, $taxid, $type);
216 :    
217 :     open(TBL, "cat $dir/Features/*/tbl |") || die "Could not open $dir";
218 :    
219 :     my $tbl = {};
220 :     while (defined($entry = <TBL>))
221 :     {
222 :     chomp $entry;
223 :    
224 :     ($id, $locus) = split /\t/, $entry;
225 :     $id =~ m/^[^\|]+\|(\d+\.\d+)\.([^\.]+)/;
226 :     ($taxid, $type) = ($1, $2);
227 :    
228 :     if ((($contig, $beg, $end, $len, $strand) = &from_locus($locus))
229 :     && defined($contig) && $contig
230 :     && defined($beg) && $beg
231 :     && defined($end) && $end
232 :     && defined($len) && $len
233 :     && defined($strand) && $strand
234 :     )
235 :     {
236 :     $tbl->{"$contig\t$strand$end"} = [ $id, $locus, $contig, $beg, $end, $len, $strand, $type, $taxid ];
237 :     }
238 :     else
239 :     {
240 :     warn "INVALID ENTRY:\t$entry\n";
241 :     }
242 :     }
243 :    
244 :     return $tbl;
245 :     }
246 :    
247 :     sub load_tbl2
248 :     {
249 :     my ($dir,$gene) = @_;
250 :    
251 : overbeek 1.3 my ($entry, $id, $locus, $contig, $beg, $end, $len, $strand, $taxid, $type, $keep);
252 : overbeek 1.1
253 :     open(TBL, "cat $dir/Features/*/tbl |") || die "Could not open $dir";
254 :    
255 :     my $tbl = {};
256 :     while (defined($entry = <TBL>))
257 :     {
258 :     chomp $entry;
259 :    
260 :     ($id, $locus) = split /\t/, $entry;
261 :     $id =~ m/^[^\|]+\|(\d+\.\d+)\.([^\.]+)/;
262 :     ($taxid, $type) = ($1, $2);
263 :    
264 :     if ((($contig, $beg, $end, $len, $strand) = &from_locus($locus))
265 :     && defined($contig) && $contig
266 :     && defined($beg) && $beg
267 :     && defined($end) && $end
268 :     && defined($len) && $len
269 :     && defined($strand) && $strand
270 :     )
271 :     {
272 : overbeek 1.3 push(@{$tbl->{$contig}}, [ $id, $locus, $contig, $beg, $end, $len, $strand, $type, $taxid ]);
273 : overbeek 1.1 if ($id eq $gene) { $keep = $contig }
274 :     }
275 :     else
276 :     {
277 :     warn "INVALID ENTRY:\t$entry\n";
278 :     }
279 :     }
280 :     $keep || die "no contig";
281 :     return sort { by_locus($a,$b) } @{$tbl->{$keep}};
282 :     }
283 :    
284 :     sub from_locus
285 :     {
286 :     my ($locus) = @_;
287 :     my ($contig, $beg, $end);
288 :    
289 :     if ( ($locus =~ m/^([^,]+)_(\d+)_\d+/) && ($contig = $1) && ($beg = $2)
290 :     && ($locus =~ m/[^,]+_\d+_(\d+)$/) && ($end = $1)
291 :     )
292 :     {
293 :     return ($contig, $beg, $end, (1+abs($end-$beg)), (($beg < $end) ? '+' : '-'));
294 :     }
295 :     else
296 :     {
297 :     die "Invalid locus $locus";
298 :     }
299 :    
300 :     return ();
301 :     }
302 :    
303 :     sub by_locus
304 :     {
305 :     my ($a, $b) = @_;
306 :    
307 :     my (undef, undef, $A_contig, $A_beg, $A_end, $A_len, $A_strand) = @$a;
308 :     my (undef, undef, $B_contig, $B_beg, $B_end, $B_len, $B_strand) = @$b;
309 :    
310 :     return ( ($A_contig cmp $B_contig)
311 :     || (&FIG::min($A_beg, $A_end) <=> &FIG::min($B_beg, $B_end))
312 :     || ($B_len <=> $A_len)
313 :     || ($A_strand cmp $B_strand)
314 :     );
315 :     }
316 :    
317 :     sub link {
318 :     my($org,$fid) = @_;
319 :    
320 :     return "<a href=diffsF.cgi?org1=$org&gene=$fid>$fid</a>";
321 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3