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

Annotation of /WebApplication/WebPage/AlignSeqsClustal.pm

Parent Directory Parent Directory | Revision Log Revision Log


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

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3