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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.17 - (view) (download)

1 : efrank 1.1 use FIG;
2 :     my $fig = new FIG;
3 :    
4 :     use HTML;
5 :     use strict;
6 :     use GenoGraphics;
7 :     use CGI;
8 :     my $cgi = new CGI;
9 :    
10 :     if (0)
11 :     {
12 :     print $cgi->header;
13 :     my @params = $cgi->param;
14 :     print "<pre>\n";
15 :     foreach $_ (@params)
16 :     {
17 :     print "$_\t:",join(",",$cgi->param($_)),":\n";
18 :     }
19 :     exit;
20 :     }
21 :    
22 :     my $html = [];
23 :    
24 :     my $prot = $cgi->param('prot');
25 :     if (! $prot)
26 :     {
27 :     push(@$html,"<h1>Sorry, you need to specify a protein</h1>\n");
28 :     &HTML::show_page($cgi,$html);
29 :     exit;
30 :     }
31 : overbeek 1.16 elsif ($prot !~ /^fig\|/)
32 :     {
33 :     if ($_ = $fig->by_alias($prot))
34 :     {
35 :     $prot = $_;
36 :     }
37 :     else
38 :     {
39 :     push(@$html,"<h1>Sorry, $prot appears not to have a FIG id at this point</h1>\n");
40 :     &HTML::show_page($cgi,$html);
41 :     exit;
42 :     }
43 :     }
44 :    
45 : efrank 1.1 my $request = $cgi->param("request");
46 :     $request = defined($request) ? $request : "";
47 :    
48 : overbeek 1.11 if ($request eq "use_protein_tool") { &use_protein_tool($fig,$cgi,$prot); }
49 :     elsif ($request eq "view_annotations") { &view_annotations($fig,$cgi,$html,$prot); }
50 : overbeek 1.15 elsif ($request eq "view_all_annotations") { &view_all_annotations($fig,$cgi,$html,$prot); }
51 : overbeek 1.11 elsif ($request eq "aa_sequence") { &aa_sequence($fig,$cgi,$html,$prot); }
52 :     elsif ($request eq "dna_sequence") { &dna_sequence($fig,$cgi,$html,$prot); }
53 :     elsif ($request eq "fast_assign") { &make_assignment($fig,$cgi,$html,$prot); }
54 :     elsif ($request eq "show_coupling_evidence") { &show_coupling_evidence($fig,$cgi,$html,$prot); }
55 :     elsif ($request eq "ec_to_maps") { &show_ec_to_maps($fig,$cgi,$html); }
56 :     elsif ($request eq "link_to_map") { &link_to_map($fig,$cgi,$html); }
57 :     elsif ($request eq "fusions") { &show_fusions($fig,$cgi,$html,$prot); }
58 :     else { &show_initial($fig,$cgi,$html,$prot); }
59 : efrank 1.1
60 :     &HTML::show_page($cgi,$html);
61 : overbeek 1.11 exit;
62 :    
63 :     #==============================================================================
64 :     # use_protein_tool
65 :     #==============================================================================
66 : efrank 1.1
67 :     sub use_protein_tool {
68 :     my($fig,$cgi,$prot) = @_;
69 :     my($url,$method,@args,$line,$name,$val);
70 :    
71 :     my $seq = $fig->get_translation($prot);
72 :     if (! $seq)
73 :     {
74 :     push(@$html,$cgi->h1("Sorry, $prot does not have a translation"));
75 :     return;
76 :     }
77 :     my $protQ = quotemeta $prot;
78 :    
79 :     my $tool = $cgi->param('tool');
80 :     $/ = "\n//\n";
81 :     my @tools = grep { $_ =~ /^$tool\n/ } `cat $FIG_Config::global/LinksToTools`;
82 :     if (@tools == 1)
83 :     {
84 :     chomp $tools[0];
85 :     (undef,undef,$url,$method,@args) = split(/\n/,$tools[0]);
86 :     my $args = [];
87 :     foreach $line (@args)
88 :     {
89 :     ($name,$val) = split(/\t/,$line);
90 :     $val =~ s/FIGID/$prot/;
91 :     $val =~ s/FIGSEQ/$seq/;
92 :     $val =~ s/\\n/\n/g;
93 :     push(@$args,[$name,$val]);
94 :     }
95 :     push(@$html,&HTML::get_html($url,$method,$args));
96 :     }
97 :     }
98 :    
99 : overbeek 1.11 #==============================================================================
100 :     # make_assignment
101 :     #==============================================================================
102 :    
103 : efrank 1.1 sub make_assignment {
104 :     my($fig,$cgi,$html,$prot) = @_;
105 :     my($userR);
106 :    
107 :     my $function = $cgi->param('func');
108 :     my $user = $cgi->param('user');
109 :    
110 :     if ($function && $user && $prot)
111 :     {
112 :     if ($user =~ /master:(.*)/)
113 :     {
114 :     $userR = $1;
115 :     $fig->assign_function($prot,"master",$function,"");
116 :     $fig->add_annotation($prot,$userR,"Set master function to\n$function\n");
117 :     }
118 :     else
119 :     {
120 :     $fig->assign_function($prot,$user,$function,"");
121 :     $fig->add_annotation($prot,$user,"Set function to\n$function\n");
122 :     }
123 :     }
124 :     $cgi->delete("request");
125 :     $cgi->delete("func");
126 :     &show_initial($fig,$cgi,$html,$prot);
127 :     }
128 :    
129 : overbeek 1.11 #==============================================================================
130 :     # view_annotations
131 :     #==============================================================================
132 :    
133 : efrank 1.1 sub view_annotations {
134 :     my($fig,$cgi,$html,$prot) = @_;
135 :    
136 :     my $col_hdrs = ["who","when","annotation"];
137 : overbeek 1.9 my $tab = [ map { [$_->[2],$_->[1],"<pre>" . $_->[3] . "<\/pre>"] } $fig->feature_annotations($prot) ];
138 : efrank 1.1 if (@$tab > 0)
139 :     {
140 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Annotations for $prot"));
141 :     }
142 :     else
143 :     {
144 :     push(@$html,"<h1>No Annotations for $prot</h1>\n");
145 :     }
146 :     }
147 :    
148 : overbeek 1.15 sub view_all_annotations {
149 :     my($fig,$cgi,$html,$peg) = @_;
150 :     my($ann);
151 :    
152 :     if ($fig->is_real_feature($peg))
153 :     {
154 :     my $col_hdrs = ["who","when","PEG","genome","annotation"];
155 :     my @related = $fig->related_by_func_sim($peg,$cgi->param('user'));
156 :     push(@related,$peg);
157 :    
158 :     my @annotations = $fig->merged_related_annotations(\@related);
159 :    
160 :     my $tab = [ map { $ann = $_;
161 :     [$ann->[2],$ann->[1],&HTML::fid_link($cgi,$ann->[0]),
162 :     $fig->genus_species(&FIG::genome_of($ann->[0])),
163 :     "<pre>" . $ann->[3] . "</pre>"
164 :     ] } @annotations];
165 :     if (@$tab > 0)
166 :     {
167 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"All Related Annotations for $peg"));
168 :     }
169 :     else
170 :     {
171 :     push(@$html,"<h1>No Annotations for $peg</h1>\n");
172 :     }
173 :     }
174 :     }
175 :    
176 : overbeek 1.11 #==============================================================================
177 :     # show_coupling_evidence
178 :     #==============================================================================
179 :    
180 : efrank 1.1 sub show_coupling_evidence {
181 :     my($fig,$cgi,$html,$peg) = @_;
182 :     my($pair,$peg1,$peg2,$link1,$link2);
183 :    
184 :     my $user = $cgi->param('user');
185 :     my $to = $cgi->param('to');
186 :     my @coup = grep { $_->[1] eq $to } $fig->coupling_and_evidence($peg,5000,1.0e-20,0.1,"keep");
187 :    
188 :     if (@coup != 1)
189 :     {
190 :     push(@$html,"<h1>Sorry, no evidence that $peg is coupled to $to</h1>\n");
191 :     }
192 :     else
193 :     {
194 :     my $col_hdrs = ["Peg1","Organism1","Function1","Peg2","Organism2","Function2"];
195 :     my $tab = [];
196 :     foreach $pair (@{$coup[0]->[2]})
197 :     {
198 :     ($peg1,$peg2) = @$pair;
199 :     $link1 = &HTML::fid_link($cgi,$peg1);
200 :     $link2 = &HTML::fid_link($cgi,$peg2);
201 : overbeek 1.11 push( @$tab, [ $link1,
202 :     $fig->org_of($peg1),
203 :     scalar $fig->function_of($peg1,$user),
204 :     $link2,
205 :     $fig->org_of($peg2),
206 :     scalar $fig->function_of($peg2,$user)
207 :     ]
208 :     );
209 : efrank 1.1 }
210 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Evidence that $peg Is Coupled To $to"));
211 :     }
212 :     }
213 :    
214 : overbeek 1.11 #==============================================================================
215 :     # psi_blast_prot_sequence
216 :     #==============================================================================
217 :    
218 : efrank 1.1 sub psi_blast_prot_sequence {
219 :     my($fig,$cgi,$prot_id) = @_;
220 :     }
221 :    
222 : overbeek 1.11 #==============================================================================
223 :     # show_initial
224 :     #==============================================================================
225 :    
226 : efrank 1.1 sub show_initial {
227 :     my($fig,$cgi,$html,$prot) = @_;
228 :    
229 :     my $gs = $fig->org_of($prot);
230 :     push(@$html,"<h1>Protein $prot: $gs</h1>\n");
231 :     if ($prot =~ /^fig\|\d+\.\d+\.peg/)
232 :     {
233 :     my $msg;
234 : overbeek 1.11 my $url = $cgi->self_url();
235 :     if ($cgi->param('translate')) {
236 :     $url =~ s/[;&]translate(=[^;&])?//i or $url =~ s/translate(=[^;&])?[;&]//i;
237 :     $msg = "Turn Off Function Translation";
238 :     }
239 :     else
240 :     {
241 :     $url .= ";translate=1";
242 :     $msg = "Translate Function Assignments";
243 :     }
244 :     push(@$html, "<a href=\"$url\">$msg</a><br>\n");
245 : efrank 1.1
246 :     &display_peg($fig,$cgi,$html,$prot);
247 :     }
248 :     else
249 :     {
250 :     # &display_external($fig,$cgi,$html,$prot);
251 :     }
252 :     }
253 :    
254 : overbeek 1.11 #==============================================================================
255 :     # display_peg
256 :     #==============================================================================
257 :    
258 : efrank 1.1 sub display_peg {
259 :     my($fig,$cgi,$html,$peg) = @_;
260 :     my $loc;
261 :    
262 :     my $half_sz = 5000;
263 : overbeek 1.10 my $fc = $cgi->param('fc');
264 :     my @fc_data;
265 :     if ($fc)
266 :     {
267 :     @fc_data = $fig->coupling_and_evidence($peg,5000,1.0e-20,0.5,"keep");
268 :     }
269 :     else
270 :     {
271 :     @fc_data = ();
272 :     }
273 : efrank 1.1
274 :     if ($loc = $fig->feature_location($peg))
275 :     {
276 :     my($contig,$beg,$end) = &FIG::boundaries_of($loc);
277 :     my $min = &FIG::max(0,&FIG::min($beg,$end) - $half_sz);
278 :     my $max = &FIG::max($beg,$end) + $half_sz;
279 :     my($feat,$min,$max) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);
280 :    
281 :     &print_context($fig,$cgi,$html,$peg,$feat,$min,$max);
282 :     }
283 :    
284 :     &print_assignments($fig,$cgi,$html,$peg);
285 :    
286 :     push(@$html,$cgi->hr);
287 : overbeek 1.15 my $link1 = $cgi->self_url() . "&request=view_annotations";
288 :     my $link2 = $cgi->self_url() . "&request=view_all_annotations";
289 :     push(@$html,"<br><a href=$link1>To View Annotations</a>/<a href=$link2>To View All Related Annotations</a>\n");
290 : efrank 1.1
291 :     my $link = $cgi->self_url() . "&request=aa_sequence";
292 :     push(@$html,"<br><a href=$link>Protein Sequence</a>\n");
293 :    
294 :     $link = $cgi->self_url() . "&request=dna_sequence";
295 :     push(@$html,"<br><a href=$link>DNA Sequence</a>\n");
296 :    
297 :     $link = $cgi->url();
298 :     $link =~ s/protein.cgi/fid_checked.cgi/;
299 :     my $user = $cgi->param('user');
300 :     if (! $user)
301 :     {
302 :     $user = "";
303 :     }
304 :     else
305 :     {
306 :     $link = $link . "?fid=$prot&user=$user&checked=$prot&assign/annotate=assign/annotate";
307 :     push(@$html,"<br><a href=$link target=checked_window>To Make an Annotation</a>\n");
308 :     }
309 :    
310 :     if ((! $fc) && ($fig->feature_location($peg)))
311 :     {
312 :     my $link = $cgi->self_url() . "&fc=1";
313 :     push(@$html,"<br><a href=$link>To Get Detailed Functional Coupling Data</a>\n");
314 :     }
315 :     elsif ($fc)
316 :     {
317 : overbeek 1.10 &print_fc($fig,$cgi,$html,$peg,\@fc_data);
318 : efrank 1.1 }
319 :    
320 :     my $link = $cgi->self_url() . "&request=fusions";
321 :     push(@$html,"<br><a href=$link>To Get Fusion Data</a>\n");
322 :    
323 :     my $has_translation = $fig->translatable($peg);
324 : overbeek 1.2 if ((! $cgi->param('compare_region')) && $has_translation)
325 :     {
326 :     my $link = $cgi->self_url() . "&compare_region=1";
327 :     push(@$html,"<br><a href=$link>To Compare Region</a>\n");
328 :     }
329 :     elsif ($cgi->param('compare_region'))
330 :     {
331 :     &print_compared_regions($fig,$cgi,$html,$peg);
332 :     }
333 :    
334 : overbeek 1.11 my $sims = $cgi->param('sims');
335 : efrank 1.1 if ((! $sims) && $has_translation)
336 :     {
337 : overbeek 1.11 my $max_expand = $cgi->param('max_expand') || 5;
338 :     my $maxN = $cgi->param('maxN') || 50; # Default 50, not 5 (GJO)
339 :     my $maxP = $cgi->param('maxP') || 1.0e-5;
340 :     my $ex_raw = $cgi->param('expand_raw') || 0; # Default 0, not 1 (GJO)
341 : overbeek 1.12
342 :     push( @$html, $cgi->start_form(-action => "protein.cgi"));
343 :     if ($cgi->param('translate'))
344 :     {
345 :     push(@$html,$cgi->hidden(-name => 'translate', -value => 1));
346 :     }
347 :     push( @$html, $cgi->hidden(-name => 'prot', -value => $peg),
348 : overbeek 1.11 $cgi->hidden(-name => 'sims', -value => 1),
349 :     $cgi->hidden(-name => 'fid', -value => $peg),
350 :     $cgi->hidden(-name => 'user', -value => $user),
351 :     $cgi->submit('Similarities'),
352 :     "MaxN: ", $cgi->textfield(-name => 'maxN', -size => 5, -value => $maxN, -override => 1),
353 :     "Max expand: ", $cgi->textfield(-name => 'max_expand', -size => 5, -value => $max_expand, -override => 1),
354 :     "MaxP: ", $cgi->textfield(-name => 'maxP', -size => 10, -value => $maxP),
355 : overbeek 1.14 "Just FIG Ids: ", $cgi->checkbox(-name => 'just_fig', -value => 1, -checked => 0, -override => 1, -label => ""),
356 : overbeek 1.11 $cgi->end_form
357 :     );
358 : efrank 1.1 }
359 :     elsif ($sims)
360 :     {
361 :     &print_similarities($fig,$cgi,$html,$peg);
362 :     }
363 :    
364 :     if ($has_translation)
365 :     {
366 :     &show_tools($fig,$cgi,$html,$peg);
367 :     }
368 :     }
369 :    
370 :     ################# Table-Driven Show Tools ############################
371 :    
372 :     sub show_tools {
373 :     my($fig,$cgi,$html,$peg) = @_;
374 :    
375 :     $cgi->param(-name => "request",
376 :     -value => "use_protein_tool");
377 :     my $url = $cgi->self_url();
378 :    
379 :     if (open(TMP,"<$FIG_Config::global/LinksToTools"))
380 :     {
381 :     push(@$html,$cgi->hr);
382 :     my $col_hdrs = ["Tool","Description"];
383 :     my $tab = [];
384 :    
385 :     $/ = "\n//\n";
386 :     while (defined($_ = <TMP>))
387 :     {
388 :     my($tool,$desc) = split(/\n/,$_);
389 :     push(@$tab,["<a href=\"$url\&tool=$tool\">$tool</a>",$desc]);
390 :     }
391 :     close(TMP);
392 :     $/ = "\n";
393 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Tools to Analyze Protein Sequences"));
394 :     }
395 :     $cgi->delete('request');
396 :     }
397 :    
398 :     ################# Functional Coupling ############################
399 :    
400 :     sub print_fc {
401 : overbeek 1.10 my($fig,$cgi,$html,$peg,$fc_data) = @_;
402 : efrank 1.1 my($sc,$neigh);
403 :    
404 :     my $user = $cgi->param('user');
405 :     my @tab = map { ($sc,$neigh) = @$_;
406 :     [&ev_link($cgi,$neigh,$sc),$neigh,scalar $fig->function_of($neigh,$user)]
407 :     }
408 : overbeek 1.10 @$fc_data;
409 : efrank 1.1 if (@tab > 0)
410 :     {
411 :     push(@$html,"<hr>\n");
412 :     my $col_hdrs = ["Score","Peg","Function"];
413 :     push(@$html,&HTML::make_table($col_hdrs,\@tab,"Functional Coupling"));
414 :     }
415 :     }
416 :    
417 :     sub ev_link {
418 :     my($cgi,$neigh,$sc) = @_;
419 :    
420 :     my $prot = $cgi->param('prot');
421 :     my $link = $cgi->url() . "?request=show_coupling_evidence&prot=$prot&to=$neigh";
422 :     return "<a href=$link>$sc</a>";
423 :     }
424 :    
425 :     ################# Assignments ############################
426 :    
427 :     sub trans_function_of {
428 :     my($cgi,$fig,$peg,$user) = @_;
429 :    
430 :     if (wantarray())
431 :     {
432 :     my $x;
433 :     my @funcs = $fig->function_of($peg);
434 :     if ($cgi->param('translate'))
435 :     {
436 :     @funcs = map { $x = $_; $x->[1] = $fig->translate_function($x->[1]); $x } @funcs;
437 :     }
438 :     return @funcs;
439 :     }
440 :     else
441 :     {
442 :     my $func = $fig->function_of($peg,$user);
443 :     if ($cgi->param('translate'))
444 :     {
445 :     $func = $fig->translate_function($func);
446 :     }
447 :     return $func;
448 :     }
449 :     }
450 :    
451 :     sub print_assignments {
452 :     my($fig,$cgi,$html,$peg) = @_;
453 :     my($who,$func,$ec,@ecs,@tmp,$id,$i,$master_func,$user_func,$x);
454 :    
455 :     my $user = $cgi->param('user');
456 :     my @funcs = map { [$peg,@$_] } &trans_function_of($cgi,$fig,$peg);
457 :    
458 :     for ($i=0; ($i < @funcs) && ($funcs[$i]->[1] ne "master"); $i++) {}
459 :     if ($i < @funcs)
460 :     {
461 :     $master_func = $funcs[$i]->[2];
462 :     }
463 :     else
464 :     {
465 :     $master_func = "";
466 :     }
467 :    
468 :     for ($i=0; ($i < @funcs) && ($funcs[$i]->[1] ne $user); $i++) {}
469 :     if ($i < @funcs)
470 :     {
471 :     $user_func = $funcs[$i]->[2];
472 :     }
473 :     else
474 :     {
475 :     $user_func = $master_func;
476 :     }
477 :     push(@$html,$cgi->h2("Current Assignment: $peg: $user_func"));
478 :     my @maps_to = grep { $_ ne $peg } map { $_->[0] } $fig->mapped_prot_ids($peg);
479 :     @funcs = ();
480 :     foreach $id (@maps_to)
481 :     {
482 :     if (($id ne $peg) && (@tmp = &trans_function_of($cgi,$fig,$id)) && (@tmp > 0))
483 :     {
484 :     push(@funcs, map { $x = $_; [$id,@$_] } @tmp);
485 :     }
486 :     }
487 :     @funcs = map { ($_->[1] eq "master") ? [$_->[0],"",$_->[2]] : $_ } @funcs;
488 :     push(@$html,"<hr>\n");
489 :    
490 :     if ((@funcs == 0) && (! $user_func))
491 :     {
492 :     push(@$html,$cgi->h1("No function has been assigned"));
493 :     }
494 :     elsif (@funcs > 0)
495 :     {
496 :     my $col_hdrs = ["Id","Organism","Who","ASSIGN","Assignment"];
497 :     my $title = "Assignments for Essentially Identical Proteins";
498 :     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 ];
499 :     push(@$html,&HTML::make_table($col_hdrs,$tab,$title));
500 :     }
501 :    
502 :     # $_ = join("",map { $_->[1] } @funcs);
503 :     # @ecs = ($_ =~ /\d\.\d+\.\d+\.\d+/g);
504 :     # foreach $ec (@ecs)
505 :     # {
506 :     # my $kegg_link = &HTML::kegg_link($ec);
507 :     # push(@$html,"<br>$kegg_link<br>\n");
508 :     # }
509 :     }
510 :    
511 :    
512 :    
513 :     ################# Similarities ############################
514 :    
515 :    
516 :     sub print_similarities {
517 :     my($fig,$cgi,$html,$peg) = @_;
518 :     my($maxN,$maxP,$expand_groups,$ex_checked);
519 :    
520 :     my $user = $cgi->param('user');
521 :     $user = $user ? $user : "";
522 :     my $current_func = &trans_function_of($cgi,$fig,$peg,$user);
523 :    
524 :     if (! ($maxN = $cgi->param('maxN')))
525 :     {
526 :     $maxN = 5;
527 :     }
528 :    
529 :     if (! ($maxP = $cgi->param('maxP')))
530 :     {
531 :     $maxP = 1.0e-5;
532 :     }
533 :    
534 : overbeek 1.11 if ($expand_groups = $cgi->param('expand_groups'))
535 : efrank 1.1 {
536 :     $ex_checked = "checked";
537 :     }
538 :     else
539 :     {
540 :     $ex_checked = "";
541 :     }
542 :    
543 :    
544 : overbeek 1.11 my $max_expand = $cgi->param('max_expand');
545 :     if (! defined($max_expand)) { $max_expand = 0 }
546 : efrank 1.1
547 :     push(@$html,"<hr>\n");
548 :    
549 :     push(@$html, $cgi->h1('Similarities'),
550 :     $cgi->start_form(-action => "protein.cgi"),
551 :     $cgi->hidden(-name => 'prot', -value => $peg),
552 :     $cgi->hidden(-name => 'sims', -value => 1),
553 :     $cgi->hidden(-name => 'fid', -value => $peg),
554 :     $cgi->hidden(-name => 'user', -value => $user),
555 :     $cgi->submit('more similarities'),
556 :     "MaxN: ", $cgi->textfield(-name => 'maxN', -size => 5, -value => 2 * $maxN, -override => 1),
557 : overbeek 1.11 "Max expand: ", $cgi->textfield(-name => 'max_expand', -size => 5, -value => $max_expand, -override => 1),
558 : efrank 1.1 "MaxP: ", $cgi->textfield(-name => 'maxP', -size => 10, -value => $maxP),
559 : overbeek 1.7 # "Expand Groups: ", $cgi->checkbox(-name => 'expand_groups', -value => 1, -checked => $ex_checked, -override => 1),
560 : overbeek 1.14 "Just FIG Ids: ", $cgi->checkbox(-name => 'just_fig', -value => 1, -checked => 0, -override => 1, -label => ""),
561 : efrank 1.1 $cgi->end_form,
562 :    
563 :     $cgi->hr
564 :     );
565 :    
566 :     my(@sims);
567 : overbeek 1.14 my $select = $cgi->param('just_fig') ? "fig" : "all";
568 :     @sims = $fig->sims($peg,$maxN,$maxP,$select,$max_expand);
569 : efrank 1.1
570 :     if (@sims)
571 :     {
572 :     my @from = $cgi->radio_group(-name => 'from',
573 :     -nolabels => 1,
574 : efrank 1.8 -override => 1,
575 : efrank 1.1 -values => ["",$peg,map { $_->id2 } @sims]);
576 :    
577 :     my $target = "window$$";
578 :     push(@$html,
579 :     $cgi->start_form(-method => 'post',
580 :     -target => $target,
581 :     -action => 'fid_checked.cgi'
582 :     ),
583 :     $cgi->hidden(-name => 'fid', -value => $peg),
584 :     $cgi->hidden(-name => 'user', -value => $user),
585 :     $cgi->br,
586 :     "CHECKED: ", $cgi->submit('align'),
587 :     $cgi->submit('view annotations'),$cgi->submit('show regions'));
588 : overbeek 1.11
589 :     if ($user)
590 :     { # Changed by GJO to derive help url from current url, not that in config
591 :     my $help_url = $cgi->url;
592 :     $help_url =~ s/protein.cgi/Html\/help_for_assignments_and_rules.html/;
593 :     push ( @$html, $cgi->br, $cgi->br,
594 :     "<a href=$help_url>Help on Assignments, Rules, and Checkboxes</a>",
595 :     $cgi->br, $cgi->br,
596 :     $cgi->submit('assign/annotate')
597 :     );
598 :    
599 : efrank 1.1 if ($cgi->param('translate'))
600 :     {
601 : overbeek 1.11 push( @$html, $cgi->submit('add rules'),
602 :     $cgi->submit('check rules'),
603 :     $cgi->br
604 :     );
605 : efrank 1.1 }
606 :     }
607 :    
608 : overbeek 1.11 push( @$html, $cgi->br,
609 :     $cgi->checkbox( -name => 'checked',
610 :     -value => $peg,
611 :     -override => 1,
612 :     -checked => 1,
613 :     -label => ""
614 :     )
615 :     );
616 :    
617 :     my $col_hdrs;
618 :     if ($user && $cgi->param('translate'))
619 :     {
620 :     push( @$html, " ASSIGN to/Translate from/SELECT current PEG", $cgi->br,
621 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
622 :     "ASSIGN from/Translate to current PEG: ", shift @from
623 :     );
624 :     $col_hdrs = [ "ASSIGN to<br>--------<br>Translate from",
625 :     "family",
626 :     "size",
627 :     "Similar sequence",
628 :     "sc",
629 :     "region in similar sequence",
630 :     "region in $peg",
631 :     "ASSIGN from<br>----------<br>Translate to",
632 :     "Function",
633 :     "Organism",
634 :     "Aliases"
635 :     ];
636 :     }
637 :     elsif ($user)
638 :     {
639 :     push( @$html, " ASSIGN to/SELECT current PEG", $cgi->br,
640 :     "ASSIGN/annotate with form: ", shift @from, $cgi->br,
641 :     "ASSIGN from current PEG: ", shift @from
642 :     );
643 :     $col_hdrs = [ "ASSIGN to<br>--------<br>SELECT",
644 :     "family",
645 :     "size",
646 :     "Similar sequence",
647 :     "sc",
648 :     "region in similar sequence",
649 :     "region in $peg",
650 :     "ASSIGN from",
651 :     "Function",
652 :     "Organism",
653 :     "Aliases"
654 :     ];
655 :     }
656 :     else
657 : efrank 1.1 {
658 : overbeek 1.11 push(@$html, " SELECT current PEG", $cgi->br );
659 :     $col_hdrs = [ "SELECT",
660 :     "family",
661 :     "size",
662 :     "Similar sequence",
663 :     "sc",
664 :     "region in similar sequence",
665 :     "region in $peg",
666 :     "Function",
667 :     "Organism",
668 :     "Aliases"
669 :     ];
670 : efrank 1.1 }
671 :    
672 : overbeek 1.11 my $tab = [];
673 :     my $title = "Similarities";
674 :    
675 :     my $sim;
676 :     foreach $sim ( @sims )
677 : efrank 1.1 {
678 : overbeek 1.11 my($psc,$family,$sz,$funcF,$id2);
679 :     $psc = $sim->psc;
680 : efrank 1.1 if ($expand_groups)
681 :     {
682 :     $id2 = $sim->id2;
683 :     if (($id2 =~ /^fig\|/) && ($family = $fig->in_family($id2)))
684 :     {
685 :     $sz = $fig->sz_family($family);
686 :     $funcF = $fig->family_function($family);
687 :     }
688 :     else
689 :     {
690 :     $sz = $funcF = "";
691 :     }
692 :     }
693 :     else
694 :     {
695 : overbeek 1.11 ($family,$sz,$funcF) = ("","","");
696 : efrank 1.1 }
697 : overbeek 1.11
698 : efrank 1.1 my $ln1 = $sim->ln1;
699 :     $id2 = $sim->id2;
700 :     my $ln2 = $sim->ln2;
701 :     my $b1 = $sim->b1;
702 :     my $e1 = $sim->e1;
703 :     my $b2 = $sim->b2;
704 :     my $e2 = $sim->e2;
705 :     my $d1 = abs($e1 - $b1) + 1;
706 :     my $d2 = abs($e2 - $b2) + 1;
707 :     my $reg1 = "$b1-$e1 (<b>$d1/$ln1</b>)";
708 :     my $reg2 = "$b2-$e2 (<b>$d2/$ln2</b>)";
709 : overbeek 1.11 my $func2 = &trans_function_of( $cgi, $fig, $id2, $user );
710 :    
711 :     if ( defined( $family ) )
712 : efrank 1.1 {
713 : overbeek 1.11 # Add $funcF test to get rid of blank line -- GJO
714 :     if ($funcF && $funcF ne $func2) { $func2 = "$funcF<br>$func2" }
715 : efrank 1.1 }
716 :     else
717 :     {
718 :     $sz = "";
719 :     $family = "";
720 :     }
721 :    
722 : overbeek 1.11 my $cbox = $fig->translatable($id2) ?
723 :     qq(<input type="checkbox" name="checked" value="$id2">) : "";
724 : efrank 1.1
725 :     my $assign_link = &assign_link($cgi,$func2,$current_func);
726 :     my $id2_link = &HTML::set_prot_links($cgi,$id2);
727 :    
728 : overbeek 1.11 # Modifed by GJO to get rid of empty column when user is not defined
729 :     push( @$tab, [ $cbox,
730 :     scalar &HTML::family_link( $family, $user ),
731 :     $sz,
732 :     $id2_link,
733 :     $psc,
734 :     $reg2,
735 :     $reg1,
736 :     ( $user ? shift @from : () ),
737 :     $func2,
738 :     $fig->org_of($id2),
739 :     join( ",", $fig->feature_aliases($id2) )
740 :     ]
741 :     );
742 : efrank 1.1 }
743 : overbeek 1.11
744 : efrank 1.1 push(@$html,&HTML::make_table($col_hdrs,$tab,$title,["nowrap"]));
745 :     push(@$html,$cgi->end_form);
746 :     }
747 :     }
748 :    
749 :     ################# Context on the Chromosome ############################
750 :    
751 :     sub print_context {
752 :     my($fig,$cgi,$html,$peg,$feat,$beg,$end) = @_;
753 :     my($contig1,$beg1,$end1,$strand,$max_so_far,$gap,$comment,$fc,$aliases);
754 :     my($why_related,$fid1,$sz,$color,$map,$gg,$n,$link,$in_neighborhood);
755 :    
756 :     $why_related = "";
757 :     my %in_cluster = map { $_ => 1 } $fig->in_cluster_with($peg);;
758 :    
759 :     my $col_hdrs = ["fid","starts","ends","size","","gap","fc","neigh","comment","aliases","Related"];
760 :     my($tab) = [];
761 :     my $genes = [];
762 :    
763 :     my $user = $cgi->param('user');
764 :     my $peg_function = &trans_function_of($cgi,$fig,$peg,$user);
765 :    
766 :     my($role,$role1,%related_roles);
767 :     foreach $role (&FIG::roles_of_function($peg_function))
768 :     {
769 :     foreach $role1 ($fig->neighborhood_of_role($role))
770 :     {
771 :     $related_roles{$role1} = 1;
772 :     }
773 :     }
774 :    
775 :     foreach $fid1 (@$feat)
776 :     {
777 :     $fc = $in_cluster{$fid1} ? &pin_link($cgi,$fid1) : "";
778 :     $aliases = $fig->feature_aliases($fid1);
779 : overbeek 1.6 ($contig1,$beg1,$end1) = $fig->boundaries_of(scalar $fig->feature_location($fid1));;
780 : efrank 1.1 $strand = ($beg1 < $end1) ? "+" : "-";
781 :    
782 :     if ($fid1 eq $peg) { $color = "green" }
783 :     elsif ($fc) { $color = "blue" }
784 :     else { $color = "red" }
785 :    
786 :     if ($fid1 =~ /peg\.(\d+)$/)
787 :     {
788 :     $n = $1;
789 :     $link = $cgi->url() . "?prot=$fid1&user=$user";
790 :     }
791 :     elsif ($fid1 =~ /\.([a-z]+)\.\d+$/)
792 :     {
793 :     $n = uc $1;
794 :     $link = "";
795 :     }
796 :     else
797 :     {
798 :     $n ="";
799 :     $link = "";
800 :     }
801 :    
802 :     push(@$genes,[&FIG::min($beg1,$end1),&FIG::max($beg1,$end1),($strand eq "+") ? "rightArrow" : "leftArrow", $color,$n,$link]);
803 :     if ($max_so_far)
804 :     {
805 :     $gap = (&FIG::min($beg1,$end1) - $max_so_far) - 1;
806 :     }
807 :     else
808 :     {
809 :     $gap = "";
810 :     }
811 :     $max_so_far = &FIG::max($beg1,$end1);
812 :    
813 :    
814 :     $in_neighborhood = "";
815 :     if (&FIG::ftype($fid1) eq "peg")
816 :     {
817 :     $comment = &trans_function_of($cgi,$fig,$fid1,$user);
818 :     foreach $role (&FIG::roles_of_function($comment))
819 :     {
820 :     if ($related_roles{$role})
821 :     {
822 :     $in_neighborhood = "*";
823 :     }
824 :     }
825 :     }
826 :     else
827 :     {
828 :     $comment = "";
829 :     }
830 :     $comment = &set_map_links($fig,&FIG::genome_of($fid1),$comment);
831 : overbeek 1.17 if ($fid1 eq $peg)
832 :     {
833 :     $comment = "\@bgcolor:#00FF00:$comment";
834 :     }
835 : efrank 1.1 $sz = abs($end1-$beg1)+1;
836 :    
837 :     push(@$tab,[&HTML::fid_link($cgi,$fid1,"local"),$beg1,$end1,$sz,$strand,$gap,$fc,$in_neighborhood,
838 :     $comment,$aliases,$why_related]);
839 :     }
840 :     $map = ["",$beg,$end,$genes];
841 :     $gg = [$map];
842 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Context on the Chromosome"));
843 : overbeek 1.2 push(@$html,@{ &GenoGraphics::render($gg,700,4,0,1) });
844 : efrank 1.1 return;
845 :     }
846 :    
847 :     sub assign_link {
848 :     my($cgi,$func,$existing_func) = @_;
849 :     my($assign_url,$assign_link);
850 :    
851 :     if ($func && ((! $existing_func) || ($existing_func ne $func)))
852 :     {
853 :     $cgi->delete('request');
854 :     $assign_url = $cgi->self_url() . "&request=fast_assign&func=$func"; ## must encode
855 :     $assign_link = "<a href=\"$assign_url\">&nbsp;<=&nbsp;</a>";
856 :     }
857 :     else
858 :     {
859 :     $assign_link = "";
860 :     }
861 :     return $assign_link;
862 :     }
863 :    
864 :     sub pin_link {
865 :     my($cgi,$peg) = @_;
866 :     my $user = $cgi->param('user');
867 :     $user = defined($user) ? $user : "";
868 :    
869 :     my $cluster_url = &FIG::cgi_url . "/chromosomal_clusters.cgi?prot=$peg&user=$user";
870 :     my $cluster_link = "<a href=\"$cluster_url\">*</a>";
871 :     return $cluster_link;
872 :     }
873 :    
874 :     sub set_map_links {
875 :     my($fig,$org,$func) = @_;
876 :    
877 :     if ($func =~ /^(.*)(\d+\.\d+\.\d+\.\d+)(.*)$/)
878 :     {
879 :     my $before = $1;
880 :     my $ec = $2;
881 :     my $after = $3;
882 :     return &set_map_links($fig,$org,$before) . &set_ec_to_maps($fig,$org,$ec) . &set_map_links($fig,$org,$after);
883 :     }
884 :     return $func;
885 :     }
886 :    
887 :     sub set_ec_to_maps {
888 :     my($fig,$org,$ec) = @_;
889 :    
890 :     my @maps = $fig->ec_to_maps($ec);
891 :     if (@maps > 0)
892 :     {
893 :     $cgi->delete('request');
894 :     my $url = $cgi->self_url() . "&request=ec_to_maps&ec=$ec&org=$org";
895 :     my $link = "<a href=\"$url\">$ec</a>";
896 :     return $link;
897 :     }
898 :     return $ec;
899 :     }
900 :    
901 :     sub show_ec_to_maps {
902 :     my($fig,$cgi,$html,$ec) = @_;
903 :    
904 :     my $ec = $cgi->param('ec');
905 :     if (! $ec)
906 :     {
907 :     push(@$html,$cgi->h1("Missing EC number"));
908 :     return;
909 :     }
910 :    
911 :     my @maps = $fig->ec_to_maps($ec);
912 :     if (@maps > 0)
913 :     {
914 :     my $col_hdrs = ["map","metabolic topic"];
915 :     my $map;
916 :     my $tab = [map { $map = $_; [&map_link($cgi,$map),$fig->map_name($map)] } @maps];
917 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"$ec: " . $fig->ec_name($ec)));
918 :     }
919 :     }
920 :    
921 :     sub map_link {
922 :     my($cgi,$map) = @_;
923 :    
924 :     $cgi->delete('request');
925 :     my $url = $cgi->self_url() . "&request=link_to_map&map=$map";
926 :     my $link = "<a href=\"$url\">$map</a>";
927 :     return $link;
928 :     }
929 :    
930 :     sub link_to_map {
931 :     my($fig,$cgi,$html) = @_;
932 :    
933 :     my $map = $cgi->param('map');
934 :     if (! $map)
935 :     {
936 :     push(@$html,$cgi->h1("Missing Map"));
937 :     return;
938 :     }
939 :    
940 :     my $org = $cgi->param('org');
941 :     if (! $org)
942 :     {
943 :     push(@$html,$cgi->h1("Missing Org Parameter"));
944 :     return;
945 :     }
946 :     my$user = $cgi->param('user');
947 :     $user = $user ? $user : "";
948 :    
949 :     $ENV{"REQUEST_METHOD"} = "GET";
950 :     $ENV{"QUERY_STRING"} = "user=$user&map=$map&org=$org";
951 :     my @out = `./show_kegg_map.cgi`;
952 :     &HTML::trim_output(\@out);
953 :     push(@$html,@out);
954 :     }
955 :    
956 :     sub aa_sequence {
957 :     my($fig,$cgi,$html,$prot) = @_;
958 :     my($seq,$func,$i);
959 :    
960 :     if ($seq = $fig->get_translation($prot))
961 :     {
962 :     $func = $fig->function_of($prot,$cgi->param('user'));
963 :     push(@$html,$cgi->pre,">$prot $func\n");
964 :     for ($i=0; ($i < length($seq)); $i += 60)
965 :     {
966 :     if ($i > (length($seq) - 60))
967 :     {
968 :     push(@$html,substr($seq,$i) . "\n");
969 :     }
970 :     else
971 :     {
972 :     push(@$html,substr($seq,$i,60) . "\n");
973 :     }
974 :     }
975 :     push(@$html,$cgi->end_pre);
976 :     }
977 :     else
978 :     {
979 :     push(@$html,$cgi->h1("No translation available for $prot"));
980 :     }
981 :     }
982 :    
983 :     sub dna_sequence {
984 :     my($fig,$cgi,$html,$fid) = @_;
985 :     my($seq,$func,$i);
986 :    
987 :     if ($seq = $fig->dna_seq($fig->genome_of($fid),scalar $fig->feature_location($fid)))
988 :     {
989 :     $func = $fig->function_of($prot,$cgi->param('user'));
990 :     push(@$html,$cgi->pre,">$fid $func\n");
991 :     for ($i=0; ($i < length($seq)); $i += 60)
992 :     {
993 :     if ($i > (length($seq) - 60))
994 :     {
995 :     push(@$html,substr($seq,$i) . "\n");
996 :     }
997 :     else
998 :     {
999 :     push(@$html,substr($seq,$i,60) . "\n");
1000 :     }
1001 :     }
1002 :     push(@$html,$cgi->end_pre);
1003 :     }
1004 :     else
1005 :     {
1006 :     push(@$html,$cgi->h1("No DNA sequence available for $fid"));
1007 :     }
1008 :     }
1009 :    
1010 :     sub show_fusions {
1011 :     my($fig,$cgi,$html,$prot) = @_;
1012 :    
1013 :     $ENV{"REQUEST_METHOD"} = "GET";
1014 :     $ENV{"QUERY_STRING"} = "peg=$prot";
1015 :     my @out = `./fusions.cgi`;
1016 :     print join("",@out);
1017 :     exit;
1018 : overbeek 1.2 }
1019 :    
1020 :     sub print_compared_regions {
1021 :     my($fig,$cgi,$html,$peg) = @_;
1022 :    
1023 :     my @closest_pegs = &closest_pegs($fig,$peg,5);
1024 :     if (@closest_pegs > 0)
1025 :     {
1026 :     if ($fig->possibly_truncated($peg))
1027 :     {
1028 :     push(@closest_pegs,&possible_extensions($peg,\@closest_pegs));
1029 :     }
1030 : overbeek 1.13 @closest_pegs = $fig->sort_fids_by_taxonomy(@closest_pegs);
1031 : overbeek 1.2 unshift(@closest_pegs,$peg);
1032 :     my @all_pegs = ();
1033 :     my $gg = &build_maps($fig,\@closest_pegs,\@all_pegs);
1034 :     my $color_sets = &cluster_genes(\@all_pegs,$peg);
1035 :     &set_colors_text_and_links($gg,\@all_pegs,$color_sets);
1036 :     push(@$html,@{ &GenoGraphics::render($gg,700,4,0,2) });
1037 :     }
1038 :     }
1039 :    
1040 :     sub closest_pegs {
1041 :     my($fig,$peg,$n) = @_;
1042 :     my($id2,$d,$peg2,$i);
1043 :    
1044 :     my @closest = map { $id2 = $_->id2; ($id2 =~ /^fig\|/) ? $id2 : () } $fig->sims($peg,5,1.0e-20,"all");
1045 :    
1046 :     if (@closest > $n) { $#closest = $n-1 }
1047 :     my %closest = map { $_ => 1 } @closest;
1048 : overbeek 1.3 my @pinned_to = grep { $_ ne $peg} $fig->in_pch_pin_with($peg);
1049 : overbeek 1.2 my $g1 = &FIG::genome_of($peg);
1050 :     @pinned_to =
1051 :     map {$_->[1] }
1052 :     sort { $a->[0] <=> $b->[0] }
1053 :     map { $peg2 = $_; $d = $fig->crude_estimate_of_distance($g1,&FIG::genome_of($peg2)); [$d,$peg2] }
1054 :     @pinned_to;
1055 :    
1056 :     for ($i=0; ($i < @pinned_to) && ($i < $n); $i++)
1057 :     {
1058 :     $closest{$pinned_to[$i]} = 1;
1059 :     }
1060 :     return return keys(%closest);
1061 :     }
1062 :    
1063 :     sub build_maps {
1064 :     my($fig,$pinned_pegs,$all_pegs) = @_;
1065 :     my($gg,$loc,$contig,$beg,$end,$mid,$min,$max,$genes,$feat,$fid);
1066 :     my($contig1,$beg1,$end1,$map,$peg);
1067 :    
1068 :     $gg = [];
1069 :     foreach $peg (@$pinned_pegs)
1070 :     {
1071 :     $loc = $fig->feature_location($peg);
1072 :     ($contig,$beg,$end) = &FIG::boundaries_of($loc);
1073 :     if ($contig && $beg && $end)
1074 :     {
1075 :     $mid = int(($beg + $end) / 2);
1076 :     $min = $mid - 8000;
1077 :     $max = $mid + 8000;
1078 :     $genes = [];
1079 :     ($feat,undef,undef) = $fig->genes_in_region(&FIG::genome_of($peg),$contig,$min,$max);
1080 :     foreach $fid (@$feat)
1081 :     {
1082 :     ($contig1,$beg1,$end1) = &FIG::boundaries_of(scalar $fig->feature_location($fid));
1083 :     $beg1 = &in_bounds($min,$max,$beg1);
1084 :     $end1 = &in_bounds($min,$max,$end1);
1085 :     push(@$genes,[&FIG::min($beg1,$end1),
1086 :     &FIG::max($beg1,$end1),
1087 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
1088 :     "grey",
1089 :     "",
1090 :     $fid]);
1091 :    
1092 :     if ($fid =~ /peg/)
1093 :     {
1094 :     push(@$all_pegs,$fid);
1095 :     }
1096 :     }
1097 :     $map = [&FIG::abbrev($fig->org_of($peg)),0,$max+1-$min,
1098 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)];
1099 :     push(@$gg,$map);
1100 :     }
1101 :     }
1102 :     return $gg;
1103 :     }
1104 :    
1105 :     sub in {
1106 :     my($x,$xL) = @_;
1107 :     my($i);
1108 :    
1109 :     for ($i=0; ($i < @$xL) && ($x != $xL->[$i]); $i++) {}
1110 :     return ($i < @$xL);
1111 :     }
1112 :    
1113 :     sub in_bounds {
1114 :     my($min,$max,$x) = @_;
1115 :    
1116 :     if ($x < $min) { return $min }
1117 :     elsif ($x > $max) { return $max }
1118 :     else { return $x }
1119 :     }
1120 :    
1121 :     sub decr_coords {
1122 :     my($genes,$min) = @_;
1123 :     my($gene);
1124 :    
1125 :     foreach $gene (@$genes)
1126 :     {
1127 :     $gene->[0] -= $min;
1128 :     $gene->[1] -= $min;
1129 :     }
1130 :     return $genes;
1131 :     }
1132 :    
1133 :     sub flip_map {
1134 :     my($genes,$min,$max) = @_;
1135 :     my($gene);
1136 :    
1137 :     foreach $gene (@$genes)
1138 :     {
1139 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
1140 :     $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
1141 :     }
1142 :     return $genes;
1143 :     }
1144 :    
1145 :     sub cluster_genes {
1146 :     my($all_pegs,$peg) = @_;
1147 :     my(%seen,$i,$j,$k,$x,$cluster,$conn,$pegI,$red_set);
1148 :    
1149 :     my @color_sets = ();
1150 :    
1151 :     $conn = &get_connections_by_similarity($all_pegs);
1152 :     for ($i=0; ($i < @$all_pegs); $i++)
1153 :     {
1154 :     if ($all_pegs->[$i] eq $peg) { $pegI = $i }
1155 :     if (! $seen{$i})
1156 :     {
1157 :     $cluster = [$i];
1158 :     $seen{$i} = 1;
1159 :     for ($j=0; ($j < @$cluster); $j++)
1160 :     {
1161 :     $x = $conn->{$cluster->[$j]};
1162 :     foreach $k (@$x)
1163 :     {
1164 :     if (! $seen{$k})
1165 :     {
1166 :     push(@$cluster,$k);
1167 :     $seen{$k} = 1;
1168 :     }
1169 :     }
1170 :     }
1171 :    
1172 :     if ((@$cluster > 1) || ($cluster->[0] eq $pegI))
1173 :     {
1174 :     push(@color_sets,$cluster);
1175 :     }
1176 :     }
1177 :     }
1178 :     for ($i=0; ($i < @color_sets) && (! &in($pegI,$color_sets[$i])); $i++) {}
1179 :     $red_set = $color_sets[$i];
1180 :     splice(@color_sets,$i,1);
1181 :     @color_sets = sort { @$b <=> @$a } @color_sets;
1182 :     unshift(@color_sets,$red_set);
1183 :    
1184 :     my $color_sets = {};
1185 :     for ($i=0; ($i < @color_sets); $i++)
1186 :     {
1187 :     foreach $x (@{$color_sets[$i]})
1188 :     {
1189 :     $color_sets->{$all_pegs->[$x]} = $i;
1190 :     }
1191 :     }
1192 :     return $color_sets;
1193 :     }
1194 :    
1195 :     sub get_connections_by_similarity {
1196 :     my($all_pegs) = @_;
1197 : overbeek 1.5 my($i,$tmp,$peg1,%peg2i,%pos_of);
1198 : overbeek 1.2
1199 :     for ($i=0; ($i < @$all_pegs); $i++)
1200 :     {
1201 : overbeek 1.5 $tmp = $fig->maps_to_id($all_pegs->[$i]);
1202 :     push(@{$pos_of{$tmp}},$i); # map the representative in nr to subscript in all_pegs
1203 :     if ($tmp ne $all_pegs->[$i])
1204 : overbeek 1.2 {
1205 :     push(@{$pos_of{$all_pegs->[$i]}},$i);
1206 :     }
1207 :     }
1208 :    
1209 :     my($sim,%conn,$x,$y);
1210 :     for ($i=0; ($i < @$all_pegs); $i++)
1211 :     {
1212 :     foreach $sim ($fig->sims($all_pegs->[$i],500,1.0e-5,"raw"))
1213 :     {
1214 :     if (defined($x = $pos_of{$sim->id2}))
1215 :     {
1216 :     foreach $y (@$x)
1217 :     {
1218 :     push(@{$conn{$i}},$y);
1219 :     }
1220 :     }
1221 :     }
1222 :     }
1223 :     return \%conn;
1224 :     }
1225 :    
1226 :     sub set_colors_text_and_links {
1227 :     my($gg,$all_pegs,$color_sets) = @_;
1228 :     my($map,$gene,$peg,$color);
1229 :    
1230 :     foreach $map (@$gg)
1231 :     {
1232 :     foreach $gene (@{$map->[3]})
1233 :     {
1234 :     $peg = $gene->[5];
1235 :     if (defined($color = $color_sets->{$peg}))
1236 :     {
1237 :     $gene->[3] = "color$color";
1238 :     $gene->[4] = $color + 1;
1239 :     }
1240 :     $gene->[5] = &peg_url($cgi,$peg);
1241 :     }
1242 :     }
1243 :     }
1244 :    
1245 :     sub peg_url {
1246 :     my($cgi,$peg) = @_;
1247 :    
1248 :     my $prot = $cgi->param('prot');
1249 :     $cgi->delete('prot');
1250 :     my $url = $cgi->self_url() . "&prot=$peg&compare_region=1";
1251 :     $cgi->delete('prot');
1252 :     $cgi->param(-name => 'prot', -value => $prot);
1253 :    
1254 :     return $url;
1255 :     }
1256 :    
1257 :     sub possible_extensions {
1258 :     my($peg,$closest_pegs) = @_;
1259 :     my($g,$sim,$id2,$peg1,%poss);
1260 :    
1261 :     $g = &FIG::genome_of($peg);
1262 :    
1263 :     foreach $peg1 (@$closest_pegs)
1264 :     {
1265 :     if ($g ne &FIG::genome_of($peg1))
1266 :     {
1267 :     foreach $sim ($fig->sims($peg1,500,1.0e-5,"all"))
1268 :     {
1269 :     $id2 = $sim->id2;
1270 :     if (($id2 ne $peg) && ($id2 =~ /^fig\|$g\./) && $fig->possibly_truncated($id2))
1271 :     {
1272 :     $poss{$id2} = 1;
1273 :     }
1274 :     }
1275 :     }
1276 :     }
1277 :     return keys(%poss);
1278 : efrank 1.1 }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3