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

Annotation of /FigKernelPackages/ChromosomalClusters.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.11 - (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 : olson 1.10 # my $ev = join("<br>",$fig->evidence_codes($fid));
245 :     my $ev = '';
246 : olson 1.1
247 :     if ($cgi->param('uni'))
248 :     {
249 :     my $uni_entry;
250 :     $uni_func = (@uni > 0) ? $fig->function_of($uni[0]) : "";
251 :     if ( $uni_func && $user )
252 :     {
253 :     $uni_entry = $cgi->checkbox(-name => 'from', -label => '', -value => $uni[0]) . "&nbsp; $uni_func";
254 :     }
255 :     else
256 :     {
257 :     $uni_entry = $uni_func;
258 :     }
259 :     $uni_ref = [ $uni_entry, "td" ];
260 :     push( @$tab,[ $set, $org, $occ, $uni_link, $uni_ref, $user_entry, $in_sub, $ev,$tran_len, $func_ref ] );
261 :     }
262 :     else
263 :     {
264 :     push( @$tab, [ $set, $org, $occ, $user_entry, $in_sub, $ev, $tran_len, $func_ref ] );
265 :     }
266 :    
267 :     # Remember the information we need to do the coloring:
268 :    
269 :     push @func_summary, [ $func, $func_ref, $uni_func, $uni_ref ];
270 :     }
271 :    
272 :     # Okay, let's propose some colors:
273 :    
274 :     my @colors = qw( #EECCAA #FFAAAA #FFCC66 #FFFF00 #AAFFAA #BBBBFF #FFAAFF ); # #FFFFFF
275 :     my %func_color = map { $_ => ( shift @colors || "#DDDDDD" ) }
276 :     sort { $func_count{ $b } <=> $func_count{ $a }
277 :     or $order{ $a } <=> $order{ $b }
278 :     }
279 :     keys %func_count;
280 :    
281 :     my ( $row );
282 :     foreach $row ( @func_summary )
283 :     {
284 :     my ( $func, $func_ref, $uni_func, $uni_ref ) = @$row;
285 :     $func_ref->[1] = "td bgcolor=" . ( $func_color{ $func } || "#DDDDDD" );
286 :     if ( $uni_ref )
287 :     {
288 :     $uni_ref->[1] = "td bgcolor=" . ( $func_color{ $uni_func } || "#DDDDDD" )
289 :     }
290 :     }
291 :    
292 :     push( @$html, &HTML::make_table( $col_hdrs, $tab, "Description By Set" ) );
293 :    
294 :     if ($user)
295 :     {
296 :     push(@$html,$cgi->submit('assign/annotate'),$cgi->end_form);
297 :     push(@$html,$cgi->end_form);
298 :     }
299 :     }
300 :    
301 :    
302 :     # Build a form for extracting subsets of genomes:
303 :    
304 :     my $target = "window$$";
305 :     push(@$html,$cgi->start_form(-method => 'post',
306 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi",
307 :     -target => $target),
308 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff));
309 :    
310 :     foreach $set (keys(%by_set))
311 :     {
312 :     my($x,$set0,$peg);
313 :     $set0 = $set - 1;
314 :     foreach $x (@{$by_set{$set}})
315 :     {
316 :     $peg = $x->[3];
317 :     push(@$html,$cgi->hidden(-name => "color", -value => "$peg:color$set0"),
318 :     $cgi->hidden(-name => "text", -value => "$peg:$set"));
319 :     }
320 :     }
321 :    
322 :     my $prot = $cgi->param('prot');
323 :    
324 :     $col_hdrs = ["show","map","genome","description","PEG","colors"];
325 :     $tab = [];
326 :     $set = $by_set{1};
327 :    
328 :     my %seen_peg;
329 :     foreach $x (sort { $a->[1] cmp $b->[1] } @$set)
330 :     {
331 :     (undef,$org,undef,$fid) = @$x;
332 :     next if ($seen_peg{$fid});
333 :     $seen_peg{$fid} = 1;
334 :    
335 :     push(@$tab,[$cgi->checkbox(-name => 'pinned_to',
336 :     -checked => 1,
337 :     -label => '',
338 :     -value => $fid),
339 :     $org,&FIG::genome_of($fid),$fig->org_of($fid),&HTML::fid_link($cgi,$fid),
340 :     join(",",sort { $a <=> $b } @{$by_line{$fid_to_line{$fid}}})
341 :     ]);
342 :     }
343 :     push(@$html,$cgi->hr);
344 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Keep Just Checked"),
345 :     $cgi->hidden(-name => 'user', -value => $user),
346 :     # $cgi->hidden(-name => 'prot', -value => $prot),
347 :     # $cgi->hidden(-name => 'pinned_to', -value => $prot),
348 :     $cgi->br,
349 :     $cgi->submit('Picked Maps Only'),
350 :     $cgi->end_form);
351 :     }
352 :    
353 :    
354 :     sub get_prot_and_pins {
355 :     my($fig,$cgi,$html) = @_;
356 :    
357 :     my $prot = $cgi->param('prot');
358 :     my @pegs = map { split(/,/,$_) } $cgi->param('pinned_to');
359 :     my @nonfig = grep { $_ !~ /^fig\|/ } @pegs;
360 :     my @pinned_to = ();
361 :    
362 :     my $uniL = {};
363 :     my $uniM = {};
364 :    
365 :     if (@nonfig > 0)
366 :     {
367 :     my $col_hdrs = ["UniProt ID","UniProt Org","UniProt Function","FIG IDs","FIG orgs","FIG Functions"];
368 :     my $tab = [];
369 :     my $x;
370 :     foreach $x (@nonfig)
371 :     {
372 :     if ($x =~ /^[A-Z0-9]{6}$/)
373 :     {
374 :     $x = "uni|$x";
375 :     }
376 :     my @to_fig = &resolve_id($fig,$x);
377 :     my($fig_id,$fig_func,$fig_org);
378 :     if (@to_fig == 0)
379 :     {
380 :     $fig_id = "No Matched FIG IDs";
381 :     $fig_func = "";
382 :     $fig_org = "";
383 :     $x =~ /uni\|(\S+)/;
384 :     $uniM->{$1} = 1;
385 :     }
386 :     else
387 :     {
388 :     $fig_id = join("<br>",map { &HTML::fid_link($cgi,$_) } @to_fig);
389 :     $fig_func = join("<br>",map { $fig->function_of($_) } @to_fig);
390 :     $fig_org = join("<br>",map { $fig->org_of($_) } @to_fig);
391 :     push(@pinned_to,@to_fig);
392 :     }
393 :     my $uni_org = $fig->org_of($x);
394 :     push(@$tab,[&HTML::uni_link($cgi,$x),$fig->org_of($x),scalar $fig->function_of($x),$fig_id,$fig_org,$fig_func]);
395 :     }
396 :     push(@$html,$cgi->hr);
397 :     push(@$html,&HTML::make_table($col_hdrs,$tab,"Correspondence Between UniProt and FIG IDs"));
398 :     push(@$html,$cgi->hr);
399 :     }
400 :     else
401 :     {
402 :     @pinned_to = @pegs;
403 :     }
404 :    
405 :     # Make @pinned_to non-redundant by building a hash and extracting the keys
406 :    
407 :     my %pinned_to = map { $_ => 1 } @pinned_to;
408 :     @pinned_to = sort { &FIG::by_fig_id($a,$b) } keys(%pinned_to);
409 :     # print STDERR &Dumper(\@pinned_to);
410 :    
411 :     # Do we have an explicit or implicit protein?
412 :    
413 :     if ((! $prot) && (@pinned_to < 2))
414 :     {
415 :     return undef;
416 :     }
417 :    
418 :     # No explicit protein, take one from the list:
419 :    
420 :     if (! $prot)
421 :     {
422 :     $prot = shift @pinned_to;
423 :     }
424 :    
425 :     my $in_pin = @pinned_to;
426 :    
427 :     # Make sure that there are pins
428 :    
429 :     if (@pinned_to < 1)
430 :     {
431 :     @pinned_to = &get_pin($fig,$prot);
432 :     $in_pin = @pinned_to;
433 :     my $max = $cgi->param('maxpin');
434 :     $max = $max ? $max : 300;
435 :     if (@pinned_to > (2 * $max))
436 :     {
437 :     @pinned_to = &limit_pinned($prot,\@pinned_to,2 * $max);
438 :     }
439 :     }
440 :    
441 :     # print STDERR &Dumper(\@pinned_to);
442 :     if (@pinned_to == 0)
443 :     {
444 :     return undef;
445 :     }
446 :    
447 :     # Ensure that there is exactly one copy of $prot, then sort by taxonomy:
448 :    
449 :     @pinned_to = ( $prot, grep { $_ ne $prot } @pinned_to );
450 :     @pinned_to = $fig->sort_fids_by_taxonomy(@pinned_to);
451 :     # print &Dumper([$prot,\@pinned_to,$in_pin]);
452 :    
453 :     # $uniL is always {}. What was it for? -- GJO
454 :    
455 :     return ( $prot, \@pinned_to, $in_pin, $uniL, $uniM );
456 :     }
457 :    
458 :    
459 :    
460 :     sub get_initial_gg_and_all_pegs {
461 :     my( $fig, $cgi, $prot, $pinned_to, $uniL, $uniM ) = @_;
462 :    
463 :     # $prot is the protein the reference protein
464 :     # @$pinned_to is the complete list of proteins to be aligned across genomes
465 :     # $uniL is {} and is never used!
466 :     # %$uniM is a hash of uniprot ids from $cgi->param('pinned_to'),
467 :     # with no other information. They create empty lines.
468 :    
469 :     my $gg = [];
470 :     my($peg,$loc,$org,$contig,$beg,$end,$min,$max,$genes,$feat,$fid);
471 :     my($contig1,$beg1,$end1,@all_pegs,$map,$mid,$pegI);
472 :    
473 :     foreach $peg ( @$pinned_to )
474 :     {
475 :     $org = $fig->org_of($peg);
476 :     # print STDERR "processing $peg\n";
477 :     $loc = $fig->feature_location($peg);
478 :     if ( $loc)
479 :     {
480 :     ($contig,$beg,$end) = $fig->boundaries_of($loc);
481 :     if ($contig && $beg && $end)
482 :     {
483 :     $mid = int(($beg + $end) / 2);
484 :     $min = $mid - 8000;
485 :     $max = $mid + 8000;
486 :     $genes = [];
487 :     ($feat,undef,undef) = $fig->genes_in_region($fig->genome_of($peg),$contig,$min,$max);
488 :     # print STDERR &Dumper($feat);
489 :     foreach $fid (@$feat)
490 :     {
491 : parrello 1.8 ($contig1,$beg1,$end1) = $fig->boundaries_of($fig->feature_location($fid));
492 : olson 1.1 # print STDERR "contig1=$contig1 beg1=$beg1 end1=$end1\n";
493 :     # print STDERR &Dumper([$fid,$fig->feature_location($fid),$fig->boundaries_of($fig->feature_location($fid))]);
494 :     $beg1 = &in_bounds($min,$max,$beg1);
495 :     $end1 = &in_bounds($min,$max,$end1);
496 :    
497 :     # Build the pop-up information for the gene:
498 :    
499 : olson 1.10 if (0)
500 :     {
501 :    
502 : olson 1.1 my $function = $fig->function_of($fid);
503 :     my $aliases1 = $fig->feature_aliases($fid);
504 :     my ( $uniprot ) = $aliases1 =~ /(uni\|[^,]+)/;
505 :    
506 :    
507 :     my $info = join( '<br/>', "<b>Org:</b> $org",
508 :     "<b>PEG:</b> $fid",
509 :     "<b>Contig:</b> $contig1",
510 :     "<b>Begin:</b> $beg1",
511 :     "<b>End:</b> $end1",
512 :     ( $function ? "<b>Function:</b> $function" : () ),
513 :     ( $uniprot ? "<b>Uniprot ID:</b> $uniprot" : () )
514 :     );
515 :    
516 :     my @allattributes=$fig->get_attributes($fid);
517 :     foreach my $eachattr (@allattributes) {
518 :     my ($gotpeg,$gottag,$val, $url)=@$eachattr;
519 :     $info .= "<br/><b>Attribute:</b> $gottag $val $url";
520 :     }
521 : olson 1.10 }
522 :     my $info = '';
523 : olson 1.1
524 :     push( @$genes, [ &FIG::min($beg1,$end1),
525 :     &FIG::max($beg1,$end1),
526 :     ($beg1 < $end1) ? "rightArrow" : "leftArrow",
527 :     "",
528 :     "",
529 :     $fid,
530 :     $info
531 :     ] );
532 :    
533 :     if ( $fid =~ /peg/ ) { push @all_pegs, $fid }
534 :     }
535 :    
536 :     # Everything is done for the one "genome", push it onto GenoGraphics input:
537 : golsen 1.4 # Sequence title can be replaced by [ title, url, popup_text, menu, popup_title ]
538 : olson 1.1
539 : overbeek 1.7 #$map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],
540 : golsen 1.5 my $org = $fig->org_of( $peg );
541 :     my $desc = "Genome: $org<br />Contig: $contig";
542 :     $map = [ [ FIG::abbrev( $org ), undef, $desc, undef, 'Contig' ],
543 : olson 1.1 0,
544 :     $max+1-$min,
545 :     ($beg < $end) ? &decr_coords($genes,$min) : &flip_map($genes,$min,$max)
546 :     ];
547 :    
548 :     push( @$gg, $map );
549 :     }
550 :     }
551 :     }
552 :    
553 :     &GenoGraphics::disambiguate_maps($gg);
554 :    
555 :     # %$uniM is a hash of uniprot IDs. This just draws blank genome lines for each.
556 :    
557 :     foreach $_ (sort keys %$uniM )
558 :     {
559 :     push( @$gg, [ $_, 0, 8000, [] ] );
560 :     }
561 :     # print STDERR &Dumper($gg); die "abort";
562 :    
563 :     # move all pegs from the $prot genome to the front of all_pegs.
564 :    
565 :     my $genome_of_prot = $prot ? FIG::genome_of( $prot ) : "";
566 :    
567 :     if ( $genome_of_prot ) {
568 :     my @tmp = ();
569 :     foreach $peg ( @all_pegs )
570 :     {
571 :     if ( $genome_of_prot eq FIG::genome_of( $peg ) ) { unshift @tmp, $peg }
572 :     else { push @tmp, $peg }
573 :     }
574 :     @all_pegs = @tmp;
575 :     }
576 :    
577 :     # Find the index of $prot in @all_pegs
578 :    
579 :    
580 :     for ($pegI = 0; ($pegI < @all_pegs) && ($prot ne $all_pegs[$pegI]); $pegI++) {}
581 :     if ($pegI == @all_pegs)
582 :     {
583 :     $pegI = 0;
584 :     }
585 :    
586 :     # print STDERR "pegi=$pegI prot=$prot $all_pegs[$pegI]\n";
587 :    
588 :     return ( $gg, \@all_pegs, $pegI );
589 :     }
590 :    
591 :    
592 :     sub add_change_sim_threshhold_form {
593 :     my($cgi,$html, $prot, $pinned_to) = @_;
594 :    
595 :     my $user = $cgi->param('user');
596 :    
597 :     my @change_sim_threshhold_form = ();
598 :     push(@change_sim_threshhold_form,start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"));
599 :     if ($user)
600 :     {
601 :     push(@change_sim_threshhold_form,hidden(-name => "user", -value => $user));
602 :     }
603 :    
604 :     my $max = $cgi->param('maxpin');
605 :     $max = $max ? $max : 300;
606 :    
607 :     push(@change_sim_threshhold_form,hidden(-name => "maxpin", -value => $max));
608 :     push(@change_sim_threshhold_form,hidden(-name => "prot", -value => $prot));
609 :     push(@change_sim_threshhold_form,hidden(-name => "pinned_to", -value => [@$pinned_to]));
610 :     push(@change_sim_threshhold_form,"Similarity Threshold: ", $cgi->textfield(-name => 'sim_cutoff', -size => 10, -value => 1.0e-20),
611 :     $cgi->submit('compute at given similarity threshhold'),
612 :     $cgi->end_form);
613 :     push(@$html,@change_sim_threshhold_form);
614 :     return;
615 :     }
616 :    
617 :    
618 :     # I now attempt to document, clean code, and make orphan genes gray. Wish us all luck. -- GJO
619 :    
620 :     sub form_sets_and_set_color_and_text {
621 :     my( $fig, $cgi, $gg, $pegI, $all_pegs, $sim_cutoff ) = @_;
622 :    
623 :     # @$gg is GenoGraphics objects (maps exist, but they will be modified)
624 :     # $pegI is index of the reference protein in @$all_pegs
625 :     # @$all_pegs is a list of all proteins on the diagram
626 :    
627 :     # all of the PEGs are now stashed in $all_pegs. We are going to now look up similarities
628 :     # between them and form connections. The tricky part is that we are going to use "raw" sims,
629 :     # which means that we need to translate IDs; a single ID in a raw similarity may refer to multiple
630 :     # entries in $all_pegs. $pos_of{$peg} is set to a list of positions (of essentially identical PEGs).
631 :    
632 :     my %peg2i; # map from id (in @$all_pegs) to index in @$all_pegs
633 :     my %pos_of; # maps representative id to indexes in @$all_pegs, and original id to its index
634 :     my @rep_ids; # list of representative ids (product of all maps_to_id)
635 :    
636 : olson 1.10 #
637 :     # Expt: pull from sims server.
638 :     #
639 :     my $ua = LWP::UserAgent->new();
640 :     my %args = ();
641 :     $args{id} = $all_pegs;
642 :     $args{mapping} = 1;
643 :    
644 :     my %maps_to_id;
645 :     my %reps;
646 :     my $res = $ua->post("http://bio-ppc-44/simserver/perl/sims2.pl", \%args);
647 :     if (!$res->is_success)
648 :     {
649 :     die "getreps failed: " . $res->code . " " . $res->status_line . "\n";
650 :     }
651 :     my $c = $res->content;
652 :     while ($c =~ /(.*)\n/g)
653 :     {
654 :     my($rep, @list) = split(/\t/, $1);
655 :     $reps{$rep} = {};
656 :    
657 :     map { my($id, $len) = split(/,/, $_); $maps_to_id{$id} = $rep; } @list;
658 :     }
659 :    
660 :     #
661 :     # get the sims too.
662 :     #
663 :     my @sims = $fig->sims($all_pegs, 500, $sim_cutoff, 'raw');
664 :     my %sims;
665 :     map { push(@{$sims{$_->id1}}, $_) } @sims;
666 :    
667 :    
668 : olson 1.1 my ( $i, $id_i );
669 :     for ($i=0; ($i < @$all_pegs); $i++)
670 :     {
671 :     $id_i = $all_pegs->[$i];
672 :     $peg2i{ $id_i } = $i;
673 :    
674 : olson 1.10 my $rep = $maps_to_id{$id_i};
675 : olson 1.1 defined( $pos_of{ $rep } ) or push @rep_ids, $rep;
676 :     push @{ $pos_of{ $rep } }, $i;
677 :     if ( $rep ne $id_i )
678 :     {
679 :     push @{ $pos_of{ $id_i } }, $i;
680 :     }
681 :     }
682 :    
683 :     # print STDERR Dumper(\%pos_of, \%peg2i, \@rep_ids);
684 :    
685 :     # @{$conn{ $rep }} will list all connections of a representative id
686 :     # (this used to be for every protein, not the representatives).
687 :    
688 :     my %conn;
689 :    
690 :     my @texts = $cgi->param('text'); # map of id to text
691 :     my @colors = $cgi->param('color'); # peg:color pairs
692 :     my @color_sets = ();
693 :    
694 :     # Case 1, find sets of related sequences using sims:
695 :    
696 :     if ( @colors == 0 )
697 :     {
698 :     # Get sequence similarities among representatives
699 :    
700 :     my ( $rep, $id2 );
701 :     foreach $rep ( @rep_ids )
702 :     {
703 :     # We get $sim_cutoff as a global var (ouch)
704 :    
705 :     $conn{ $rep } = [ map { defined( $pos_of{ $id2 = $_->id2 } ) ? $id2 : () }
706 : olson 1.10 @{$sims{$rep}}
707 : olson 1.1 ];
708 :     }
709 :     # print STDERR &Dumper(\%conn);
710 :    
711 :     # Build similarity clusters
712 :    
713 :     my %seen = ();
714 :     foreach $rep ( @rep_ids )
715 :     {
716 :     next if $seen{ $rep };
717 :    
718 :     my @cluster = ( $rep );
719 :     my @pending = ( $rep );
720 :     $seen{ $rep } = 1;
721 :    
722 :     while ( $id2 = shift @pending )
723 :     {
724 :     my $k;
725 :     foreach $k ( @{ $conn{ $id2 } } )
726 :     {
727 :     next if $seen{ $k };
728 :    
729 :     push @cluster, $k;
730 :     push @pending, $k;
731 :     $seen{ $k } = 1;
732 :     }
733 :    
734 :     }
735 :     if ( @cluster > 1 ) { push @color_sets, \@cluster }
736 :     }
737 :    
738 :     # Clusters were built by representatives.
739 :     # Map (and expand) back to lists of indices into @all_pegs.
740 :    
741 :     @color_sets = map { [ map { @{ $pos_of{ $_ } } } @$_ ] }
742 :     @color_sets;
743 :     }
744 :     else # Case 2, supplied colors are group labels that should be same color
745 :     {
746 :     my( %sets, $peg, $x, $color );
747 :     foreach $x ( @colors )
748 :     {
749 :     ( $peg, $color ) = $x =~ /^(.*):([^:]*)$/;
750 :     if ( $peg2i{ $peg } )
751 :     {
752 :     push @{ $sets{ $color } }, $peg2i{ $peg };
753 :     }
754 :     }
755 :    
756 :     @color_sets = map { $sets{ $_ } } keys %sets;
757 :     }
758 :    
759 :     # Order the clusters from largest to smallest
760 :    
761 :     @color_sets = sort { @$b <=> @$a } @color_sets;
762 :     # foreach ( @color_sets ) { print STDERR "[ ", join( ", ", @$_ ), " ]\n" }
763 :    
764 :     # Move cluster with reference prot to the beginning:
765 :    
766 :     my $set1;
767 :     @color_sets = map { ( &in( $pegI, $_ ) && ( $set1 = $_ ) ) ? () : $_ } @color_sets;
768 :     if ( $set1 )
769 :     {
770 :     unshift @color_sets, $set1;
771 :     # print STDERR &Dumper(["color_sets",[map { [ map { $all_pegs->[$_] } @$_ ] } @color_sets]]); die "aborted";
772 :     }
773 :     # else
774 :     # {
775 :     # print STDERR &Dumper(\@color_sets);
776 :     # print STDERR "could not find initial PEG in color sets\n";
777 :     # }
778 :    
779 :     my( %color, %text, $i, $j );
780 :     for ( $i=0; ($i < @color_sets); $i++)
781 :     {
782 :     my $color_set_i = $color_sets[ $i ];
783 :     my $picked_color = &pick_color( $cgi, $all_pegs, $color_set_i, $i, \@colors );
784 :     my $picked_text = &pick_text( $cgi, $all_pegs, $color_set_i, $i, \@texts );
785 :    
786 :     foreach $j ( @$color_set_i )
787 :     {
788 :     $color{$all_pegs->[$j]} = $picked_color;
789 :     $text{$all_pegs->[$j]} = $picked_text;
790 :     }
791 :     }
792 :    
793 :     # print STDERR &Dumper($all_pegs,\@color_sets);
794 :     return (\%color,\%text);
795 :     }
796 :    
797 :     sub add_commentary_form {
798 :     my($prot,$user,$cgi,$html,$vals) = @_;
799 :    
800 :    
801 :     my @commentary_form = ();
802 :     my $ctarget = "window$$";
803 :    
804 :     my $uni = $cgi->param('uni');
805 :     if (! defined($uni)) { $uni = "" }
806 :    
807 :     push(@commentary_form,start_form(-target => $ctarget,
808 :     -action => &FIG::cgi_url . "/chromosomal_clusters.cgi"
809 :     ));
810 :     push(@commentary_form,hidden(-name => "request", -value => "show_commentary"));
811 :     push(@commentary_form,hidden(-name => "prot", -value => $prot));
812 :     push(@commentary_form,hidden(-name => "user", -value => $user));
813 :     push(@commentary_form,hidden(-name => "uni", -value => $uni));
814 :    
815 :     push(@commentary_form,hidden(-name => "show", -value => [@$vals]));
816 :     push(@commentary_form,submit('commentary'));
817 :     push(@commentary_form,end_form());
818 :     push(@$html,@commentary_form);
819 :    
820 :     return;
821 :     }
822 :    
823 :     sub update_gg_with_color_and_text {
824 :     my( $cgi, $gg, $color, $text, $prot ) = @_;
825 :    
826 :     my( $gene, $n, %how_many, $x, $map, $i, %got_color );
827 :    
828 :     my %must_have_color;
829 :    
830 :     my @must_have = $cgi->param('must_have');
831 :     push @must_have, $prot;
832 :    
833 :     my @vals = ();
834 :     for ( $i = (@$gg - 1); ($i >= 0); $i--)
835 :     {
836 :     my @vals1 = ();
837 :     $map = $gg->[$i]; # @$map = ( abbrev, min_coord, max_coord, \@genes )
838 :    
839 :     undef %got_color;
840 :     my $got_red = 0;
841 :     my $found = 0;
842 :     undef %how_many;
843 :    
844 :     foreach $gene ( @{$map->[3]} )
845 :     {
846 :     # @$gene = ( min_coord, max_coord, symbol, color, text, id_link, pop_up_info )
847 :    
848 :     my $id = $gene->[5];
849 :     if ( $x = $color->{ $id } )
850 :     {
851 :     $gene->[3] = $x;
852 :     $gene->[4] = $n = $text->{ $id };
853 :     $got_color{ $x } = 1;
854 :     if ( ( $x =~ /^(red|color0)$/ )
855 :     && &FIG::between( $gene->[0], ($map->[1]+$map->[2])/2, $gene->[1] )
856 :     ) { $got_red = 1 }
857 :     $how_many{ $n }++;
858 :     push @vals1, join( "@", $n, $i, $id, $map->[0], $how_many{$n} );
859 :     $found++;
860 :     }
861 :     else
862 :     {
863 :     $gene->[3] = "ltgray"; # Light gray
864 :     }
865 :     #
866 :     # RDO: for this code, don't change into a link. We want that
867 :     # to be done locally on a SEED.
868 :     #
869 :     # $gene->[5] = &HTML::fid_link( $cgi, $id, 0, 1 );
870 :     }
871 :    
872 :     for ( $x = 0; ( $x < @must_have ) && $got_color{ $color->{ $must_have[ $x ] } }; $x++ ) {}
873 :     if ( ( $x < @must_have ) || ( ! $got_red ) )
874 :     {
875 :     # print STDERR &Dumper($map);
876 :     if ( @{ $map->[3] } > 0 ) { splice( @$gg, $i, 1 ) }
877 :     }
878 :     else
879 :     {
880 :     push @vals, @vals1;
881 :     }
882 :     }
883 :     # print STDERR &Dumper($gg);
884 :    
885 :     return \@vals;
886 :     }
887 :    
888 :     sub thin_out_over_max {
889 :     my($cgi,$prot,$gg,$html,$in_pin) = @_;
890 :    
891 :     my $user = $cgi->param('user');
892 :     $user = $user ? $user : "";
893 :    
894 :     my $max = $cgi->param('maxpin');
895 :     $max = $max ? $max : 300;
896 :    
897 :     if ($in_pin > $max)
898 :     {
899 :     my $sim_cutoff = $cgi->param('sim_cutoff');
900 :     if (! $sim_cutoff) { $sim_cutoff = 1.0e-20 }
901 :    
902 :     my $to = &FIG::min(scalar @$gg,$max);
903 :     push(@$html,$cgi->h1("Truncating from $in_pin pins to $to pins"),
904 :     $cgi->start_form(-action => &FIG::cgi_url . "/chromosomal_clusters.cgi"),,
905 :     "Max Pins: ", $cgi->textfield(-name => 'maxpin',
906 :     -value => $_,
907 :     -override => 1),
908 :     $cgi->hidden(-name => 'user', -value => $user),
909 :     $cgi->hidden(-name => 'prot', -value => $prot),
910 :     $cgi->hidden(-name => 'sim_cutoff', -value => $sim_cutoff),
911 :     $cgi->submit("Recompute after adjusting Max Pins"),
912 :     $cgi->end_form,
913 :     $cgi->hr);
914 :    
915 :     if (@$gg > $max)
916 :     {
917 :     my($i,$to_cut);
918 :     for ($i=0; ($i < @$gg) && (! &in_map($prot,$gg->[$i])); $i++) {}
919 :    
920 :     if ($i < @$gg)
921 :     {
922 :     my $beg = $i - int($max/2);
923 :     my $end = $i + int($max/2);
924 :     if (($beg < 0) && ($end < @$gg))
925 :     {
926 :     $beg = 0;
927 :     $end = $beg + ($max - 1);
928 :     }
929 :     elsif (($end >= @$gg) && ($beg > 0))
930 :     {
931 :     $end = @$gg - 1;
932 :     $beg = $end - ($max - 1);
933 :     }
934 :    
935 :     if ($end < (@$gg - 1))
936 :     {
937 :     splice(@$gg,$end+1);
938 :     }
939 :    
940 :     if ($beg > 0)
941 :     {
942 :     splice(@$gg,0,$beg);
943 :     }
944 :     }
945 :     }
946 :     }
947 :     }
948 :    
949 :     sub in_map {
950 :     my($peg,$map) = @_;
951 :     my $i;
952 :    
953 :     my $genes = $map->[3];
954 :     for ($i=0; ($i < @$genes) && (index($genes->[$i]->[5],"$peg\&") < 0); $i++) {}
955 :     return ($i < @$genes);
956 :     }
957 :    
958 :     sub limit_pinned {
959 :     my($prot,$pinned_to,$max) = @_;
960 :    
961 :     my($i,$to_cut);
962 :     for ($i=0; ($i < @$pinned_to) && ($pinned_to->[$i] ne $prot); $i++) {}
963 :    
964 :     if ($i < @$pinned_to)
965 :     {
966 :     my $beg = $i - int($max/2);
967 :     my $end = $i + int($max/2);
968 :     if (($beg < 0) && ($end < @$pinned_to))
969 :     {
970 :     $beg = 0;
971 :     $end = $beg + ($max - 1);
972 :     }
973 :     elsif (($end >= @$pinned_to) && ($beg > 0))
974 :     {
975 :     $end = @$pinned_to - 1;
976 :     $beg = $end - ($max - 1);
977 :     }
978 :    
979 :     if ($end < (@$pinned_to - 1))
980 :     {
981 :     splice(@$pinned_to,$end+1);
982 :     }
983 :    
984 :     if ($beg > 0)
985 :     {
986 :     splice(@$pinned_to,0,$beg);
987 :     }
988 :     }
989 :     return @$pinned_to;
990 :     }
991 :    
992 :     sub resolve_id {
993 :     my($fig,$id) = @_;
994 :     my(@pegs);
995 :    
996 :     if ($id =~ /^fig/) { return $id }
997 :    
998 :     if (@pegs = $fig->by_alias($id)) { return @pegs }
999 :    
1000 :     if (($id =~ /^[A-Z0-9]{6}$/) && (@pegs = $fig->by_alias("uni|$id"))) { return @pegs }
1001 :    
1002 :     if (($id =~ /^\d+$/) && (@pegs = $fig->by_alias("gi|$id"))) { return @pegs }
1003 :    
1004 :     if (($id =~ /^\d+$/) && (@pegs = $fig->by_alias("gi|$id"))) { return @pegs }
1005 :    
1006 :     return ();
1007 :     }
1008 :    
1009 :     sub cache_html {
1010 :     my($fig,$cgi,$html) = @_;
1011 :    
1012 :     my @params = sort $cgi->param;
1013 :     # print STDERR &Dumper(\@params);
1014 :     if ((@params == 3) &&
1015 :     ($params[0] eq 'prot') &&
1016 :     ($params[1] eq 'uni') &&
1017 :     ($params[2] eq 'user'))
1018 :     {
1019 :     my $prot = $cgi->param('prot');
1020 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
1021 :     {
1022 :     my $user = $cgi->param('user');
1023 :     my $uni = $cgi->param('uni');
1024 :     my $file = &cache_file($prot,$uni);
1025 :     if (open(CACHE,">$file"))
1026 :     {
1027 :     foreach $_ (@$html)
1028 :     {
1029 :     # $_ =~ s/user=$user/USER=@@@/g;
1030 :     print CACHE $_;
1031 :     }
1032 :     close(CACHE);
1033 :     }
1034 :     }
1035 :     }
1036 :     }
1037 :    
1038 :     sub cache_file {
1039 :     my($prot,$uni) = @_;
1040 :    
1041 :     &FIG::verify_dir("$FIG_Config::temp/Cache");
1042 :     return "$FIG_Config::temp/Cache/$prot:$uni";
1043 :     }
1044 :    
1045 :     sub handled_by_cache {
1046 :     my($fig,$cgi) = @_;
1047 :    
1048 :     my @params = sort $cgi->param;
1049 :    
1050 :     my $is_sprout = $cgi->param('SPROUT');
1051 :    
1052 :     my $i;
1053 :     for ($i=0; ($params[$i] =~ /prot|uni|user|SPROUT/); $i++) {}
1054 :    
1055 :     # warn "handled_by_cache: i=$i params=@params\n";
1056 :     if ($i == @params)
1057 :     {
1058 :     my $prot = $cgi->param('prot');
1059 :     if ($prot =~ /^fig\|\d+\.\d+\.peg\.\d+$/)
1060 :     {
1061 :     my $sprout = $is_sprout ? "&SPROUT=1" : "";
1062 :     my $user = $cgi->param('user');
1063 :     my $uni = $cgi->param('uni');
1064 :     my $file = &cache_file($prot,$uni);
1065 :    
1066 :     if (open(CACHE,"<$file"))
1067 :     {
1068 :     warn "Using local cache $file\n";
1069 :     my $html = [];
1070 :     my $fig_loc;
1071 :     my $to_loc = &FIG::cgi_url;
1072 :     $to_loc =~ /http:\/\/(.*?)\/FIG/;
1073 :     $to_loc = $1;
1074 :     while (defined($_ = <CACHE>))
1075 :     {
1076 :     if ((! $fig_loc) && ($_ =~ /http:\/\/(.*?)\/FIG\/chromosomal_clusters.cgi/))
1077 :     {
1078 :     $fig_loc = quotemeta $1;
1079 :     }
1080 :    
1081 :     $_ =~ s/http:\/\/$fig_loc\//http:\/\/$to_loc\//g;
1082 :     $_ =~ s/USER=\@\@\@/user=$user$sprout/g;
1083 :     $_ =~ s/\buser=[^&;\"]*/user=$user$sprout/g;
1084 :    
1085 :     push(@$html,$_);
1086 :     }
1087 :     close(CACHE);
1088 :    
1089 :     my_show_page($cgi,$html);
1090 :     return 1;
1091 :     }
1092 :     else
1093 :     {
1094 :     my $to_loc = &FIG::cgi_url;
1095 :     my $h;
1096 :     if ($h = get_pins_html($fig, $prot))
1097 :     {
1098 :     #
1099 :     # If we're in sprout, strip the form at the end.
1100 :     # We need to also tack on a hidden variable that sets SPROUT=1.
1101 :     #
1102 :    
1103 :     my $html = [];
1104 :    
1105 :     for (split(/\n/, $h))
1106 :     {
1107 :     if ($is_sprout)
1108 :     {
1109 :     if(/form.*GENDB/)
1110 :     {
1111 :     last;
1112 :     }
1113 :     elsif (/type="submit" name=\"(commentary|compute)/)
1114 :     {
1115 :     push(@$html, qq(<input type="hidden" name="SPROUT" value="1">\n));
1116 :     }
1117 :    
1118 :     #
1119 :     # Don't offer the recompute option.#
1120 :     #
1121 :    
1122 :     s,Similarity Threshold:.*value="compute at given similarity threshhold" />,,;
1123 :    
1124 :     }
1125 :     s/user=master:cached/user=$user$sprout/g;
1126 :     s/name="user" value="master:cached"/name="user" value="$user"/;
1127 :     push(@$html, "$_\n");
1128 :     }
1129 :    
1130 :     my_show_page($cgi, $html);
1131 :     return 1;
1132 :     }
1133 :     }
1134 :     }
1135 :     }
1136 :     return 0;
1137 :     }
1138 :    
1139 :     sub get_pin {
1140 :     my($fig,$peg) = @_;
1141 :    
1142 :     my($peg2,%pinned_to,$tuple);
1143 :    
1144 : olson 1.10 if ($fig->is_complete($fig->genome_of($peg)))
1145 : olson 1.1 {
1146 :     foreach $peg2 (map { $_->[0] } $fig->coupled_to($peg))
1147 :     {
1148 :     foreach $tuple ($fig->coupling_evidence($peg,$peg2))
1149 :     {
1150 :     $pinned_to{$tuple->[0]} = 1;
1151 :     }
1152 :     }
1153 :     my @tmp = $fig->sort_fids_by_taxonomy(keys(%pinned_to));
1154 :     if (@tmp > 0)
1155 :     {
1156 :     return @tmp;
1157 :     }
1158 :     }
1159 :     return $fig->sort_fids_by_taxonomy($fig->in_pch_pin_with($peg));
1160 :     }
1161 :    
1162 :     sub get_pins_html
1163 :     {
1164 :     my($fig, $peg) = @_;
1165 :    
1166 :     my $ua = new LWP::UserAgent;
1167 :    
1168 :     my $peg_enc = uri_escape($peg);
1169 :     my $my_url_enc = uri_escape($fig->cgi_url());
1170 :     my $pins_url = "http://clearinghouse.theseed.org/Clearinghouse/pins_for_peg.cgi";
1171 :    
1172 :     my $url = "$pins_url?peg=$peg_enc&fig_base=$my_url_enc";
1173 :     my $resp = $ua->get($url);
1174 :    
1175 :     if ($resp->is_success)
1176 :     {
1177 :     return $resp->content;
1178 :     }
1179 :     else
1180 :     {
1181 :     return undef;
1182 :     }
1183 :     }
1184 :    
1185 :     sub my_show_page
1186 :     {
1187 :     my($cgi, $html) = @_;
1188 :    
1189 :     if ($cgi->param('SPROUT'))
1190 :     {
1191 :     my $h = { pins => $html };
1192 :     print "Content-Type: text/html\n";
1193 :     print "\n";
1194 :     my $templ = "$FIG_Config::fig/CGI/Html/CCluster_tmpl.html";
1195 :     print PageBuilder::Build("<$templ", $h,"Html");
1196 :     }
1197 :     else
1198 :     {
1199 :     &HTML::show_page($cgi, $html);
1200 :     }
1201 :     }
1202 :    
1203 :     sub evidence_codes_link {
1204 :     my($cgi) = $_;
1205 :    
1206 :     return "<A href=\"Html/evidence_codes.html\" target=\"SEED_or_SPROUT_help\">Ev</A>";
1207 :     }
1208 :    
1209 :     sub evidence_codes {
1210 :     my($fig,$peg) = @_;
1211 :    
1212 :     if ($peg !~ /^fig\|\d+\.\d+\.peg\.\d+$/) { return "" }
1213 :    
1214 : parrello 1.11 my @codes = $fig->get_attributes($peg, "evidence_code");
1215 : paczian 1.9 my @pretty_codes = ();
1216 :     foreach my $code (@codes) {
1217 :     my $pretty_code = $code->[2];
1218 :     if ($pretty_code =~ /;/) {
1219 :     my ($cd, $ss) = split(";", $code->[2]);
1220 :     $ss =~ s/_/ /g;
1221 :     $pretty_code = $cd . " in " . $ss;
1222 :     }
1223 :     push(@pretty_codes, $pretty_code);
1224 :     }
1225 :     return @pretty_codes;
1226 : olson 1.1 }
1227 :    
1228 :    
1229 : paczian 1.9
1230 : olson 1.1 #####################################################################

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3