[Bio] / FigWebServices / align_and_tree.cgi Repository:
ViewVC logotype

Diff of /FigWebServices/align_and_tree.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.3, Mon Nov 14 01:44:00 2011 UTC revision 1.4, Sun Nov 20 01:29:59 2011 UTC
# Line 17  Line 17 
17  #  #
18    
19  use strict;  use strict;
20  use HTML;  use FIG;
21  use FIG_CGI;  use CGI;
 use FIGgjo;        # colorize_roles, colorize_functions  
 use gjoseqlib;     # read_fasta, print_alignment_as_fasta  
 use gjoalign2html; # repad_alignment, color_alignment_by_consensus  
 use gjonewicklib;  
22  use SAPserver;  use SAPserver;
23  use AlignsAndTreesServer qw( peg_alignment_metadata  use CGIAlignTreeViewer;
                              peg_alignment_by_ID  
                              peg_tree_by_ID  
                              aligns_with_pegID  
                              get_md5_projections  
                            );  
24    
25  use Data::Dumper;  use Data::Dumper;
 use Carp;  
   
 my( $fig, $cgi, $user ) = FIG_CGI::init( debug_save   => 0,  
                                          debug_load   => 0,  
                                          print_params => 0 );  
26    
27    my $fig             = FIG->new();
28    my $cgi             = CGI->new();
29  my $sapObject = SAPserver->new();  my $sapObject = SAPserver->new();
30    
31  # The html will be assembled here.  my $user            = $cgi->param( 'user' ) || '';
32    my $url             = "align_and_tree.cgi";
33    my $hidden_form_var = $cgi->hidden( -name => 'user', -value => $user ) . "\n";
34    
35  print $cgi->header;  print $cgi->header;
36  my @html = ();  my ( $html, $title ) = CGIAlignTreeViewer::run( $fig, $cgi, $sapObject, $user, $url, $hidden_form_var );
37    $title ||= "$url";
38  #------------------------------------------------------------------------------  $html  ||= $cgi->h2( 'No HTML returned by script.' ) . "\n";
 #  Convert the cgi paramater values to a local summary of the work to be done  
 #------------------------------------------------------------------------------  
   
 my $action        = $cgi->param( 'action' );        # assign is the only special action  
 my $ali_tree_id   = $cgi->param( 'ali_tree_id' )  || '';  
 my @ali_tree_ids  = $cgi->param( 'at_ids' );  
 my $align_format  = $cgi->param( 'align_format' );  # default || fasta || clustal  
 my $align_id      = $cgi->param( 'align_id' );  
 my $au            = $cgi->param( 'assign_using' );  
 my $assign_using  = ( $au =~ /^Sap/i ) ? 'Sapling' : 'SEED';  
 my @checked       = $cgi->param( 'checked' );  
 my $color_aln_by  = $cgi->param( 'color_aln_by' ) || 'consensus'; # consensus || residue  
 my $fid           = $cgi->param( 'fid' )          || '';  
 my $from          = $cgi->param( 'from' )         || '';     # assignment to propagate  
 my $rep_pegs      = $cgi->param( 'rep_pegs' )     || 'all';  # all || roles || dlit || paralog  
 my $show_aliases  = $cgi->param( 'show_aliases' ) || '';  
 my $show_align    = $cgi->param( 'show_align' );  
 my $show_tree     = $cgi->param( 'show_tree' );  
 my $tree_format   = $cgi->param( 'tree_format' );   # default || newick || png  
 my $tree_id       = $cgi->param( 'tree_id' );  
   
 #  Let's see if we can work out missing values from other data:  
   
 $fid         ||= $checked[0] if @checked == 1;  
 $ali_tree_id ||= $align_id || $tree_id || '';  
 $ali_tree_id   = '' if $action =~ /ali.* tree.* with.* prot/;  #  Forced update of list  
 if ( ( ! $ali_tree_id ) && ( ! @ali_tree_ids ) && $fid )  
 {  
     @ali_tree_ids = AlignsAndTreesServer::aligns_with_pegID( $sapObject, $fid );  
 }  
 $ali_tree_id ||= $ali_tree_ids[0] if @ali_tree_ids == 1;  
   
 #  Move alignment and tree selection information into one id and two booleans  
   
 $show_align ||= $align_id;  
 $show_tree  ||= $tree_id;  
   
 #------------------------------------------------------------------------------  
 #  We have the analysis paramaters.  Put them in a local hash so they can be passed to  
 #  subroutines.  
 #------------------------------------------------------------------------------  
   
 my $data = {};  
   
 $data->{ fig }          =  $fig;  
 $data->{ sap }          =  $sapObject;  
 $data->{ cgi }          =  $cgi;  
 $data->{ html }         = \@html;  
 $data->{ user }         =  $user;  
   
 $data->{ action }       =  $action;  
 $data->{ ali_tree_id }  =  $ali_tree_id;  
 $data->{ ali_tree_ids } = \@ali_tree_ids;  
 $data->{ align_format } =  $align_format;  
 $data->{ assign_using } =  $assign_using;  
 $data->{ can_assign }   =  $user && ( $assign_using =~ /SEED/i );  
 $data->{ checked }      = \@checked;  
 $data->{ color_aln_by } =  $color_aln_by;  
 $data->{ fid }          =  $fid;  
 $data->{ from }         =  $from;  
 $data->{ rep_pegs }     =  $rep_pegs;  
 $data->{ show_aliases } =  $show_aliases;  
 $data->{ show_align }   =  $show_align;  
 $data->{ show_tree }    =  $show_tree;  
 $data->{ tree_format }  =  $tree_format;  
   
 #------------------------------------------------------------------------------  
 #  Start the page:  
 #------------------------------------------------------------------------------  
   
 page_head_html( $data );  
   
   
 #------------------------------------------------------------------------------  
 #  Deal with assignments:  
 #------------------------------------------------------------------------------  
   
 if ( $data->{ action } =~ /assign/i )  
 {  
     make_assignments( $data );  
 }  
   
 #------------------------------------------------------------------------------  
 #  Change the focus peg:  
 #------------------------------------------------------------------------------  
   
 if ( $data->{ action } =~ /focus/i && $from )  
 {  
     $fid = $from;  
 }  
   
 #------------------------------------------------------------------------------  
 #  Start the form:  
 #------------------------------------------------------------------------------  
   
 push @html, $cgi->start_form( -method => 'post',  
                               -action => 'align_and_tree.cgi',  
                               -name   => 'alignment'  
                             );  
   
 #------------------------------------------------------------------------------  
 #  Alignment and tree format controls:  
 #------------------------------------------------------------------------------  
   
 add_general_options( $data );  
   
 #------------------------------------------------------------------------------  
 #  Collect all of the necessary alignment and/or tree data:  
 #------------------------------------------------------------------------------  
   
 if ( $data->{ ali_tree_id } && ( $data->{ show_align } || $data->{ show_tree } ) )  
 {  
     compile_alignment_and_tree_data( $data );  
 }  
   
 #------------------------------------------------------------------------------  
 #  Alignment dispaly  
 #------------------------------------------------------------------------------  
   
 if ( $data->{ ali_tree_id } && $data->{ show_align } )  
 {  
     show_alignment( $data );  
 }  
   
 #------------------------------------------------------------------------------  
 #  Tree display  
 #------------------------------------------------------------------------------  
   
 if ( $data->{ ali_tree_id } && $data->{ show_tree } )  
 {  
     show_tree( $data );  
 }  
   
 #------------------------------------------------------------------------------  
 #  Select alignments and trees with given fid  
 #------------------------------------------------------------------------------  
   
 if ( ! $data->{ ali_tree_id } )  
 {  
     show_alignments_and_trees_with_fid( $data );  
 }  
   
 #------------------------------------------------------------------------------  
 #  Finish form and page  
 #------------------------------------------------------------------------------  
   
 push @html, join( "\n",  
                   $cgi->end_form,  
                   $cgi->br,  
                   '</BODY>',  
                   '</HTML>',  
                   ''  
                 );  
   
 #------------------------------------------------------------------------------  
 #  Report the output  
 #------------------------------------------------------------------------------  
   
 print join( '', @html, "\n" );  
 exit;  
   
   
 #==============================================================================  
 #  Only subroutines below  
 #==============================================================================  
 #  This is a sufficient set of escaping for text in HTML (function and alias):  
 #  
 #     $html = html_esc( $text )  
 #------------------------------------------------------------------------------  
   
 sub html_esc { local $_ = $_[0]; s/\&/&amp;/g; s/\>/&gt;/g; s/\</&lt;/g; $_ }  
   
   
 #===============================================================================  
 #  Start the HTML  
 #===============================================================================  
   
 sub page_head_html  
 {  
     my ( $data ) = @_;  
     my $html = $data->{ html } || [];  
   
     my $ali_tree_id = $data->{ ali_tree_id };  
     my $fid         = $data->{ fid };  
     my $show_align  = $data->{ show_align };  
     my $show_tree   = $data->{ show_tree };  
   
     my $title;  
     if ( $show_align && $ali_tree_id )  
     {  
         if ( $show_tree ) { $title = "The SEED: Protein Alignment $ali_tree_id" }  
         else              { $title = "The SEED: Protein Alignment and Tree $ali_tree_id" }  
     }  
     elsif ( $show_tree && $ali_tree_id )  
     {  
         $title = "The SEED: Protein Tree $ali_tree_id";  
     }  
     else  
     {  
         if ( $fid ) { $title = "The SEED: Protein Alignment and Tree Selector for '$fid'" }  
         else        { $title = "The SEED: Protein Alignment and Tree Selector" }  
     }  
   
     #  This stuff is because different browsers render the contents differently.  
   
     my $agent  = $ENV{ HTTP_USER_AGENT } || '';  
     my $height = $agent =~ /Safari/i  ? '110%'  
                : $agent =~ /Firefox/i ? '100%'  
                :                        '100%';  
     my $lsize  = $agent =~ /Safari/i  ? '160%'  
                : $agent =~ /Firefox/i ? '130%'  
                :                        '140%';  
   
     push @$html, <<"End_of_Head";  
 <HTML>  
 <HEAD>  
 <TITLE>$title</TITLE>  
   
 <STYLE Type="text/css">  
   /* Support for HTML printer graphics tree */  
   DIV.tree {  
     border-spacing: 0px;  
     font-size:     100%;  
     line-height:    $height;  
     white-space: nowrap;  
   }  
   DIV.tree A {  
     text-decoration: none;  
   }  
   DIV.tree PRE {  
     padding:    0px;  
     margin:     0px;  
     font-size: $lsize;  
     display: inline;  
   }  
   DIV.tree INPUT {  
     padding: 0px;  
     margin:  0px;  
     height: 10px;    /* ignored by Firefox */  
     width:  10px;    /* ignored by Firefox */  
   }  
   DIV.tree SPAN.w {  /* used for tree white space */  
     color: white;  
   }  
 </STYLE>  
   
 </HEAD>  
 <BODY>  
 End_of_Head  
   
     return @$html if wantarray;  
 }  
   
   
 #===============================================================================  
 #  Make requested assignments.  
 #===============================================================================  
   
 sub make_assignments  
 {  
     my ( $data ) = @_;  
   
     my $fig  = $data->{ fig };  
     my $sap  = $data->{ sap };  
     my $cgi  = $data->{ cgi };  
     my $html = $data->{ html };  
     my $user = $data->{ user };  
     my $from = $data->{ from };  
   
     my $func;  
     if ( defined( $from ) && ( $func = $fig->function_of( $from, $user ) ) && @{ $data->{ checked } } )  
     {  
         $func =~ s/\s+\#[^\#].*$//;       #  Remove single hash comments  
         # We now expand the pegs to all pegs with the same md5:  
         my $pegs_to_md5 = AlignsAndTreesServer::pegs_to_md5( $sap, @{ $data->{ checked } } );  
   
         #***********************************************************************  
         #  Note: values %$pegs_to_md5 may include values that you do not want!!!  
         #***********************************************************************  
         my %seen_md5;  
         my @md5s = grep { ! $seen_md5{ $_ }++ }  
                    map  { $pegs_to_md5->{ $_ } }  
                    @{ $data->{ checked } };  
         my $md5s_to_pegs = AlignsAndTreesServer::md5s_to_pegs( $sap, @md5s );  
   
         #***********************************************************************  
         #  Note: values %$md5s_to_pegs may include values that you do not want!!!  
         #***********************************************************************  
         my %seen_peg = ( $from => 1 );   #  Skip self assignment  
         my @pegs = grep { ! $seen_peg{ $_ }++ }  
                    map  { @{ $md5s_to_pegs->{ $_ } || [] } }  
                    @md5s;  
   
         if (  $data->{ assign_using } =~ /SEED/i && $fig )  
         {  
             my ( $nsucc, $nfail );  
             foreach my $peg ( @pegs )  
             {  
                 if ( $fig->assign_function( $peg, $user, $func, "" ) )  
                 {  
                     $fig->add_annotation( $peg, $user, "Assigned based on tree proximity to $from\n" );  
                     $nsucc++;  
                 }  
                 else  
                 {  
                     $nfail++;  
                 }  
             }  
             push @$html, $cgi->h3( "$nsucc protein assignments made." )   if $nsucc;  
             push @$html, $cgi->h3( "$nfail attemped protein assignments ignored." ) if $nfail;  
         }  
     }  
 }  
   
   
 #===============================================================================  
 #  Push the general page options into the html.  
 #===============================================================================  
   
 sub add_general_options  
 {  
     my ( $data ) = @_;  
     my $cgi  = $data->{ cgi };  
     my $html = $data->{ html } || [];  
   
     if ( @{ $data->{ checked } } && ! $data->{ show_tree } )  
     {  
         push @$html, $cgi->hidden( -name => 'checked', -value => $data->{ checked } );  
     }  
   
     if ( $data->{ ali_tree_id } )  
     {  
         push @$html, $cgi->hidden( -name => 'ali_tree_id', -value => $data->{ ali_tree_id } );  
     }  
   
     push @$html, 'SEED user: ',  
                  $cgi->textfield( -name => "user", -value => $user, -size => 32 ),  
                  $cgi->br;  
   
     if ( $data->{ ali_tree_id } || $data->{ fid } )  
     {  
         push @$html, 'Focus protein ID? ';  
     }  
     else  
     {  
         push @$html, $cgi->h2( 'Enter a SEED protein id: ' );  
     }  
   
     push @$html, $cgi->textfield( -name => "fid", -size => 32, -value => $data->{ fid } ),  
                  $cgi->submit( -name => 'action', -value => 'list all alignments and trees with this protein' ),  
                  $cgi->br;  
   
     if ( ! $data->{ show_align } && ! $data->{ show_tree } )  
     {  
         push @$html, $cgi->h2( 'Neither alignment nor tree are selected below.  Please select at least one.' );  
     }  
   
     push @$html, $cgi->checkbox( -name     => 'show_align',  
                                  -label    => 'Show alignment',  
                                  -override => 1,  
                                  -checked  => $data->{ show_align }  
                                ),  
                  '&nbsp;',  
                  $cgi->checkbox( -name     => 'show_tree',  
                                  -label    => 'Show tree',  
                                  -override => 1,  
                                  -checked  => $data->{ show_tree }  
                                ),  
                  $cgi->br, $cgi->br;  
   
     if ( $user )  
     {  
         push @$html, 'Use for functions and assignments: ',  
                      $cgi->radio_group( -name     => 'assign_using',  
                                         -override => 1,  
                                         -values   => [ 'Sapling', 'SEED' ],  
                                         -default  => $data->{ assign_using }  
                                       ),  
                      $cgi->br;  
     }  
   
     push @$html, $cgi->br,  
                  'Color alignment by: ',  
                  $cgi->radio_group( -name     => 'color_aln_by',  
                                     -override => 1,  
                                     -values   => [ 'consensus', 'residue' ],  
                                     -default  => $data->{ color_aln_by }  
                                   ),  
                  $cgi->br;  
   
     push @$html, 'Alignment format: ',  
                  $cgi->radio_group( -name     => 'align_format',  
                                     -override => 1,  
                                     -values   => [ 'default', 'fasta', 'clustal' ],  
                                     -default  => $data->{ align_format } || 'default'  
                                   ),  
                  $cgi->br, $cgi->br;  
   
     push @$html, 'Tree format: ',  
                  $cgi->radio_group( -name     => 'tree_format',  
                                     -override => 1,  
                                     -values   => [ 'default', 'newick', 'png' ],  
                                     -default  => $data->{ tree_format } || 'default'  
                                   ),  
                  $cgi->br;  
   
     push @$html, $cgi->checkbox( -name     => 'show_aliases',  
                                  -label    => 'Show aliases in tree',  
                                  -override => 1,  
                                  -checked  => $data->{ show_aliases }  
                                ),  
                  $cgi->br, $cgi->br;  
   
     push @$html, $cgi->submit( -name => 'action', -value => 'update' ),  
                  $cgi->br;  
   
     return @$html if wantarray;  
 }  
   
   
 #------------------------------------------------------------------------------  
 #  Compile all necessary data for alignments and trees.  
 #  The per sequence metadata are:  
 #  
 #      [ $peg_id, $peg_length, $trim_beg, $trim_end, $location_string ]  
 #  
 #------------------------------------------------------------------------------  
   
 sub compile_alignment_and_tree_data  
 {  
     my ( $data ) = @_;  
   
     ( $data->{ ali_tree_id } && ( $data->{ show_align } || $data->{ show_tree } ) )  
         or return 0;  
   
     my $html = $data->{ html } || [];  
     my $sap  = $data->{ sap };  
   
     my $align = [];  
     my $tree  = undef;  
     my $metaH = {};  
   
     if ( $data->{ show_align } )  
     {  
         ( $align, $metaH ) = AlignsAndTreesServer::peg_alignment_by_ID( $data->{ ali_tree_id } );  
     }  
     if ( $data->{ show_tree } )  
     {  
         ( $tree, $metaH ) = AlignsAndTreesServer::peg_tree_by_ID( $data->{ ali_tree_id } );  
     }  
   
     $metaH && %$metaH  
         or push @$html, $cgi->h2( "No data for alignment and tree '$data->{ali_tree_id}'." );  
   
     my @uids = keys %$metaH;    # Ids of alignment line and tree tips  
     my %fid_of_uid = map { $_ => $metaH->{$_}->[0] } @uids;  
   
     my %peg_seen = {};  
     my @fids = grep { ! $peg_seen{$_}++ } values %fid_of_uid;  
   
     #--------------------------------------------------------------------------  
     #  Find the current functions and organism names:  
     #--------------------------------------------------------------------------  
   
     my $fid_funcH = {};  
     my $orgH      = {};  
     if ( @fids && $data->{ assign_using } =~ /^SEED/i && $fig )  
     {  
         foreach my $peg ( @fids )  
         {  
             $fid_funcH->{ $peg } = $fig->function_of( $peg, $user ) || "";  
             $orgH->{ $peg }      = $fig->org_of( $peg );  
         }  
     }  
     elsif ( @fids )  
     {  
        $sap ||= SAPserver->new();  
        $fid_funcH = $sap->ids_to_functions( -ids => \@fids ) || {};  
        $orgH      = $sap->ids_to_genomes( -ids => \@fids, -name => 1 ) || {};  
     }  
   
     #--------------------------------------------------------------------------  
     #  Aliases  
     #--------------------------------------------------------------------------  
   
     my $aliasH = {};  
     if ( $data->{ show_aliases } ) { 0 }  
   
     #--------------------------------------------------------------------------  
     #  dlits  
     #--------------------------------------------------------------------------  
   
     my $dlitH = $sap->dlits_for_ids( -ids => \@fids );  
   
     #--------------------------------------------------------------------------  
     #  Projections from peg of md5a:  
     #  
     #  [ $n_shared, $identity, $score ]  
     #--------------------------------------------------------------------------  
   
     #  Get the projections  
     my $md5   = AlignsAndTreesServer::peg_to_md5( $sap, $fid ) || '';  
     my $projH = AlignsAndTreesServer::get_md5_projections( $md5, { details => 1 } ) || {};  
     my @projs = @{ $projH->{ $md5 } || [] };  
   
     #  Expend the md5 values  
     my @proj_md5s   = map { $_->[0] } @projs;  
     my $md5_to_pegs = AlignsAndTreesServer::md5s_to_pegs( $sap, $md5, @proj_md5s );  
   
     #  Expand the projections  
     my ( $proj, $md5b, @pegs );  
     my %projection;  
     foreach $proj ( @projs )  
     {  
         $md5b = $proj->[0];  
         @pegs = @{ $md5_to_pegs->{ $md5b } || [] };  
         foreach ( @pegs ) { $projection{ $_ } = [ @$proj[ 1 .. 3 ] ] }  
     }  
   
     #  Projections to identical sequences  
     @pegs = @{ $md5_to_pegs->{ $md5 } || [] };  
     foreach ( @pegs ) { $projection{ $_ } = [ 10, 100, 1 ] }  
   
     #--------------------------------------------------------------------------  
     #  Put in data hash  
     #--------------------------------------------------------------------------  
   
     $data->{ alias }      =  $aliasH;  
     $data->{ align }      =  $align;  
     $data->{ dlits }      =  $dlitH;  
     $data->{ fid_func }   =  $fid_funcH;  
     $data->{ fid_of_uid } = \%fid_of_uid;  
     $data->{ fids }       = \@fids;  
     $data->{ org }        =  $orgH;  
     $data->{ projects }   = \%projection;  
     $data->{ seq_meta }   =  $metaH;  
     $data->{ tree }       =  $tree;  
     $data->{ uids }       = \@uids;  
   
     return @$html if wantarray;  
 }  
   
   
 #==============================================================================  
 #  Show an alignment  
 #==============================================================================  
   
 sub show_alignment  
 {  
     my ( $data ) = @_;  
     my $html = $data->{ html } || [];  
   
     ( $data->{ ali_tree_id } && $data->{ show_align } ) or return;  
   
     my $align = $data->{ align };  
     $align && @$align  
         or push @$html, $cgi->h2( "No data for alignment '$data->{ali_tree_id}'." );  
   
     #  This defines the ordering.  
     my @seq_ids = map { $_->[0] } @$align;  
   
     push @$html, $cgi->h2( "Alignment $data->{ali_tree_id}" ) . "\n";  
   
     my $fid_of_uid = $data->{ fid_of_uid };  
     my $fid_func   = $data->{ fid_func };  
     my $org        = $data->{ org };  
   
     if ( $align && @$align && ( $data->{ align_format } =~ /^fasta/i ) )  
     {  
         my ( $id, $peg );  
         my %def = map { $id = $_->[0];  
                         $peg = $fid_of_uid->{ $id };  
                         $id => join( ' ', $id,  
                                           ( $fid_func->{ $id } ? $fid_func->{$id} : () ),  
                                           ( $org->{ $id }      ? "[$org->{$id}]"    : () )  
                                    )  
                       }  
                   @$align;  
   
         push @$html, join( "\n",  
                           "<PRE>",  
                           ( map { ( ">$def{$_->[0]}", $_->[2] =~ m/(.{1,60})/g ) } @$align ),  
                           "</PRE>\n"  
                         );  
     }  
   
     elsif ( $align && @$align && ( $data->{ align_format } =~ /^clustal/i ) )  
     {  
         push @$html, "<PRE>\n", &to_clustal( $align ), "</PRE>\n";  
     }  
   
     elsif ( $align && @$align )  
     {  
         my ( $align2, $legend );  
   
         #  Color by residue type:  
   
         if ( $data->{ color_aln_by } eq 'residue' )  
         {  
             my %param1 = ( align => $align, protein => 1 );  
             $align2 = gjoalign2html::color_alignment_by_residue( \%param1 );  
         }  
   
         #  Color by consensus:  
   
         else  
         {  
             my %param1 = ( align => $align );  
             ( $align2, $legend ) = gjoalign2html::color_alignment_by_consensus( \%param1 );  
         }  
   
         #  Add organism names:  
   
         foreach ( @$align2 ) { $_->[1] = $org->{ $_->[0] || '' } }  
   
         #  Build a tool tip with organism names and functions:  
   
         my %tips = map { $_ => [ $_, join( $cgi->hr, $org->{ $_ }, $fid_func->{ $_ } ) ] }  
                    map { $_->[0] }  
                    @$align2;  
         $tips{ 'Consen1' } = [ 'Consen1', 'Primary consensus residue' ];  
         $tips{ 'Consen2' } = [ 'Consen2', 'Secondary consensus residue' ];  
   
         my %param2 = ( align   => $align2,  
                        tooltip => \%tips  
                      );  
         $param2{ legend } = $legend if $legend;  
   
         push @$html, join( "\n",  
                            scalar gjoalign2html::alignment_2_html_table( \%param2 ),  
                            $cgi->br,  
                          );  
     }  
   
     return @$html if wantarray;  
 }  
   
   
 #------------------------------------------------------------------------------  
 #  Clustal format alignment  
 #------------------------------------------------------------------------------  
 sub to_clustal  
 {  
     my( $alignment ) = @_;  
   
     my($tuple,$seq,$i);  
     my $len_name = 0;  
     foreach $tuple ( @$alignment )  
     {  
         my $sz = length( $tuple->[0] );  
         $len_name = ($sz > $len_name) ? $sz : $len_name;  
     }  
   
     my @seq  = map { $_->[2] } @$alignment;  
     my $seq1 = shift @seq;  
     my $cons = "\377" x length($seq1);  
     foreach $seq (@seq)  
     {  
         $seq  = ~($seq ^ $seq1);  
         $seq  =~ tr/\377/\000/c;  
         $cons &= $seq;  
     }  
     $cons =~ tr/\000/ /;  
     $cons =~ tr/\377/*/;  
   
     push(@$alignment,["","",$cons]);  
   
     my @out = ();  
     for ($i=0; ($i < length($seq1)); $i += 50)  
     {  
         foreach $tuple (@$alignment)  
         {  
             my($id,undef,$seq) = @$tuple;  
             my $line = sprintf("\%-${len_name}s %s\n", $id, substr($seq,$i,50));  
             push(@out,$line);  
         }  
         push(@out,"\n");  
     }  
     return join("","CLUSTAL W (1.8.3) multiple sequence alignment\n\n\n",@out);  
 }  
   
   
 #==============================================================================  
 #  Tree:  
 #==============================================================================  
   
 sub show_tree  
 {  
     my ( $data ) = @_;  
   
     my $html = $data->{ html } || [];  
   
     my $tree = $data->{ tree };  
     if ( ! $tree )  
     {  
         push @$html, $cgi->h2( "No data for tree '$data->{ali_tree_id}'." );  
         return wantarray ? @$html : ();  
     }  
   
     push @$html, $cgi->h2( "Tree $data->{ali_tree_id}" ) . "\n"  if $tree;  
   
     my $can_assign = $data->{ can_assign };  
     my $fid_of_uid = $data->{ fid_of_uid };  
     my $fid_func   = $data->{ fid_func } || {};  
     my $org        = $data->{ org }      || {};  
     my $alias      = $data->{ alias }    || {};  
     my $dlits      = $data->{ dlits }    || {};  
     my $proj       = $data->{ projects } || {};  
   
     #------------------------------------------------------------------  
     #  Newick tree  
     #------------------------------------------------------------------  
     if ( $tree && ( $data->{ tree_format } =~ /^newick/i ) )  
     {  
         push @$html, "<pre>\n" . &gjonewicklib::formatNewickTree( $tree ) . "</pre>\n";  
     }  
   
     #------------------------------------------------------------------  
     #  PNG tree  
     #------------------------------------------------------------------  
     elsif ( $tree && ( $data->{ tree_format } =~ /^png/i ) )  
     {  
         my $okay;  
         eval { require gd_tree_0; $okay = 1 };  
         my $fmt;  
         if ( $okay && ( $fmt = ( gd_tree::gd_has_png() ? 'png'  :  
                                  gd_tree::gd_has_jpg() ? 'jpeg' :  
                                                          undef  
                                ) ) )  
         {  
             #------------------------------------------------------------------  
             #  Formulate the desired labels  
             #------------------------------------------------------------------  
             my %labels;  
             foreach my $id ( @{ $data->{ uids } } )  
             {  
                 my   $peg = $fid_of_uid->{ $id };  
                 my   @label;  
                 push @label, $id;  
                 push @label, $fid_func->{ $peg }          if $fid_func->{ $peg };  
                 push @label, "[$org->{$peg}]"             if $org->{ $peg };  
                 push @label, html_esc( $alias->{ $peg } ) if $alias->{ $peg };  
   
                 $labels{ $id } = join( ' ', @label );  
             }  
   
             #------------------------------------------------------------------  
             #  Relabel the tips, midpoint root, pretty it up and draw  
             #  the tree as printer plot  
             #  
             #  Adjustable parameters on text_plot_newick:  
             #  
             #     @lines = text_plot_newick( $node, $width, $min_dx, $dy )  
             #------------------------------------------------------------------  
             my $tree2 = newick_relabel_nodes( $tree, \%labels );  
             my $tree3 = reroot_newick_to_midpoint_w( $tree2 );  
   
             $tree = aesthetic_newick_tree( $tree3 );  
             my $options = { thickness =>  2,  
                             dy        => 15,  
                           };  
             my $gd = gd_tree::gd_plot_newick( $tree, $options );  
   
             my $name = sprintf( "align_and_tree_%d_%08d.$fmt", $$, int(1e8*rand()) );  
             my $file = "$FIG_Config::temp/$name";  
             open    TREE, ">$file";  
             binmode TREE;  
             print   TREE $gd->$fmt;  
             close   TREE;  
             chmod   0644, $file;  
   
             my $url = &FIG::temp_url() . "/$name";  
             push @$html, $cgi->br . "\n"  
                       . "<img src='$url' border=0>\n"  
                       .  $cgi->br . "\n";  
         }  
         else  
         {  
             push @$html, "<h3>Failed to convert tree to PNG.  Sorry.</h3>\n"  
                       . "<h3>Please choose another format above.</h3>\n";  
         }  
     }  
   
     #------------------------------------------------------------------  
     #  Printer plot tree  
     #------------------------------------------------------------------  
     else  
     {  
         #------------------------------------------------------------------  
         #  Formulate the desired labels:  
         #------------------------------------------------------------------  
         #  Build a function-to-color translation table based on frequency of  
         #  function. Normally white is reserved for the current function, but  
         #  there is none here. Assign colors until we run out, then go gray.  
         #  Undefined function is not in %func_color, and so is not in  
         #  %formatted_func  
         #----------------------------------------------------------------------  
         my %formatted_func = &FIGgjo::colorize_roles( $fid_func );  
   
         my %labels;  
         foreach my $id ( @{ $data->{ uids } } )  
         {  
             my $peg      = $fid_of_uid->{ $id };  
             my $func     = $fid_func->{ $peg };  
             my $functext = $func ? $formatted_func{ $func } : '';  
             my $orgname  = $org->{ $peg } ? html_esc( $org->{ $peg } ) : '';  
             my $proj_scr = $proj->{ $peg } ? $proj->{ $peg }->[2] : 0;  
             my $hbar     = score_to_hbar( $proj_scr );  
   
             if ( $dlits->{$peg} && @{$dlits->{$peg}} )  
             {  
                 $functext = qq(<SPAN Style='font-weight:bold'>$functext</SPAN>) if $functext;  
                 $orgname  = qq(<SPAN Style='font-weight:bold'>$orgname</SPAN>)  if $orgname;  
             }  
   
             my   @label;  
             push @label, &HTML::fid_link( $cgi, $peg ) . '&nbsp;';  
             push @label, qq(<INPUT Type=checkbox Name=checked Value="$peg">) if $can_assign && $orgname;  
             push @label, qq(<INPUT Type=radio    Name=from    Value="$peg">) if $func;  
             push @label, $hbar;  
             push @label, $functext                                           if $functext;  
             push @label, "[$orgname]"                                        if $orgname;  
             push @label, html_esc( $alias->{ $peg } )                        if $alias->{ $peg };  
   
             $labels{ $id } = join( ' ', @label );  
         }  
   
         #------------------------------------------------------------------  
         #  Relabel the tips, midpoint root, and pretty it up.  
         #------------------------------------------------------------------  
   
         my $tree2 = newick_relabel_nodes( $tree, \%labels );  
         my $tree3 = reroot_newick_to_midpoint_w( $tree2 );  
         $tree = aesthetic_newick_tree( $tree3 );  
   
         #------------------------------------------------------------------  
         #  Form and JavaScript added by RAE, 2004-Jul-22, 2004-Aug-23.  
         #  Modified by GDP to make it DWWM, 2004-Jul-23, 2004-Aug-04.  
         #------------------------------------------------------------------  
   
         push @$html, join( "\n",  
                            $cgi->start_form( -method => 'post',  
                                              -target => '_blank',  
                                              -action => 'fid_checked.cgi',  
                                              -name   => 'protein_tree'  
                                            ),  
                            $cgi->hidden( -name => 'align_format', -value => $data->{ align_format } ),  
                            $cgi->hidden( -name => 'color_aln_by', -value => $data->{ color_aln_by } ),  
                            $cgi->hidden( -name => 'fid',          -value => $data->{ fid } ),  
                            $cgi->hidden( -name => 'show_aliases', -value => $data->{ show_aliases } ),  
                            $cgi->hidden( -name => 'tree_format',  -value => $data->{ tree_format } ),  
                            $cgi->hidden( -name => 'user',         -value => $user ),  
                            ""  
                          );  
   
         #------------------------------------------------------------------  
         #  Draw the tree as printer plot.  
         #------------------------------------------------------------------  
   
         if ( $user )  
         {  
             push @$html, $cgi->submit( -name => 'action', -value => 'assign' );  
         }  
         push @$html, $cgi->submit( -name => 'action', -value => 'chnage focus peg' ),  
                      $cgi->br;  
   
         my $plot_options = { chars  => 'html',     # html-encoded unicode box set  
                              format => 'tree_lbl', # line = [ $graphic, $label ]  
                              dy     =>  1,  
                              min_dx =>  1,  
                              width  => 64  
                            };  
         push @$html, join( "\n",  
                            '',  
                            '<DIV Class="tree">',  
                            ( map { my ( $line, $lbl ) = @$_;  
                                    #  Fix white space for even spacing:  
                                    $line =~ s/((&nbsp;)+)/<SPAN Class=w>$1<\/SPAN>/g;  
                                    $line =~ s/&nbsp;/&#9474;/g;  
                                    #  Output line, with or without label:  
                                    $lbl ? "<PRE>$line</PRE> $lbl<BR />"  
                                         : "<PRE>$line</PRE><BR />"  
                                  }  
                              gjonewicklib::text_plot_newick( $tree, $plot_options )  
                            ),  
                            '</DIV>',  
                            '', ''  
                          );  
   
         push @$html, join ("\n", $cgi->br, &HTML::java_buttons( "protein_tree", "checked" ), $cgi->br, "");  
   
         if ( $user )  
         {  
             push @$html, $cgi->submit( -name => 'action', -value => 'assign' );  
         }  
   
         push @$html, $cgi->submit( -name => 'action', -value => 'chnage focus peg' ),  
                      $cgi->br;  
   
         push @$html, $cgi->end_form;  
     }  
   
     return @$html if wantarray;  
 }  
   
   
 #==============================================================================  
 #  Select alignments and trees with given fid  
 #==============================================================================  
   
 sub show_alignments_and_trees_with_fid  
 {  
     my ( $data ) = @_;  
     my $html = $data->{ html } || [];  
     my $sap  = $data->{ sap };  
   
     if ( @{ $data->{ ali_tree_ids } } )  
     {  
         push @$html, $cgi->h2( "Select an Alignment and/or Tree" ),  
                     '<TABLE>',  
                     '<TR><TH>ID</TH><TH>Count</TH><TH>Role</TH><TR>',  
                     '<TABLEBODY>';  
         foreach my $id ( @{ $data->{ ali_tree_ids } } )  
         {  
             push @$html, '<TR><TD ColSpan=3><HR /></TD></TR>';  
   
             my @role_data = AlignsAndTreesServer::roles_in_align( $sap, $id );  
             splice @role_data, 5 if @role_data > 5;  
             my $nrow = @role_data;  
             my ( $role, $cnt ) = @{ shift @role_data };  
             $role = html_esc( $role );  
             push @$html, "<TR><TD RowSpan=$nrow><INPUT Type=radio Name=ali_tree_id Value=$id /> $id</TD>";  
             push @$html, "    <TD Style='text-align:right'>$cnt</TD>";  
             push @$html, "    <TD>$role</TD>";  
             push @$html, "</TR>";  
             foreach ( @role_data )  
             {  
                 ( $role, $cnt ) = @$_;  
                 $role = html_esc( $role );  
                 push @$html, "<TR>";  
                 push @$html, "    <TD Style='text-align:right'>$cnt</TD>";  
                 push @$html, "    <TD>$role</TD>";  
                 push @$html, "</TR>";  
             }  
         }  
         push @$html, '</TABLEBODY>',  
                     '</TABLE>', $cgi->br,  
                     $cgi->submit( -name => 'action', -value => 'update' ),  
                     $cgi->br;  
     }  
     elsif ( $data->{ fid } )  
     {  
         @{ $data->{ ali_tree_ids } } = AlignsAndTreesServer::aligns_with_pegID( $sap, $data->{ fid } );  
         push @$html, "Sorry, no alignments with protein id '$data->{fid}'\n<BR /><BR />\n" if ! @{ $data->{ ali_tree_ids } };  
     }  
   
     return @$html if wantarray;  
 }  
   
   
 #  Vertical and horizontal histogram bar graphics characters:  
 #  
 #  9601-9608  
 #  9615-9608  
 #  
 sub score_to_vbar  
 {  
     my ($scr) = @_;  
     my $code = int(($scr ** 0.8) / 0.15) + 9601;  
     return "&#$code";  
 }  
   
   
 sub score_to_hbar  
 {  
     my ($scr) = @_;  
     return '&nbsp;&nbsp;' if $scr == 0;  
     my $code = 9615 - int( 7.999 * ($scr ** 1.00) );  
     return "&#$code";  
 }  
   
   
39    
40    print "<TITLE>$title</TITLE>\n";
41    print $html;

Legend:
Removed from v.1.3  
changed lines
  Added in v.1.4

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3