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

Annotation of /FigWebServices/homologs_in_clusters.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (view) (download)

1 : overbeek 1.1 #### start #####
2 : overbeek 1.4 use InterfaceRoutines;
3 :    
4 : overbeek 1.1
5 :     use HTML;
6 :     use strict;
7 :     use CGI;
8 :     my $cgi = new CGI;
9 :    
10 : overbeek 1.4 use FIG;
11 :     my $sproutAvail = eval {
12 :     require SproutFIG;
13 :     require PageBuilder;
14 :     };
15 :    
16 :     my($fig_or_sprout);
17 :     my $is_sprout;
18 :     my $html = [];
19 :    
20 :     if ($cgi->param('SPROUT')) {
21 :     $is_sprout = 1;
22 :     $fig_or_sprout = new SproutFIG($FIG_Config::sproutDB, $FIG_Config::sproutData);
23 :     unshift @$html, "<TITLE>The NMPDR Homologs in Clusters Page</TITLE>\n";
24 :     } else {
25 :     $is_sprout = 0;
26 :     $fig_or_sprout = new FIG;
27 :     unshift @$html, "<TITLE>The SEED Homologs in Clusters Page</TITLE>\n";
28 :     }
29 :    
30 : overbeek 1.1 if (0)
31 :     {
32 :     my $VAR1;
33 :     eval(join("",`cat /tmp/homologs_in_clusters_parms`));
34 :     $cgi = $VAR1;
35 :     # print STDERR &Dumper($cgi);
36 :     }
37 :    
38 :     if (0)
39 :     {
40 :     print $cgi->header;
41 :     my @params = $cgi->param;
42 :     print "<pre>\n";
43 :     foreach $_ (@params)
44 :     {
45 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
46 :     }
47 :    
48 :     if (0)
49 :     {
50 :     if (open(TMP,">/tmp/homologs_in_clusters_parms"))
51 :     {
52 :     print TMP &Dumper($cgi);
53 :     close(TMP);
54 :     }
55 :     }
56 :     exit;
57 :     }
58 :    
59 :     my $prot = $cgi->param('prot');
60 :     if (! $prot)
61 :     {
62 :     push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
63 :     &HTML::show_page($cgi,$html);
64 :     exit;
65 :     }
66 :    
67 :    
68 :     if ($prot !~ /^fig\|/)
69 :     {
70 : overbeek 1.4 my @poss = $fig_or_sprout->by_alias($prot);
71 : overbeek 1.1 if (@poss > 0)
72 :     {
73 :     $prot = $poss[0];
74 :     }
75 :     else
76 :     {
77 :     push(@$html,"<h1>Sorry, $prot appears not to have a FIG id at this point</h1>\n");
78 :     &HTML::show_page($cgi,$html);
79 :     exit;
80 :     }
81 :     }
82 :    
83 : overbeek 1.4 &compute_desired_homologs($fig_or_sprout,$cgi,$html,$prot);
84 : olson 1.5
85 :     if ($is_sprout)
86 :     {
87 :     my $h = { homologs => $html };
88 :    
89 :     print "Content-Type: text/html\n";
90 :     print "\n";
91 :     my $templ = "$FIG_Config::fig/CGI/Html/Homologs_tmpl.html";
92 :     print PageBuilder::Build("<$templ", $h,"Html");
93 :     }
94 :     else
95 :     {
96 :     &HTML::show_page($cgi,$html);
97 :     }
98 : overbeek 1.1 exit;
99 :    
100 :     sub compute_desired_homologs {
101 : overbeek 1.4 my($fig_or_sprout,$cgi,$html,$peg) = @_;
102 : overbeek 1.1
103 : overbeek 1.4 my @pinned = &relevant_homologs($fig_or_sprout,$cgi,$peg);
104 : overbeek 1.1 # print STDERR &Dumper(\@pinned);
105 :    
106 : overbeek 1.4 # my @clusters = sort { (@$b <=> @$a) } &sets_of_homologs($fig_or_sprout,$cgi,$peg,\@pinned);
107 : overbeek 1.1 # print STDERR &Dumper(\@clusters);
108 :    
109 : overbeek 1.3 # my @homologs = &extract_homologs($peg,\@pinned,\@clusters);
110 : overbeek 1.1 # print STDERR &Dumper(\@homologs);
111 :    
112 :     my $sc;
113 : overbeek 1.7 my @tab = map { my($peg,$sc,$sim) = @$_; [$sim,$sc,
114 : overbeek 1.1 &HTML::fid_link($cgi,$peg),
115 : overbeek 1.4 $fig_or_sprout->genus_species($fig_or_sprout->genome_of($peg)),
116 :     scalar $fig_or_sprout->function_of($peg,$cgi->param('user')),
117 :     &HTML::set_prot_links($cgi,join( ', ', $fig_or_sprout->feature_aliases($peg) ))
118 : overbeek 1.3 ] } @pinned;
119 : overbeek 1.6 if (@tab > 0)
120 :     {
121 : overbeek 1.8 push(@$html,&HTML::make_table(["Sim. Sc.","Cluster Size","PEG","Genome", "Function","Aliases"],\@tab,"PEGs that Might Be in Clusters"));
122 : overbeek 1.6 }
123 :     else
124 :     {
125 :     push(@$html, $cgi->h1("Sorry, we have no clusters containing homologs of $peg"));
126 :     }
127 : overbeek 1.1 }
128 :    
129 :     sub relevant_homologs {
130 : overbeek 1.4 my($fig_or_sprout,$cgi,$peg) = @_;
131 : overbeek 1.1 my($maxN,$maxP,$genome1,$sim,$id2,$genome2,%seen);
132 :    
133 :     $maxN = $cgi->param('maxN');
134 :     $maxN = $maxN ? $maxN : 50;
135 :    
136 :     $maxP = $cgi->param('maxP');
137 :     $maxP = $maxP ? $maxP : 1.0e-10;
138 :    
139 : overbeek 1.4 my @sims = $fig_or_sprout->sims( $peg, $maxN, $maxP, "fig");
140 : overbeek 1.1
141 :     my @homologs = ();
142 :     $seen{&FIG::genome_of($peg)} = 1;
143 :     foreach $sim (@sims)
144 :     {
145 :     $id2 = $sim->id2;
146 :     $genome2 = &FIG::genome_of($id2);
147 : overbeek 1.3 my @coup;
148 : overbeek 1.4 if ((! $seen{$genome2}) && (@coup = $fig_or_sprout->coupled_to($id2)) && (@coup > 0))
149 : overbeek 1.1 {
150 :     $seen{$genome2} = 1;
151 : overbeek 1.8 push(@homologs,[$id2,@coup+1,$sim->psc]);
152 : overbeek 1.1 }
153 :     }
154 : overbeek 1.3 return sort { $b->[1] <=> $a->[1] } @homologs;
155 : overbeek 1.1 }
156 :    
157 :     sub sets_of_homologs {
158 : overbeek 1.4 my($fig_or_sprout,$cgi,$given_peg,$pinned) = @_;
159 : overbeek 1.1 my($peg,$mid,$min,$max,$feat,$fid);
160 :    
161 :     my $bound = $cgi->param('bound');
162 :     $bound = $bound ? $bound : 4000;
163 :    
164 :     my @pegs = ();
165 :     foreach $peg (($given_peg,@$pinned))
166 :     {
167 : overbeek 1.4 my $loc = $fig_or_sprout->feature_location($peg);
168 : overbeek 1.1 if ($loc)
169 :     {
170 :     my($contig,$beg,$end) = &FIG::boundaries_of($loc);
171 :     if ($contig && $beg && $end)
172 :     {
173 :     $mid = int(($beg + $end) / 2);
174 :     $min = $mid - $bound;
175 :     $max = $mid + $bound;
176 :    
177 : overbeek 1.4 ($feat,undef,undef) = &genes_in_region($fig_or_sprout,$cgi,&FIG::genome_of($peg),$contig,$min,$max);
178 : overbeek 1.1 foreach $fid (@$feat)
179 :     {
180 :     if (&FIG::ftype($fid) eq "peg")
181 :     {
182 :     push(@pegs,$fid);
183 :     }
184 :     }
185 :     }
186 :     }
187 :     }
188 :    
189 :     my %represents;
190 :     foreach $peg (@pegs)
191 :     {
192 : overbeek 1.4 my $tmp = $fig_or_sprout->maps_to_id($peg);
193 : overbeek 1.1 push(@{$represents{$tmp}},$peg);
194 : overbeek 1.4 # if ($tmp ne $peg) { push(@{$represents{$peg}},$peg) }
195 : overbeek 1.1 }
196 :     my($sim,%conn,$x,$y,$i,$j);
197 :     foreach $y (keys(%represents))
198 :     {
199 :     $x = $represents{$y};
200 :     for ($i=0; ($i < @$x); $i++)
201 :     {
202 :     for ($j=$i+1; ($j < @$x); $j++)
203 :     {
204 :     push(@{$conn{$x->[$i]}},$x->[$j]);
205 :     push(@{$conn{$x->[$j]}},$x->[$i]);
206 :     }
207 :     }
208 :     }
209 :    
210 :     my $maxN = $cgi->param('maxN');
211 :     $maxN = $maxN ? $maxN : 50;
212 :    
213 :     my $maxP = $cgi->param('maxP');
214 :     $maxP = $maxP ? $maxP : 1.0e-10;
215 :    
216 :     foreach $peg (@pegs)
217 :     {
218 : overbeek 1.4 foreach $sim ($fig_or_sprout->sims( $peg, $maxN, $maxP, "raw"))
219 : overbeek 1.1 {
220 :     if (defined($x = $represents{$sim->id2}))
221 :     {
222 :     foreach $y (@$x)
223 :     {
224 :     push(@{$conn{$peg}},$y);
225 :     }
226 :     }
227 :     }
228 :     }
229 :    
230 :     my(%seen,$k,$cluster);
231 :     my @clusters = ();
232 :     for ($i=0; ($i < @pegs); $i++)
233 :     {
234 :     $peg = $pegs[$i];
235 :     if (! $seen{$peg})
236 :     {
237 :     $cluster = [$peg];
238 :     $seen{$peg} = 1;
239 :     for ($j=0; ($j < @$cluster); $j++)
240 :     {
241 :     $x = $conn{$cluster->[$j]};
242 :     foreach $k (@$x)
243 :     {
244 :     if (! $seen{$k})
245 :     {
246 :     push(@$cluster,$k);
247 :     $seen{$k} = 1;
248 :     }
249 :     }
250 :     }
251 :    
252 :     if (@$cluster > 1)
253 :     {
254 :     push(@clusters,$cluster);
255 :     }
256 :     }
257 :     }
258 :     return @clusters;
259 :     }
260 :    
261 :     sub extract_homologs {
262 :     my($given_peg,$pinned,$clusters) = @_;
263 :     my(%main,$cluster,$peg,%counts,@with_counts);
264 :    
265 :     %main = map { $_ => 1 } ($given_peg,@$pinned);
266 :     foreach $cluster (@$clusters)
267 :     {
268 :     foreach $peg (@$cluster)
269 :     {
270 :     if (! $main{$peg})
271 :     {
272 :     $counts{&FIG::genome_of($peg)} += @$cluster - 1;
273 :     }
274 :     }
275 :     }
276 :    
277 :     foreach $peg (($given_peg,@$pinned))
278 :     {
279 :     push(@with_counts,[$peg,$counts{&FIG::genome_of($peg)}]);
280 :     }
281 :    
282 :     return grep { $_->[1] > 2} sort { $b->[1] <=> $a->[1] } @with_counts;
283 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3