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

Annotation of /FigWebServices/protein.cgi

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3