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

Annotation of /FigWebServices/diffsF.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (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 :     my($fig,$cgi,$html,$org1,$org2) = @_;
143 :    
144 :     $org1T = &load_tbl1($org1);
145 :     $org2T = &load_tbl1($org2);
146 :    
147 :     foreach $key (sort { by_locus($org1T->{$a},$org1T->{$b}) } keys %$org1T)
148 :     {
149 :     $type1 = $org1T->{$key}->[TYPE];
150 :     $locus1 = $org1T->{$key}->[LOCUS];
151 :    
152 :     if ($org2T->{$key})
153 :     {
154 :     $type2 = $org2T->{$key}->[TYPE];
155 :     $locus2 = $org2T->{$key}->[LOCUS];
156 :     if (($type1 ne $type2) || ($locus1 ne $locus2))
157 :     {
158 :     $fid1 = $org1T->{$key}->[FID];
159 :     $fid2 = $org2T->{$key}->[FID];
160 :     $link1 = &link($org1,$fid1);
161 :     $link2 = &link($org2,$fid2);
162 : overbeek 1.2
163 :     if (($len1 = $org1T->{$key}->[LEN]) < ($len2 = $org2T->{$key}->[LEN])) {
164 :     $changed = qq(lengthened);
165 :     }
166 :     else {
167 :     $changed = qq(shortened);
168 :     }
169 :     push(@$html,$cgi->h2("$changed: $link1 ($len1 bp) => $link2 ($len2 bp)"));
170 : overbeek 1.1 }
171 :     }
172 :     else
173 :     {
174 :     $fid1 = $org1T->{$key}->[FID];
175 :     $link1 = &link($org1,$fid1);
176 : overbeek 1.2 push(@$html,$cgi->h2("just1: $link1 ($org1T->{$key}->[LEN] bp)"));
177 : overbeek 1.1 }
178 :     }
179 :    
180 :     foreach $key (sort { by_locus($org2T->{$a},$org2T->{$b}) } keys %$org2T)
181 :     {
182 :     if (! $org1T->{$key})
183 :     {
184 :     $type2 = $org2T->{$key}->[TYPE];
185 :     $locus2 = $org2T->{$key}->[LOCUS];
186 :     $fid2 = $org2T->{$key}->[FID];
187 :     $link2 = &link($org2,$fid2);
188 : overbeek 1.2 push(@$html,$cgi->h2("just2: $link2 ($org2T->{$key}->[LEN] bp)"));
189 : overbeek 1.1 }
190 :     }
191 :     }
192 :    
193 :     sub load_tbl1
194 :     {
195 :     my ($dir) = @_;
196 :     my ($entry, $id, $locus, $contig, $beg, $end, $len, $strand, $taxid, $type);
197 :    
198 :     open(TBL, "cat $dir/Features/*/tbl |") || die "Could not open $dir";
199 :    
200 :     my $tbl = {};
201 :     while (defined($entry = <TBL>))
202 :     {
203 :     chomp $entry;
204 :    
205 :     ($id, $locus) = split /\t/, $entry;
206 :     $id =~ m/^[^\|]+\|(\d+\.\d+)\.([^\.]+)/;
207 :     ($taxid, $type) = ($1, $2);
208 :    
209 :     if ((($contig, $beg, $end, $len, $strand) = &from_locus($locus))
210 :     && defined($contig) && $contig
211 :     && defined($beg) && $beg
212 :     && defined($end) && $end
213 :     && defined($len) && $len
214 :     && defined($strand) && $strand
215 :     )
216 :     {
217 :     $tbl->{"$contig\t$strand$end"} = [ $id, $locus, $contig, $beg, $end, $len, $strand, $type, $taxid ];
218 :     }
219 :     else
220 :     {
221 :     warn "INVALID ENTRY:\t$entry\n";
222 :     }
223 :     }
224 :    
225 :     return $tbl;
226 :     }
227 :    
228 :     sub load_tbl2
229 :     {
230 :     my ($dir,$gene) = @_;
231 :    
232 :     my ($entry, $id, $locus, $contig, $beg, $end, $len, $strand, $taxid, $type,$keep);
233 :    
234 :     open(TBL, "cat $dir/Features/*/tbl |") || die "Could not open $dir";
235 :    
236 :     my $tbl = {};
237 :     while (defined($entry = <TBL>))
238 :     {
239 :     chomp $entry;
240 :    
241 :     ($id, $locus) = split /\t/, $entry;
242 :     $id =~ m/^[^\|]+\|(\d+\.\d+)\.([^\.]+)/;
243 :     ($taxid, $type) = ($1, $2);
244 :    
245 :     if ((($contig, $beg, $end, $len, $strand) = &from_locus($locus))
246 :     && defined($contig) && $contig
247 :     && defined($beg) && $beg
248 :     && defined($end) && $end
249 :     && defined($len) && $len
250 :     && defined($strand) && $strand
251 :     )
252 :     {
253 :     push(@{$tbl->{$contig}},[ $id, $locus, $contig, $beg, $end, $len, $strand, $type, $taxid ]);
254 :     if ($id eq $gene) { $keep = $contig }
255 :     }
256 :     else
257 :     {
258 :     warn "INVALID ENTRY:\t$entry\n";
259 :     }
260 :     }
261 :     $keep || die "no contig";
262 :     return sort { by_locus($a,$b) } @{$tbl->{$keep}};
263 :     }
264 :    
265 :     sub from_locus
266 :     {
267 :     my ($locus) = @_;
268 :     my ($contig, $beg, $end);
269 :    
270 :     if ( ($locus =~ m/^([^,]+)_(\d+)_\d+/) && ($contig = $1) && ($beg = $2)
271 :     && ($locus =~ m/[^,]+_\d+_(\d+)$/) && ($end = $1)
272 :     )
273 :     {
274 :     return ($contig, $beg, $end, (1+abs($end-$beg)), (($beg < $end) ? '+' : '-'));
275 :     }
276 :     else
277 :     {
278 :     die "Invalid locus $locus";
279 :     }
280 :    
281 :     return ();
282 :     }
283 :    
284 :     sub by_locus
285 :     {
286 :     my ($a, $b) = @_;
287 :    
288 :     my (undef, undef, $A_contig, $A_beg, $A_end, $A_len, $A_strand) = @$a;
289 :     my (undef, undef, $B_contig, $B_beg, $B_end, $B_len, $B_strand) = @$b;
290 :    
291 :     return ( ($A_contig cmp $B_contig)
292 :     || (&FIG::min($A_beg, $A_end) <=> &FIG::min($B_beg, $B_end))
293 :     || ($B_len <=> $A_len)
294 :     || ($A_strand cmp $B_strand)
295 :     );
296 :     }
297 :    
298 :     sub link {
299 :     my($org,$fid) = @_;
300 :    
301 :     return "<a href=diffsF.cgi?org1=$org&gene=$fid>$fid</a>";
302 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3