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

Annotation of /FigWebServices/diffsF.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3