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

View of /FigWebServices/align_and_tree.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (download) (annotate)
Mon Nov 14 01:44:00 2011 UTC (8 years, 3 months ago) by golsen
Branch: MAIN
Changes since 1.2: +686 -434 lines
Much new functionality.

# -*- perl -*-
#
# Copyright (c) 2003-2011 University of Chicago and Fellowship
# for Interpretations of Genomes. All Rights Reserved.
#
# This file is part of the SEED Toolkit.
#
# The SEED Toolkit is free software. You can redistribute
# it and/or modify it under the terms of the SEED Toolkit
# Public License.
#
# You should have received a copy of the SEED Toolkit Public License
# along with this program; if not write to the University of Chicago
# at info@ci.uchicago.edu or the Fellowship for Interpretation of
# Genomes at veronika@thefig.info or download a copy from
# http://www.theseed.org/LICENSE.TXT.
#

use strict;
use HTML;
use FIG_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;
use SAPserver;
use AlignsAndTreesServer qw( peg_alignment_metadata
                             peg_alignment_by_ID
                             peg_tree_by_ID
                             aligns_with_pegID
                             get_md5_projections
                           );

use Data::Dumper;
use Carp;

my( $fig, $cgi, $user ) = FIG_CGI::init( debug_save   => 0,
                                         debug_load   => 0,
                                         print_params => 0 );

my $sapObject = SAPserver->new();

# The html will be assembled here.

print $cgi->header;
my @html = ();

#------------------------------------------------------------------------------
#  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";
}




MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3