[Bio] / WebApplication / WebPage / AlignSeqsClustal.pm Repository:
ViewVC logotype

Annotation of /WebApplication/WebPage/AlignSeqsClustal.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

1 : bartels 1.1 package WebPage::AlignSeqsClustal;
2 :    
3 :     use base qw( WebPage );
4 :    
5 :     use FIG_Config;
6 :    
7 :     use URI::Escape;
8 :    
9 :     use strict;
10 :     use warnings;
11 :    
12 :     #use HTML;
13 :     use FIGgjo; # colorize_roles, colorize_functions
14 :     use gjoalignment; # align_with_clustal
15 :     use gjonewicklib;
16 :     use clustaltree; # tree_with_clustal
17 :     use gjoseqlib; # read_fasta, print_alignment_as_fasta
18 :     use BasicLocation;
19 :    
20 :     use Data::Dumper;
21 :    
22 :     1;
23 :    
24 :     =pod
25 :    
26 :     =head1 NAME
27 :    
28 :     Annotation - an instance of WebPage which displays information about an Annotation
29 :    
30 :     =head1 DESCRIPTION
31 :    
32 :     Display information about an Annotation
33 :    
34 :     =head1 METHODS
35 :    
36 :     =over 4
37 :    
38 :     * B<init> ()
39 :    
40 :     Called when the web page is instanciated.
41 :    
42 :     =cut
43 :    
44 :    
45 :     my $max_n_diff = 1; # Maximum number of exceptions to consensus
46 :     my $max_f_diff = 0.10; # Maximum fraction exceptions to consensus
47 :     my $minblos = 1; # Minimum score to be called a conservative change
48 :    
49 :     sub init {
50 :     my ($self) = @_;
51 :    
52 :     $self->title( 'Alignment and Tree' );
53 :     $self->application->register_component( 'Table', 'AnnoTable' );
54 :     $self->application->register_component( 'Info', 'CommentInfo' );
55 :     $self->application->register_component( 'RegionDisplay','ComparedRegions' );
56 :    
57 :     return 1;
58 :     }
59 :    
60 :     sub require_javascript {
61 :    
62 :     return [ "$FIG_Config::cgi_url/Html/showfunctionalroles.js" ];
63 :    
64 :     }
65 :    
66 :     =item * B<output> ()
67 :    
68 :     Returns the html output of the Annotation page.
69 :    
70 :     =cut
71 :    
72 :     sub output {
73 :     my ( $self ) = @_;
74 :    
75 :     my $application = $self->application;
76 :     $self->{ 'cgi' } = $application->cgi;
77 :     $self->{ 'fig' } = $application->data_handle( 'FIG' );
78 :    
79 :     my $user;
80 :     if ($application->session->user) {
81 :     $user = $application->session->user;
82 :     $self->{ 'seeduser' } = $user->login;
83 :     }
84 :    
85 :     #################
86 :     # Get sequences #
87 :     #################
88 :    
89 :     my @seqs = $self->{ 'cgi' }->param( 'cds_checkbox' );
90 :     unless ( scalar( @seqs ) ) {
91 :     @seqs = $self->{ 'cgi' }->param( 'fid' );
92 :     }
93 :    
94 :     ##############
95 :     # parameters #
96 :     ##############
97 :    
98 :     $self->{ 'align_format' } = $self->{ 'cgi' }->param( 'align_format' );
99 :     $self->{ 'tree_format' } = $self->{ 'cgi' }->param( 'tree_format' );
100 :     $self->{ 'color_aln_by' } = $self->{ 'cgi' }->param( 'color_aln_by' ) || 'consensus';
101 :     $self->{ 'seq_format' } = $self->{ 'cgi' }->param( 'seq_format' ) || 'protein';
102 :    
103 : bartels 1.2 if ( $self->{ 'seq_format' } eq 'pre' ) {
104 :     my $firstp = $self->{ 'cgi' }->param( 'firstpoint' );
105 :     my $secondp = $self->{ 'cgi' }->param( 'secondpoint' );
106 :     if ( defined( $firstp ) && $firstp =~ /^-?\d+$/ ) {
107 :     $self->{ 'seq_format' } .= "_$firstp";
108 :     }
109 :     if ( defined( $secondp ) && $secondp =~ /^-?\d+$/ ) {
110 :     $self->{ 'seq_format' } .= "_$secondp";
111 :     }
112 :     }
113 :    
114 : bartels 1.1 #########
115 :     # TASKS #
116 :     #########
117 :    
118 :     my $comment;
119 :    
120 :     my $action = $self->{ 'cgi' }->param( 'actionhidden' );
121 :     if ( defined( $action ) && $action eq 'View Annotations' ) {
122 :     return $self->viewAnnotations();
123 :     }
124 :     elsif ( defined( $action ) && $action eq 'Annotate' ) {
125 :     $comment = $self->annotateTree();
126 :     }
127 :     elsif ( defined( $action ) && $action eq 'Reload' ) {
128 :     $self->{ 'align_format' } = $self->{ 'cgi' }->param( 'Alignment' );
129 :     $self->{ 'tree_format' } = $self->{ 'cgi' }->param( 'Tree' );
130 :     #$color_aln_by = $self->{ 'cgi' }->param( 'color_aln_by' ) || 'consensus';
131 :     $self->{ 'seq_format' } = $self->{ 'cgi' }->param( 'Sequence' );
132 :     if ( $self->{ 'seq_format' } eq 'pre' ) {
133 :     my $firstp = $self->{ 'cgi' }->param( 'firstpoint' );
134 :     my $secondp = $self->{ 'cgi' }->param( 'secondpoint' );
135 :     if ( defined( $firstp ) && $firstp =~ /^-?\d+$/ ) {
136 :     $self->{ 'seq_format' } .= "_$firstp";
137 :     }
138 :     if ( defined( $secondp ) && $secondp =~ /^-?\d+$/ ) {
139 :     $self->{ 'seq_format' } .= "_$secondp";
140 :     }
141 :     }
142 :     }
143 :     elsif ( defined( $action ) && $action eq 'Align' ) {
144 :     my @checked = $self->{ 'cgi' }->param( 'checked' );
145 :     @seqs = ();
146 :     foreach my $cb ( @checked ) {
147 :     if ( $cb =~ /^checked_(fig.*)/ ) {
148 :     push @seqs, $1;
149 :     }
150 :     }
151 :     }
152 :     elsif ( defined( $action ) && $action eq 'ShowRegions' ) {
153 :     my @checked = $self->{ 'cgi' }->param( 'checked' );
154 :     @seqs = ();
155 :     my @genomes;
156 :     foreach my $cb ( @checked ) {
157 :     if ( $cb =~ /^checked_(fig.*)/ ) {
158 :     push @seqs, $1;
159 :     push @genomes, $self->{ 'fig' }->genome_of( $1 );
160 :     }
161 :     }
162 :    
163 :     my $regdisp = $self->application->component( 'ComparedRegions' );
164 :     my $genome_number = scalar( @genomes );
165 :    
166 :     $regdisp->focus( $seqs[0] );
167 :     $regdisp->show_genomes( \@genomes );
168 :     $regdisp->number_of_regions( $genome_number );
169 :     # $regdisp->add_features( $add_features );
170 :     $regdisp->fig( $self->{ 'fig' } );
171 :     my $regdispout = $regdisp->output();
172 :    
173 :     return $regdisp->output();
174 :     }
175 :    
176 :    
177 :     my @nseqs = ();
178 :     foreach my $key ( @seqs ) {
179 :     if ( $key =~ /cds_checkbox_(.*)/ ) {
180 :     $key = $1;
181 :     }
182 :     push @nseqs, $key;
183 :     }
184 :    
185 :     @seqs = @nseqs;
186 :    
187 :     my %seen;
188 :    
189 :     my @seqsTA;
190 :    
191 :     if ( $self->{ 'seq_format' } eq 'DNA' ) {
192 :     @seqsTA = grep { $_->[2] }
193 :     map { [ $_, '', $self->{ 'fig' }->get_dna_seq( $_ ) ] }
194 :     grep { ! $seen{ $_ }++ }
195 :     @seqs;
196 :     }
197 :     elsif ( $self->{ 'seq_format' } =~ /^pre_(-?\d+)_(-?\d+)/ ) {
198 :     my $before = $1;
199 :     my $after = $2;
200 :     @seqsTA = grep { $_->[2] }
201 :     map { [ $_, '', $self->get_flanking( $_, $before, $after ) ] }
202 :     grep { ! $seen{ $_ }++ }
203 :     @seqs;
204 :     }
205 :     else {
206 :     @seqsTA = grep { $_->[2] }
207 :     map { [ $_, '', $self->{ 'fig' }->get_translation( $_ ) ] }
208 :     grep { ! $seen{ $_ }++ }
209 :     @seqs;
210 :     }
211 :    
212 :     @seqs = map { $_->[0] } @seqsTA;
213 :    
214 :     my %orgs = map { $_ => $self->{ 'fig' }->org_of( $_ ) || '' } @seqs;
215 :     $self->{ 'orgs' } = \%orgs;
216 :    
217 :     my @tbl_data;
218 :     foreach my $fid ( @seqs ) {
219 :     my $func = $self->{ 'fig' }->function_of( $fid, $self->{ 'seeduser' } ) || "";
220 :     $func =~ s/ +;/;/g; # An ideosyncracy of some assignments
221 :     $self->{ 'fid_func' }->{ $fid } = $func;
222 :     push @tbl_data, [ $fid, $orgs{ $fid }, $func ];
223 :     }
224 :    
225 :     ############################
226 :     # construct the anno table #
227 :     ############################
228 :     my $annotable = $self->application->component( 'AnnoTable' );
229 :     $annotable->columns( [ { name => 'ID', filter => 1, sortable => 1 },
230 :     { name => 'Organism', filter => 1, sortable => 1 },
231 :     { name => 'Annotation', filter => 1, sortable => 1 },
232 :     ] );
233 :     $annotable->data( \@tbl_data );
234 :     $annotable->show_top_browse( 1 );
235 :     $annotable->show_select_items_per_page( 1 );
236 :     $annotable->items_per_page( 10 );
237 :    
238 :     ###########################
239 :     # construct the alignment #
240 :     ###########################
241 :     my @align = gjoalignment::align_with_clustal( \@seqsTA );
242 :     my $alignmentcont;
243 :    
244 :     if ( @align ) {
245 :     if ( $self->{ 'align_format' } eq "fasta" ) {
246 :     $alignmentcont = "<pre>" .
247 :     join( "", map { my $tseq = $_->[2];
248 :     $tseq =~ s/(.{1,60})/$1\n/g;
249 :     ">$_->[0] $_->[1]\n$tseq"
250 :     } @seqsTA ) .
251 :     "</pre>\n";
252 :     }
253 :     elsif ( $self->{ 'align_format' } eq "clustal" ) {
254 :     my $clustal_alignment = &to_clustal( \@align );
255 :     $alignmentcont = "<pre>\n$clustal_alignment</pre>\n";
256 :     }
257 :     elsif ( $self->{ 'align_format' } eq "special" ) {
258 :     $alignmentcont = $self->gjoalignment( \@align, \@seqs, $self->{ 'color_aln_by' } );
259 :     }
260 :     else {
261 :     $alignmentcont = undef;
262 :     }
263 :     }
264 :    
265 :     ######################
266 :     # construct the tree #
267 :     ######################
268 :    
269 :     my $tree = clustaltree::tree_with_clustal( \@align );
270 :     my $treecont;
271 : bartels 1.2 if ( defined( $self->{ 'tree_format' } ) && $self->{ 'tree_format' } eq 'newick' ) {
272 : bartels 1.1 $treecont .= &gjonewicklib::formatNewickTree( $tree );
273 :     }
274 : bartels 1.2 elsif ( defined( $self->{ 'tree_format' } ) && $self->{ 'tree_format' } eq 'normal' ) {
275 : bartels 1.1 $treecont = $self->construct_tree( \@seqs, $tree );
276 :     }
277 :     else {
278 :     $treecont = undef;
279 :     }
280 :    
281 :     ################
282 :     # Hiddenvalues #
283 :     ################
284 :    
285 :     my $hiddenvalues;
286 :     $hiddenvalues->{ 'actionhidden' } = '';
287 :     $hiddenvalues->{ 'align_format' } = $self->{ 'align_format' };
288 :     $hiddenvalues->{ 'tree_format' } = $self->{ 'tree_format' };
289 :     $hiddenvalues->{ 'color_aln_by' } = $self->{ 'color_aln_by' };
290 :     $hiddenvalues->{ 'seq_format' } = $self->{ 'seq_format' };
291 :    
292 :     my $content;
293 :    
294 :     ####################
295 :     # Display comments #
296 :     ####################
297 :    
298 :     if ( defined( $comment ) && $comment ne '' ) {
299 :     my $info_component = $self->application->component( 'CommentInfo' );
300 :    
301 :     $info_component->content( $comment );
302 :     $info_component->default( 0 );
303 :     $content .= $info_component->output();
304 :     }
305 :    
306 :     ###########
307 :     # CONTENT #
308 :     ###########
309 :    
310 :     $content .= $self->start_form( 'form', $hiddenvalues );
311 :     $content .= "<H1>Protein table</H1>\n";
312 :     $content .= "<P>This table shows the proteins for which an alignment / tree will be displayed on this page.</P>";
313 :     $content .= $annotable->output();
314 :     $content .= "<BR><BR>";
315 :     $content .= $self->get_actions( \@seqs );
316 :    
317 :     if ( defined( $alignmentcont ) ) {
318 :     $content .= "<H1>Alignment: ". $self->{ 'align_format' }."</H1>";
319 :     $content .= "<P>This part shows the alignment of the features. The alignment format is ";
320 :     $content .= $self->{ 'align_format' };
321 :     $content .= ". Currently, you can see an alignment of ";
322 :     if ( $self->{ 'seq_format' } eq 'protein' ) {
323 :     $content .= "the protein sequences of the features.";
324 :     }
325 :     elsif ( $self->{ 'seq_format' } eq 'DNA' ) {
326 :     $content .= "the DNA sequences of the features.";
327 :     }
328 :     else {
329 :     $content .= "the DNA sequences of downstream of the features.";
330 :     }
331 :     $content .= "</P>";
332 :     $content .= $alignmentcont;
333 :     }
334 :     if ( defined( $treecont ) ) {
335 :     $content .= "<H1>Neighbor-joining Tree of Selected Proteins</H1>";
336 :     $content .= $treecont;
337 :     }
338 :     $content .= $self->end_form();
339 :    
340 :     return $content;
341 :     }
342 :    
343 :     sub to_clustal {
344 :     my ( $alignment ) = @_;
345 :    
346 :     my ( $tuple,$seq,$i );
347 :     my $len_name = 0;
348 :     foreach $tuple ( @$alignment ) {
349 :     my $sz = length($tuple->[0]);
350 :     $len_name = ($sz > $len_name) ? $sz : $len_name;
351 :     }
352 :    
353 :     my @seq = map { $_->[2] } @$alignment;
354 :     my $seq1 = shift @seq;
355 :     my $cons = "\377" x length($seq1);
356 :     foreach $seq (@seq) {
357 :     $seq = ~($seq ^ $seq1);
358 :     $seq =~ tr/\377/\000/c;
359 :     $cons &= $seq;
360 :     }
361 :     $cons =~ tr/\000/ /;
362 :     $cons =~ tr/\377/*/;
363 :    
364 :     push(@$alignment,["","",$cons]);
365 :    
366 :     my @out = ();
367 :     for ($i=0; ($i < length($seq1)); $i += 50) {
368 :     foreach $tuple (@$alignment) {
369 :     my($id,undef,$seq) = @$tuple;
370 :     my $line = sprintf("%-" . $len_name . "s",$id) . " " . substr($seq,$i,50) . "\n";
371 :     push(@out,$line);
372 :     }
373 :     push(@out,"\n");
374 :     }
375 :     return join("","CLUSTAL W (1.8.3) multiple sequence alignment\n\n\n",@out);
376 :     }
377 :    
378 :    
379 :     sub construct_tree {
380 :    
381 :     my ( $self, $checkedarr, $tree ) = @_;
382 :    
383 :     my @checked = @$checkedarr;
384 :     my $user = $self->{ 'seeduser' };
385 :     my $peg_id = $self->{ 'cgi' }->param( 'fid' );
386 :    
387 :     my %formatted_func = &FIGgjo::colorize_roles( $self->{ 'fid_func' } );
388 :    
389 :     my $html;
390 :     $html .= join( "\n",
391 :     # $self->start_form( -method => 'post',
392 :     # -target => 'window$$',
393 :     # -action => 'fid_checked.cgi',
394 :     # -name => 'fid_checked'
395 :     # ),
396 :     $self->{ 'cgi' }->hidden(-name => 'fid', -value => $peg_id),
397 :     # $cgi->hidden(-name => 'SPROUT', -value => $sprout),
398 :     # $cgi->hidden(-name => 'user', -value => $user),
399 :     $self->{ 'cgi' }->hidden(-name => 'color_aln_by', -value => 'consensus'),
400 :     ""
401 :     );
402 :    
403 :     #------------------------------------------------------------------
404 :     # Build checkboxes and radio buttons for appropriate sequences:
405 :     #------------------------------------------------------------------
406 :    
407 :     my @translatable = grep { $self->{ 'fig' }->translatable( $_ ) } @checked;
408 :    
409 :     my %check = map { $_ => qq(<input type=checkbox name=checked value="checked_$_">) }
410 :     @translatable;
411 :    
412 :     my %from;
413 :     if ( $user ) {
414 :     %from = map { m/value=\"([^\"]+)\"/; $1 => $_ }
415 :     $self->{ 'cgi' }->radio_group( -name => 'from',
416 :     -nolabels => 1,
417 :     -override => 1,
418 :     -values => [ @translatable ],
419 :     -default => $peg_id
420 :     );
421 :     }
422 :    
423 :     #------------------------------------------------------------------
424 :     # Aliases
425 :     #------------------------------------------------------------------
426 :    
427 :     my %alias = map { $_->[0] => $_->[1] }
428 :     grep { $_->[1] }
429 :     map { [ $_, scalar $self->{ 'fig' }->feature_aliases( $_ ) ] }
430 :     @checked;
431 :    
432 :     #------------------------------------------------------------------
433 :     # Formulate the desired labels:
434 :     #------------------------------------------------------------------
435 :    
436 :     my %labels;
437 :     foreach my $fid ( @checked ) {
438 :     my @label;
439 :     push @label, "<A HREF='?page=Annotation&feature=$fid'>$fid</A>";
440 :     push @label, "[ $self->{ 'orgs' }->{ $fid } ]" if $self->{ 'orgs' }->{ $fid };
441 :     push @label, $check{ $fid } if $check{ $fid };
442 :     push @label, $from{ $fid } if $from{ $fid };
443 :     push @label, $formatted_func{ $self->{ 'fid_func' }->{ $fid } } if $self->{ 'fid_func' }->{ $fid };
444 :     push @label, html_esc( $alias{ $fid } ) if $alias{ $fid };
445 :    
446 :     $labels{ $fid } = join( ' ', @label );
447 :     }
448 :    
449 :     #------------------------------------------------------------------
450 :     # Relabel the tips, midpoint root, pretty it up and draw
451 :     # the tree as printer plot
452 :     #
453 :     # Adjustable parameters on text_plot_newick:
454 :     #
455 :     # @lines = text_plot_newick( $node, $width, $min_dx, $dy )
456 :     #------------------------------------------------------------------
457 :    
458 :     my $tree2 = newick_relabel_nodes( $tree, \%labels );
459 :     my $tree3 = reroot_newick_to_approx_midpoint_w( $tree2 );
460 :     my $tree4 = aesthetic_newick_tree( $tree3 );
461 :     $html .= join( "\n",
462 :     '<PRE>',
463 :     text_plot_newick( $tree4, 80, 2, 2 ),
464 :     '</PRE>',
465 :     ''
466 :     );
467 :    
468 :     #------------------------------------------------------------------
469 :     # RAE Add the check all/uncheck all boxes.
470 :     #------------------------------------------------------------------
471 :    
472 :     my $checkall = "<INPUT TYPE=BUTTON name='CheckAll' value='Check All' onclick='checkAll( \"checked\" )'>\n";
473 :     my $checkfirst = "<INPUT TYPE=BUTTON name='CheckFirst' value='Check First Half' onclick='checkFirst( \"checked\" )'>\n";
474 :     my $checksecond = "<INPUT TYPE=BUTTON name='CheckSecond' value='Check Second Half' onclick='checkSecond( \"checked\" )'>\n";
475 :     my $uncheckall = "<INPUT TYPE=BUTTON name='UnCheckAll' value='Uncheck All' onclick='uncheckAll( \"checked\" )'>\n";
476 :    
477 :     my $viewAnnotations = "<INPUT TYPE=BUTTON name='ViewAnnotations' value='View Annotations' onclick='submitPage( \"View Annotations\" )'>\n";
478 :     my $annotateButton = "<INPUT TYPE=BUTTON name='Annotate' value='Annotate' onclick='submitPage( \"Annotate\" )'>\n";
479 :     my $alignButton = "<INPUT TYPE=BUTTON name='Align' value='Align' onclick='submitPage( \"Align\" )'>\n";
480 :     my $showRegions = "<INPUT TYPE=BUTTON name='ShowRegions' value='Show Regions' onclick='submitPage( \"ShowRegions\" )'>\n";
481 :    
482 :     $html .= "<TABLE><TR><TD><B>Select:</B></TD><TD>$checkall</TD><TD>$checkfirst</TD><TD>$checksecond</TD><TD>$uncheckall</TD></TR></TABLE><BR>";
483 :    
484 :     # $html .= "<TABLE><TR><TD><B>Action:</B></TD><TD>$viewAnnotations</TD><TD>$annotateButton</TD><TD>$alignButton</TD><TD>$showRegions</TD></TR></TABLE><BR>";
485 :     $html .= "<TABLE><TR><TD><B>Action:</B></TD><TD>$viewAnnotations</TD><TD>$annotateButton</TD><TD>$alignButton</TD></TR></TABLE><BR>";
486 :    
487 :     # $html .= join("\n",
488 :     # "For selected (checked) sequences: "
489 :     # , $self->{ 'cgi' }->submit('align'),
490 :     # , $self->{ 'cgi' }->submit('view annotations')
491 :     # , $self->{ 'cgi' }->submit('show regions')
492 :     # , $self->{ 'cgi' }->br
493 :     # , ""
494 :     # );
495 :    
496 :     if ( $self->{ 'seeduser' } ) {
497 :     # $html .= $self->{ 'cgi' }->submit('assign/annotate') . "\n";
498 :    
499 :     if ( $self->{ 'cgi' }->param('translate')) {
500 :     $html .= join("\n",
501 :     , $self->{ 'cgi' }->submit('add rules')
502 :     , $self->{ 'cgi' }->submit('check rules')
503 :     , $self->{ 'cgi' }->br
504 :     , ''
505 :     );
506 :     }
507 :    
508 :     # $html .= join( "\n", $self->{ 'cgi' }->br,
509 :     # "<a href='Html/help_for_assignments_and_rules.html'>Help on Assignments, Rules, and Checkboxes</a>",
510 :     # ""
511 :     # );
512 :     }
513 :    
514 :     # $html .= $cgi->end_form . "\n";
515 :    
516 :     # 'align' with less than 2 sequences checked
517 :    
518 :     return $html;
519 :     }
520 :    
521 :    
522 :     sub gjoalignment {
523 :    
524 :     my ( $self, $alg, $check, $color_aln_by ) = @_;
525 :     my ( $align2, $legend );
526 :     my @align = @$alg;
527 :     my @checked = @$check;
528 :    
529 :     # Color by residue type:
530 :    
531 :     if ( $color_aln_by eq 'residue' ) {
532 :     my %param1 = ( align => \@align, protein => 1 );
533 :     $align2 = color_alignment_by_residue( \%param1 );
534 :     }
535 :    
536 :     # Color by consensus:
537 :    
538 :     else {
539 :     my %param1 = ( align => \@align );
540 :     ( $align2, $legend ) = color_alignment_by_consensus( \%param1 );
541 :     }
542 :    
543 :     # Add organism names:
544 :    
545 :     foreach ( @$align2 ) { $_->[1] = $self->{ 'orgs' }->{ $_->[0] } }
546 :    
547 :     # Build a tool tip with organism names and functions:
548 :    
549 :     my %tips = map { $_ => [ $_, join( '<HR>', $self->{ 'orgs' }->{ $_ }, $self->{ 'fid_func' }->{ $_ } ) ] } @checked;
550 :     $tips{ 'Consen1' } = [ 'Consen1', 'Primary consensus residue' ];
551 :     $tips{ 'Consen2' } = [ 'Consen2', 'Secondary consensus residue' ];
552 :    
553 :     my %param2 = ( align => $align2,
554 :     ( $legend ? ( legend => $legend ) : () ),
555 :     tooltip => \%tips
556 :     );
557 :    
558 :     my $alignment = join( "\n",
559 :     scalar alignment_2_html_table( \%param2 ), "<BR>"
560 :     );
561 :    
562 :     return $alignment;
563 :     }
564 :    
565 :     sub color_alignment_by_residue {
566 :     my $align = shift if ( ref($_[0]) eq 'ARRAY' );
567 :    
568 :     my %data = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
569 :     foreach ( keys %data ) { $data{ canonical_key( $_ ) } = $data{ $_ } }
570 :    
571 :     $align ||= $data{ align } || $data{ alignment };
572 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
573 :     {
574 :     print STDERR "color_alignment_by_residue called without alignment\n";
575 :     return ();
576 :     }
577 :    
578 :     my $colors = $data{ color };
579 :     if ( $colors && ( ref( $colors ) eq 'HASH' ) )
580 :     {
581 :     print STDERR "color_alignment_by_residue called without invalid colors hash\n";
582 :     return ();
583 :     }
584 :    
585 :     if ( ! $colors )
586 :     {
587 :     my $is_prot = defined( $data{ protein } ) ? $data{ protein } : &guess_prot( $align );
588 :     my $pallet = $data{ pallet };
589 :     $colors = $is_prot ? aa_colors( $pallet ) : nt_colors( $pallet );
590 :     }
591 :    
592 :     my ( $id, $def, $seq );
593 :     my $pad_char = $data{ padchar } || $data{ pad } || ' ';
594 :     my $reg1 = qr/^([^A-Za-z.*]+)/;
595 :     my $reg2 = qr/([^A-Za-z.*]+)$/;
596 :     my @colored_align = ();
597 :    
598 :     foreach ( @$align )
599 :     {
600 :     ( $id, $def, $seq ) = @$_;
601 :     $seq =~ s/$reg1/$pad_char x length($1)/e;
602 :     $seq =~ s/$reg2/$pad_char x length($1)/e;
603 :     push @colored_align, [ $id, $def, scalar color_sequence( $seq, $colors ) ];
604 :     }
605 :    
606 :     my @legend = (); # Need to create this still
607 :     if ( wantarray )
608 :     {
609 :     my ( $i, $chr );
610 :     my @row = ();
611 :     foreach ( $i = 32; $i < 127; $i++ )
612 :     {
613 :     $chr = chr( $i );
614 :     push @row, [ $chr, $colors->{$chr} || '#fff' ];
615 :     if ( $i % 32 == 31 ) { push @legend, [ @row ]; @row = () }
616 :     }
617 :     push @legend, [ @row ];
618 :     }
619 :    
620 :     wantarray ? ( \@colored_align, \@legend ) : \@colored_align;
621 :     }
622 :    
623 :     sub color_alignment_by_consensus {
624 :     my $align;
625 :     $align = shift if ( ref($_[0]) eq 'ARRAY' );
626 :    
627 :     # Options, with canonical form of keys
628 :    
629 :     my %data = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
630 :     foreach ( keys %data ) { $data{ canonical_key( $_ ) } = $data{ $_ } }
631 :    
632 :     $align ||= $data{ align } || $data{ alignment };
633 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
634 :     {
635 :     print STDERR "color_alignment_by_consensus called without alignment\n";
636 :     return ();
637 :     }
638 :    
639 :     my ( $pallet, $legend ) = consensus_pallet( $data{ color } );
640 :    
641 :     my $conserve_list = conservative_change_list( \%data );
642 :     my $conserve_hash = conservative_change_hash( \%data );
643 :    
644 :     my $chars = qr/^[-*A-Za-z]$/;
645 :    
646 :     my $s;
647 :     my $pad_char = $data{ padchar } || $data{ pad } || ' ';
648 :     my $reg1 = qr/^([^A-Za-z.*]+)/;
649 :     my $reg2 = qr/([^A-Za-z.*]+)$/;
650 :    
651 :     my @seq = map { $s = uc $_->[2];
652 :     $s =~ s/$reg1/$pad_char x length($1)/e;
653 :     $s =~ s/$reg2/$pad_char x length($1)/e;
654 :     $s
655 :     }
656 :     @$align;
657 :    
658 :     # Define the consensus type(s) for each site. There are a 3 options:
659 :     # 1. There is a single consensus nucleotide.
660 :     # 2. Two residue types are sufficient to describe the position.
661 :     # 3. A residue and conservative changes are sufficient.
662 :    
663 :     my $len = length( $seq[0] );
664 :    
665 :     $max_n_diff = $data{ maxndiff } if defined( $data{ maxndiff } );
666 :     $max_f_diff = $data{ maxfdiff } if defined( $data{ maxfdiff } );
667 :    
668 :     my @col_clr; # An array of hashes, one for each column
669 :     my $cons1 = ' ' x $len; # Primary consensus characters
670 :     my $cons2 = ' ' x $len; # Secondary consensus characters
671 :    
672 :     my ( $i, %cnt, $chr, @c, $min_consen, $c1, $c2, $clr );
673 :    
674 :     for ( $i = 0; $i < $len; $i++)
675 :     {
676 :     # Count the number of each residue type in the column
677 :    
678 :     %cnt = ();
679 :     foreach ( @seq ) { $chr = substr($_,$i,1); $cnt{$chr}++ if $chr =~ /$chars/ }
680 :    
681 :     my @harr = map { $cnt{$_} } keys %cnt;
682 :    
683 :     my $n_signif = 0;
684 :     foreach my $n ( @harr ) {
685 :     $n_signif += $n;
686 :     }
687 :    
688 :     # $n_signif = sum( map { $cnt{$_} } keys %cnt );
689 :     $min_consen = $n_signif - max( $max_n_diff, int( $max_f_diff * $n_signif ) );
690 :    
691 :     ( $c1, $c2, @c ) = consensus_residues( \%cnt, $min_consen, $conserve_hash );
692 :    
693 :     substr( $cons1, $i, 1 ) = $c1 if $c1;
694 :     substr( $cons2, $i, 1 ) = $c2 if $c2;
695 :     push @col_clr, consensus_colors( $pallet, $conserve_list, $c1, $c2, @c );
696 :     }
697 :    
698 :     my @color_align = ();
699 :     # my ( $id, $def, $seq );
700 :     foreach ( @$align, [ 'Consen1', 'Primary consensus', $cons1 ],
701 :     [ 'Consen2', 'Secondary consensus', $cons2 ]
702 :     )
703 :     {
704 :     my ( $id, $def, $seq ) = @$_;
705 :     if ( $id =~ /^fig/ ) {
706 :     $id = "<A HREF='?page=Annotation&feature=$id'>$id</A>";
707 :     }
708 :    
709 :     $seq =~ s/^([^A-Za-z.]+)/$pad_char x length($1)/e;
710 :     $seq =~ s/([^A-Za-z.]+)$/$pad_char x length($1)/e;
711 :    
712 :     $i = 0;
713 :     my @clr_seq = map { [ $_, $col_clr[$i++]->{$_} || '#fff' ] }
714 :     split //, $seq;
715 :     push @color_align, [ $id, $def, \@clr_seq ];
716 :     }
717 :    
718 :     wantarray ? ( \@color_align, $legend ) : \@color_align;
719 :     }
720 :    
721 :     #-------------------------------------------------------------------------------
722 :     # A canonical key is lower case, has no underscores, and no terminal s
723 :     #
724 :     # $key = canonical_key( $key )
725 :     #-------------------------------------------------------------------------------
726 :     sub canonical_key {
727 :     my $key = lc shift;
728 :     $key =~ s/_//g;
729 :     $key =~ s/s$//;
730 :     return $key ;
731 :     }
732 :    
733 :     sub alignment_2_html_table
734 :     {
735 :     my $align;
736 :     $align = shift if ( ref($_[0]) eq 'ARRAY' );
737 :    
738 :     # Options, with canonical form of keys
739 :    
740 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
741 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
742 :    
743 :     $align ||= $options{ align } || $options{ alignment };
744 :     if ( ! $align || ( ref( $align ) ne 'ARRAY' ) )
745 :     {
746 :     print STDERR "alignment_2_html_table called without alignment\n";
747 :     return '';
748 :     }
749 :    
750 :     my $tooltip = $options{ tooltip } || $options{ popup } || 0;
751 :     my $tiplink = '';
752 :    
753 :     my $nojavascript = $options{ nojavascript } || ( $tooltip ? 0 : 1 );
754 :    
755 :     my @html;
756 :     push @html, "<TABLE Col=3>\n";
757 :     foreach ( @$align )
758 :     {
759 :     if ( $tooltip )
760 :     {
761 :     # Default tooltip is the id and description, but user can supply a
762 :     # hash with alternative mouseover parameters:
763 :     #
764 :     # mouseover( $ttl, $text, $menu, $parent, $ttl_color, $text_color )
765 :     #
766 :     my @args;
767 :     if ( ( ref( $tooltip ) eq 'HASH' )
768 :     && ( ref( $tooltip->{ $_->[0] } ) eq 'ARRAY' )
769 :     )
770 :     {
771 :     @args = @{ $tooltip->{ $_->[0] } }
772 :     }
773 :     else
774 :     {
775 :     @args = ( $_->[0], ( $_->[1] || ' ' ) );
776 :     }
777 :     # $tiplink = '<A' . &mouseover( @args ) . '>';
778 :     }
779 :    
780 :     push @html, " <TR>\n",
781 :     " <TD NoWrap>$_->[0]</TD>\n",
782 :     # " <TD NoWrap>$_->[1]</TD>\n",
783 :     " <TD><Pre>",
784 :     ( $tooltip ? $tiplink : () ),
785 :     sequence_2_html( $_->[2] ),
786 :     ( $tooltip ? '</A>' : () ),
787 :     "</Pre></TD>\n",
788 :     " </TR>\n";
789 :     }
790 :     push @html, "</TABLE>\n";
791 :    
792 :     my $legend = $options{ key } || $options{ legend };
793 :     if ( ref( $legend ) eq 'ARRAY' )
794 :     {
795 :     push @html, "<BR />\n", "<TABLE Col=1>\n";
796 :     foreach ( @$legend )
797 :     {
798 :     push @html, " <TR><TD><Pre><Big>",
799 :     sequence_2_html( $_ ),
800 :     "</Big></Pre></TD></TR>\n";
801 :     }
802 :     push @html, "</TABLE>\n";
803 :     }
804 :    
805 :     # my $javascript = $nojavascript ? '' : &mouseover_JavaScript();
806 :     my $javascript = $nojavascript;
807 :    
808 :     wantarray && $javascript ? ( join( '', @html ), $javascript ) # ( $html, $script )
809 :     : join( '', $javascript, @html ); # $html
810 :     }
811 :    
812 :     sub sequence_2_html
813 :     {
814 :     return $_[0] if ref( $_[0] ) ne 'ARRAY';
815 :    
816 :     my $string = shift;
817 :     my @html = ();
818 :     my ( $txt, $clr );
819 :     foreach ( @{ merge_common_color( $string ) } )
820 :     {
821 :     $txt = html_esc( $_->[0] );
822 :     $txt or next;
823 :     $clr = $_->[1];
824 :     push @html, ( $clr ? qq(<span style="background-color:$clr">$txt</span>)
825 :     : $txt
826 :     )
827 :     }
828 :     join '', @html;
829 :     }
830 :    
831 :     sub merge_common_color
832 :     {
833 :     return $_[0] if ref( $_[0] ) ne 'ARRAY';
834 :    
835 :     my @string = ();
836 :     my $color = '';
837 :     my @common_color = ();
838 :     foreach ( @{ $_[0] }, [ '', 0 ] ) # One bogus empty string to flush it
839 :     {
840 :     if ( $_->[1] ne $color )
841 :     {
842 :     push @string, [ join( '', @common_color ), $color ],
843 :     @common_color = ();
844 :     $color = $_->[1]
845 :     }
846 :     push @common_color, $_->[0];
847 :     }
848 :     return \@string;
849 :     }
850 :    
851 :     sub consensus_pallet
852 :     {
853 :     # Initialize with a standard set, ensuring that all keys are covered:
854 :    
855 :     my %pallet = ( '' => '#fff',
856 :     other => '#fff',
857 :     consen1 => '#bdf', consen1g => '#def',
858 :     positive => '#6e9',
859 :     consen2 => '#ee4', consen2g => '#eea',
860 :     mismatch => '#f9f'
861 :     );
862 :    
863 :     # Overwrite defaults with user-supplied colors
864 :    
865 :     if ( ref($_[0]) eq 'HASH' )
866 :     {
867 :     my %user_pallet = %{ $_[0] };
868 :     foreach ( keys %user_pallet ) { $pallet{ $_ } = $user_pallet{ $_ } }
869 :     }
870 :    
871 :     my @legend;
872 :     if ( wantarray )
873 :     {
874 :     @legend = ( [ [ 'Consensus 1' => $pallet{ consen1 } ],
875 :     [ ' (when a gap)' => $pallet{ consen1g } ] ],
876 :    
877 :     [ [ 'Conservative difference' => $pallet{ positive } ] ],
878 :    
879 :     [ [ 'Consensus 2' => $pallet{ consen2 } ],
880 :     [ ' (when a gap)' => $pallet{ consen2g } ] ],
881 :    
882 :     [ [ 'Nonconservative diff.' => $pallet{ mismatch } ] ],
883 :    
884 :     [ [ 'Other character' => $pallet{ '' } ] ],
885 :     );
886 :     }
887 :    
888 :     wantarray ? ( \%pallet, \@legend ) : \%pallet;
889 :     }
890 :    
891 :     sub conservative_change_list
892 :     {
893 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
894 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
895 :    
896 :     my $min_score = defined( $options{ minscore } ) ? $options{ minscore } : 1;
897 :    
898 :     my $matrix = ( ref( $options{ matrix } ) eq 'HASH' ) ? $options{ matrix }
899 :     : blosum62_hash_hash();
900 :    
901 :     my %hash;
902 :     foreach ( keys %$matrix )
903 :     {
904 :     my $score = $matrix->{ $_ };
905 :     $hash{ $_ } = [ grep { $score->{ $_ } >= $min_score } keys %$score ];
906 :     }
907 :     return \%hash;
908 :     }
909 :    
910 :     sub conservative_change_hash
911 :     {
912 :     my %options = ( ref( $_[0] ) eq 'HASH' ) ? %{ $_[0] } : @_;
913 :     foreach ( keys %options ) { $options{ canonical_key( $_ ) } = $options{ $_ } }
914 :    
915 :     my $min_score = defined( $options{ minscore } ) ? $options{ minscore } : 1;
916 :    
917 :     my $matrix = ( ref( $options{ matrix } ) eq 'HASH' ) ? $options{ matrix }
918 :     : blosum62_hash_hash();
919 :    
920 :     my %hash;
921 :     foreach ( keys %$matrix )
922 :     {
923 :     my $score = $matrix->{ $_ };
924 :     $hash{ $_ } = { map { $_ => 1 }
925 :     grep { $score->{ $_ } >= $min_score }
926 :     keys %$score
927 :     };
928 :     }
929 :    
930 :     return \%hash;
931 :     }
932 :    
933 :     sub blosum62_hash_hash
934 :     {
935 :     my ( $aa_list, $raw_scores ) = raw_blosum62();
936 :     my %hash;
937 :     my @scores = @$raw_scores;
938 :     foreach ( @$aa_list )
939 :     {
940 :     my @scr = @{ shift @scores };
941 :     $hash{ $_ } = { map { $_ => shift @scr } @$aa_list };
942 :     }
943 :     return \%hash;
944 :     }
945 :    
946 :     sub raw_blosum62
947 :     {
948 :     return ( [ qw( A R N D C Q E G H I L K M F P S T W Y V B Z X * ) ],
949 :     [ map { shift @$_; $_ }
950 :     (
951 :     # A R N D C Q E G H I L K M F P S T W Y V B Z X * #
952 :     [ qw( A 4 -1 -2 -2 0 -1 -1 0 -2 -1 -1 -1 -1 -2 -1 1 0 -3 -2 0 -2 -1 0 -4 ) ],
953 :     [ qw( R -1 5 0 -2 -3 1 0 -2 0 -3 -2 2 -1 -3 -2 -1 -1 -3 -2 -3 -1 0 -1 -4 ) ],
954 :     [ qw( N -2 0 6 1 -3 0 0 0 1 -3 -3 0 -2 -3 -2 1 0 -4 -2 -3 3 0 -1 -4 ) ],
955 :     [ qw( D -2 -2 1 6 -3 0 2 -1 -1 -3 -4 -1 -3 -3 -1 0 -1 -4 -3 -3 4 1 -1 -4 ) ],
956 :     [ qw( C 0 -3 -3 -3 9 -3 -4 -3 -3 -1 -1 -3 -1 -2 -3 -1 -1 -2 -2 -1 -3 -3 -2 -4 ) ],
957 :     [ qw( Q -1 1 0 0 -3 5 2 -2 0 -3 -2 1 0 -3 -1 0 -1 -2 -1 -2 0 3 -1 -4 ) ],
958 :     [ qw( E -1 0 0 2 -4 2 5 -2 0 -3 -3 1 -2 -3 -1 0 -1 -3 -2 -2 1 4 -1 -4 ) ],
959 :     [ qw( G 0 -2 0 -1 -3 -2 -2 6 -2 -4 -4 -2 -3 -3 -2 0 -2 -2 -3 -3 -1 -2 -1 -4 ) ],
960 :     [ qw( H -2 0 1 -1 -3 0 0 -2 8 -3 -3 -1 -2 -1 -2 -1 -2 -2 2 -3 0 0 -1 -4 ) ],
961 :     [ qw( I -1 -3 -3 -3 -1 -3 -3 -4 -3 4 2 -3 1 0 -3 -2 -1 -3 -1 3 -3 -3 -1 -4 ) ],
962 :     [ qw( L -1 -2 -3 -4 -1 -2 -3 -4 -3 2 4 -2 2 0 -3 -2 -1 -2 -1 1 -4 -3 -1 -4 ) ],
963 :     [ qw( K -1 2 0 -1 -3 1 1 -2 -1 -3 -2 5 -1 -3 -1 0 -1 -3 -2 -2 0 1 -1 -4 ) ],
964 :     [ qw( M -1 -1 -2 -3 -1 0 -2 -3 -2 1 2 -1 5 0 -2 -1 -1 -1 -1 1 -3 -1 -1 -4 ) ],
965 :     [ qw( F -2 -3 -3 -3 -2 -3 -3 -3 -1 0 0 -3 0 6 -4 -2 -2 1 3 -1 -3 -3 -1 -4 ) ],
966 :     [ qw( P -1 -2 -2 -1 -3 -1 -1 -2 -2 -3 -3 -1 -2 -4 7 -1 -1 -4 -3 -2 -2 -1 -2 -4 ) ],
967 :     [ qw( S 1 -1 1 0 -1 0 0 0 -1 -2 -2 0 -1 -2 -1 4 1 -3 -2 -2 0 0 0 -4 ) ],
968 :     [ qw( T 0 -1 0 -1 -1 -1 -1 -2 -2 -1 -1 -1 -1 -2 -1 1 5 -2 -2 0 -1 -1 0 -4 ) ],
969 :     [ qw( W -3 -3 -4 -4 -2 -2 -3 -2 -2 -3 -2 -3 -1 1 -4 -3 -2 11 2 -3 -4 -3 -2 -4 ) ],
970 :     [ qw( Y -2 -2 -2 -3 -2 -1 -2 -3 2 -1 -1 -2 -1 3 -3 -2 -2 2 7 -1 -3 -2 -1 -4 ) ],
971 :     [ qw( V 0 -3 -3 -3 -1 -2 -2 -3 -3 3 1 -2 1 -1 -2 -2 0 -3 -1 4 -3 -2 -1 -4 ) ],
972 :     [ qw( B -2 -1 3 4 -3 0 1 -1 0 -3 -4 0 -3 -3 -2 0 -1 -4 -3 -3 4 1 -1 -4 ) ],
973 :     [ qw( Z -1 0 0 1 -3 3 4 -2 0 -3 -3 1 -1 -3 -1 0 -1 -3 -2 -2 1 4 -1 -4 ) ],
974 :     [ qw( X 0 -1 -1 -1 -2 -1 -1 -1 -1 -1 -1 -1 -1 -1 -2 0 0 -2 -1 -1 -1 -1 -1 -4 ) ],
975 :     [ qw( * -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 -4 1 ) ]
976 :     )
977 :     ]
978 :     )
979 :     }
980 :    
981 :     sub max { $_[0] > $_[1] ? $_[0] : $_[1] }
982 :    
983 :     sub consensus_residues
984 :     {
985 :     my ( $cnt_hash, $min_match, $conserve_hash ) = @_;
986 :    
987 :     # Sort the residues from most to least frequent, and note first 2:
988 :    
989 :     my %cnt = %$cnt_hash;
990 :     my ( $c1, $c2, @c );
991 :    
992 :     ( $c1, $c2 ) = @c = sort { $cnt{$b} <=> $cnt{$a} } keys %cnt;
993 :     ( $cnt{$c1} >= 2 ) or return ( '', '' );
994 :    
995 :     # Are there at least $min_match of the most abundant?
996 :    
997 :     if ( $cnt{$c1} >= $min_match )
998 :     {
999 :     $c2 = '';
1000 :     }
1001 :    
1002 :     # Are there at least $min_match of the two most abundant?
1003 :    
1004 :     elsif ( ( $cnt{$c2} >= 2 ) && ( ( $cnt{$c1} + $cnt{$c2} ) >= $min_match ) )
1005 :     {
1006 :     $c1 = lc $c1;
1007 :     $c2 = lc $c2;
1008 :     }
1009 :    
1010 :     # Can we make a consensus of conservative changes?
1011 :    
1012 :     else
1013 :     {
1014 :     $c2 = '';
1015 :     my ( $is_conservative, @pos );
1016 :     my $found = 0;
1017 :     foreach $c1 ( grep { /^[AC-IK-NP-TVWY]$/ } @c )
1018 :     {
1019 :     ( $is_conservative = $conserve_hash->{ $c1 } ) or next;
1020 :     @pos = grep { $is_conservative->{ $_ } } @c;
1021 :     my @sumarr = map { $cnt{ $_ } } @pos;
1022 :     my $total = 0;
1023 :     foreach my $s ( @sumarr ) {
1024 :     $total += $s;
1025 :     }
1026 :     # $total = sum( map { $cnt{ $_ } } @pos );
1027 :     if ( $total >= $min_match ) { $found = 1; last }
1028 :     }
1029 :     $c1 = $found ? lc $c1 : '';
1030 :     }
1031 :    
1032 :     return ( $c1, $c2, @c );
1033 :     }
1034 :    
1035 :     sub consensus_colors
1036 :     {
1037 :     my ( $pallet, $conservative, $c1, $c2, @c ) = @_;
1038 :     # print STDERR Dumper( $c1, $c2, \@c ); exit;
1039 :     return {} if ! $c1;
1040 :    
1041 :     my %pallet = ( ref($pallet) eq 'HASH' ) ? %$pallet
1042 :     : @{ scalar consensus_pallet() };
1043 :    
1044 :     $conservative = {} if ref( $conservative ) ne 'HASH';
1045 :    
1046 :     # Mark everything but ' ' and . as mismatch, then overwrite exceptions:
1047 :    
1048 :     my %color = map { $_ => $pallet{ mismatch } }
1049 :     grep { ! /^[ .]$/ }
1050 :     @c;
1051 :    
1052 :     if ( $c1 ne '-' )
1053 :     {
1054 :     $c1 = uc $c1;
1055 :     foreach ( @{ $conservative->{$c1} || [] } )
1056 :     {
1057 :     $color{ $_ } = $pallet{ positive }
1058 :     }
1059 :     $color{ $c1 } = $pallet{ consen1 };
1060 :     if ( $c2 )
1061 :     {
1062 :     $color{ uc $c2 } = ( $c2 ne '-' ) ? $pallet{ consen2 } : $pallet{ consen2g };
1063 :     }
1064 :     }
1065 :     else
1066 :     {
1067 :     $color{ $c1 } = $pallet{ consen1g };
1068 :     if ( $c2 ) { $color{ uc $c2 } = $pallet{ consen2 } }
1069 :     }
1070 :    
1071 :     # Copy colors to lowercase letters:
1072 :    
1073 :     foreach ( grep { /^[A-Z]$/ } keys %color )
1074 :     {
1075 :     $color{ lc $_ } = $color{ $_ }
1076 :     }
1077 :    
1078 :     return \%color;
1079 :     }
1080 :    
1081 :     sub html_esc
1082 :     {
1083 :     my $txt = shift;
1084 :     $txt =~ s/\&/&amp;/g;
1085 :     $txt =~ s/\</&lt;/g;
1086 :     $txt =~ s/\>/&gt;/g;
1087 :     return $txt;
1088 :     }
1089 :    
1090 :    
1091 :     sub get_flanking {
1092 :     my ( $self, $fid, $before, $after ) = @_;
1093 :    
1094 :     return if ( !defined( $fid ) || $fid !~ /^fig/ );
1095 :    
1096 :     my $feat_seq = $self->{ 'fig' }->get_dna_seq( $fid );
1097 :     my $length_feat = length( $feat_seq );
1098 :    
1099 :     my $feature_location = $self->{ 'fig' }->feature_location( $fid );
1100 :     my $genome = $self->{ 'fig' }->genome_of( $fid );
1101 :     my $additional = $self->{ 'cgi' }->param( 'FLANKING' ) || 500;
1102 :    
1103 :     my @loc = split /,/, $feature_location;
1104 :     my ( $contig, $beg, $end ) = BasicLocation::Parse( $loc[0] );
1105 :    
1106 :     if ( defined( $contig ) and defined( $beg ) and defined( $end ) ) {
1107 :     my ( $n1, $npre );
1108 :     if ( $beg < $end ) {
1109 :     $n1 = $beg - $before;
1110 :     $n1 = 1 if $n1 < 1;
1111 :     $npre = $beg - $n1;
1112 :     }
1113 :     else {
1114 :     $n1 = $beg + $before;
1115 :     my $clen = $self->{ 'fig' }->contig_ln( $genome, $contig );
1116 :     $n1 = $clen if $n1 > $clen;
1117 :     $npre = $n1 - $beg;
1118 :     }
1119 :    
1120 :     # Add to the end of the last segment:
1121 :     ( $contig, $beg, $end ) = BasicLocation::Parse($loc[-1]);
1122 :     my ( $n2, $npost );
1123 :     if ( $beg < $end ) {
1124 :     $n2 = $beg - $after;
1125 :     my $clen = $self->{ 'fig' }->contig_ln( $genome, $contig );
1126 :     $n2 = $clen if $n2 > $clen;
1127 :     $npost = $beg - $n2;
1128 :     }
1129 :     else {
1130 :     $n2 = $beg + $after;
1131 :     $n2 = 1 if $n2 < 1;
1132 :     $npost = $n2 - $beg;
1133 :     }
1134 :     $loc[0] = join( '_', $contig, $n1, $n2 );
1135 :    
1136 :     my $seq = $self->{ 'fig' }->dna_seq( $genome, join( ',', @loc ) );
1137 :     if ( $seq ) {
1138 :    
1139 :     if ( $npost > 0 ) {
1140 :     $seq = lc( substr( $seq, 0 ) );
1141 :     }
1142 :     elsif ( $length_feat < abs( $npost ) ) {
1143 :     $seq = lc( substr( $seq, 0, $npre ) ) . uc( substr( $seq, $npre, $length_feat ) ) . lc( substr( $seq, ( $npre + $length_feat ) ) );
1144 :     }
1145 :     else {
1146 :     $seq = lc( substr( $seq, 0, $npre ) ) . uc( substr( $seq, $npre ) );
1147 :     }
1148 :     return $seq;
1149 :     }
1150 :     }
1151 :     }
1152 :    
1153 :     sub viewAnnotations {
1154 :     my ( $self, $checked ) = @_;
1155 :    
1156 :     my @checked = $self->{ 'cgi' }->param( 'checked' );
1157 :    
1158 :     my $html;
1159 :     my $col_hdrs = ["who","when","annotation"];
1160 :     $html .= join("\n", "<table border=\"2\" align=\"center\">",
1161 :     $self->{ 'cgi' }->Tr($self->{ 'cgi' }->th({ align => "center" }, $col_hdrs)),
1162 :     "");
1163 :     foreach my $cb ( @checked ) {
1164 :     if ( $cb =~ /^checked_(fig.*)/ ) {
1165 :     my $fid = $1;
1166 :     my $tab = [ map { [$_->[2],$_->[1],$_->[3]] } $self->{ 'fig' }->feature_annotations($fid) ];
1167 :     my $title = (@$tab == 0 ? "No " : "") . "Annotations for $fid";
1168 :     $html .= join("\n", $self->{ 'cgi' }->Tr( $self->{ 'cgi' }->td({ colspan => 3, align => "center" }, $title ) ), "");
1169 :     if ( @$tab > 0 ) {
1170 :     for my $row ( @$tab ) {
1171 :     $html .= $self->{ 'cgi' }->Tr( $self->{ 'cgi' }->td( $row ) );
1172 :     }
1173 :     }
1174 :     }
1175 :     }
1176 :     $html .= "</table>\n";
1177 :     return $html;
1178 :     }
1179 :    
1180 :     sub annotateTree {
1181 :     my ( $self ) = @_;
1182 :    
1183 :     my $html = '';
1184 :     my $from = $self->{ 'cgi' }->param( 'from' );
1185 :     my @checked = $self->{ 'cgi' }->param( 'checked' );
1186 :    
1187 :     if ( defined( $from ) && ( my $func = $self->{ 'fig' }->function_of( $from, $self->{ 'seeduser' } ) ) ) {
1188 :     $func =~ s/\s+\#[^\#].*$//;
1189 :     foreach my $cb ( @checked ) {
1190 :     if ( $cb =~ /^checked_(fig.*)/ ) {
1191 :     my $peg = $1;
1192 :    
1193 :     if ( $self->{ 'fig' }->assign_function( $peg, $self->{ 'seeduser' }, $func, "" ) ) {
1194 :     $html .= $self->{ 'cgi' }->h3( "Done for $peg" );
1195 :     }
1196 :     else {
1197 :     $html .= $self->{ 'cgi' }->h3( "Failed for $peg" );
1198 :     }
1199 :     }
1200 :     }
1201 :     }
1202 :     else {
1203 :     $html .= join("\n", "<table border=1>",
1204 :     "<tr><td>Protein</td><td>Organism</td><td>Current Function</td><td>By Whom</td></tr>",
1205 :     "");
1206 :     my $defaultann = ''; # this will just be the last function with BUT NOT added if we are negating the function
1207 :     foreach my $peg ( @checked ) {
1208 :     my @funcs = $self->{ 'fig' }->function_of( $peg );
1209 :     if ( ! @funcs ) {
1210 :     @funcs = ( [ "", ] )
1211 :     }
1212 :     my $nfunc = @funcs;
1213 :     my $org = $self->{ 'fig' }->org_of( $peg );
1214 :     $html .= join("\n", "<tr>",
1215 :     "<td rowspan=$nfunc>$peg</td>",
1216 :     "<td rowspan=$nfunc>$org</td>",
1217 :     ""
1218 :     );
1219 :     my ( $who, $what );
1220 :     $html .= join( "</tr>\n<tr>", map { ($who,$what) = @$_; "<td>$what</td><td>$who</td>" } @funcs );
1221 :     $html .= "</tr>\n";
1222 :     if ( $self->{ 'cgi' }->param( "negate" ) ) {
1223 :     $defaultann = "$what BUT NOT";
1224 :     }
1225 :     }
1226 :     $html .= "</table>\n";
1227 :     }
1228 :     return $html;
1229 :     }
1230 :    
1231 :    
1232 :     ###########################
1233 :     # Buttons under the table #
1234 :     ###########################
1235 :     sub get_actions {
1236 :    
1237 :     my ( $self, $seqs ) = @_;
1238 :     my $application = $self->application;
1239 :    
1240 :     # my $buttons = "<DIV id='controlpanel' style='width: 80%;'>
1241 :     my $buttons = "<H1>Options</H1>\n";
1242 :     $buttons .= "<P>Here you can choose what type of sequence you want to see, if you would like to see an alignment and what format it should have, as well as if and what format of a tree you would like to see.</P>";
1243 :    
1244 :     foreach my $s ( @$seqs ) {
1245 :     $buttons .= $self->{ 'cgi' }->hidden( -name => 'fid', -value => $s ),
1246 :     }
1247 :    
1248 :     my $reload = "<INPUT TYPE=BUTTON name='Reload' value='Reload' onclick='submitPage( \"Reload\" )'>\n";
1249 :     my $before = 0;
1250 :     my $after = 0;
1251 :    
1252 :     my $checked_dnaseq = '';
1253 :     my $checked_dnaflank = '';
1254 :     my $checked_proteinseq = '';
1255 :     if ( $self->{ 'seq_format' } eq 'DNA' ) {
1256 :     $checked_dnaseq = 'CHECKED';
1257 :     }
1258 :     elsif ( $self->{ 'seq_format' } =~ /^pre_(-?\d+)_(-?\d+)/ ) {
1259 :     $checked_dnaflank = 'CHECKED';
1260 :     $before = $1;
1261 :     $after = $2;
1262 :     }
1263 :     else {
1264 :     $checked_proteinseq = 'CHECKED';
1265 :     }
1266 :    
1267 :     my $checked_fastaal = '';
1268 :     my $checked_clustalal = '';
1269 :     my $checked_specialal = '';
1270 :     my $checked_noal = '';
1271 :     if ( $self->{ 'align_format' } eq 'fasta' ) {
1272 :     $checked_fastaal = 'CHECKED';
1273 :     }
1274 :     elsif ( $self->{ 'align_format' } eq 'special' ) {
1275 :     $checked_specialal = 'CHECKED';
1276 :     }
1277 :     elsif ( $self->{ 'align_format' } eq 'clustal' ) {
1278 :     $checked_clustalal = 'CHECKED';
1279 :     }
1280 :     else {
1281 :     $checked_noal = 'CHECKED';
1282 :     }
1283 :    
1284 :     my $checked_newick = '';
1285 :     my $checked_normal = '';
1286 :     my $checked_notree = '';
1287 : bartels 1.2 if ( defined( $self->{ 'tree_format' } ) && $self->{ 'tree_format' } eq 'newick' ) {
1288 : bartels 1.1 $checked_newick = 'CHECKED';
1289 :     }
1290 : bartels 1.2 elsif ( defined( $self->{ 'tree_format' } ) && $self->{ 'tree_format' } eq 'normal' ) {
1291 : bartels 1.1 $checked_normal = 'CHECKED';
1292 :     }
1293 :     else {
1294 :     $checked_notree = 'CHECKED';
1295 :     }
1296 :    
1297 :     my $firstpoint = "<INPUT TYPE=TEXT NAME='firstpoint' ID='firstpoint' SIZE=10 VALUE='$before'>";
1298 :     my $secondpoint = "<INPUT TYPE=TEXT NAME='secondpoint' ID='secondpoint' SIZE=10 VALUE='$after'>";
1299 :    
1300 :     my $proteinbox = "<INPUT TYPE=\"RADIO\" NAME=\"Sequence\" VALUE=\"protein\" ID=\"PROTEIN\" $checked_proteinseq >";
1301 :     my $dnabox = "<INPUT TYPE=\"RADIO\" NAME=\"Sequence\" VALUE=\"DNA\" ID=\"DNASEQ\" $checked_dnaseq >";
1302 :     my $flankingbox = "<INPUT TYPE=\"RADIO\" NAME=\"Sequence\" VALUE=\"pre\" ID=\"DNAFLANK\" $checked_dnaflank >";
1303 :    
1304 :     my $fastabox = "<INPUT TYPE=\"RADIO\" NAME=\"Alignment\" VALUE=\"fasta\" ID=\"FASTAAL\" $checked_fastaal >";
1305 :     my $clustalbox = "<INPUT TYPE=\"RADIO\" NAME=\"Alignment\" VALUE=\"clustal\" ID=\"CLUSTALAL\" $checked_clustalal >";
1306 :     my $specialbox = "<INPUT TYPE=\"RADIO\" NAME=\"Alignment\" VALUE=\"special\" ID=\"SPECIALAL\" $checked_specialal >";
1307 :     my $noalbox = "<INPUT TYPE=\"RADIO\" NAME=\"Alignment\" VALUE=\"noal\" ID=\"NOAL\" $checked_noal >";
1308 :    
1309 :     my $newickbox = "<INPUT TYPE=\"RADIO\" NAME=\"Tree\" VALUE=\"newick\" ID=\"NEWICKTREE\" $checked_newick >";
1310 :     my $normalbox = "<INPUT TYPE=\"RADIO\" NAME=\"Tree\" VALUE=\"normal\" ID=\"NORMALTREE\" $checked_normal >";
1311 :     my $notreebox = "<INPUT TYPE=\"RADIO\" NAME=\"Tree\" VALUE=\"notree\" ID=\"NOTREE\" $checked_notree >";
1312 :    
1313 :     $buttons .= "<TABLE><TR><TD><B>Sequence:</B></TD><TD>$proteinbox Protein</TD><TD>$dnabox DNA</TD><TD COLSPAN=2>$flankingbox upstream DNA: $firstpoint - $secondpoint</TD></TR>";
1314 :     $buttons .= "<TR><TD><B>Alignment:</B></TD><TD>$noalbox No Alignment</TD><TD>$fastabox Fasta:</TD><TD>$clustalbox Clustal</TD><TD>$specialbox Special</TD></TR>";
1315 :     $buttons .= "<TR><TD><B>Tree:</B></TD><TD>$notreebox No Tree</TD><TD>$newickbox Newick</TD><TD>$normalbox NJTree</TD></TR></TABLE><BR>";
1316 :     $buttons .= "<TABLE><TR><TD>$reload</TD></TR></TABLE>";
1317 :     # $buttons .= "</DIV>";
1318 :    
1319 :     return $buttons;
1320 :     }

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3