[Bio] / FigKernelPackages / ChromosomalClusters.pm Repository:
ViewVC logotype

Annotation of /FigKernelPackages/ChromosomalClusters.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (view) (download) (as text)

1 : olson 1.1
2 :     #
3 :     # Module that incorporates the guts of what used to be in
4 :     # chromosomal_clusters.cgi. We put it here so we can use this code in the
5 :     # batch-mode script that precomputes the clustering data for incorporation
6 :     # in distributed SEED data releases.
7 :     #
8 :    
9 :     use FIG;
10 :     use HTML;
11 :     use GenoGraphics;
12 :    
13 :     use Exporter;
14 :     use base qw(Exporter);
15 :     use vars qw(@EXPORT);
16 :    
17 :     use strict;
18 :     use CGI;
19 :    
20 :     @EXPORT = qw(compute_pin_for_peg);
21 :    
22 :     #
23 :     # Compute a pin. This is a little weird since it uses a CGI object for
24 :     # parameter passing, but that's because it used to be a CGI script.
25 :     #
26 :    
27 :     sub compute_pin_for_peg
28 :     {
29 :     my($fig, $peg, $cgi) = @_;
30 :    
31 :     my $html = [];
32 :     if (!ref($cgi))
33 :     {
34 :     $cgi = new CGI();
35 :     }
36 :    
37 :     $cgi->param('prot', $peg);
38 :    
39 :     my $sim_cutoff = $cgi->param('sim_cutoff');
40 :     if (! $sim_cutoff) { $sim_cutoff = 1.0e-20 }
41 :    
42 :     my ( $prot, $pinned_to, $in_pin, $uniL, $uniM ) = get_prot_and_pins( $fig, $cgi, $html );
43 :    
44 :     if (!$prot)
45 :     {
46 :     return undef;
47 :     }
48 :    
49 :     my ($gg, $all_pegs, $pegI ) = get_initial_gg_and_all_pegs( $fig, $cgi, $prot, $pinned_to, $uniL, $uniM );
50 :    
51 :     my( $color, $text ) = form_sets_and_set_color_and_text( $fig, $cgi, $gg, $pegI, $all_pegs, $sim_cutoff );
52 :    
53 :     my $vals = update_gg_with_color_and_text( $cgi, $gg, $color, $text, $prot );
54 :    
55 :    
56 :     if ( @$gg > 0 )
57 :     {
58 :     &thin_out_over_max( $cgi, $prot, $gg, $html, $in_pin );
59 :     }
60 :     return($gg, $prot);
61 :     }
62 :    
63 :     # Everything below here is subroutines. =======================================
64 :    
65 :     sub pick_color {
66 :     my( $cgi, $all_pegs, $color_set, $i, $colors ) = @_;
67 :    
68 :     if ( @$colors > 0 )
69 :     {
70 :     my( $j, $peg, $color );
71 :     my %colors_imported = map { ( $peg, $color ) = $_ =~ /^(.*):([^:]*)$/ } @$colors;
72 :     for ($j=0; ($j < @$color_set) && (! $colors_imported{$all_pegs->[$color_set->[$j]]}); $j++) {}
73 :     if ($j < @$color_set)
74 :     {
75 :     return $colors_imported{$all_pegs->[$color_set->[$j]]};
76 :     }
77 :     }
78 :     return ( $i == 0 ) ? "red" : "color$i";
79 :     }
80 :    
81 :     sub pick_text {
82 :     my($cgi,$all_pegs,$color_set,$i,$texts) = @_;
83 :     my($peg,$text,$j);
84 :    
85 :     if (@$texts > 0)
86 :     {
87 :     my %texts_imported = map { ($peg,$text) = split(/:/,$_); $peg => $text } @$texts;
88 :     for ($j=0; ($j < @$color_set) && (! $texts_imported{$all_pegs->[$color_set->[$j]]}); $j++) {}
89 :     if ($j < @$color_set)
90 :     {
91 :     return $texts_imported{$all_pegs->[$color_set->[$j]]};
92 :     }
93 :     }
94 :     return $i+1;
95 :     }
96 :    
97 :     sub in {
98 :     my( $x, $xL ) = @_;
99 :    
100 :     foreach ( @$xL ) { if ( $x == $_ ) { return 1 } }
101 :     return 0;
102 :     }
103 :    
104 :     sub in_bounds {
105 :     my($min,$max,$x) = @_;
106 :    
107 :     if ($x < $min) { return $min }
108 :     elsif ($x > $max) { return $max }
109 :     else { return $x }
110 :     }
111 :    
112 :     sub decr_coords {
113 :     my($genes,$min) = @_;
114 :     my($gene);
115 :    
116 :     foreach $gene (@$genes)
117 :     {
118 :     $gene->[0] -= $min;
119 :     $gene->[1] -= $min;
120 :     }
121 :     return $genes;
122 :     }
123 :    
124 :     sub flip_map {
125 :     my($genes,$min,$max) = @_;
126 :     my($gene);
127 :    
128 :     foreach $gene (@$genes)
129 :     {
130 :     ($gene->[0],$gene->[1]) = ($max - $gene->[1],$max - $gene->[0]);
131 :     $gene->[2] = ($gene->[2] eq "rightArrow") ? "leftArrow" : "rightArrow";
132 :     }
133 :     return $genes;
134 :     }
135 :    
136 :     sub gs_of {
137 :     my($peg) = @_;
138 :    
139 :     $peg =~ /fig\|(\d+)/;
140 :     return $1;
141 :     }
142 :    
143 :    
144 :     # How about some color commentary?
145 :    
146 :     sub show_commentary {
147 :     my($fig,$cgi,$html,$sim_cutoff) = @_;
148 :    
149 :     my(@vals,$val,%by_set,$col_hdrs,$tab,$n,$occ,$org,$fid,$set,$x,$i,%by_line,%fid_to_line);
150 :     $cgi->delete('request');
151 :    
152 :     @vals = $cgi->param('show');
153 :     foreach $val (@vals)
154 :     {
155 :     ( $n, $i, $fid, $org, $occ ) = split( /\@/, $val );
156 :     push( @{ $by_set{$n} }, [ $i, $org, $occ, $fid ] );
157 :     push( @{ $by_line{$i} }, $n );
158 :     if ($n == 1) { $fid_to_line{$fid} = $i }
159 :     }
160 :    
161 :     my($func,$user_entry,$func_entry,$target);
162 :    
163 :     my $user = $cgi->param('user');
164 :     if ($user)
165 :     {
166 :     $target = "window$$";
167 :     }
168 :    
169 :     foreach $set (sort { $a <=> $b } keys(%by_set))
170 :     {
171 :     if ($cgi->param('uni'))
172 :     {
173 :     $col_hdrs = ["Set","Organism","Occ","UniProt","UniProt Function","PEG","SS",
174 :     &evidence_codes_link($cgi),"Ln","Function"];
175 :     }
176 :     else
177 :     {
178 :     $col_hdrs = ["Set","Organism","Occ","PEG","SS",&evidence_codes_link($cgi),"Ln","Function"];
179 :     }
180 :     $tab = [];
181 :    
182 :     if ($user)
183 :     {
184 :     push(@$html,$cgi->start_form(-method => 'post',
185 :     -target => $target,
186 :     -action => &FIG::cgi_url . "/fid_checked.cgi"),
187 :     $cgi->hidden(-name => 'user', -value => $user)
188 :     );
189 :     }
190 :    
191 :     # For colorized functions we need to get the functions, then set the
192 :     # colors. Given the structure of the current code, it seems easiest
193 :     # to accumulate the information on a first pass, exactly as done now,
194 :     # but then go back and stuff the colors in (possibly even by keeping
195 :     # a stack of references to the ultimate locations).
196 :    
197 :     my( @uni, $uni_link );
198 :     my @func_summary = ();
199 :     my %func_count = ();
200 :     my %order = ();
201 :     my $cnt = 0;
202 :    
203 :     foreach $x ( sort { ($a->[0] <=> $b->[0]) or ($a->[2] <=> $b->[2]) } @{ $by_set{$set} } )
204 :     {
205 :     ( undef, $org, $occ, $fid ) = @$x;
206 :     my $tran_len = $fig->translation_length($fid);
207 :     my @subs = $fig->peg_to_subsystems($fid);
208 :     my $in_sub = @subs;
209 :    
210 :     @uni = $cgi->param('uni') ? $fig->to_alias($fid,"uni") : "";
211 :     $uni_link = join( ", ", map { &HTML::uni_link( $cgi, $_ ) } @uni );
212 :    
213 :     $user_entry = &HTML::fid_link( $cgi, $fid );
214 :    
215 :     if ($user)
216 :     {
217 :     $user_entry = $cgi->checkbox(-name => 'checked', -label => '', -value => $fid) . "&nbsp; $user_entry";
218 :     }
219 :    
220 :     $func = $fig->function_of($fid,$cgi->param('user'));
221 :     if ($user && $func)
222 :     {
223 :     $func_entry = $cgi->checkbox(-name => 'from', -label => '', -value => $fid) . "&nbsp; $func";
224 :     }
225 :     else
226 :     {
227 :     $func_entry = $func;
228 :     }
229 :    
230 :     # Record the count of each function, and the order of first occurance:
231 :    
232 :     if ( $func ) { ( $func_count{ $func }++ ) or ( $order{ $func } = ++$cnt ) }
233 :    
234 :     # We need to build a table entry that HTML::make_table will color
235 :     # the cell. It would certainly be possible to use the old colon
236 :     # delimited prefix. Rob Edwards added the really nice feature that
237 :     # if the cell contents are a reference to an array, then the first
238 :     # element in the content, and the second element is the tag. We
239 :     # Will till it in so that if nothing else happens it is fine.
240 :    
241 :     my $func_ref = [ $func_entry, "td" ];
242 :     my $uni_ref = undef;
243 :     my $uni_func = undef;
244 :     my $ev = join("<br>",$fig->evidence_codes($fid));
245 :    
246 :     if ($cgi->param('uni'))
247 :     {
248 :     my $uni_entry;
249 :     $uni_func = (@uni > 0) ? $fig->function_of($uni[0]) : "";
250 :     if ( $uni_func && $user )
251 :     {
252 :     $uni_entry = $cgi->checkbox(-name => 'from', -label => '', -value => $uni[0]) . "&nbsp; $uni_func";
253 :     }
254 :     else
255 :     {
256 :     $uni_entry = $uni_func;
257 :     }
258 :     $uni_ref = [ $uni_entry, "td" ];
259 :     push( @$tab,[ $set, $org, $occ, $uni_link, $uni_ref, $user_entry, $in_sub, $ev,$tran_len, $func_ref ] );
260 :     }
261 :     else
262 :     {
263 :     push( @$tab, [ $set, $org, $occ, $user_entry, $in_sub, $ev, $tran_len, $func_ref ] );
264 :     }
265 :    
266 :     # Remember the information we need to do the coloring:
267 :    
268 :     push @func_summary, [ $func, $func_ref, $uni_func, $uni_ref ];
269 :     }
270 :    
271 :     # Okay, let's propose some colors:
272 :    
273 :     my @colors = qw( #EECCAA #FFAAAA #FFCC66 #FFFF00 #AAFFAA #BBBBFF #FFAAFF ); # #FFFFFF
274 :     my %func_color = map { $_ => ( shift @colors || "#DDDDDD" ) }
275 :     sort { $func_count{ $b } <=> $func_count{ $a }
276 :     or $order{ $a } <=> $order{ $b }
277 :     }
278 :     keys %func_count;
279 :    
280 :     my ( $row );
281 :     foreach $row ( @func_summary )
282 :     {
283 :     my ( $func, $func_ref, $uni_func, $uni_ref ) = @$row;
284 :     $func_ref->[1] = "td bgcolor=" . ( $func_color{ $func } || "#DDDDDD" );
285 :     if ( $uni_ref )
286 :     {
287 :     $uni_ref->[1] = "td bgcolor=" . ( $func_color{ $uni_func } || "#DDDDDD" )
288 :     }
289 :     }
290 :    
291 :     push( @$html, &HTML::make_table( $col_hdrs, $tab, "Description By Set" ) );
292 :    
293 :     if ($user)
294 :     {
295 :     push(@$html,$cgi->submit('assign/annotate'),$cgi->end_form);
296 :     push(@$html,$cgi->end_form);
297 :     }
298 :     }
299 :    
300 :    
301 :     # Build a form for extracting subsets of genomes:
302 :    
303 :     my $target = "window$$";
304 :     push(@$html,$cgi->start_form(-method => 'post',
305 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi",
306 :     -target => $target),
307 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff));
308 :    
309 :     foreach $set (keys(%by_set))
310 :     {
311 :     my($x,$set0,$peg);
312 :     $set0 = $set - 1;
313 :     foreach $x (@{$by_set{$set}})
314 :     {
315 :     $peg = $x->[3];
316 :     push(@$html,$cgi->hidden(-name => "color", -value => "$peg:color$set0"),
317 :     $cgi->hidden(-name => "text", -value => "$peg:$set"));
318 :     }
319 :     }
320 :    
321 :     my $prot = $cgi->param('prot');
322 :    
323 :     $col_hdrs = ["show","map","genome","description","PEG","colors"];
324 :     $tab = [];
325 :     $set = $by_set{1};
326 :    
327 :     my %seen_peg;
328 :     foreach $x (sort { $a->[1] cmp $b->[1] } @$set)
329 :     {
330 :     (undef,$org,undef,$fid) = @$x;
331 :     next if ($seen_peg{$fid});
332 :     $seen_peg{$fid} = 1;
333 :    
334 :     push(@$tab,[$cgi->checkbox(-name => 'pinned_to',
335 :     -checked => 1,
336 :     -label => '',
337 :     -value => $fid),
338 :     $org,&FIG::genome_of($fid),$fig->org_of($fid),&HTML::fid_link($cgi,$fid),
339 :     join(",",sort { $a <=> $b } @{$by_line{$fid_to_line{$fid}}})
340 :     ]);
341 :     }
342 :     push(@$html,$cgi->hr);
343 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Keep Just Checked"),
344 :     $cgi->hidden(-name => 'user', -value => $user),
345 :     # $cgi->hidden(-name => 'prot', -value => $prot),
346 :     # $cgi->hidden(-name => 'pinned_to', -value => $prot),
347 :     $cgi->br,
348 :     $cgi->submit('Picked Maps Only'),
349 :     $cgi->end_form);
350 :     }
351 :    
352 :    
353 :     sub get_prot_and_pins {
354 :     my($fig,$cgi,$html) = @_;
355 :    
356 :     my $prot = $cgi->param('prot');
357 :     my @pegs = map { split(/,/,$_) } $cgi->param('pinned_to');
358 :     my @nonfig = grep { $_ !~ /^fig\|/ } @pegs;
359 :     my @pinned_to = ();
360 :    
361 :     my $uniL = {};
362 :     my $uniM = {};
363 :    
364 :     if (@nonfig > 0)
365 :     {
366 :     my $col_hdrs = ["UniProt ID","UniProt Org","UniProt Function","FIG IDs","FIG orgs","FIG Functions"];
367 :     my $tab = [];
368 :     my $x;
369 :     foreach $x (@nonfig)
370 :     {
371 :     if ($x =~ /^[A-Z0-9]{6}$/)
372 :     {
373 :     $x = "uni|$x";
374 :     }
375 :     my @to_fig = &resolve_id($fig,$x);
376 :     my($fig_id,$fig_func,$fig_org);
377 :     if (@to_fig == 0)
378 :     {
379 :     $fig_id = "No Matched FIG IDs";
380 :     $fig_func = "";
381 :     $fig_org = "";
382 :     $x =~ /uni\|(\S+)/;
383 :     $uniM->{$1} = 1;
384 :     }
385 :     else
386 :     {
387 :     $fig_id = join("<br>",map { &HTML::fid_link($cgi,$_) } @to_fig);
388 :     $fig_func = join("<br>",map { $fig->function_of($_) } @to_fig);
389 :     $fig_org = join("<br>",map { $fig->org_of($_) } @to_fig);
390 :     push(@pinned_to,@to_fig);
391 :     }
392 :     my $uni_org = $fig->org_of($x);
393 :     push(@$tab,[&HTML::uni_link($cgi,$x),$fig->org_of($x),scalar $fig->function_of($x),$fig_id,$fig_org,$fig_func]);
394 :     }
395 :     push(@$html,$cgi->hr);
396 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Correspondence Between UniProt and FIG IDs"));
397 :     push(@$html,$cgi->hr);
398 :     }
399 :     else
400 :     {
401 :     @pinned_to = @pegs;
402 :     }
403 :    
404 :     # Make @pinned_to non-redundant by building a hash and extracting the keys
405 :    
406 :     my %pinned_to = map { $_ => 1 } @pinned_to;
407 :     @pinned_to = sort { &FIG::by_fig_id($a,$b) } keys(%pinned_to);
408 :     # print STDERR &Dumper(\@pinned_to);
409 :    
410 :     # Do we have an explicit or implicit protein?
411 :    
412 :     if ((! $prot) && (@pinned_to < 2))
413 :     {
414 :     return undef;
415 :     }
416 :    
417 :     # No explicit protein, take one from the list:
418 :    
419 :     if (! $prot)
420 :     {
421 :     $prot = shift @pinned_to;
422 :     }
423 :    
424 :     my $in_pin = @pinned_to;
425 :    
426 :     # Make sure that there are pins
427 :    
428 :     if (@pinned_to < 1)
429 :     {
430 :     @pinned_to = &get_pin($fig,$prot);
431 :     $in_pin = @pinned_to;
432 :     my $max = $cgi->param('maxpin');
433 :     $max = $max ? $max : 300;
434 :     if (@pinned_to > (2 * $max))
435 :     {
436 :     @pinned_to = &limit_pinned($prot,\@pinned_to,2 * $max);
437 :     }
438 :     }
439 :    
440 :     # print STDERR &Dumper(\@pinned_to);
441 :     if (@pinned_to == 0)
442 :     {
443 :     return undef;
444 :     }
445 :    
446 :     # Ensure that there is exactly one copy of $prot, then sort by taxonomy:
447 :    
448 :     @pinned_to = ( $prot, grep { $_ ne $prot } @pinned_to );
449 :     @pinned_to = $fig->sort_fids_by_taxonomy(@pinned_to);
450 :     # print &Dumper([$prot,\@pinned_to,$in_pin]);
451 :    
452 :     # $uniL is always {}. What was it for? -- GJO
453 :    
454 :     return ( $prot, \@pinned_to, $in_pin, $uniL, $uniM );
455 :     }
456 :    
457 :    
458 :    
459 :     sub get_initial_gg_and_all_pegs {
460 :     my( $fig, $cgi, $prot, $pinned_to, $uniL, $uniM ) = @_;
461 :    
462 :     # $prot is the protein the reference protein
463 :     # @$pinned_to is the complete list of proteins to be aligned across genomes
464 :     # $uniL is {} and is never used!
465 :     # %$uniM is a hash of uniprot ids from $cgi->param('pinned_to'),
466 :     # with no other information. They create empty lines.
467 :    
468 :     my $gg = [];
469 :     my($peg,$loc,$org,$contig,$beg,$end,$min,$max,$genes,$feat,$fid);
470 :     my($contig1,$beg1,$end1,@all_pegs,$map,$mid,$pegI);
471 :    
472 :     foreach $peg ( @$pinned_to )
473 :     {
474 :     $org = $fig->org_of($peg);
475 :     # print STDERR "processing $peg\n";
476 :     $loc = $fig->feature_location($peg);
477 :     if ( $loc)
478 :     {
479 :     ($contig,$beg,$end) = $fig->boundaries_of($loc);
480 :     if ($contig && $beg && $end)
481 :     {
482 :     $mid = int(($beg + $end) / 2);
483 :     $min = $mid - 8000;
484 :     $max = $mid + 8000;
485 :     $genes = [];
486 :     ($feat,undef,undef) = $fig->genes_in_region($fig->genome_of($peg),$contig,$min,$max);
487 :     # print STDERR &Dumper($feat);
488 :     foreach $fid (@$feat)
489 :     {
490 :     ($contig1,$beg1,$end1) = &FIG::boundaries_of($fig->feature_location($fid));
491 :     # print STDERR "contig1=$contig1 beg1=$beg1 end1=$end1\n";
492 :     # print STDERR &Dumper([$fid,$fig->feature_location($fid),$fig->boundaries_of($fig->feature_location($fid))]);
493 :     $beg1 = &in_bounds($min,$max,$beg1);
494 :     $end1 = &in_bounds($min,$max,$end1);
495 :    
496 :     # Build the pop-up information for the gene:
497 :    
498 :     my $function = $fig->function_of($fid);
499 :     my $aliases1 = $fig->feature_aliases($fid);
500 :     my ( $uniprot ) = $aliases1 =~ /(uni\|[^,]+)/;
501 :    
502 :    
503 :     my $info = join( '<br/>', "<b>Org:</b> $org",
504 :     "<b>PEG:</b> $fid",
505 :     "<b>Contig:</b> $contig1",
506 :     "<b>Begin:</b> $beg1",
507 :     "<b>End:</b> $end1",
508 :     ( $function ? "<b>Function:</b> $function" : () ),
509 :     ( $uniprot ? "<b>Uniprot ID:</b> $uniprot" : () )
510 :     );
511 :    
512 :     my @allattributes=$fig->get_attributes($fid);
513 :     foreach my $eachattr (@allattributes) {
514 :     my ($gotpeg,$gottag,$val, $url)=@$eachattr;
515 :     $info .= "<br/><b>Attribute:</b> $gottag $val $url";
516 :     }
517 :    
518 :     push( @$genes, [ &FIG::min($beg1,$end1),
519 :     &FIG::max($beg1,$end1),
520 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
521 :     "",
522 :     "",
523 :     $fid,
524 :     $info
525 :     ] );
526 :    
527 :     if ( $fid =~ /peg/ ) { push @all_pegs, $fid }
528 :     }
529 :    
530 :     # Everything is done for the one "genome", push it onto GenoGraphics input:
531 :    
532 :     $map = [ &FIG::abbrev($fig->org_of($peg)),
533 :     0,
534 :     $max+1-$min,
535 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)
536 :     ];
537 :    
538 :     push( @$gg, $map );
539 :     }
540 :     }
541 :     }
542 :    
543 :     &GenoGraphics::disambiguate_maps($gg);
544 :    
545 :     # %$uniM is a hash of uniprot IDs. This just draws blank genome lines for each.
546 :    
547 :     foreach $_ (sort keys %$uniM )
548 :     {
549 :     push( @$gg, [ $_, 0, 8000, [] ] );
550 :     }
551 :     # print STDERR &Dumper($gg); die "abort";
552 :    
553 :     # move all pegs from the $prot genome to the front of all_pegs.
554 :    
555 :     my $genome_of_prot = $prot ? FIG::genome_of( $prot ) : "";
556 :    
557 :     if ( $genome_of_prot ) {
558 :     my @tmp = ();
559 :     foreach $peg ( @all_pegs )
560 :     {
561 :     if ( $genome_of_prot eq FIG::genome_of( $peg ) ) { unshift @tmp, $peg }
562 :     else { push @tmp, $peg }
563 :     }
564 :     @all_pegs = @tmp;
565 :     }
566 :    
567 :     # Find the index of $prot in @all_pegs
568 :    
569 :    
570 :     for ($pegI = 0; ($pegI < @all_pegs) && ($prot ne $all_pegs[$pegI]); $pegI++) {}
571 :     if ($pegI == @all_pegs)
572 :     {
573 :     $pegI = 0;
574 :     }
575 :    
576 :     # print STDERR "pegi=$pegI prot=$prot $all_pegs[$pegI]\n";
577 :    
578 :     return ( $gg, \@all_pegs, $pegI );
579 :     }
580 :    
581 :    
582 :     sub add_change_sim_threshhold_form {
583 :     my($cgi,$html, $prot, $pinned_to) = @_;
584 :    
585 :     my $user = $cgi->param('user');
586 :    
587 :     my @change_sim_threshhold_form = ();
588 :     push(@change_sim_threshhold_form,start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"));
589 :     if ($user)
590 :     {
591 :     push(@change_sim_threshhold_form,hidden(-name => "user", -value => $user));
592 :     }
593 :    
594 :     my $max = $cgi->param('maxpin');
595 :     $max = $max ? $max : 300;
596 :    
597 :     push(@change_sim_threshhold_form,hidden(-name => "maxpin", -value => $max));
598 :     push(@change_sim_threshhold_form,hidden(-name => "prot", -value => $prot));
599 :     push(@change_sim_threshhold_form,hidden(-name => "pinned_to", -value => [@$pinned_to]));
600 :     push(@change_sim_threshhold_form,"Similarity Threshold: ", $cgi->textfield(-name => 'sim_cutoff', -size => 10, -value => 1.0e-20),
601 :     $cgi->submit('compute at given similarity threshhold'),
602 :     $cgi->end_form);
603 :     push(@$html,@change_sim_threshhold_form);
604 :     return;
605 :     }
606 :    
607 :    
608 :     # I now attempt to document, clean code, and make orphan genes gray. Wish us all luck. -- GJO
609 :    
610 :     sub form_sets_and_set_color_and_text {
611 :     my( $fig, $cgi, $gg, $pegI, $all_pegs, $sim_cutoff ) = @_;
612 :    
613 :     # @$gg is GenoGraphics objects (maps exist, but they will be modified)
614 :     # $pegI is index of the reference protein in @$all_pegs
615 :     # @$all_pegs is a list of all proteins on the diagram
616 :    
617 :     # all of the PEGs are now stashed in $all_pegs. We are going to now look up similarities
618 :     # between them and form connections. The tricky part is that we are going to use "raw" sims,
619 :     # which means that we need to translate IDs; a single ID in a raw similarity may refer to multiple
620 :     # entries in $all_pegs. $pos_of{$peg} is set to a list of positions (of essentially identical PEGs).
621 :    
622 :     my %peg2i; # map from id (in @$all_pegs) to index in @$all_pegs
623 :     my %pos_of; # maps representative id to indexes in @$all_pegs, and original id to its index
624 :     my @rep_ids; # list of representative ids (product of all maps_to_id)
625 :    
626 :     my ( $i, $id_i );
627 :     for ($i=0; ($i < @$all_pegs); $i++)
628 :     {
629 :     $id_i = $all_pegs->[$i];
630 :     $peg2i{ $id_i } = $i;
631 :    
632 :     my $rep = $fig->maps_to_id($id_i );
633 :     defined( $pos_of{ $rep } ) or push @rep_ids, $rep;
634 :     push @{ $pos_of{ $rep } }, $i;
635 :     if ( $rep ne $id_i )
636 :     {
637 :     push @{ $pos_of{ $id_i } }, $i;
638 :     }
639 :     }
640 :    
641 :     # print STDERR Dumper(\%pos_of, \%peg2i, \@rep_ids);
642 :    
643 :     # @{$conn{ $rep }} will list all connections of a representative id
644 :     # (this used to be for every protein, not the representatives).
645 :    
646 :     my %conn;
647 :    
648 :     my @texts = $cgi->param('text'); # map of id to text
649 :     my @colors = $cgi->param('color'); # peg:color pairs
650 :     my @color_sets = ();
651 :    
652 :     # Case 1, find sets of related sequences using sims:
653 :    
654 :     if ( @colors == 0 )
655 :     {
656 :     # Get sequence similarities among representatives
657 :    
658 :     my ( $rep, $id2 );
659 :     foreach $rep ( @rep_ids )
660 :     {
661 :     # We get $sim_cutoff as a global var (ouch)
662 :    
663 :     $conn{ $rep } = [ map { defined( $pos_of{ $id2 = $_->id2 } ) ? $id2 : () }
664 :     $fig->sims($rep, 500, $sim_cutoff, "raw" )
665 :     ];
666 :     }
667 :     # print STDERR &Dumper(\%conn);
668 :    
669 :     # Build similarity clusters
670 :    
671 :     my %seen = ();
672 :     foreach $rep ( @rep_ids )
673 :     {
674 :     next if $seen{ $rep };
675 :    
676 :     my @cluster = ( $rep );
677 :     my @pending = ( $rep );
678 :     $seen{ $rep } = 1;
679 :    
680 :     while ( $id2 = shift @pending )
681 :     {
682 :     my $k;
683 :     foreach $k ( @{ $conn{ $id2 } } )
684 :     {
685 :     next if $seen{ $k };
686 :    
687 :     push @cluster, $k;
688 :     push @pending, $k;
689 :     $seen{ $k } = 1;
690 :     }
691 :    
692 :     }
693 :     if ( @cluster > 1 ) { push @color_sets, \@cluster }
694 :     }
695 :    
696 :     # Clusters were built by representatives.
697 :     # Map (and expand) back to lists of indices into @all_pegs.
698 :    
699 :     @color_sets = map { [ map { @{ $pos_of{ $_ } } } @$_ ] }
700 :     @color_sets;
701 :     }
702 :     else # Case 2, supplied colors are group labels that should be same color
703 :     {
704 :     my( %sets, $peg, $x, $color );
705 :     foreach $x ( @colors )
706 :     {
707 :     ( $peg, $color ) = $x =~ /^(.*):([^:]*)$/;
708 :     if ( $peg2i{ $peg } )
709 :     {
710 :     push @{ $sets{ $color } }, $peg2i{ $peg };
711 :     }
712 :     }
713 :    
714 :     @color_sets = map { $sets{ $_ } } keys %sets;
715 :     }
716 :    
717 :     # Order the clusters from largest to smallest
718 :    
719 :     @color_sets = sort { @$b <=> @$a } @color_sets;
720 :     # foreach ( @color_sets ) { print STDERR "[ ", join( ", ", @$_ ), " ]\n" }
721 :    
722 :     # Move cluster with reference prot to the beginning:
723 :    
724 :     my $set1;
725 :     @color_sets = map { ( &in( $pegI, $_ ) && ( $set1 = $_ ) ) ? () : $_ } @color_sets;
726 :     if ( $set1 )
727 :     {
728 :     unshift @color_sets, $set1;
729 :     # print STDERR &Dumper(["color_sets",[map { [ map { $all_pegs->[$_] } @$_ ] } @color_sets]]); die "aborted";
730 :     }
731 :     # else
732 :     # {
733 :     # print STDERR &Dumper(\@color_sets);
734 :     # print STDERR "could not find initial PEG in color sets\n";
735 :     # }
736 :    
737 :     my( %color, %text, $i, $j );
738 :     for ( $i=0; ($i < @color_sets); $i++)
739 :     {
740 :     my $color_set_i = $color_sets[ $i ];
741 :     my $picked_color = &pick_color( $cgi, $all_pegs, $color_set_i, $i, \@colors );
742 :     my $picked_text = &pick_text( $cgi, $all_pegs, $color_set_i, $i, \@texts );
743 :    
744 :     foreach $j ( @$color_set_i )
745 :     {
746 :     $color{$all_pegs->[$j]} = $picked_color;
747 :     $text{$all_pegs->[$j]} = $picked_text;
748 :     }
749 :     }
750 :    
751 :     # print STDERR &Dumper($all_pegs,\@color_sets);
752 :     return (\%color,\%text);
753 :     }
754 :    
755 :     sub add_commentary_form {
756 :     my($prot,$user,$cgi,$html,$vals) = @_;
757 :    
758 :    
759 :     my @commentary_form = ();
760 :     my $ctarget = "window$$";
761 :    
762 :     my $uni = $cgi->param('uni');
763 :     if (! defined($uni)) { $uni = "" }
764 :    
765 :     push(@commentary_form,start_form(-target => $ctarget,
766 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi"
767 :     ));
768 :     push(@commentary_form,hidden(-name => "request", -value => "show_commentary"));
769 :     push(@commentary_form,hidden(-name => "prot", -value => $prot));
770 :     push(@commentary_form,hidden(-name => "user", -value => $user));
771 :     push(@commentary_form,hidden(-name => "uni", -value => $uni));
772 :    
773 :     push(@commentary_form,hidden(-name => "show", -value => [@$vals]));
774 :     push(@commentary_form,submit('commentary'));
775 :     push(@commentary_form,end_form());
776 :     push(@$html,@commentary_form);
777 :    
778 :     return;
779 :     }
780 :    
781 :     sub update_gg_with_color_and_text {
782 :     my( $cgi, $gg, $color, $text, $prot ) = @_;
783 :    
784 :     my( $gene, $n, %how_many, $x, $map, $i, %got_color );
785 :    
786 :     my %must_have_color;
787 :    
788 :     my @must_have = $cgi->param('must_have');
789 :     push @must_have, $prot;
790 :    
791 :     my @vals = ();
792 :     for ( $i = (@$gg - 1); ($i >= 0); $i--)
793 :     {
794 :     my @vals1 = ();
795 :     $map = $gg->[$i]; # @$map = ( abbrev, min_coord, max_coord, \@genes )
796 :    
797 :     undef %got_color;
798 :     my $got_red = 0;
799 :     my $found = 0;
800 :     undef %how_many;
801 :    
802 :     foreach $gene ( @{$map->[3]} )
803 :     {
804 :     # @$gene = ( min_coord, max_coord, symbol, color, text, id_link, pop_up_info )
805 :    
806 :     my $id = $gene->[5];
807 :     if ( $x = $color->{ $id } )
808 :     {
809 :     $gene->[3] = $x;
810 :     $gene->[4] = $n = $text->{ $id };
811 :     $got_color{ $x } = 1;
812 :     if ( ( $x =~ /^(red|color0)$/ )
813 :     && &FIG::between( $gene->[0], ($map->[1]+$map->[2])/2, $gene->[1] )
814 :     ) { $got_red = 1 }
815 :     $how_many{ $n }++;
816 :     push @vals1, join( "@", $n, $i, $id, $map->[0], $how_many{$n} );
817 :     $found++;
818 :     }
819 :     else
820 :     {
821 :     $gene->[3] = "ltgray"; # Light gray
822 :     }
823 :     #
824 :     # RDO: for this code, don't change into a link. We want that
825 :     # to be done locally on a SEED.
826 :     #
827 :     # $gene->[5] = &HTML::fid_link( $cgi, $id, 0, 1 );
828 :     }
829 :    
830 :     for ( $x = 0; ( $x < @must_have ) && $got_color{ $color->{ $must_have[ $x ] } }; $x++ ) {}
831 :     if ( ( $x < @must_have ) || ( ! $got_red ) )
832 :     {
833 :     # print STDERR &Dumper($map);
834 :     if ( @{ $map->[3] } > 0 ) { splice( @$gg, $i, 1 ) }
835 :     }
836 :     else
837 :     {
838 :     push @vals, @vals1;
839 :     }
840 :     }
841 :     # print STDERR &Dumper($gg);
842 :    
843 :     return \@vals;
844 :     }
845 :    
846 :     sub thin_out_over_max {
847 :     my($cgi,$prot,$gg,$html,$in_pin) = @_;
848 :    
849 :     my $user = $cgi->param('user');
850 :     $user = $user ? $user : "";
851 :    
852 :     my $max = $cgi->param('maxpin');
853 :     $max = $max ? $max : 300;
854 :    
855 :     if ($in_pin > $max)
856 :     {
857 :     my $sim_cutoff = $cgi->param('sim_cutoff');
858 :     if (! $sim_cutoff) { $sim_cutoff = 1.0e-20 }
859 :    
860 :     my $to = &FIG::min(scalar @$gg,$max);
861 :     push(@$html,$cgi->h1("Truncating from $in_pin pins to $to pins"),
862 :     $cgi->start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"),,
863 :     "Max Pins: ", $cgi->textfield(-name => 'maxpin',
864 :     -value => $_,
865 :     -override => 1),
866 :     $cgi->hidden(-name => 'user', -value => $user),
867 :     $cgi->hidden(-name => 'prot', -value => $prot),
868 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff),
869 :     $cgi->submit("Recompute after adjusting Max Pins"),
870 :     $cgi->end_form,
871 :     $cgi->hr);
872 :    
873 :     if (@$gg > $max)
874 :     {
875 :     my($i,$to_cut);
876 :     for ($i=0; ($i < @$gg) && (! &in_map($prot,$gg->[$i])); $i++) {}
877 :    
878 :     if ($i < @$gg)
879 :     {
880 :     my $beg = $i - int($max/2);
881 :     my $end = $i + int($max/2);
882 :     if (($beg < 0) && ($end < @$gg))
883 :     {
884 :     $beg = 0;
885 :     $end = $beg + ($max - 1);
886 :     }
887 :     elsif (($end >= @$gg) && ($beg > 0))
888 :     {
889 :     $end = @$gg - 1;
890 :     $beg = $end - ($max - 1);
891 :     }
892 :    
893 :     if ($end < (@$gg - 1))
894 :     {
895 :     splice(@$gg,$end+1);
896 :     }
897 :    
898 :     if ($beg > 0)
899 :     {
900 :     splice(@$gg,0,$beg);
901 :     }
902 :     }
903 :     }
904 :     }
905 :     }
906 :    
907 :     sub in_map {
908 :     my($peg,$map) = @_;
909 :     my $i;
910 :    
911 :     my $genes = $map->[3];
912 :     for ($i=0; ($i < @$genes) && (index($genes->[$i]->[5],"$peg\&") < 0); $i++) {}
913 :     return ($i < @$genes);
914 :     }
915 :    
916 :     sub limit_pinned {
917 :     my($prot,$pinned_to,$max) = @_;
918 :    
919 :     my($i,$to_cut);
920 :     for ($i=0; ($i < @$pinned_to) && ($pinned_to->[$i] ne $prot); $i++) {}
921 :    
922 :     if ($i < @$pinned_to)
923 :     {
924 :     my $beg = $i - int($max/2);
925 :     my $end = $i + int($max/2);
926 :     if (($beg < 0) && ($end < @$pinned_to))
927 :     {
928 :     $beg = 0;
929 :     $end = $beg + ($max - 1);
930 :     }
931 :     elsif (($end >= @$pinned_to) && ($beg > 0))
932 :     {
933 :     $end = @$pinned_to - 1;
934 :     $beg = $end - ($max - 1);
935 :     }
936 :    
937 :     if ($end < (@$pinned_to - 1))
938 :     {
939 :     splice(@$pinned_to,$end+1);
940 :     }
941 :    
942 :     if ($beg > 0)
943 :     {
944 :     splice(@$pinned_to,0,$beg);
945 :     }
946 :     }
947 :     return @$pinned_to;
948 :     }
949 :    
950 :     sub resolve_id {
951 :     my($fig,$id) = @_;
952 :     my(@pegs);
953 :    
954 :     if ($id =~ /^fig/) { return $id }
955 :    
956 :     if (@pegs = $fig->by_alias($id)) { return @pegs }
957 :    
958 :     if (($id =~ /^[A-Z0-9]{6}$/) && (@pegs = $fig->by_alias("uni|$id"))) { return @pegs }
959 :    
960 :     if (($id =~ /^\d+$/) && (@pegs = $fig->by_alias("gi|$id"))) { return @pegs }
961 :    
962 :     if (($id =~ /^\d+$/) && (@pegs = $fig->by_alias("gi|$id"))) { return @pegs }
963 :    
964 :     return ();
965 :     }
966 :    
967 :     sub cache_html {
968 :     my($fig,$cgi,$html) = @_;
969 :    
970 :     my @params = sort $cgi->param;
971 :     # print STDERR &Dumper(\@params);
972 :     if ((@params == 3) &&
973 :     ($params[0] eq 'prot') &&
974 :     ($params[1] eq 'uni') &&
975 :     ($params[2] eq 'user'))
976 :     {
977 :     my $prot = $cgi->param('prot');
978 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
979 :     {
980 :     my $user = $cgi->param('user');
981 :     my $uni = $cgi->param('uni');
982 :     my $file = &cache_file($prot,$uni);
983 :     if (open(CACHE,">$file"))
984 :     {
985 :     foreach $_ (@$html)
986 :     {
987 :     # $_ =~ s/user=$user/USER=@@@/g;
988 :     print CACHE $_;
989 :     }
990 :     close(CACHE);
991 :     }
992 :     }
993 :     }
994 :     }
995 :    
996 :     sub cache_file {
997 :     my($prot,$uni) = @_;
998 :    
999 :     &FIG::verify_dir("$FIG_Config::temp/Cache");
1000 :     return "$FIG_Config::temp/Cache/$prot:$uni";
1001 :     }
1002 :    
1003 :     sub handled_by_cache {
1004 :     my($fig,$cgi) = @_;
1005 :    
1006 :     my @params = sort $cgi->param;
1007 :    
1008 :     my $is_sprout = $cgi->param('SPROUT');
1009 :    
1010 :     my $i;
1011 :     for ($i=0; ($params[$i] =~ /prot|uni|user|SPROUT/); $i++) {}
1012 :    
1013 :     # warn "handled_by_cache: i=$i params=@params\n";
1014 :     if ($i == @params)
1015 :     {
1016 :     my $prot = $cgi->param('prot');
1017 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
1018 :     {
1019 :     my $sprout = $is_sprout ? "&SPROUT=1" : "";
1020 :     my $user = $cgi->param('user');
1021 :     my $uni = $cgi->param('uni');
1022 :     my $file = &cache_file($prot,$uni);
1023 :    
1024 :     if (open(CACHE,"<$file"))
1025 :     {
1026 :     warn "Using local cache $file\n";
1027 :     my $html = [];
1028 :     my $fig_loc;
1029 :     my $to_loc = &FIG::cgi_url;
1030 :     $to_loc =~ /http:\/\/(.*?)\/FIG/;
1031 :     $to_loc = $1;
1032 :     while (defined($_ = <CACHE>))
1033 :     {
1034 :     if ((! $fig_loc) && ($_ =~ /http:\/\/(.*?)\/FIG\/chromosomal_clusters.cgi/))
1035 :     {
1036 :     $fig_loc = quotemeta $1;
1037 :     }
1038 :    
1039 :     $_ =~ s/http:\/\/$fig_loc\//http:\/\/$to_loc\//g;
1040 :     $_ =~ s/USER=\@\@\@/user=$user$sprout/g;
1041 :     $_ =~ s/\buser=[^&;\"]*/user=$user$sprout/g;
1042 :    
1043 :     push(@$html,$_);
1044 :     }
1045 :     close(CACHE);
1046 :    
1047 :     my_show_page($cgi,$html);
1048 :     return 1;
1049 :     }
1050 :     else
1051 :     {
1052 :     my $to_loc = &FIG::cgi_url;
1053 :     my $h;
1054 :     if ($h = get_pins_html($fig, $prot))
1055 :     {
1056 :     #
1057 :     # If we're in sprout, strip the form at the end.
1058 :     # We need to also tack on a hidden variable that sets SPROUT=1.
1059 :     #
1060 :    
1061 :     my $html = [];
1062 :    
1063 :     for (split(/\n/, $h))
1064 :     {
1065 :     if ($is_sprout)
1066 :     {
1067 :     if(/form.*GENDB/)
1068 :     {
1069 :     last;
1070 :     }
1071 :     elsif (/type="submit" name=\"(commentary|compute)/)
1072 :     {
1073 :     push(@$html, qq(<input type="hidden" name="SPROUT" value="1">\n));
1074 :     }
1075 :    
1076 :     #
1077 :     # Don't offer the recompute option.#
1078 :     #
1079 :    
1080 :     s,Similarity Threshold:.*value="compute at given similarity threshhold" />,,;
1081 :    
1082 :     }
1083 :     s/user=master:cached/user=$user$sprout/g;
1084 :     s/name="user" value="master:cached"/name="user" value="$user"/;
1085 :     push(@$html, "$_\n");
1086 :     }
1087 :    
1088 :     my_show_page($cgi, $html);
1089 :     return 1;
1090 :     }
1091 :     }
1092 :     }
1093 :     }
1094 :     return 0;
1095 :     }
1096 :    
1097 :     sub get_pin {
1098 :     my($fig,$peg) = @_;
1099 :    
1100 :     my($peg2,%pinned_to,$tuple);
1101 :    
1102 :     if ($fig->table_exists($fig,'pchs') &&
1103 :     $fig->is_complete($fig->genome_of($peg)))
1104 :     {
1105 :     foreach $peg2 (map { $_->[0] } $fig->coupled_to($peg))
1106 :     {
1107 :     foreach $tuple ($fig->coupling_evidence($peg,$peg2))
1108 :     {
1109 :     $pinned_to{$tuple->[0]} = 1;
1110 :     }
1111 :     }
1112 :     my @tmp = $fig->sort_fids_by_taxonomy(keys(%pinned_to));
1113 :     if (@tmp > 0)
1114 :     {
1115 :     return @tmp;
1116 :     }
1117 :     }
1118 :     return $fig->sort_fids_by_taxonomy($fig->in_pch_pin_with($peg));
1119 :     }
1120 :    
1121 :     sub get_pins_html
1122 :     {
1123 :     my($fig, $peg) = @_;
1124 :    
1125 :     my $ua = new LWP::UserAgent;
1126 :    
1127 :     my $peg_enc = uri_escape($peg);
1128 :     my $my_url_enc = uri_escape($fig->cgi_url());
1129 :     my $pins_url = "http://clearinghouse.theseed.org/Clearinghouse/pins_for_peg.cgi";
1130 :    
1131 :     my $url = "$pins_url?peg=$peg_enc&fig_base=$my_url_enc";
1132 :     my $resp = $ua->get($url);
1133 :    
1134 :     if ($resp->is_success)
1135 :     {
1136 :     return $resp->content;
1137 :     }
1138 :     else
1139 :     {
1140 :     return undef;
1141 :     }
1142 :     }
1143 :    
1144 :     sub my_show_page
1145 :     {
1146 :     my($cgi, $html) = @_;
1147 :    
1148 :     if ($cgi->param('SPROUT'))
1149 :     {
1150 :     my $h = { pins => $html };
1151 :     print "Content-Type: text/html\n";
1152 :     print "\n";
1153 :     my $templ = "$FIG_Config::fig/CGI/Html/CCluster_tmpl.html";
1154 :     print PageBuilder::Build("<$templ", $h,"Html");
1155 :     }
1156 :     else
1157 :     {
1158 :     &HTML::show_page($cgi, $html);
1159 :     }
1160 :     }
1161 :    
1162 :     sub evidence_codes_link {
1163 :     my($cgi) = $_;
1164 :    
1165 :     return "<A href=\"Html/evidence_codes.html\" target=\"SEED_or_SPROUT_help\">Ev</A>";
1166 :     }
1167 :    
1168 :     sub evidence_codes {
1169 :     my($fig,$peg) = @_;
1170 :    
1171 :     if ($peg !~ /^fig\|\d+\.\d+\.peg\.\d+$/) { return "" }
1172 :    
1173 :     my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($peg);
1174 :     return (@codes > 0) ? map { $_->[2] } @codes : ();
1175 :     }
1176 :    
1177 :    
1178 :     #####################################################################

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3