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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.50 - (view) (download)

1 : overbeek 1.44 #### start ####
2 : efrank 1.1 use FIG;
3 :     my $fig = new FIG;
4 : heiko 1.45 use FIGGenDB;
5 : olson 1.48 use FIGjs;
6 : efrank 1.1
7 :     use HTML;
8 : olson 1.48 use Data::Dumper;
9 :    
10 : efrank 1.1 use strict;
11 :     use GenoGraphics;
12 :     use CGI;
13 :     my $cgi = new CGI;
14 :    
15 :     if (0)
16 :     {
17 : overbeek 1.40 my $VAR1;
18 :     eval(join("",`cat /tmp/protein_parms`));
19 :     $cgi = $VAR1;
20 :     # print STDERR &Dumper($cgi);
21 :     }
22 :    
23 :     if (0)
24 :     {
25 : efrank 1.1 print $cgi->header;
26 :     my @params = $cgi->param;
27 :     print "<pre>\n";
28 :     foreach $_ (@params)
29 :     {
30 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
31 :     }
32 : overbeek 1.40
33 :     if (0)
34 :     {
35 :     if (open(TMP,">/tmp/protein_parms"))
36 :     {
37 :     print TMP &Dumper($cgi);
38 :     close(TMP);
39 :     }
40 :     }
41 : efrank 1.1 exit;
42 :     }
43 :    
44 :     my $html = [];
45 : golsen 1.19 unshift @$html, "<TITLE>The SEED Protein Page</TITLE>\n";
46 : efrank 1.1
47 :     my $prot = $cgi->param('prot');
48 :     if (! $prot)
49 :     {
50 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
51 : efrank 1.1 push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
52 :     &HTML::show_page($cgi,$html);
53 :     exit;
54 :     }
55 : golsen 1.34
56 : overbeek 1.44
57 : golsen 1.34 if ($prot !~ /^fig\|/)
58 : overbeek 1.16 {
59 : overbeek 1.44 my @poss = $fig->by_alias($prot);
60 :     if (@poss > 0)
61 : overbeek 1.16 {
62 : overbeek 1.44 $prot = $poss[0];
63 : overbeek 1.16 }
64 :     else
65 :     {
66 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
67 : overbeek 1.16 push(@$html,"<h1>Sorry, $prot appears not to have a FIG id at this point</h1>\n");
68 :     &HTML::show_page($cgi,$html);
69 :     exit;
70 :     }
71 :     }
72 : efrank 1.1
73 : golsen 1.34 #
74 :     # Allow previous and next actions in calls to the script -- GJO
75 :     #
76 :    
77 :     my $adjust = $cgi->param('previous PEG') ? -1 : $cgi->param('next PEG') ? 1 : 0;
78 :     if ( $adjust ) {
79 :     my ( $prefix, $protnum ) = $prot =~ /^(.*\.)(\d+)$/;
80 :     if ( $prefix && $protnum ) {
81 :     my $prot2 = $prefix . ($protnum + $adjust);
82 :     if ( $fig->translatable( $prot2 ) ) {
83 :     $prot = $prot2;
84 :     $cgi->delete('prot');
85 :     $cgi->param(-name => 'prot', -value => $prot);
86 :     }
87 :     }
88 :     ( $adjust < 0 ) && $cgi->delete('previous PEG');
89 :     ( $adjust > 0 ) && $cgi->delete('next PEG');
90 :     }
91 :    
92 :     my $request = $cgi->param("request") || "";
93 :    
94 :     if ($request eq "use_protein_tool") { &use_protein_tool($fig,$cgi,$html,$prot); }
95 : overbeek 1.11 elsif ($request eq "view_annotations") { &view_annotations($fig,$cgi,$html,$prot); }
96 : overbeek 1.15 elsif ($request eq "view_all_annotations") { &view_all_annotations($fig,$cgi,$html,$prot); }
97 : overbeek 1.11 elsif ($request eq "aa_sequence") { &aa_sequence($fig,$cgi,$html,$prot); }
98 :     elsif ($request eq "dna_sequence") { &dna_sequence($fig,$cgi,$html,$prot); }
99 :     elsif ($request eq "fast_assign") { &make_assignment($fig,$cgi,$html,$prot); }
100 :     elsif ($request eq "show_coupling_evidence") { &show_coupling_evidence($fig,$cgi,$html,$prot); }
101 :     elsif ($request eq "ec_to_maps") { &show_ec_to_maps($fig,$cgi,$html); }
102 :     elsif ($request eq "link_to_map") { &link_to_map($fig,$cgi,$html); }
103 :     elsif ($request eq "fusions") { &show_fusions($fig,$cgi,$html,$prot); }
104 :     else { &show_initial($fig,$cgi,$html,$prot); }
105 : efrank 1.1
106 :     &HTML::show_page($cgi,$html);
107 : overbeek 1.11 exit;
108 :    
109 :     #==============================================================================
110 :     # use_protein_tool
111 :     #==============================================================================
112 : efrank 1.1
113 :     sub use_protein_tool {
114 : golsen 1.34 my($fig,$cgi,$html,$prot) = @_;
115 : efrank 1.1 my($url,$method,@args,$line,$name,$val);
116 :    
117 :     my $seq = $fig->get_translation($prot);
118 :     if (! $seq)
119 :     {
120 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
121 : efrank 1.1 push(@$html,$cgi->h1("Sorry, $prot does not have a translation"));
122 :     return;
123 :     }
124 :     my $protQ = quotemeta $prot;
125 :    
126 :     my $tool = $cgi->param('tool');
127 :     $/ = "\n//\n";
128 :     my @tools = grep { $_ =~ /^$tool\n/ } `cat $FIG_Config::global/LinksToTools`;
129 :     if (@tools == 1)
130 :     {
131 :     chomp $tools[0];
132 :     (undef,undef,$url,$method,@args) = split(/\n/,$tools[0]);
133 :     my $args = [];
134 :     foreach $line (@args)
135 :     {
136 :     ($name,$val) = split(/\t/,$line);
137 :     $val =~ s/FIGID/$prot/;
138 :     $val =~ s/FIGSEQ/$seq/;
139 :     $val =~ s/\\n/\n/g;
140 :     push(@$args,[$name,$val]);
141 :     }
142 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Tool</TITLE>\n";
143 : efrank 1.1 push(@$html,&HTML::get_html($url,$method,$args));
144 :     }
145 :     }
146 :    
147 : overbeek 1.11 #==============================================================================
148 :     # make_assignment
149 :     #==============================================================================
150 :    
151 : efrank 1.1 sub make_assignment {
152 :     my($fig,$cgi,$html,$prot) = @_;
153 :     my($userR);
154 :    
155 :     my $function = $cgi->param('func');
156 :     my $user = $cgi->param('user');
157 :    
158 :     if ($function && $user && $prot)
159 :     {
160 :     if ($user =~ /master:(.*)/)
161 :     {
162 :     $userR = $1;
163 :     $fig->assign_function($prot,"master",$function,"");
164 :     $fig->add_annotation($prot,$userR,"Set master function to\n$function\n");
165 :     }
166 :     else
167 :     {
168 :     $fig->assign_function($prot,$user,$function,"");
169 :     $fig->add_annotation($prot,$user,"Set function to\n$function\n");
170 :     }
171 :     }
172 :     $cgi->delete("request");
173 :     $cgi->delete("func");
174 :     &show_initial($fig,$cgi,$html,$prot);
175 :     }
176 :    
177 : overbeek 1.11 #==============================================================================
178 :     # view_annotations
179 :     #==============================================================================
180 :    
181 : efrank 1.1 sub view_annotations {
182 :     my($fig,$cgi,$html,$prot) = @_;
183 :    
184 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";
185 : efrank 1.1 my $col_hdrs = ["who","when","annotation"];
186 : overbeek 1.9 my $tab = [ map { [$_->[2],$_->[1],"<pre>" . $_->[3] . "<\/pre>"] } $fig->feature_annotations($prot) ];
187 : efrank 1.1 if (@$tab > 0)
188 :     {
189 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Annotations for $prot"));
190 :     }
191 :     else
192 :     {
193 :     push(@$html,"<h1>No Annotations for $prot</h1>\n");
194 :     }
195 :     }
196 :    
197 : overbeek 1.15 sub view_all_annotations {
198 :     my($fig,$cgi,$html,$peg) = @_;
199 :     my($ann);
200 :    
201 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Annotations</TITLE>\n";
202 : overbeek 1.15 if ($fig->is_real_feature($peg))
203 :     {
204 :     my $col_hdrs = ["who","when","PEG","genome","annotation"];
205 :     my @related = $fig->related_by_func_sim($peg,$cgi->param('user'));
206 :     push(@related,$peg);
207 :    
208 :     my @annotations = $fig->merged_related_annotations(\@related);
209 :    
210 :     my $tab = [ map { $ann = $_;
211 :     [$ann->[2],$ann->[1],&HTML::fid_link($cgi,$ann->[0]),
212 :     $fig->genus_species(&FIG::genome_of($ann->[0])),
213 :     "<pre>" . $ann->[3] . "</pre>"
214 :     ] } @annotations];
215 :     if (@$tab > 0)
216 :     {
217 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"All Related Annotations for $peg"));
218 :     }
219 :     else
220 :     {
221 :     push(@$html,"<h1>No Annotations for $peg</h1>\n");
222 :     }
223 :     }
224 :     }
225 :    
226 : overbeek 1.11 #==============================================================================
227 :     # show_coupling_evidence
228 :     #==============================================================================
229 :    
230 : efrank 1.1 sub show_coupling_evidence {
231 :     my($fig,$cgi,$html,$peg) = @_;
232 :     my($pair,$peg1,$peg2,$link1,$link2);
233 :    
234 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Functional Coupling</TITLE>\n";
235 : efrank 1.1 my $user = $cgi->param('user');
236 :     my $to = $cgi->param('to');
237 : overbeek 1.43 my @coup = grep { $_->[1] eq $to } $fig->coupling_and_evidence($peg,5000,1.0e-10,4,"keep");
238 : efrank 1.1
239 :     if (@coup != 1)
240 :     {
241 :     push(@$html,"<h1>Sorry, no evidence that $peg is coupled to $to</h1>\n");
242 :     }
243 :     else
244 :     {
245 :     my $col_hdrs = ["Peg1","Organism1","Function1","Peg2","Organism2","Function2"];
246 :     my $tab = [];
247 :     foreach $pair (@{$coup[0]->[2]})
248 :     {
249 :     ($peg1,$peg2) = @$pair;
250 :     $link1 = &HTML::fid_link($cgi,$peg1);
251 :     $link2 = &HTML::fid_link($cgi,$peg2);
252 : overbeek 1.11 push( @$tab, [ $link1,
253 :     $fig->org_of($peg1),
254 :     scalar $fig->function_of($peg1,$user),
255 :     $link2,
256 :     $fig->org_of($peg2),
257 :     scalar $fig->function_of($peg2,$user)
258 :     ]
259 :     );
260 : efrank 1.1 }
261 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Evidence that $peg Is Coupled To $to"));
262 :     }
263 :     }
264 :    
265 : overbeek 1.11 #==============================================================================
266 :     # psi_blast_prot_sequence
267 :     #==============================================================================
268 :    
269 : efrank 1.1 sub psi_blast_prot_sequence {
270 :     my($fig,$cgi,$prot_id) = @_;
271 :     }
272 :    
273 : overbeek 1.11 #==============================================================================
274 :     # show_initial
275 :     #==============================================================================
276 :    
277 : efrank 1.1 sub show_initial {
278 :     my($fig,$cgi,$html,$prot) = @_;
279 :    
280 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Page</TITLE>\n";
281 : efrank 1.1 my $gs = $fig->org_of($prot);
282 :     if ($prot =~ /^fig\|\d+\.\d+\.peg/)
283 :     {
284 : overbeek 1.36 if (! $fig->is_real_feature($prot))
285 :     {
286 :     push(@$html,"<h1>Sorry, $prot is an unknown identifier</h1>\n");
287 : overbeek 1.11 }
288 :     else
289 :     {
290 : overbeek 1.36 push(@$html,"<h1>Protein $prot: $gs</h1>\n");
291 :     my $msg;
292 :     my $url = $cgi->self_url();
293 :     if ($cgi->param('translate')) {
294 :     $url =~ s/[;&]translate(=[^;&])?//i or $url =~ s/translate(=[^;&])?[;&]//i;
295 :     $msg = "Turn Off Function Translation";
296 :     }
297 :     else
298 :     {
299 :     $url .= ";translate=1";
300 :     $msg = "Translate Function Assignments";
301 :     }
302 :     push(@$html, "<a href=\"$url\">$msg</a><br>\n");
303 :    
304 :     &display_peg($fig,$cgi,$html,$prot);
305 : overbeek 1.11 }
306 : efrank 1.1 }
307 :     else
308 :     {
309 :     # &display_external($fig,$cgi,$html,$prot);
310 :     }
311 :     }
312 :    
313 : overbeek 1.11 #==============================================================================
314 :     # display_peg
315 :     #==============================================================================
316 :    
317 : efrank 1.1 sub display_peg {
318 :     my($fig,$cgi,$html,$peg) = @_;
319 :     my $loc;
320 :    
321 :     my $half_sz = 5000;
322 : overbeek 1.10 my $fc = $cgi->param('fc');
323 :     my @fc_data;
324 :     if ($fc)
325 :     {
326 : redwards 1.49 # RAE Added the following lines so that you can define this in the URL
327 :     # but the default behavior remains unchanged. I doubt anyone will ever
328 :     # see this, but I use it sometimes to see what happens
329 :    
330 :     my ($bound,$sim_cutoff,$coupling_cutoff)=(5000, 1.0e-10, 4);
331 :     if ($cgi->param('fcbound')) {$bound=$cgi->param('fcbound')}
332 :     if ($cgi->param('fcsim')) {$sim_cutoff=$cgi->param('fcsim')}
333 :     if ($cgi->param('fccoup')) {$coupling_cutoff=$cgi->param('fccoup')}
334 :    
335 :     @fc_data = $fig->coupling_and_evidence($peg,$bound,$sim_cutoff,$coupling_cutoff,"keep");
336 : overbeek 1.10 }
337 :     else
338 :     {
339 :     @fc_data = ();
340 :     }
341 : efrank 1.1
342 :     if ($loc = $fig->feature_location($peg))
343 :     {
344 :     my($contig,$beg,$end) = &FIG::boundaries_of($loc);
345 :     my $min = &FIG::max(0,&FIG::min($beg,$end) - $half_sz);
346 :     my $max = &FIG::max($beg,$end) + $half_sz;
347 :     my($feat,$min,$max) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);
348 :    
349 :     &print_context($fig,$cgi,$html,$peg,$feat,$min,$max);
350 :     }
351 :    
352 :     &print_assignments($fig,$cgi,$html,$peg);
353 : olson 1.48 push @$html, "\n", &FIGjs::toolTipScript();
354 : efrank 1.1
355 :     push(@$html,$cgi->hr);
356 : overbeek 1.15 my $link1 = $cgi->self_url() . "&request=view_annotations";
357 :     my $link2 = $cgi->self_url() . "&request=view_all_annotations";
358 :     push(@$html,"<br><a href=$link1>To View Annotations</a>/<a href=$link2>To View All Related Annotations</a>\n");
359 : olson 1.48
360 :     push(@$html, "<br/>".&FIGGenDB::linkPEGGenDB($peg));
361 :     push(@$html, "<br/>".&FIGGenDB::importOrganismGenDB($peg));
362 : efrank 1.1
363 :     my $link = $cgi->self_url() . "&request=aa_sequence";
364 :     push(@$html,"<br><a href=$link>Protein Sequence</a>\n");
365 :    
366 :     $link = $cgi->self_url() . "&request=dna_sequence";
367 :     push(@$html,"<br><a href=$link>DNA Sequence</a>\n");
368 :    
369 :     $link = $cgi->url();
370 :     $link =~ s/protein.cgi/fid_checked.cgi/;
371 :     my $user = $cgi->param('user');
372 :     if (! $user)
373 :     {
374 :     $user = "";
375 :     }
376 :     else
377 :     {
378 :     $link = $link . "?fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate";
379 :     push(@$html,"<br><a href=$link target=checked_window>To Make an Annotation</a>\n");
380 :     }
381 :    
382 :     if ((! $fc) && ($fig->feature_location($peg)))
383 :     {
384 :     my $link = $cgi->self_url() . "&fc=1";
385 :     push(@$html,"<br><a href=$link>To Get Detailed Functional Coupling Data</a>\n");
386 :     }
387 :     elsif ($fc)
388 :     {
389 : overbeek 1.10 &print_fc($fig,$cgi,$html,$peg,\@fc_data);
390 : efrank 1.1 }
391 :    
392 :     my $link = $cgi->self_url() . "&request=fusions";
393 :     push(@$html,"<br><a href=$link>To Get Fusion Data</a>\n");
394 :    
395 : overbeek 1.44 my $link = &FIG::cgi_url . "/homologs_in_clusters.cgi?prot=$peg&user=$user\n";
396 :     push(@$html,"<br><a href=$link>To Find Homologs in Clusters</a>\n");
397 :    
398 : efrank 1.1 my $has_translation = $fig->translatable($peg);
399 : overbeek 1.2 if ((! $cgi->param('compare_region')) && $has_translation)
400 :     {
401 :     my $link = $cgi->self_url() . "&compare_region=1";
402 :     push(@$html,"<br><a href=$link>To Compare Region</a>\n");
403 :     }
404 :     elsif ($cgi->param('compare_region'))
405 :     {
406 :     &print_compared_regions($fig,$cgi,$html,$peg);
407 :     }
408 :    
409 : overbeek 1.44
410 : overbeek 1.11 my $sims = $cgi->param('sims');
411 : efrank 1.1 if ((! $sims) && $has_translation)
412 :     {
413 : golsen 1.18 my $max_expand = $cgi->param('max_expand') || 5;
414 :     my $maxN = $cgi->param('maxN') || 50; # Default 50, not 5 (GJO)
415 :     my $maxP = $cgi->param('maxP') || 1.0e-5;
416 :     my $ex_raw = $cgi->param('expand_raw') || 0; # Default 0, not 1 (GJO)
417 :     my $just_fig = $cgi->param('just_fig') || 0;
418 : overbeek 1.23 my $show_env = $cgi->param('show_env') || 0;
419 : golsen 1.18 my $hide_alias = $cgi->param('hide_alias') || 0;
420 :    
421 : golsen 1.34 push( @$html, $cgi->start_form(-action => "protein.cgi#Similarities"));
422 : overbeek 1.12 if ($cgi->param('translate'))
423 :     {
424 :     push(@$html,$cgi->hidden(-name => 'translate', -value => 1));
425 :     }
426 :     push( @$html, $cgi->hidden(-name => 'prot', -value => $peg),
427 : overbeek 1.11 $cgi->hidden(-name => 'sims', -value => 1),
428 :     $cgi->hidden(-name => 'fid', -value => $peg),
429 :     $cgi->hidden(-name => 'user', -value => $user),
430 :     $cgi->submit('Similarities'),
431 : golsen 1.18 " MaxN: ", $cgi->textfield(-name => 'maxN', -size => 5, -value => $maxN, -override => 1),
432 :     " Max expand: ", $cgi->textfield(-name => 'max_expand', -size => 5, -value => $max_expand, -override => 1),
433 :     " MaxP: ", $cgi->textfield(-name => 'maxP', -size => 10, -value => $maxP),
434 :     " Just FIG Ids: ", $cgi->checkbox(-name => 'just_fig', -value => 1, -checked => $just_fig, -override => 1, -label => ""),
435 : overbeek 1.23 " Show Env. samples: ", $cgi->checkbox(-name => 'show_env', -value => 1, -checked => $show_env, -override => 1, -label => ""),
436 : golsen 1.18 " Hide aliases: ", $cgi->checkbox(-name => 'hide_alias', -value => 1, -checked => $hide_alias, -override => 1, -label => ""),
437 : overbeek 1.11 $cgi->end_form
438 :     );
439 : efrank 1.1 }
440 :     elsif ($sims)
441 :     {
442 :     &print_similarities($fig,$cgi,$html,$peg);
443 :     }
444 :    
445 :     if ($has_translation)
446 :     {
447 :     &show_tools($fig,$cgi,$html,$peg);
448 :     }
449 :     }
450 :    
451 :     ################# Table-Driven Show Tools ############################
452 :    
453 :     sub show_tools {
454 :     my($fig,$cgi,$html,$peg) = @_;
455 :    
456 :     $cgi->param(-name => "request",
457 :     -value => "use_protein_tool");
458 :     my $url = $cgi->self_url();
459 :    
460 :     if (open(TMP,"<$FIG_Config::global/LinksToTools"))
461 :     {
462 :     push(@$html,$cgi->hr);
463 :     my $col_hdrs = ["Tool","Description"];
464 :     my $tab = [];
465 :    
466 :     $/ = "\n//\n";
467 :     while (defined($_ = <TMP>))
468 :     {
469 :     my($tool,$desc) = split(/\n/,$_);
470 :     push(@$tab,["<a href=\"$url\&tool=$tool\">$tool</a>",$desc]);
471 :     }
472 :     close(TMP);
473 :     $/ = "\n";
474 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Tools to Analyze Protein Sequences"));
475 :     }
476 :     $cgi->delete('request');
477 :     }
478 :    
479 :     ################# Functional Coupling ############################
480 :    
481 :     sub print_fc {
482 : overbeek 1.10 my($fig,$cgi,$html,$peg,$fc_data) = @_;
483 : efrank 1.1 my($sc,$neigh);
484 :    
485 :     my $user = $cgi->param('user');
486 :     my @tab = map { ($sc,$neigh) = @$_;
487 :     [&ev_link($cgi,$neigh,$sc),$neigh,scalar $fig->function_of($neigh,$user)]
488 :     }
489 : overbeek 1.10 @$fc_data;
490 : efrank 1.1 if (@tab > 0)
491 :     {
492 :     push(@$html,"<hr>\n");
493 :     my $col_hdrs = ["Score","Peg","Function"];
494 :     push(@$html,&HTML::make_table($col_hdrs,\@tab,"Functional Coupling"));
495 :     }
496 :     }
497 :    
498 :     sub ev_link {
499 :     my($cgi,$neigh,$sc) = @_;
500 :    
501 :     my $prot = $cgi->param('prot');
502 :     my $link = $cgi->url() . "?request=show_coupling_evidence&prot=$prot&to=$neigh";
503 :     return "<a href=$link>$sc</a>";
504 :     }
505 :    
506 :     ################# Assignments ############################
507 :    
508 :     sub trans_function_of {
509 :     my($cgi,$fig,$peg,$user) = @_;
510 :    
511 :     if (wantarray())
512 :     {
513 :     my $x;
514 :     my @funcs = $fig->function_of($peg);
515 :     if ($cgi->param('translate'))
516 :     {
517 :     @funcs = map { $x = $_; $x->[1] = $fig->translate_function($x->[1]); $x } @funcs;
518 :     }
519 :     return @funcs;
520 :     }
521 :     else
522 :     {
523 :     my $func = $fig->function_of($peg,$user);
524 :     if ($cgi->param('translate'))
525 :     {
526 :     $func = $fig->translate_function($func);
527 :     }
528 :     return $func;
529 :     }
530 :     }
531 :    
532 :     sub print_assignments {
533 :     my($fig,$cgi,$html,$peg) = @_;
534 :     my($who,$func,$ec,@ecs,@tmp,$id,$i,$master_func,$user_func,$x);
535 :    
536 :     my $user = $cgi->param('user');
537 :     my @funcs = map { [$peg,@$_] } &trans_function_of($cgi,$fig,$peg);
538 :    
539 :     for ($i=0; ($i < @funcs) && ($funcs[$i]->[1] ne "master"); $i++) {}
540 :     if ($i < @funcs)
541 :     {
542 :     $master_func = $funcs[$i]->[2];
543 :     }
544 :     else
545 :     {
546 :     $master_func = "";
547 :     }
548 :    
549 :     for ($i=0; ($i < @funcs) && ($funcs[$i]->[1] ne $user); $i++) {}
550 :     if ($i < @funcs)
551 :     {
552 :     $user_func = $funcs[$i]->[2];
553 :     }
554 :     else
555 :     {
556 :     $user_func = $master_func;
557 :     }
558 :     push(@$html,$cgi->h2("Current Assignment: $peg: $user_func"));
559 :     my @maps_to = grep { $_ ne $peg } map { $_->[0] } $fig->mapped_prot_ids($peg);
560 :     @funcs = ();
561 :     foreach $id (@maps_to)
562 :     {
563 :     if (($id ne $peg) && (@tmp = &trans_function_of($cgi,$fig,$id)) && (@tmp > 0))
564 :     {
565 :     push(@funcs, map { $x = $_; [$id,@$_] } @tmp);
566 :     }
567 :     }
568 :     @funcs = map { ($_->[1] eq "master") ? [$_->[0],"",$_->[2]] : $_ } @funcs;
569 :     push(@$html,"<hr>\n");
570 :    
571 :     if ((@funcs == 0) && (! $user_func))
572 :     {
573 :     push(@$html,$cgi->h1("No function has been assigned"));
574 :     }
575 : overbeek 1.25
576 :     my $tab = [ map { ($id,$who,$func) = @$_; [ &HTML::set_prot_links($cgi,$id),$fig->org_of($id),$who,($user ? &assign_link($cgi,$func,$user_func) : ""), &set_map_links($fig,&FIG::genome_of($peg),$func)] } @funcs ];
577 :     if (@$tab > 0)
578 : efrank 1.1 {
579 :     my $col_hdrs = ["Id","Organism","Who","ASSIGN","Assignment"];
580 :     my $title = "Assignments for Essentially Identical Proteins";
581 :     push(@$html,&HTML::make_table($col_hdrs,$tab,$title));
582 :     }
583 :    
584 : overbeek 1.26
585 : overbeek 1.38
586 :     my @attr = $fig->feature_attributes($peg);
587 :     if (@attr > 0)
588 :     {
589 :     my $tab = [];
590 :     foreach $_ (@attr)
591 :     {
592 :     my($tag,$val,$url) = @$_;
593 :     push(@$tab,[$tag,"<a href=\"$url\">$val</a>"]);
594 :     }
595 :     push(@$html,$cgi->br,$cgi->hr,&HTML::make_table(["Key","Value"],$tab,"Attributes"),$cgi->hr);
596 :     }
597 :    
598 : olson 1.28 #
599 :     # Show the subsystems in which this protein participates.
600 :     #
601 :    
602 :     if (my @subsystems = $fig->subsystems_for_peg($peg))
603 :     {
604 :     push(@$html,
605 :     $cgi->hr,
606 :     $cgi->h2("Subsystems in which this peg is present"));
607 :    
608 :     my(@hdrs);
609 :     my(@table);
610 :    
611 :     @hdrs = ("Subsystem", "Role");
612 :    
613 :     for my $ent (@subsystems)
614 :     {
615 :     my($sub, $role) = @$ent;
616 :     my $url = $cgi->a({href => "ssa2.cgi?user=$user&ssa_name=$sub&request=show_ssa"}, $sub);
617 :     push(@table, [$url, $role]);
618 :     }
619 :     push(@$html, &HTML::make_table(\@hdrs, \@table));
620 :     }
621 :    
622 : overbeek 1.26 push(@$html,$cgi->hr);
623 : overbeek 1.31
624 :     my @links = $fig->peg_links($peg);
625 :     if (@links > 0)
626 : overbeek 1.25 {
627 : overbeek 1.31 my $col_hdrs = [1,2,3,4,5];
628 : overbeek 1.25 my $title = "Links to Related Entries in Other Sites";
629 : overbeek 1.31 my $tab = [];
630 :     my ($n,$i);
631 :     for ($i=0; ($i < @links); $i += 5)
632 :     {
633 :     $n = (($i + (5-1)) < @links) ? $i+(5-1) : $i+(@links - $i);
634 :     push(@$tab,[@links[$i..$n]]);
635 :     }
636 : overbeek 1.26 push(@$html,&HTML::make_table($col_hdrs,$tab,$title));
637 : overbeek 1.25 }
638 :    
639 : overbeek 1.26 my $url = &FIG::cgi_url . "/add_links.cgi?peg=$peg";
640 :     push(@$html,"<a href=$url>To Add New Links to this Gene</a>\n");
641 :    
642 : efrank 1.1 # $_ = join("",map { $_->[1] } @funcs);
643 :     # @ecs = ($_ =~ /\d\.\d+\.\d+\.\d+/g);
644 :     # foreach $ec (@ecs)
645 :     # {
646 :     # my $kegg_link = &HTML::kegg_link($ec);
647 :     # push(@$html,"<br>$kegg_link<br>\n");
648 :     # }
649 :     }
650 :    
651 :    
652 :    
653 :     ################# Similarities ############################
654 :    
655 :    
656 :     sub print_similarities {
657 : golsen 1.34 my( $fig, $cgi, $html, $peg ) = @_;
658 :     my( $maxN, $maxP, $expand_groups, $ex_checked );
659 : efrank 1.1
660 : golsen 1.18 my $user = $cgi->param('user') || "";
661 : efrank 1.1 my $current_func = &trans_function_of($cgi,$fig,$peg,$user);
662 :    
663 : golsen 1.18 $maxN = defined( $cgi->param('maxN') ) ? $cgi->param('maxN') : 5;
664 :     $maxP = defined( $cgi->param('maxP') ) ? $cgi->param('maxP') : 1.0e-5;
665 :     $expand_groups = $cgi->param('expand_groups');
666 :     $ex_checked = $expand_groups ? "checked" : "";
667 :    
668 :     my $max_expand = $cgi->param('max_expand') || 0;
669 :     my $just_fig = $cgi->param('just_fig') || 0;
670 : overbeek 1.23 my $show_env = $cgi->param('show_env') || 0;
671 : golsen 1.18 my $hide_alias = $cgi->param('hide_alias') || 0;
672 : efrank 1.1
673 : golsen 1.34 push( @$html, $cgi->hr,
674 :     "<a name=Similarities>",
675 :     $cgi->h1('Similarities'),
676 :     "</a>\n"
677 :     );
678 :    
679 :     #
680 :     # Instead of automatically doubling maxN, use the value of
681 :     # $cgi->param("more similarities") to drive increase in maxN and
682 :     # max_expand
683 :     #
684 :     if ( $cgi->param('more similarities') ) {
685 :     $maxN *= 2;
686 :     $max_expand *= 2;
687 :     $cgi->delete('more similarities');
688 :     }
689 :    
690 :     my ( $prev, $next ) = ( 0, 0 );
691 :     my ( $prefix, $protnum ) = $peg =~ /^(.*\.)(\d+)$/;
692 :     if ( $prefix && $protnum ) {
693 :     $prev = ( $protnum > 1 ) && $fig->translatable( $prefix . ($protnum-1) );
694 :     $next = $fig->translatable( $prefix . ($protnum+1) );
695 :     }
696 : efrank 1.1
697 : golsen 1.34 push(@$html, $cgi->start_form(-action => "protein.cgi#Similarities"),
698 : efrank 1.1 $cgi->hidden(-name => 'prot', -value => $peg),
699 :     $cgi->hidden(-name => 'sims', -value => 1),
700 : golsen 1.34 $cgi->hidden(-name => 'fid', -value => $peg),
701 : efrank 1.1 $cgi->hidden(-name => 'user', -value => $user),
702 : golsen 1.34 " MaxN: ", $cgi->textfield(-name => 'maxN', -size => 5, -value => $maxN, -override => 1),
703 : golsen 1.18 " Max expand: ", $cgi->textfield(-name => 'max_expand', -size => 5, -value => $max_expand, -override => 1),
704 :     " MaxP: ", $cgi->textfield(-name => 'maxP', -size => 10, -value => $maxP),
705 :     " Just FIG Ids: ", $cgi->checkbox(-name => 'just_fig', -value => 1, -checked => $just_fig, -override => 1, -label => ""),
706 : overbeek 1.23 " Show Env. samples: ", $cgi->checkbox(-name => 'show_env', -value => 1, -checked => $show_env, -override => 1, -label => ""),
707 : golsen 1.18 " Hide aliases: ", $cgi->checkbox(-name => 'hide_alias', -value => 1, -checked => $hide_alias, -override => 1, -label => ""),
708 : golsen 1.34 $cgi->br,
709 :     $prev ? $cgi->submit('previous PEG') : (),
710 :     $cgi->submit('resubmit'),
711 :     $cgi->submit('more similarities'),
712 :     $next ? $cgi->submit('next PEG') : (),
713 :     $cgi->end_form
714 :     );
715 : efrank 1.1
716 : golsen 1.34 push( @$html, $cgi->hr );
717 : efrank 1.1
718 : golsen 1.18 my $select = $just_fig ? "fig" : "all";
719 :     my @sims = $fig->sims( $peg, $maxN, $maxP, $select, $max_expand );
720 : efrank 1.1
721 :     if (@sims)
722 :     {
723 :     my @from = $cgi->radio_group(-name => 'from',
724 :     -nolabels => 1,
725 : efrank 1.8 -override => 1,
726 : efrank 1.1 -values => ["",$peg,map { $_->id2 } @sims]);
727 :    
728 :     my $target = "window$$";
729 : redwards 1.37 # RAE: added a name to the form so tha the javascript works
730 : golsen 1.18 push( @$html, $cgi->start_form( -method => 'post',
731 :     -target => $target,
732 : redwards 1.37 -action => 'fid_checked.cgi',
733 :     -name => 'fid_checked'
734 : golsen 1.18 ),
735 :     $cgi->hidden(-name => 'fid', -value => $peg),
736 :     $cgi->hidden(-name => 'user', -value => $user),
737 :     $cgi->br,
738 :     "For Selected (checked) sequences: ",
739 :     $cgi->submit('align'),
740 :     $cgi->submit('view annotations'),
741 :     $cgi->submit('show regions')
742 :     );
743 : overbeek 1.11
744 :     if ($user)
745 : golsen 1.18 { my $help_url = "Html/help_for_assignments_and_rules.html";
746 : overbeek 1.11 push ( @$html, $cgi->br, $cgi->br,
747 :     "<a href=$help_url>Help on Assignments, Rules, and Checkboxes</a>",
748 :     $cgi->br, $cgi->br,
749 :     $cgi->submit('assign/annotate')
750 :     );
751 :    
752 : efrank 1.1 if ($cgi->param('translate'))
753 :     {
754 : overbeek 1.11 push( @$html, $cgi->submit('add rules'),
755 :     $cgi->submit('check rules'),
756 :     $cgi->br
757 :     );
758 : efrank 1.1 }
759 :     }
760 :    
761 : overbeek 1.11 push( @$html, $cgi->br,
762 :     $cgi->checkbox( -name => 'checked',
763 :     -value => $peg,
764 :     -override => 1,
765 :     -checked => 1,
766 :     -label => ""
767 :     )
768 :     );
769 :    
770 :     my $col_hdrs;
771 : golsen 1.18 my $color_help = "(<A href=\"Html/similarity_region_colors.html\">colors explained</A>)";
772 : overbeek 1.11 if ($user && $cgi->param('translate'))
773 :     {
774 :     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,
775 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
776 :     "ASSIGN from/Translate to current PEG: ", shift @from
777 :     );
778 : golsen 1.18 $col_hdrs = [ "ASSIGN to<hr>Translate from",
779 :     $expand_groups ? "family" : (),
780 :     $expand_groups ? "size" : (),
781 : overbeek 1.11 "Similar sequence",
782 : overbeek 1.30 "E-val<br>% iden",
783 : golsen 1.18 "region in<br>similar sequence<br>$color_help",
784 :     "region in<br>$peg<br>$color_help",
785 :     "ASSIGN from<hr>Translate to",
786 : overbeek 1.50 "In Sub",
787 : overbeek 1.11 "Function",
788 :     "Organism",
789 : golsen 1.18 ! $hide_alias ? "Aliases" : ()
790 : overbeek 1.11 ];
791 :     }
792 :     elsif ($user)
793 :     {
794 :     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,
795 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
796 :     "ASSIGN from current PEG: ", shift @from
797 :     );
798 : golsen 1.18 $col_hdrs = [ "ASSIGN to<hr>SELECT",
799 :     $expand_groups ? "family" : (),
800 :     $expand_groups ? "size" : (),
801 : overbeek 1.11 "Similar sequence",
802 : overbeek 1.30 "E-val<br>% iden",
803 : golsen 1.18 "region in<br>similar sequence<br>$color_help",
804 :     "region in<br>$peg<br>$color_help",
805 : overbeek 1.11 "ASSIGN from",
806 : overbeek 1.50 "In Sub",
807 : overbeek 1.11 "Function",
808 :     "Organism",
809 : golsen 1.18 ! $hide_alias ? "Aliases" : ()
810 : overbeek 1.11 ];
811 :     }
812 :     else
813 : efrank 1.1 {
814 : overbeek 1.11 push(@$html, " SELECT current PEG", $cgi->br );
815 :     $col_hdrs = [ "SELECT",
816 : golsen 1.18 $expand_groups ? "family" : (),
817 :     $expand_groups ? "size" : (),
818 : overbeek 1.11 "Similar sequence",
819 : overbeek 1.30 "E-val<br>% iden",
820 : golsen 1.18 "region in<br>similar sequence<br>$color_help",
821 :     "region in<br>$peg<br>$color_help",
822 : overbeek 1.50 "In Sub",
823 : overbeek 1.11 "Function",
824 :     "Organism",
825 : golsen 1.18 ! $hide_alias ? "Aliases" : ()
826 : overbeek 1.11 ];
827 : efrank 1.1 }
828 :    
829 : redwards 1.37 # RAE Add the check all/uncheck all boxes.
830 :     push (@$html, $cgi->br, &HTML::java_buttons("fid_checked", "checked"), $cgi->br);
831 :    
832 :    
833 : golsen 1.18 #
834 :     # Total rewrite of sim table code: cleaner program flow; omitting
835 :     # empty columns; colorizing region-of-similarity cells -- GJO
836 :     #
837 :     # Start the similarity table with "Caption" and header row
838 :    
839 :     my $ncol = @$col_hdrs;
840 :     push( @$html, "<TABLE border cols=$ncol>\n",
841 :     "\t<Caption><h2>Similarities</h2></Caption>\n",
842 :     "\t<TR>\n\t\t<TH>",
843 :     join( "</TH>\n\t\t<TH>", @$col_hdrs ),
844 :     "</TH>\n\t</TR>\n"
845 :     );
846 :    
847 :     # Add the table data, row-by-row
848 : overbeek 1.11
849 : golsen 1.18 my $alia = ! $hide_alias;
850 : overbeek 1.11 my $sim;
851 :     foreach $sim ( @sims )
852 : efrank 1.1 {
853 : golsen 1.18 my $id2 = $sim->id2;
854 : overbeek 1.29 if ((! $show_env) && ($id2 =~ /^fig\|99999/))
855 :     {
856 :     shift @from;
857 :     next;
858 :     }
859 : golsen 1.18 my $cbox = $fig->translatable($id2) ?
860 :     qq(<input type=checkbox name=checked value="$id2">) : "";
861 : overbeek 1.11
862 : golsen 1.18 my( $family, $sz, $funcF, $fam_link );
863 :     if ($expand_groups && ($id2 =~ /^fig\|/) && ($family = $fig->in_family($id2)))
864 : efrank 1.1 {
865 : golsen 1.18 $sz = $fig->sz_family($family);
866 :     $funcF = html_enc( $fig->family_function($family) );
867 :     $fam_link = scalar &HTML::family_link( $family, $user );
868 : efrank 1.1 }
869 :     else
870 :     {
871 : golsen 1.18 $family = $sz = $funcF = $fam_link = "";
872 : efrank 1.1 }
873 :    
874 :     my $id2_link = &HTML::set_prot_links($cgi,$id2);
875 : golsen 1.18 chomp $id2_link;
876 : overbeek 1.50
877 :     my @in_sub = $fig->peg_to_subsystems($id2);
878 :     my $in_sub;
879 :     if (@in_sub > 0)
880 :     {
881 :     $in_sub = @in_sub;
882 :     }
883 :     else
884 :     {
885 :     $in_sub = "";
886 :     }
887 :    
888 : golsen 1.18 my $psc = $sim->psc;
889 : overbeek 1.30 my $iden = $sim->iden;
890 : golsen 1.18 my $ln1 = $sim->ln1;
891 :     my $ln2 = $sim->ln2;
892 :     my $b1 = $sim->b1;
893 :     my $e1 = $sim->e1;
894 :     my $b2 = $sim->b2;
895 :     my $e2 = $sim->e2;
896 :     my $d1 = abs($e1 - $b1) + 1;
897 :     my $d2 = abs($e2 - $b2) + 1;
898 :     my $reg1 = "$b1-$e1 (<b>$d1/$ln1</b>)";
899 :     my $color1 = match_color( $b1, $e1, $ln1 );
900 :     my $reg2 = "$b2-$e2 (<b>$d2/$ln2</b>)";
901 :     my $color2 = match_color( $b2, $e2, $ln2 );
902 :     my $radio = $user ? shift @from : undef;
903 :     my $func2 = html_enc( scalar &trans_function_of( $cgi, $fig, $id2, $user ) );
904 : redwards 1.37 ## RAE Added color3. This will color function tables that do not match the original
905 :     ## annotation. This makes is a lot easier to see what is different (e.g. caps/spaces, etc)
906 :     my $color3="#FFFFFF";
907 :     unless ($func2 eq $current_func) {$color3="#FFDEAD"}
908 :    
909 : golsen 1.18 if ($funcF && $funcF ne $func2) { $func2 = "$funcF<br>$func2" }
910 : golsen 1.32
911 :     #
912 :     # Colorize organisms:
913 :     #
914 :     # my $org = html_enc( $fig->org_of( $id2 ) );
915 :     my ($org,$oc) = $fig->org_and_color_of( $id2 );
916 :     $org = html_enc( $org );
917 :    
918 : golsen 1.18 my $aliases = $alia ? html_enc( join( ", ", $fig->feature_aliases($id2) ) )
919 :     : undef;
920 :    
921 :     # Okay, everything is calculated, let's "print" the row datum-by-datum:
922 :    
923 :     push( @$html, "\t<TR>\n",
924 : golsen 1.32 #
925 :     # Colorize check box by Domain
926 :     #
927 :     "\t\t<TD Align=center Bgcolor=$oc>$cbox</TD>\n",
928 : golsen 1.18 $expand_groups ? "\t\t<TD>$fam_link</TD>/n" : (),
929 :     $expand_groups ? "\t\t<TD>$sz</TD>\n" : (),
930 :     "\t\t<TD Nowrap>$id2_link</TD>\n",
931 : overbeek 1.30 "\t\t<TD Nowrap>$psc<br>$iden\%</TD>\n",
932 : golsen 1.18 "\t\t<TD Nowrap Bgcolor=$color2>$reg2</TD>\n",
933 :     "\t\t<TD Nowrap Bgcolor=$color1>$reg1</TD>\n",
934 :     $user ? "\t\t<TD Align=center>$radio</TD>\n" : (),
935 : overbeek 1.50 "\t\t<TD>$in_sub</TD>",
936 : redwards 1.37 "\t\t<TD Bgcolor=$color3>$func2</TD>\n",
937 : golsen 1.32 #
938 :     # Colorize organism by Domain
939 :     #
940 :     # "\t\t<TD>$org</TD>\n",
941 :     "\t\t<TD Bgcolor=$oc>$org</TD>\n",
942 : golsen 1.18 $alia ? "\t\t<TD>$aliases</TD>\n" : (),
943 :     "\t</TR>\n"
944 : overbeek 1.11 );
945 : efrank 1.1 }
946 : overbeek 1.11
947 : golsen 1.18 push( @$html, "</TABLE>\n" );
948 :     push( @$html, $cgi->end_form );
949 : efrank 1.1 }
950 :     }
951 :    
952 : golsen 1.18 #
953 :     # Support functions for writing the similarities
954 :     #
955 :     # This is a sufficient set of escaping for text in HTML:
956 :     #
957 :    
958 :     sub html_enc { $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }
959 :    
960 :     #
961 :     # Make a background color that reflects the position and extent of a
962 :     # matching region.
963 :     #
964 :     # Left side is red; right side is blue.
965 :     # Long match is white or pastel; short match is saturated color.
966 :     #
967 :    
968 :     sub match_color {
969 :     my ( $b, $e, $n ) = @_;
970 :     my ( $l, $r ) = ( $e > $b ) ? ( $b, $e ) : ( $e, $b );
971 :     # my $hue = 3/4 * 0.5*($l+$r)/$n - 1/24;
972 :     my $hue = 5/6 * 0.5*($l+$r)/$n - 1/12;
973 :     my $cov = ( $r - $l + 1 ) / $n;
974 :     my $sat = 1 - 10 * $cov / 9;
975 :     # my $br = 0.8 + 0.2 * $cov;
976 :     my $br = 1;
977 :     rgb2html( hsb2rgb( $hue, $sat, $br ) );
978 :     }
979 :    
980 :     #
981 :     # Convert HSB to RGB. Hue is taken to be in range 0 - 1 (red to red);
982 :     #
983 :    
984 :     sub hsb2rgb {
985 :     my ( $h, $s, $br ) = @_;
986 :     $h = 6 * ($h - floor($h)); # Hue is made cyclic modulo 1
987 :     if ( $s > 1 ) { $s = 1 } elsif ( $s < 0 ) { $s = 0 }
988 :     if ( $br > 1 ) { $br = 1 } elsif ( $br < 0 ) { $br = 0 }
989 :     my ( $r, $g, $b ) = ( $h <= 3 ) ? ( ( $h <= 1 ) ? ( 1, $h, 0 )
990 :     : ( $h <= 2 ) ? ( 2 - $h, 1, 0 )
991 :     : ( 0, 1, $h - 2 )
992 :     )
993 :     : ( ( $h <= 4 ) ? ( 0, 4 - $h, 1 )
994 :     : ( $h <= 5 ) ? ( $h - 4, 0, 1 )
995 :     : ( 1, 0, 6 - $h )
996 :     );
997 :     ( ( $r * $s + 1 - $s ) * $br,
998 :     ( $g * $s + 1 - $s ) * $br,
999 :     ( $b * $s + 1 - $s ) * $br
1000 :     )
1001 :     }
1002 :    
1003 :     #
1004 :     # Convert an RGB value to an HTML color string:
1005 :     #
1006 :    
1007 :     sub rgb2html {
1008 :     my ( $r, $g, $b ) = @_;
1009 :     if ( $r > 1 ) { $r = 1 } elsif ( $r < 0 ) { $r = 0 }
1010 :     if ( $g > 1 ) { $g = 1 } elsif ( $g < 0 ) { $g = 0 }
1011 :     if ( $b > 1 ) { $b = 1 } elsif ( $b < 0 ) { $b = 0 }
1012 :     sprintf("\"#%02x%02x%02x\"", int(255.999*$r), int(255.999*$g), int(255.999*$b) )
1013 :     }
1014 :    
1015 :     #
1016 :     # floor could be gotten from POSIX::, but why bother?
1017 :     #
1018 :    
1019 :     sub floor {
1020 :     my $x = $_[0];
1021 :     defined( $x ) || return undef;
1022 :     ( $x >= 0 ) || ( int($x) == $x ) ? int( $x ) : -1 - int( - $x )
1023 :     }
1024 :    
1025 :    
1026 : efrank 1.1 ################# Context on the Chromosome ############################
1027 :    
1028 :     sub print_context {
1029 :     my($fig,$cgi,$html,$peg,$feat,$beg,$end) = @_;
1030 :     my($contig1,$beg1,$end1,$strand,$max_so_far,$gap,$comment,$fc,$aliases);
1031 :     my($why_related,$fid1,$sz,$color,$map,$gg,$n,$link,$in_neighborhood);
1032 :    
1033 : overbeek 1.41
1034 :     my $user = $cgi->param('user');
1035 :     push(@$html,$cgi->start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"),
1036 :     $cgi->hidden(-name => "prot", -value => $peg),
1037 : overbeek 1.44 $cgi->hidden(-name => "uni", -value => 1),
1038 : overbeek 1.41 $cgi->hidden(-name => "user", -value => $user));
1039 :    
1040 : efrank 1.1 $why_related = "";
1041 :     my %in_cluster = map { $_ => 1 } $fig->in_cluster_with($peg);;
1042 :    
1043 : overbeek 1.41 my $col_hdrs = ["fid","starts","ends","size","","gap","req.<br>in<br>pin","fc","neigh","comment","aliases","Related"];
1044 : efrank 1.1 my($tab) = [];
1045 :     my $genes = [];
1046 :    
1047 :     my $peg_function = &trans_function_of($cgi,$fig,$peg,$user);
1048 :    
1049 :     my($role,$role1,%related_roles);
1050 :     foreach $role (&FIG::roles_of_function($peg_function))
1051 :     {
1052 :     foreach $role1 ($fig->neighborhood_of_role($role))
1053 :     {
1054 :     $related_roles{$role1} = 1;
1055 :     }
1056 :     }
1057 :    
1058 :     foreach $fid1 (@$feat)
1059 :     {
1060 :     $fc = $in_cluster{$fid1} ? &pin_link($cgi,$fid1) : "";
1061 : olson 1.48 my $aliases = join( ', ', $fig->feature_aliases($fid1) );
1062 : overbeek 1.6 ($contig1,$beg1,$end1) = $fig->boundaries_of(scalar $fig->feature_location($fid1));;
1063 : efrank 1.1 $strand = ($beg1 < $end1) ? "+" : "-";
1064 :    
1065 : olson 1.48 my $function = $fig->function_of($fid1);
1066 :     my $uniprot;
1067 :     if ($aliases =~ /(uni[^,]+)/) {
1068 :     # print STDERR "$1\n";
1069 :     $uniprot = $1;
1070 :     }
1071 :     my $info = join ('<br/>', "<b>PEG:</b> ".$fid1, "<b>Contig:</b> ".$contig1, "<b>Begin:</b> ".$beg1, "<b>End:</b> ".$end1,$function ? "<b>Function:</b> ".$function : '', $uniprot ? "<b>Uniprot ID:</b> ".$uniprot : '');
1072 :    
1073 :    
1074 : efrank 1.1 if ($fid1 eq $peg) { $color = "green" }
1075 :     elsif ($fc) { $color = "blue" }
1076 :     else { $color = "red" }
1077 :    
1078 :     if ($fid1 =~ /peg\.(\d+)$/)
1079 :     {
1080 :     $n = $1;
1081 :     $link = $cgi->url() . "?prot=$fid1&user=$user";
1082 :     }
1083 :     elsif ($fid1 =~ /\.([a-z]+)\.\d+$/)
1084 :     {
1085 :     $n = uc $1;
1086 :     $link = "";
1087 :     }
1088 :     else
1089 :     {
1090 :     $n ="";
1091 :     $link = "";
1092 :     }
1093 :    
1094 : olson 1.48 push(@$genes,[&FIG::min($beg1,$end1),&FIG::max($beg1,$end1),($strand eq "+") ? "rightArrow" : "leftArrow", $color,$n,$link,$info]);
1095 : efrank 1.1 if ($max_so_far)
1096 :     {
1097 :     $gap = (&FIG::min($beg1,$end1) - $max_so_far) - 1;
1098 :     }
1099 :     else
1100 :     {
1101 :     $gap = "";
1102 :     }
1103 :     $max_so_far = &FIG::max($beg1,$end1);
1104 :    
1105 :    
1106 :     $in_neighborhood = "";
1107 :     if (&FIG::ftype($fid1) eq "peg")
1108 :     {
1109 :     $comment = &trans_function_of($cgi,$fig,$fid1,$user);
1110 :     foreach $role (&FIG::roles_of_function($comment))
1111 :     {
1112 :     if ($related_roles{$role})
1113 :     {
1114 :     $in_neighborhood = "*";
1115 :     }
1116 :     }
1117 :     }
1118 :     else
1119 :     {
1120 :     $comment = "";
1121 :     }
1122 :     $comment = &set_map_links($fig,&FIG::genome_of($fid1),$comment);
1123 : overbeek 1.17 if ($fid1 eq $peg)
1124 :     {
1125 : overbeek 1.20 $comment = "\@bgcolor=\"#00FF00\":$comment";
1126 : overbeek 1.17 }
1127 : efrank 1.1 $sz = abs($end1-$beg1)+1;
1128 :    
1129 : overbeek 1.42 my $must_have = (($fid1 eq $peg) || (! $fc)) ? "" : $cgi->checkbox(-name => 'must_have',
1130 :     -value => $fid1,
1131 :     -checked => 0,
1132 :     -override => 1,
1133 :     -label => "");
1134 : overbeek 1.41
1135 :     push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,
1136 :     $must_have,
1137 :     $fc,$in_neighborhood,
1138 : overbeek 1.33 $comment,&HTML::set_prot_links($cgi,$aliases),$why_related]);
1139 : efrank 1.1 }
1140 :     $map = ["",$beg,$end,$genes];
1141 :     $gg = [$map];
1142 : overbeek 1.27 push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on contig $contig1"));
1143 : overbeek 1.41 push(@$html,$cgi->br,$cgi->submit('pin with checked genes'),$cgi->end_form,$cgi->br);
1144 : overbeek 1.2 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });
1145 : efrank 1.1 return;
1146 :     }
1147 :    
1148 :     sub assign_link {
1149 :     my($cgi,$func,$existing_func) = @_;
1150 :     my($assign_url,$assign_link);
1151 :    
1152 :     if ($func && ((! $existing_func) || ($existing_func ne $func)))
1153 :     {
1154 :     $cgi->delete('request');
1155 :     $assign_url = $cgi->self_url() . "&request=fast_assign&func=$func"; ## must encode
1156 :     $assign_link = "<a href=\"$assign_url\">&nbsp;<=&nbsp;</a>";
1157 :     }
1158 :     else
1159 :     {
1160 :     $assign_link = "";
1161 :     }
1162 :     return $assign_link;
1163 :     }
1164 :    
1165 :     sub pin_link {
1166 :     my($cgi,$peg) = @_;
1167 :     my $user = $cgi->param('user');
1168 :     $user = defined($user) ? $user : "";
1169 :    
1170 : overbeek 1.44 my $cluster_url = "chromosomal_clusters.cgi?prot=$peg&user=$user&uni=1";
1171 : efrank 1.1 my $cluster_link = "<a href=\"$cluster_url\">*</a>";
1172 :     return $cluster_link;
1173 :     }
1174 :    
1175 :     sub set_map_links {
1176 :     my($fig,$org,$func) = @_;
1177 :    
1178 :     if ($func =~ /^(.*)(\d+\.\d+\.\d+\.\d+)(.*)$/)
1179 :     {
1180 :     my $before = $1;
1181 :     my $ec = $2;
1182 :     my $after = $3;
1183 :     return &set_map_links($fig,$org,$before) . &set_ec_to_maps($fig,$org,$ec) . &set_map_links($fig,$org,$after);
1184 :     }
1185 :     return $func;
1186 :     }
1187 :    
1188 :     sub set_ec_to_maps {
1189 :     my($fig,$org,$ec) = @_;
1190 :    
1191 :     my @maps = $fig->ec_to_maps($ec);
1192 :     if (@maps > 0)
1193 :     {
1194 :     $cgi->delete('request');
1195 :     my $url = $cgi->self_url() . "&request=ec_to_maps&ec=$ec&org=$org";
1196 :     my $link = "<a href=\"$url\">$ec</a>";
1197 :     return $link;
1198 :     }
1199 :     return $ec;
1200 :     }
1201 :    
1202 :     sub show_ec_to_maps {
1203 :     my($fig,$cgi,$html,$ec) = @_;
1204 :    
1205 :     my $ec = $cgi->param('ec');
1206 :     if (! $ec)
1207 :     {
1208 :     push(@$html,$cgi->h1("Missing EC number"));
1209 :     return;
1210 :     }
1211 :    
1212 :     my @maps = $fig->ec_to_maps($ec);
1213 :     if (@maps > 0)
1214 :     {
1215 :     my $col_hdrs = ["map","metabolic topic"];
1216 :     my $map;
1217 :     my $tab = [map { $map = $_; [&map_link($cgi,$map),$fig->map_name($map)] } @maps];
1218 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"$ec: " . $fig->ec_name($ec)));
1219 :     }
1220 :     }
1221 :    
1222 :     sub map_link {
1223 :     my($cgi,$map) = @_;
1224 :    
1225 :     $cgi->delete('request');
1226 :     my $url = $cgi->self_url() . "&request=link_to_map&map=$map";
1227 :     my $link = "<a href=\"$url\">$map</a>";
1228 :     return $link;
1229 :     }
1230 :    
1231 :     sub link_to_map {
1232 :     my($fig,$cgi,$html) = @_;
1233 :    
1234 :     my $map = $cgi->param('map');
1235 :     if (! $map)
1236 :     {
1237 :     push(@$html,$cgi->h1("Missing Map"));
1238 :     return;
1239 :     }
1240 :    
1241 :     my $org = $cgi->param('org');
1242 :     if (! $org)
1243 :     {
1244 :     push(@$html,$cgi->h1("Missing Org Parameter"));
1245 :     return;
1246 :     }
1247 :     my$user = $cgi->param('user');
1248 :     $user = $user ? $user : "";
1249 :    
1250 :     $ENV{"REQUEST_METHOD"} = "GET";
1251 :     $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$org";
1252 :     my @out = `./show_kegg_map.cgi`;
1253 :     &HTML::trim_output(\@out);
1254 :     push(@$html,@out);
1255 :     }
1256 :    
1257 :     sub aa_sequence {
1258 :     my($fig,$cgi,$html,$prot) = @_;
1259 :     my($seq,$func,$i);
1260 :    
1261 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Protein Sequence</TITLE>\n";
1262 : efrank 1.1 if ($seq = $fig->get_translation($prot))
1263 :     {
1264 :     $func = $fig->function_of($prot,$cgi->param('user'));
1265 :     push(@$html,$cgi->pre,">$prot $func\n");
1266 :     for ($i=0; ($i < length($seq)); $i += 60)
1267 :     {
1268 :     if ($i > (length($seq) - 60))
1269 :     {
1270 :     push(@$html,substr($seq,$i) . "\n");
1271 :     }
1272 :     else
1273 :     {
1274 :     push(@$html,substr($seq,$i,60) . "\n");
1275 :     }
1276 :     }
1277 :     push(@$html,$cgi->end_pre);
1278 :     }
1279 :     else
1280 :     {
1281 :     push(@$html,$cgi->h1("No translation available for $prot"));
1282 :     }
1283 :     }
1284 :    
1285 :     sub dna_sequence {
1286 :     my($fig,$cgi,$html,$fid) = @_;
1287 :     my($seq,$func,$i);
1288 :    
1289 : golsen 1.19 unshift @$html, "<TITLE>The SEED: Nucleotide Sequence</TITLE>\n";
1290 : efrank 1.1 if ($seq = $fig->dna_seq($fig->genome_of($fid),scalar $fig->feature_location($fid)))
1291 :     {
1292 :     $func = $fig->function_of($prot,$cgi->param('user'));
1293 :     push(@$html,$cgi->pre,">$fid $func\n");
1294 :     for ($i=0; ($i < length($seq)); $i += 60)
1295 :     {
1296 :     if ($i > (length($seq) - 60))
1297 :     {
1298 :     push(@$html,substr($seq,$i) . "\n");
1299 :     }
1300 :     else
1301 :     {
1302 :     push(@$html,substr($seq,$i,60) . "\n");
1303 :     }
1304 :     }
1305 :     push(@$html,$cgi->end_pre);
1306 :     }
1307 :     else
1308 :     {
1309 :     push(@$html,$cgi->h1("No DNA sequence available for $fid"));
1310 :     }
1311 :     }
1312 :    
1313 :     sub show_fusions {
1314 :     my($fig,$cgi,$html,$prot) = @_;
1315 :    
1316 : overbeek 1.22 my $user = $cgi->param('user');
1317 :     $user = $user ? $user : "";
1318 : efrank 1.1 $ENV{"REQUEST_METHOD"} = "GET";
1319 : overbeek 1.22 $ENV{"QUERY_STRING"} = "peg=$prot&user=$user";
1320 : efrank 1.1 my @out = `./fusions.cgi`;
1321 :     print join("",@out);
1322 :     exit;
1323 : overbeek 1.2 }
1324 :    
1325 :     sub print_compared_regions {
1326 :     my($fig,$cgi,$html,$peg) = @_;
1327 :    
1328 :     my @closest_pegs = &closest_pegs($fig,$peg,5);
1329 : overbeek 1.40
1330 : overbeek 1.2 if (@closest_pegs > 0)
1331 :     {
1332 :     if ($fig->possibly_truncated($peg))
1333 :     {
1334 :     push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));
1335 :     }
1336 : overbeek 1.13 @closest_pegs = $fig->sort_fids_by_taxonomy(@closest_pegs);
1337 : overbeek 1.2 unshift(@closest_pegs,$peg);
1338 :     my @all_pegs = ();
1339 :     my $gg = &build_maps($fig,\@closest_pegs,\@all_pegs);
1340 : olson 1.48 #warn Dumper($gg);
1341 : overbeek 1.2 my $color_sets = &cluster_genes(\@all_pegs,$peg);
1342 :     &set_colors_text_and_links($gg,\@all_pegs,$color_sets);
1343 : overbeek 1.35 ################################### add commentary capability
1344 :    
1345 :     my @commentary_form = ();
1346 :     my $ctarget = "window$$";
1347 :     my $user = $cgi->param('user');
1348 :     push(@commentary_form,$cgi->start_form(-target => $ctarget,
1349 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi"
1350 :     ));
1351 :     push(@commentary_form,$cgi->hidden(-name => "request", -value => "show_commentary"));
1352 :     push(@commentary_form,$cgi->hidden(-name => "prot", -value => $peg));
1353 : overbeek 1.44 push(@commentary_form,$cgi->hidden(-name => "uni", -value => 1));
1354 : overbeek 1.35 push(@commentary_form,$cgi->hidden(-name => "user", -value => $user));
1355 :    
1356 :     my($gene,$n,%how_many,$val,@vals,$x);
1357 :     my($i,$map);
1358 :     @vals = ();
1359 :     for ($i=(@$gg - 1); ($i >= 0); $i--)
1360 :     {
1361 :     my @vals1 = ();
1362 :     $map = $gg->[$i];
1363 :     my $found = 0;
1364 :     my $got_red = 0;
1365 :     undef %how_many;
1366 :     foreach $gene (@{$map->[3]})
1367 :     {
1368 :     if (($x = $gene->[3]) ne "grey")
1369 :     {
1370 :     $n = $gene->[4];
1371 :     if ($n == 1) { $got_red = 1 }
1372 :     $how_many{$n}++;
1373 :     $gene->[5] =~ /(fig\|\d+\.\d+\.peg\.\d+)/;
1374 :     $val = join("@",($n,$i,$1,$map->[0],$how_many{$n}));
1375 :     push(@vals1,$val);
1376 :     $found++;
1377 :     }
1378 :     }
1379 :    
1380 :     if (! $got_red)
1381 :     {
1382 :     splice(@$gg,$i,1);
1383 :     }
1384 :     else
1385 :     {
1386 :     push(@vals,@vals1);
1387 :     }
1388 :     }
1389 :    
1390 :     if (@$gg == 0)
1391 :     {
1392 :     push(@$html,$cgi->h1("Sorry, no pins worked out"));
1393 :     }
1394 :     else
1395 :     {
1396 :     push(@commentary_form,$cgi->hidden(-name => "show", -value => [@vals]));
1397 :     push(@commentary_form,$cgi->submit('commentary'));
1398 :     push(@commentary_form,$cgi->end_form());
1399 :     push(@$html,@commentary_form);
1400 :     }
1401 :     ################################################################end commentary
1402 : overbeek 1.2 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });
1403 : olson 1.48 push @$html, &FIGGenDB::linkClusterGenDB($peg);
1404 : overbeek 1.2 }
1405 :     }
1406 :    
1407 :     sub closest_pegs {
1408 :     my($fig,$peg,$n) = @_;
1409 :     my($id2,$d,$peg2,$i);
1410 :    
1411 :     my @closest = map { $id2 = $_->id2; ($id2 =~ /^fig\|/) ? $id2 : () } $fig->sims($peg,5,1.0e-20,"all");
1412 :    
1413 :     if (@closest > $n) { $#closest = $n-1 }
1414 :     my %closest = map { $_ => 1 } @closest;
1415 : overbeek 1.3 my @pinned_to = grep { $_ ne $peg} $fig->in_pch_pin_with($peg);
1416 : overbeek 1.2 my $g1 = &FIG::genome_of($peg);
1417 :     @pinned_to =
1418 :     map {$_->[1] }
1419 :     sort { $a->[0] <=> $b->[0] }
1420 :     map { $peg2 = $_; $d = $fig->crude_estimate_of_distance($g1,&FIG::genome_of($peg2)); [$d,$peg2] }
1421 :     @pinned_to;
1422 :    
1423 :     for ($i=0; ($i < @pinned_to) && ($i < $n); $i++)
1424 :     {
1425 :     $closest{$pinned_to[$i]} = 1;
1426 :     }
1427 :     return return keys(%closest);
1428 :     }
1429 :    
1430 :     sub build_maps {
1431 :     my($fig,$pinned_pegs,$all_pegs) = @_;
1432 :     my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);
1433 :     my($contig1,$beg1,$end1,$map,$peg);
1434 :    
1435 :     $gg = [];
1436 :     foreach $peg (@$pinned_pegs)
1437 :     {
1438 :     $loc = $fig->feature_location($peg);
1439 :     ($contig,$beg,$end) = &FIG::boundaries_of($loc);
1440 :     if ($contig && $beg && $end)
1441 :     {
1442 :     $mid = int(($beg + $end) / 2);
1443 :     $min = $mid - 8000;
1444 :     $max = $mid + 8000;
1445 :     $genes = [];
1446 :     ($feat,undef,undef) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);
1447 :     foreach $fid (@$feat)
1448 :     {
1449 :     ($contig1,$beg1,$end1) = &FIG::boundaries_of(scalar $fig->feature_location($fid));
1450 :     $beg1 = &in_bounds($min,$max,$beg1);
1451 :     $end1 = &in_bounds($min,$max,$end1);
1452 : olson 1.48 my $aliases = join( ', ', $fig->feature_aliases($fid) );
1453 :     my $function = $fig->function_of($fid);
1454 :     my $uniprot;
1455 :     if ($aliases =~ /(uni[^,]+)/) {
1456 :     $uniprot = $1;
1457 :     }
1458 :     my $info = join ('<br/>', "<b>PEG:</b> ".$fid, "<b>Contig:</b> ".$contig1, "<b>Begin:</b> ".$beg1, "<b>End:</b> ".$end1,$function ? "<b>Function:</b> ".$function : '', $uniprot ? "<b>Uniprot ID:</b> ".$uniprot : '');
1459 :     my $fmg = join ('<br/>', "<a href=\&quot;protein.cgi?compare_region=1\&prot=$fid\&user=\&quot>show</a>",
1460 :     "<a onClick=\&quot;setValue('bound1', '$fid'); return false;\&quot;>set bound 1</a>",
1461 :     "<a onClick=\&quot;setValue('bound2', '$fid'); return false;\&quot;>set bound 2</a>",
1462 :     "<a onClick=\&quot;setValue('candidates', '$fid'); return false;\&quot;>set candidate</a>");
1463 :    
1464 : overbeek 1.2 push(@$genes,[&FIG::min($beg1,$end1),
1465 :     &FIG::max($beg1,$end1),
1466 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
1467 :     "grey",
1468 :     "",
1469 : olson 1.48 $fid,
1470 :     $info, $fmg]);
1471 : overbeek 1.2
1472 :     if ($fid =~ /peg/)
1473 :     {
1474 :     push(@$all_pegs,$fid);
1475 :     }
1476 :     }
1477 :     $map = [&FIG::abbrev($fig->org_of($peg)),0,$max+1-$min,
1478 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)];
1479 :     push(@$gg,$map);
1480 :     }
1481 :     }
1482 : overbeek 1.40
1483 :     my(%seen,$abbr);
1484 :     foreach $map (@$gg)
1485 :     {
1486 :     $abbr = $map->[0];
1487 :     if (defined($seen{$abbr}))
1488 :     {
1489 :     $seen{$abbr}++;
1490 :     $map->[0] = substr($map->[0],0,10) . "\*$seen{$abbr}";
1491 :     }
1492 :     else
1493 :     {
1494 :     $seen{$abbr} = 0;
1495 :     }
1496 :     }
1497 : overbeek 1.2 return $gg;
1498 :     }
1499 :    
1500 :     sub in {
1501 :     my($x,$xL) = @_;
1502 :     my($i);
1503 :    
1504 :     for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
1505 :     return ($i < @$xL);
1506 :     }
1507 :    
1508 :     sub in_bounds {
1509 :     my($min,$max,$x) = @_;
1510 :    
1511 :     if ($x < $min) { return $min }
1512 :     elsif ($x > $max) { return $max }
1513 :     else { return $x }
1514 :     }
1515 :    
1516 :     sub decr_coords {
1517 :     my($genes,$min) = @_;
1518 :     my($gene);
1519 :    
1520 :     foreach $gene (@$genes)
1521 :     {
1522 :     $gene->[0] -= $min;
1523 :     $gene->[1] -= $min;
1524 :     }
1525 :     return $genes;
1526 :     }
1527 :    
1528 :     sub flip_map {
1529 :     my($genes,$min,$max) = @_;
1530 :     my($gene);
1531 :    
1532 :     foreach $gene (@$genes)
1533 :     {
1534 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
1535 :     $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
1536 :     }
1537 :     return $genes;
1538 :     }
1539 :    
1540 :     sub cluster_genes {
1541 :     my($all_pegs,$peg) = @_;
1542 :     my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
1543 :    
1544 :     my @color_sets = ();
1545 :    
1546 :     $conn = &get_connections_by_similarity($all_pegs);
1547 :     for ($i=0; ($i < @$all_pegs); $i++)
1548 :     {
1549 :     if ($all_pegs->[$i] eq $peg) { $pegI = $i }
1550 :     if (! $seen{$i})
1551 :     {
1552 :     $cluster = [$i];
1553 :     $seen{$i} = 1;
1554 :     for ($j=0; ($j < @$cluster); $j++)
1555 :     {
1556 :     $x = $conn->{$cluster->[$j]};
1557 :     foreach $k (@$x)
1558 :     {
1559 :     if (! $seen{$k})
1560 :     {
1561 :     push(@$cluster,$k);
1562 :     $seen{$k} = 1;
1563 :     }
1564 :     }
1565 :     }
1566 :    
1567 :     if ((@$cluster > 1) || ($cluster->[0] eq $pegI))
1568 :     {
1569 :     push(@color_sets,$cluster);
1570 :     }
1571 :     }
1572 :     }
1573 :     for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
1574 :     $red_set = $color_sets[$i];
1575 :     splice(@color_sets,$i,1);
1576 :     @color_sets = sort { @$b <=> @$a } @color_sets;
1577 :     unshift(@color_sets,$red_set);
1578 :    
1579 :     my $color_sets = {};
1580 :     for ($i=0; ($i < @color_sets); $i++)
1581 :     {
1582 :     foreach $x (@{$color_sets[$i]})
1583 :     {
1584 :     $color_sets->{$all_pegs->[$x]} = $i;
1585 :     }
1586 :     }
1587 :     return $color_sets;
1588 :     }
1589 :    
1590 :     sub get_connections_by_similarity {
1591 :     my($all_pegs) = @_;
1592 : overbeek 1.40 my($i,$j,$tmp,$peg,%pos_of);
1593 :     my($sim,%conn,$x,$y);
1594 : overbeek 1.2
1595 :     for ($i=0; ($i < @$all_pegs); $i++)
1596 :     {
1597 : overbeek 1.5 $tmp = $fig->maps_to_id($all_pegs->[$i]);
1598 :     push(@{$pos_of{$tmp}},$i); # map the representative in nr to subscript in all_pegs
1599 :     if ($tmp ne $all_pegs->[$i])
1600 : overbeek 1.2 {
1601 :     push(@{$pos_of{$all_pegs->[$i]}},$i);
1602 :     }
1603 :     }
1604 :    
1605 : overbeek 1.40 foreach $y (keys(%pos_of))
1606 :     {
1607 :     $x = $pos_of{$y};
1608 :     for ($i=0; ($i < @$x); $i++)
1609 :     {
1610 :     for ($j=$i+1; ($j < @$x); $j++)
1611 :     {
1612 :     push(@{$conn{$x->[$i]}},$x->[$j]);
1613 :     push(@{$conn{$x->[$j]}},$x->[$i]);
1614 :     }
1615 :     }
1616 :     }
1617 :    
1618 : overbeek 1.2 for ($i=0; ($i < @$all_pegs); $i++)
1619 :     {
1620 :     foreach $sim ($fig->sims($all_pegs->[$i],500,1.0e-5,"raw"))
1621 :     {
1622 :     if (defined($x = $pos_of{$sim->id2}))
1623 :     {
1624 :     foreach $y (@$x)
1625 :     {
1626 :     push(@{$conn{$i}},$y);
1627 :     }
1628 :     }
1629 :     }
1630 :     }
1631 :     return \%conn;
1632 :     }
1633 :    
1634 :     sub set_colors_text_and_links {
1635 :     my($gg,$all_pegs,$color_sets) = @_;
1636 :     my($map,$gene,$peg,$color);
1637 :    
1638 :     foreach $map (@$gg)
1639 :     {
1640 :     foreach $gene (@{$map->[3]})
1641 :     {
1642 :     $peg = $gene->[5];
1643 :     if (defined($color = $color_sets->{$peg}))
1644 :     {
1645 : overbeek 1.35 $gene->[3] = ($color == 0) ? "red" : "color$color";
1646 : overbeek 1.2 $gene->[4] = $color + 1;
1647 :     }
1648 :     $gene->[5] = &peg_url($cgi,$peg);
1649 :     }
1650 :     }
1651 :     }
1652 :    
1653 :     sub peg_url {
1654 :     my($cgi,$peg) = @_;
1655 :    
1656 :     my $prot = $cgi->param('prot');
1657 :     $cgi->delete('prot');
1658 :     my $url = $cgi->self_url() . "&prot=$peg&compare_region=1";
1659 :     $cgi->delete('prot');
1660 :     $cgi->param(-name => 'prot', -value => $prot);
1661 :    
1662 :     return $url;
1663 :     }
1664 :    
1665 :     sub possible_extensions {
1666 :     my($peg,$closest_pegs) = @_;
1667 :     my($g,$sim,$id2,$peg1,%poss);
1668 :    
1669 :     $g = &FIG::genome_of($peg);
1670 :    
1671 :     foreach $peg1 (@$closest_pegs)
1672 :     {
1673 :     if ($g ne &FIG::genome_of($peg1))
1674 :     {
1675 :     foreach $sim ($fig->sims($peg1,500,1.0e-5,"all"))
1676 :     {
1677 :     $id2 = $sim->id2;
1678 :     if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && $fig->possibly_truncated($id2))
1679 :     {
1680 :     $poss{$id2} = 1;
1681 :     }
1682 :     }
1683 :     }
1684 :     }
1685 :     return keys(%poss);
1686 : efrank 1.1 }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3