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

Annotation of /FigKernelPackages/ChromosomalClusters.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (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 : olson 1.2 return($gg);
61 : olson 1.1 }
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 : golsen 1.4 # Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ]
532 : olson 1.1
533 : overbeek 1.7 #$map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],
534 : golsen 1.5 my $org = $fig->org_of( $peg );
535 :     my $desc = "Genome: $org<br />Contig: $contig";
536 :     $map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],
537 : olson 1.1 0,
538 :     $max+1-$min,
539 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)
540 :     ];
541 :    
542 :     push( @$gg, $map );
543 :     }
544 :     }
545 :     }
546 :    
547 :     &GenoGraphics::disambiguate_maps($gg);
548 :    
549 :     # %$uniM is a hash of uniprot IDs. This just draws blank genome lines for each.
550 :    
551 :     foreach $_ (sort keys %$uniM )
552 :     {
553 :     push( @$gg, [ $_, 0, 8000, [] ] );
554 :     }
555 :     # print STDERR &Dumper($gg); die "abort";
556 :    
557 :     # move all pegs from the $prot genome to the front of all_pegs.
558 :    
559 :     my $genome_of_prot = $prot ? FIG::genome_of( $prot ) : "";
560 :    
561 :     if ( $genome_of_prot ) {
562 :     my @tmp = ();
563 :     foreach $peg ( @all_pegs )
564 :     {
565 :     if ( $genome_of_prot eq FIG::genome_of( $peg ) ) { unshift @tmp, $peg }
566 :     else { push @tmp, $peg }
567 :     }
568 :     @all_pegs = @tmp;
569 :     }
570 :    
571 :     # Find the index of $prot in @all_pegs
572 :    
573 :    
574 :     for ($pegI = 0; ($pegI < @all_pegs) && ($prot ne $all_pegs[$pegI]); $pegI++) {}
575 :     if ($pegI == @all_pegs)
576 :     {
577 :     $pegI = 0;
578 :     }
579 :    
580 :     # print STDERR "pegi=$pegI prot=$prot $all_pegs[$pegI]\n";
581 :    
582 :     return ( $gg, \@all_pegs, $pegI );
583 :     }
584 :    
585 :    
586 :     sub add_change_sim_threshhold_form {
587 :     my($cgi,$html, $prot, $pinned_to) = @_;
588 :    
589 :     my $user = $cgi->param('user');
590 :    
591 :     my @change_sim_threshhold_form = ();
592 :     push(@change_sim_threshhold_form,start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"));
593 :     if ($user)
594 :     {
595 :     push(@change_sim_threshhold_form,hidden(-name => "user", -value => $user));
596 :     }
597 :    
598 :     my $max = $cgi->param('maxpin');
599 :     $max = $max ? $max : 300;
600 :    
601 :     push(@change_sim_threshhold_form,hidden(-name => "maxpin", -value => $max));
602 :     push(@change_sim_threshhold_form,hidden(-name => "prot", -value => $prot));
603 :     push(@change_sim_threshhold_form,hidden(-name => "pinned_to", -value => [@$pinned_to]));
604 :     push(@change_sim_threshhold_form,"Similarity Threshold: ", $cgi->textfield(-name => 'sim_cutoff', -size => 10, -value => 1.0e-20),
605 :     $cgi->submit('compute at given similarity threshhold'),
606 :     $cgi->end_form);
607 :     push(@$html,@change_sim_threshhold_form);
608 :     return;
609 :     }
610 :    
611 :    
612 :     # I now attempt to document, clean code, and make orphan genes gray. Wish us all luck. -- GJO
613 :    
614 :     sub form_sets_and_set_color_and_text {
615 :     my( $fig, $cgi, $gg, $pegI, $all_pegs, $sim_cutoff ) = @_;
616 :    
617 :     # @$gg is GenoGraphics objects (maps exist, but they will be modified)
618 :     # $pegI is index of the reference protein in @$all_pegs
619 :     # @$all_pegs is a list of all proteins on the diagram
620 :    
621 :     # all of the PEGs are now stashed in $all_pegs. We are going to now look up similarities
622 :     # between them and form connections. The tricky part is that we are going to use "raw" sims,
623 :     # which means that we need to translate IDs; a single ID in a raw similarity may refer to multiple
624 :     # entries in $all_pegs. $pos_of{$peg} is set to a list of positions (of essentially identical PEGs).
625 :    
626 :     my %peg2i; # map from id (in @$all_pegs) to index in @$all_pegs
627 :     my %pos_of; # maps representative id to indexes in @$all_pegs, and original id to its index
628 :     my @rep_ids; # list of representative ids (product of all maps_to_id)
629 :    
630 :     my ( $i, $id_i );
631 :     for ($i=0; ($i < @$all_pegs); $i++)
632 :     {
633 :     $id_i = $all_pegs->[$i];
634 :     $peg2i{ $id_i } = $i;
635 :    
636 :     my $rep = $fig->maps_to_id($id_i );
637 :     defined( $pos_of{ $rep } ) or push @rep_ids, $rep;
638 :     push @{ $pos_of{ $rep } }, $i;
639 :     if ( $rep ne $id_i )
640 :     {
641 :     push @{ $pos_of{ $id_i } }, $i;
642 :     }
643 :     }
644 :    
645 :     # print STDERR Dumper(\%pos_of, \%peg2i, \@rep_ids);
646 :    
647 :     # @{$conn{ $rep }} will list all connections of a representative id
648 :     # (this used to be for every protein, not the representatives).
649 :    
650 :     my %conn;
651 :    
652 :     my @texts = $cgi->param('text'); # map of id to text
653 :     my @colors = $cgi->param('color'); # peg:color pairs
654 :     my @color_sets = ();
655 :    
656 :     # Case 1, find sets of related sequences using sims:
657 :    
658 :     if ( @colors == 0 )
659 :     {
660 :     # Get sequence similarities among representatives
661 :    
662 :     my ( $rep, $id2 );
663 :     foreach $rep ( @rep_ids )
664 :     {
665 :     # We get $sim_cutoff as a global var (ouch)
666 :    
667 :     $conn{ $rep } = [ map { defined( $pos_of{ $id2 = $_->id2 } ) ? $id2 : () }
668 :     $fig->sims($rep, 500, $sim_cutoff, "raw" )
669 :     ];
670 :     }
671 :     # print STDERR &Dumper(\%conn);
672 :    
673 :     # Build similarity clusters
674 :    
675 :     my %seen = ();
676 :     foreach $rep ( @rep_ids )
677 :     {
678 :     next if $seen{ $rep };
679 :    
680 :     my @cluster = ( $rep );
681 :     my @pending = ( $rep );
682 :     $seen{ $rep } = 1;
683 :    
684 :     while ( $id2 = shift @pending )
685 :     {
686 :     my $k;
687 :     foreach $k ( @{ $conn{ $id2 } } )
688 :     {
689 :     next if $seen{ $k };
690 :    
691 :     push @cluster, $k;
692 :     push @pending, $k;
693 :     $seen{ $k } = 1;
694 :     }
695 :    
696 :     }
697 :     if ( @cluster > 1 ) { push @color_sets, \@cluster }
698 :     }
699 :    
700 :     # Clusters were built by representatives.
701 :     # Map (and expand) back to lists of indices into @all_pegs.
702 :    
703 :     @color_sets = map { [ map { @{ $pos_of{ $_ } } } @$_ ] }
704 :     @color_sets;
705 :     }
706 :     else # Case 2, supplied colors are group labels that should be same color
707 :     {
708 :     my( %sets, $peg, $x, $color );
709 :     foreach $x ( @colors )
710 :     {
711 :     ( $peg, $color ) = $x =~ /^(.*):([^:]*)$/;
712 :     if ( $peg2i{ $peg } )
713 :     {
714 :     push @{ $sets{ $color } }, $peg2i{ $peg };
715 :     }
716 :     }
717 :    
718 :     @color_sets = map { $sets{ $_ } } keys %sets;
719 :     }
720 :    
721 :     # Order the clusters from largest to smallest
722 :    
723 :     @color_sets = sort { @$b <=> @$a } @color_sets;
724 :     # foreach ( @color_sets ) { print STDERR "[ ", join( ", ", @$_ ), " ]\n" }
725 :    
726 :     # Move cluster with reference prot to the beginning:
727 :    
728 :     my $set1;
729 :     @color_sets = map { ( &in( $pegI, $_ ) && ( $set1 = $_ ) ) ? () : $_ } @color_sets;
730 :     if ( $set1 )
731 :     {
732 :     unshift @color_sets, $set1;
733 :     # print STDERR &Dumper(["color_sets",[map { [ map { $all_pegs->[$_] } @$_ ] } @color_sets]]); die "aborted";
734 :     }
735 :     # else
736 :     # {
737 :     # print STDERR &Dumper(\@color_sets);
738 :     # print STDERR "could not find initial PEG in color sets\n";
739 :     # }
740 :    
741 :     my( %color, %text, $i, $j );
742 :     for ( $i=0; ($i < @color_sets); $i++)
743 :     {
744 :     my $color_set_i = $color_sets[ $i ];
745 :     my $picked_color = &pick_color( $cgi, $all_pegs, $color_set_i, $i, \@colors );
746 :     my $picked_text = &pick_text( $cgi, $all_pegs, $color_set_i, $i, \@texts );
747 :    
748 :     foreach $j ( @$color_set_i )
749 :     {
750 :     $color{$all_pegs->[$j]} = $picked_color;
751 :     $text{$all_pegs->[$j]} = $picked_text;
752 :     }
753 :     }
754 :    
755 :     # print STDERR &Dumper($all_pegs,\@color_sets);
756 :     return (\%color,\%text);
757 :     }
758 :    
759 :     sub add_commentary_form {
760 :     my($prot,$user,$cgi,$html,$vals) = @_;
761 :    
762 :    
763 :     my @commentary_form = ();
764 :     my $ctarget = "window$$";
765 :    
766 :     my $uni = $cgi->param('uni');
767 :     if (! defined($uni)) { $uni = "" }
768 :    
769 :     push(@commentary_form,start_form(-target => $ctarget,
770 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi"
771 :     ));
772 :     push(@commentary_form,hidden(-name => "request", -value => "show_commentary"));
773 :     push(@commentary_form,hidden(-name => "prot", -value => $prot));
774 :     push(@commentary_form,hidden(-name => "user", -value => $user));
775 :     push(@commentary_form,hidden(-name => "uni", -value => $uni));
776 :    
777 :     push(@commentary_form,hidden(-name => "show", -value => [@$vals]));
778 :     push(@commentary_form,submit('commentary'));
779 :     push(@commentary_form,end_form());
780 :     push(@$html,@commentary_form);
781 :    
782 :     return;
783 :     }
784 :    
785 :     sub update_gg_with_color_and_text {
786 :     my( $cgi, $gg, $color, $text, $prot ) = @_;
787 :    
788 :     my( $gene, $n, %how_many, $x, $map, $i, %got_color );
789 :    
790 :     my %must_have_color;
791 :    
792 :     my @must_have = $cgi->param('must_have');
793 :     push @must_have, $prot;
794 :    
795 :     my @vals = ();
796 :     for ( $i = (@$gg - 1); ($i >= 0); $i--)
797 :     {
798 :     my @vals1 = ();
799 :     $map = $gg->[$i]; # @$map = ( abbrev, min_coord, max_coord, \@genes )
800 :    
801 :     undef %got_color;
802 :     my $got_red = 0;
803 :     my $found = 0;
804 :     undef %how_many;
805 :    
806 :     foreach $gene ( @{$map->[3]} )
807 :     {
808 :     # @$gene = ( min_coord, max_coord, symbol, color, text, id_link, pop_up_info )
809 :    
810 :     my $id = $gene->[5];
811 :     if ( $x = $color->{ $id } )
812 :     {
813 :     $gene->[3] = $x;
814 :     $gene->[4] = $n = $text->{ $id };
815 :     $got_color{ $x } = 1;
816 :     if ( ( $x =~ /^(red|color0)$/ )
817 :     && &FIG::between( $gene->[0], ($map->[1]+$map->[2])/2, $gene->[1] )
818 :     ) { $got_red = 1 }
819 :     $how_many{ $n }++;
820 :     push @vals1, join( "@", $n, $i, $id, $map->[0], $how_many{$n} );
821 :     $found++;
822 :     }
823 :     else
824 :     {
825 :     $gene->[3] = "ltgray"; # Light gray
826 :     }
827 :     #
828 :     # RDO: for this code, don't change into a link. We want that
829 :     # to be done locally on a SEED.
830 :     #
831 :     # $gene->[5] = &HTML::fid_link( $cgi, $id, 0, 1 );
832 :     }
833 :    
834 :     for ( $x = 0; ( $x < @must_have ) && $got_color{ $color->{ $must_have[ $x ] } }; $x++ ) {}
835 :     if ( ( $x < @must_have ) || ( ! $got_red ) )
836 :     {
837 :     # print STDERR &Dumper($map);
838 :     if ( @{ $map->[3] } > 0 ) { splice( @$gg, $i, 1 ) }
839 :     }
840 :     else
841 :     {
842 :     push @vals, @vals1;
843 :     }
844 :     }
845 :     # print STDERR &Dumper($gg);
846 :    
847 :     return \@vals;
848 :     }
849 :    
850 :     sub thin_out_over_max {
851 :     my($cgi,$prot,$gg,$html,$in_pin) = @_;
852 :    
853 :     my $user = $cgi->param('user');
854 :     $user = $user ? $user : "";
855 :    
856 :     my $max = $cgi->param('maxpin');
857 :     $max = $max ? $max : 300;
858 :    
859 :     if ($in_pin > $max)
860 :     {
861 :     my $sim_cutoff = $cgi->param('sim_cutoff');
862 :     if (! $sim_cutoff) { $sim_cutoff = 1.0e-20 }
863 :    
864 :     my $to = &FIG::min(scalar @$gg,$max);
865 :     push(@$html,$cgi->h1("Truncating from $in_pin pins to $to pins"),
866 :     $cgi->start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"),,
867 :     "Max Pins: ", $cgi->textfield(-name => 'maxpin',
868 :     -value => $_,
869 :     -override => 1),
870 :     $cgi->hidden(-name => 'user', -value => $user),
871 :     $cgi->hidden(-name => 'prot', -value => $prot),
872 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff),
873 :     $cgi->submit("Recompute after adjusting Max Pins"),
874 :     $cgi->end_form,
875 :     $cgi->hr);
876 :    
877 :     if (@$gg > $max)
878 :     {
879 :     my($i,$to_cut);
880 :     for ($i=0; ($i < @$gg) && (! &in_map($prot,$gg->[$i])); $i++) {}
881 :    
882 :     if ($i < @$gg)
883 :     {
884 :     my $beg = $i - int($max/2);
885 :     my $end = $i + int($max/2);
886 :     if (($beg < 0) && ($end < @$gg))
887 :     {
888 :     $beg = 0;
889 :     $end = $beg + ($max - 1);
890 :     }
891 :     elsif (($end >= @$gg) && ($beg > 0))
892 :     {
893 :     $end = @$gg - 1;
894 :     $beg = $end - ($max - 1);
895 :     }
896 :    
897 :     if ($end < (@$gg - 1))
898 :     {
899 :     splice(@$gg,$end+1);
900 :     }
901 :    
902 :     if ($beg > 0)
903 :     {
904 :     splice(@$gg,0,$beg);
905 :     }
906 :     }
907 :     }
908 :     }
909 :     }
910 :    
911 :     sub in_map {
912 :     my($peg,$map) = @_;
913 :     my $i;
914 :    
915 :     my $genes = $map->[3];
916 :     for ($i=0; ($i < @$genes) && (index($genes->[$i]->[5],"$peg\&") < 0); $i++) {}
917 :     return ($i < @$genes);
918 :     }
919 :    
920 :     sub limit_pinned {
921 :     my($prot,$pinned_to,$max) = @_;
922 :    
923 :     my($i,$to_cut);
924 :     for ($i=0; ($i < @$pinned_to) && ($pinned_to->[$i] ne $prot); $i++) {}
925 :    
926 :     if ($i < @$pinned_to)
927 :     {
928 :     my $beg = $i - int($max/2);
929 :     my $end = $i + int($max/2);
930 :     if (($beg < 0) && ($end < @$pinned_to))
931 :     {
932 :     $beg = 0;
933 :     $end = $beg + ($max - 1);
934 :     }
935 :     elsif (($end >= @$pinned_to) && ($beg > 0))
936 :     {
937 :     $end = @$pinned_to - 1;
938 :     $beg = $end - ($max - 1);
939 :     }
940 :    
941 :     if ($end < (@$pinned_to - 1))
942 :     {
943 :     splice(@$pinned_to,$end+1);
944 :     }
945 :    
946 :     if ($beg > 0)
947 :     {
948 :     splice(@$pinned_to,0,$beg);
949 :     }
950 :     }
951 :     return @$pinned_to;
952 :     }
953 :    
954 :     sub resolve_id {
955 :     my($fig,$id) = @_;
956 :     my(@pegs);
957 :    
958 :     if ($id =~ /^fig/) { return $id }
959 :    
960 :     if (@pegs = $fig->by_alias($id)) { return @pegs }
961 :    
962 :     if (($id =~ /^[A-Z0-9]{6}$/) && (@pegs = $fig->by_alias("uni|$id"))) { return @pegs }
963 :    
964 :     if (($id =~ /^\d+$/) && (@pegs = $fig->by_alias("gi|$id"))) { return @pegs }
965 :    
966 :     if (($id =~ /^\d+$/) && (@pegs = $fig->by_alias("gi|$id"))) { return @pegs }
967 :    
968 :     return ();
969 :     }
970 :    
971 :     sub cache_html {
972 :     my($fig,$cgi,$html) = @_;
973 :    
974 :     my @params = sort $cgi->param;
975 :     # print STDERR &Dumper(\@params);
976 :     if ((@params == 3) &&
977 :     ($params[0] eq 'prot') &&
978 :     ($params[1] eq 'uni') &&
979 :     ($params[2] eq 'user'))
980 :     {
981 :     my $prot = $cgi->param('prot');
982 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
983 :     {
984 :     my $user = $cgi->param('user');
985 :     my $uni = $cgi->param('uni');
986 :     my $file = &cache_file($prot,$uni);
987 :     if (open(CACHE,">$file"))
988 :     {
989 :     foreach $_ (@$html)
990 :     {
991 :     # $_ =~ s/user=$user/USER=@@@/g;
992 :     print CACHE $_;
993 :     }
994 :     close(CACHE);
995 :     }
996 :     }
997 :     }
998 :     }
999 :    
1000 :     sub cache_file {
1001 :     my($prot,$uni) = @_;
1002 :    
1003 :     &FIG::verify_dir("$FIG_Config::temp/Cache");
1004 :     return "$FIG_Config::temp/Cache/$prot:$uni";
1005 :     }
1006 :    
1007 :     sub handled_by_cache {
1008 :     my($fig,$cgi) = @_;
1009 :    
1010 :     my @params = sort $cgi->param;
1011 :    
1012 :     my $is_sprout = $cgi->param('SPROUT');
1013 :    
1014 :     my $i;
1015 :     for ($i=0; ($params[$i] =~ /prot|uni|user|SPROUT/); $i++) {}
1016 :    
1017 :     # warn "handled_by_cache: i=$i params=@params\n";
1018 :     if ($i == @params)
1019 :     {
1020 :     my $prot = $cgi->param('prot');
1021 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
1022 :     {
1023 :     my $sprout = $is_sprout ? "&SPROUT=1" : "";
1024 :     my $user = $cgi->param('user');
1025 :     my $uni = $cgi->param('uni');
1026 :     my $file = &cache_file($prot,$uni);
1027 :    
1028 :     if (open(CACHE,"<$file"))
1029 :     {
1030 :     warn "Using local cache $file\n";
1031 :     my $html = [];
1032 :     my $fig_loc;
1033 :     my $to_loc = &FIG::cgi_url;
1034 :     $to_loc =~ /http:\/\/(.*?)\/FIG/;
1035 :     $to_loc = $1;
1036 :     while (defined($_ = <CACHE>))
1037 :     {
1038 :     if ((! $fig_loc) && ($_ =~ /http:\/\/(.*?)\/FIG\/chromosomal_clusters.cgi/))
1039 :     {
1040 :     $fig_loc = quotemeta $1;
1041 :     }
1042 :    
1043 :     $_ =~ s/http:\/\/$fig_loc\//http:\/\/$to_loc\//g;
1044 :     $_ =~ s/USER=\@\@\@/user=$user$sprout/g;
1045 :     $_ =~ s/\buser=[^&;\"]*/user=$user$sprout/g;
1046 :    
1047 :     push(@$html,$_);
1048 :     }
1049 :     close(CACHE);
1050 :    
1051 :     my_show_page($cgi,$html);
1052 :     return 1;
1053 :     }
1054 :     else
1055 :     {
1056 :     my $to_loc = &FIG::cgi_url;
1057 :     my $h;
1058 :     if ($h = get_pins_html($fig, $prot))
1059 :     {
1060 :     #
1061 :     # If we're in sprout, strip the form at the end.
1062 :     # We need to also tack on a hidden variable that sets SPROUT=1.
1063 :     #
1064 :    
1065 :     my $html = [];
1066 :    
1067 :     for (split(/\n/, $h))
1068 :     {
1069 :     if ($is_sprout)
1070 :     {
1071 :     if(/form.*GENDB/)
1072 :     {
1073 :     last;
1074 :     }
1075 :     elsif (/type="submit" name=\"(commentary|compute)/)
1076 :     {
1077 :     push(@$html, qq(<input type="hidden" name="SPROUT" value="1">\n));
1078 :     }
1079 :    
1080 :     #
1081 :     # Don't offer the recompute option.#
1082 :     #
1083 :    
1084 :     s,Similarity Threshold:.*value="compute at given similarity threshhold" />,,;
1085 :    
1086 :     }
1087 :     s/user=master:cached/user=$user$sprout/g;
1088 :     s/name="user" value="master:cached"/name="user" value="$user"/;
1089 :     push(@$html, "$_\n");
1090 :     }
1091 :    
1092 :     my_show_page($cgi, $html);
1093 :     return 1;
1094 :     }
1095 :     }
1096 :     }
1097 :     }
1098 :     return 0;
1099 :     }
1100 :    
1101 :     sub get_pin {
1102 :     my($fig,$peg) = @_;
1103 :    
1104 :     my($peg2,%pinned_to,$tuple);
1105 :    
1106 : olson 1.3 if ($fig->table_exists('pchs') &&
1107 : olson 1.1 $fig->is_complete($fig->genome_of($peg)))
1108 :     {
1109 :     foreach $peg2 (map { $_->[0] } $fig->coupled_to($peg))
1110 :     {
1111 :     foreach $tuple ($fig->coupling_evidence($peg,$peg2))
1112 :     {
1113 :     $pinned_to{$tuple->[0]} = 1;
1114 :     }
1115 :     }
1116 :     my @tmp = $fig->sort_fids_by_taxonomy(keys(%pinned_to));
1117 :     if (@tmp > 0)
1118 :     {
1119 :     return @tmp;
1120 :     }
1121 :     }
1122 :     return $fig->sort_fids_by_taxonomy($fig->in_pch_pin_with($peg));
1123 :     }
1124 :    
1125 :     sub get_pins_html
1126 :     {
1127 :     my($fig, $peg) = @_;
1128 :    
1129 :     my $ua = new LWP::UserAgent;
1130 :    
1131 :     my $peg_enc = uri_escape($peg);
1132 :     my $my_url_enc = uri_escape($fig->cgi_url());
1133 :     my $pins_url = "http://clearinghouse.theseed.org/Clearinghouse/pins_for_peg.cgi";
1134 :    
1135 :     my $url = "$pins_url?peg=$peg_enc&fig_base=$my_url_enc";
1136 :     my $resp = $ua->get($url);
1137 :    
1138 :     if ($resp->is_success)
1139 :     {
1140 :     return $resp->content;
1141 :     }
1142 :     else
1143 :     {
1144 :     return undef;
1145 :     }
1146 :     }
1147 :    
1148 :     sub my_show_page
1149 :     {
1150 :     my($cgi, $html) = @_;
1151 :    
1152 :     if ($cgi->param('SPROUT'))
1153 :     {
1154 :     my $h = { pins => $html };
1155 :     print "Content-Type: text/html\n";
1156 :     print "\n";
1157 :     my $templ = "$FIG_Config::fig/CGI/Html/CCluster_tmpl.html";
1158 :     print PageBuilder::Build("<$templ", $h,"Html");
1159 :     }
1160 :     else
1161 :     {
1162 :     &HTML::show_page($cgi, $html);
1163 :     }
1164 :     }
1165 :    
1166 :     sub evidence_codes_link {
1167 :     my($cgi) = $_;
1168 :    
1169 :     return "<A href=\"Html/evidence_codes.html\" target=\"SEED_or_SPROUT_help\">Ev</A>";
1170 :     }
1171 :    
1172 :     sub evidence_codes {
1173 :     my($fig,$peg) = @_;
1174 :    
1175 :     if ($peg !~ /^fig\|\d+\.\d+\.peg\.\d+$/) { return "" }
1176 :    
1177 :     my @codes = grep { $_->[1] =~ /^evidence_code/i } $fig->get_attributes($peg);
1178 :     return (@codes > 0) ? map { $_->[2] } @codes : ();
1179 :     }
1180 :    
1181 :    
1182 :     #####################################################################

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3