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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.25 - (view) (download)

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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3