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

View of /FigWebServices/fid_checked.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.44 - (download) (annotate)
Sat Sep 29 03:58:17 2007 UTC (12 years, 4 months ago) by overbeek
Branch: MAIN
CVS Tags: rast_rel_2008_06_18, rast_rel_2008_06_16, rast_rel_2008_07_21, rast_rel_2008_04_23
Changes since 1.43: +94 -7 lines
fixes to display on protein page, alternative formats for alignments and trees in fid_checked.cgi

# -*- perl -*-
#
# Copyright (c) 2003-2007 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.
#


# comment for debugging - there are latent bugs in here that strict exposes!
use strict;
use HTML;
use FIG_CGI;
use TemplateObject;
use FIGgjo;        # colorize_roles, colorize_functions
use gjoalignment;  # align_with_clustal
use gjoseqlib;     # read_fasta, print_alignment_as_fasta
use gjoalign2html; # repad_alignment, color_alignment_by_consensus
use clustaltree;   # tree_with_clustal
use gjonewicklib;
use Data::Dumper;

use Carp;

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

my $to = TemplateObject->new($cgi, php => 'Align');

my $peg_id    = $cgi->param('fid');
my $maxN      = $cgi->param('maxN');
my $maxP      = $cgi->param('maxP');
my @checked   = $cgi->param('checked');
my @from      = $cgi->param('from');
my $function  = $cgi->param('function'); 
$function=$fig->clean_spaces($function);
my($timestamp,$who,$annotation);
#print STDERR "\n\n$0: ", (scalar localtime(time())), "\n";
#print STDERR "\@from =    ", Dumper(\@from);
#print STDERR "\@checked = ", Dumper(\@checked);
if (is_sprout($cgi) || ! defined($user)) { $user = "" }

# The forms will be assembled here.
my $formData = "";
# The alignment will be assembled here.
my $alignData = "";
# The tree will be assembled here.
my $treeData = "";
# Useful debugging stuff will be put here.
my $paramData = "";
# Display the features selected.
if (@checked == 0) {
    $paramData .= "<p>No features selected.</p>\n";
} else {
    $paramData .= "<p>Features selected: " . join(", ", @checked) . ".</p>\n";
}

my $sproutFlag = (is_sprout($cgi) ? "&SPROUT=1" : "");

#==============================================================================
#  align
#
#  Nearly total rewrite by GJO -- 2007-04-09
#==============================================================================

if ( ( $cgi->param('align') &&  @checked >= 2 ) || $cgi->param('update') )
{
    print join( "\n", $cgi->header,
                     '<HTML>',
                     '<HEAD>',
                     '<TITLE>The SEED: Alignment and Tree of Proteins</TITLE>',
                     '</HEAD>',
                     '<BODY>',
                     ''
              );

    #----------------------------------------------------------------------
    #  Make ids unique and get a sequence.
    #  But don't need sequences if cached.
    #----------------------------------------------------------------------

    my @seqs;
    my $cached = $cgi->param('cached') || '';

    if ( ! $cached )
    {
        my %seen;
        @seqs = grep { $_->[2] }
                map  { [ $_, '', $fig->get_translation( $_ ) ] }
                grep { ! $seen{ $_ }++ }
                @checked;
        @checked = map { $_->[0] } @seqs;
    }

    # my $checked = join( "\' \'", @checked );  # never used?

    #----------------------------------------------------------------------
    #  Find the current functions:
    #----------------------------------------------------------------------

    my ( $fid, $func );
    my %fid_func = ();

    foreach $fid ( @checked )
    {
        $func = $fig->function_of( $fid, $user ) || "";
        $func =~ s/ +;/;/g;              # An ideosyncracy of some assignments
        $fid_func{ $fid } = $func;
    }

    #----------------------------------------------------------------------
    #  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 %formatted_func = &FIGgjo::colorize_functions( \%fid_func );

    #----------------------------------------------------------------------
    #  Get the organism names:
    #----------------------------------------------------------------------

    my %orgs = map { $_ => $fig->org_of( $_ ) || '' } @checked;

    my $sprout = $cgi->param('SPROUT') ? 1 : "";
    my $target = "window$$";
    my $newcache = $cached
               || ("fid_checked_data_" . $$ . "_" . sprintf( '%09d', 1e9*rand()+0.5 ));

    $treeData .= "<h2>Alignment of Selected Proteins</h2>\n";

    #----------------------------------------------------------------------
    #  Alignment:
    #----------------------------------------------------------------------
    #  Make or retreive the alignment:

    my @align;
    if ( $cached )
    {
        @align = read_cached_align( $cached );
    }
    else
    {
        @align = gjoalignment::align_with_clustal( @seqs );
        write_cached_align( $newcache, \@align ) if @align;
    }

    my $color_aln_by = $cgi->param( 'color_aln_by' ) || 'consensus';
    my $align_format = $cgi->param('align_format');
    my $tree_format  = $cgi->param('tree_format');

    if (@align && ($align_format eq "fasta"))
    {
	$treeData .= "<pre>" . 
	             join("",map { my $tseq = $_->[2]; 
				   $tseq =~ s/(.{1,60})/$1\n/g; 
				   ">$_->[0] $_->[1]\n$tseq" 
				 } @align) .
                     "</pre>\n";
    }
    elsif (@align && ($align_format eq "clustal"))
    {
	my $clustal_alignment = &to_clustal(\@align);
	$treeData .= "<pre>\n$clustal_alignment</pre>\n";
    }
    elsif ( @align )
    {
        my ( $align2, $legend );

        #  Color by residue type:

        if ( $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] = $orgs{ $_->[0] } }

        #  Build a tool tip with organism names and functions:

        my %tips = map { $_ => [ $_, join( '<HR>', $orgs{ $_ }, $fid_func{ $_ } ) ] }
                   @checked;
        $tips{ 'Consen1' } = [ 'Consen1', 'Primary consensus residue' ];
        $tips{ 'Consen2' } = [ 'Consen2', 'Secondary consensus residue' ];

        my %param2 = ( align   => $align2,
                       ( $legend ? ( legend  => $legend ) : () ),
                       tooltip => \%tips
                     );

        $treeData .= join( "\n",
                           scalar gjoalign2html::alignment_2_html_table( \%param2 ),
                           $cgi->br,

                         );
    }

    if (@align)
    {
	$treeData .= join( "\n",
                           $cgi->start_form( -method => 'post',
                                             -action => 'fid_checked.cgi',
                                             -name   => 'alignment'
                                           ),
                           $cgi->hidden(-name => 'fid',     -value => $peg_id),
                           $cgi->hidden(-name => 'SPROUT',  -value => $sprout),
                           $cgi->hidden(-name => 'user',    -value => $user),
                           $cgi->hidden(-name => 'cached',  -value => $newcache),
                           $cgi->hidden(-name => 'checked', -value => [@checked]),

                           'Color alignment by: ',
                           $cgi->radio_group( -name     => 'color_aln_by',
                                              -override => 1,
                                              -values   => [ 'consensus', 'residue' ],
                                              -default  => $color_aln_by
                                            ),

                           $cgi->br,
                           'Alignment format: ',
                           $cgi->radio_group( -name     => 'align_format',
                                              -override => 1,
                                              -values   => [ 'default', 'fasta', 'clustal' ],
                                              -default  => $align_format || 'default'
                                            ),

                           $cgi->br,
                           'Tree format: ',
                           $cgi->radio_group( -name     => 'tree_format',
                                              -override => 1,
                                              -values   => [ 'default', 'newick' ],
                                              -default  => $tree_format || 'default'
                                            ),

                           $cgi->br,
                           $cgi->submit( 'update' ),
                           $cgi->br
			   );
        $treeData .= $cgi->end_form . "\n";
    }

    #----------------------------------------------------------------------
    #  Tree:
    #----------------------------------------------------------------------
    #  Make or retreive the tree:

    my $tree;
    if ( $cached )
    {
        $tree = read_cached_tree( $cached );
        $treeData .= "<BR />Failed to retreive previous tree<BR />" if ! $tree;
    }
    else
    {
        $tree = clustaltree::tree_with_clustal( \@align );
        $treeData .= "<BR />Failed to make tree<BR />" if ! $tree;
        write_cached_tree( $newcache, $tree ) if $tree;
    }

    if ( $tree && ($tree_format eq "newick"))
    {
	$treeData .= "<h2>Neighbor-joining Tree of Selected Proteins</h2>\n<pre>\n" .
	             &gjonewicklib::formatNewickTree($tree) .
		     "</pre>\n";
    }
    elsif ($tree)
    {
        #------------------------------------------------------------------
        #  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.
        #------------------------------------------------------------------

        $treeData .= join( "\n",
                           "<h2>Neighbor-joining Tree of Selected Proteins</h2>",
                           $cgi->start_form( -method => 'post',
                                             -target => $target,
                                             -action => 'fid_checked.cgi',
                                             -name   => 'fid_checked'
                                           ),
                           $cgi->hidden(-name => 'fid',          -value => $peg_id),
                           $cgi->hidden(-name => 'SPROUT',       -value => $sprout),
                           $cgi->hidden(-name => 'user',         -value => $user),
                           $cgi->hidden(-name => 'color_aln_by', -value => $color_aln_by),
                           ""
                         );

        #------------------------------------------------------------------
        #  Build checkboxes and radio buttons for appropriate sequences:
        #------------------------------------------------------------------

        my @translatable = grep { $fig->translatable( $_ ) } @checked;

        my %check = map { $_ => qq(<input type=checkbox name=checked value="$_">) }
                    @translatable;

        my %from;
        if ( $user )
        {
            %from = map { m/value=\"([^\"]+)\"/; $1 => $_ }
                    $cgi->radio_group( -name     => 'from',
                                       -nolabels => 1,
                                       -override => 1,
                                       -values   => [ @translatable ],
                                       -default  => $peg_id
                                     );
        }

        #------------------------------------------------------------------
        #  Aliases
        #------------------------------------------------------------------

        my %alias = map  { $_->[0] => $_->[1] }
                    grep { $_->[1] }
                    map  { [ $_, scalar $fig->feature_aliases( $_ ) ] }
                    @checked;

        #------------------------------------------------------------------
        #  Formulate the desired labels:
        #------------------------------------------------------------------

        my %labels;
        foreach $fid ( @checked )
        {
            my @label;
            push @label, &HTML::fid_link( $cgi, $fid );
            push @label, "[$orgs{$fid}]"                      if $orgs{ $fid };
            push @label, $check{ $fid }                       if $check{ $fid };
            push @label, $from{ $fid }                        if $from{ $fid };
            push @label, $formatted_func{ $fid_func{ $fid } } if $fid_func{ $fid };
            push @label, html_esc( $alias{ $fid } )           if $alias{ $fid };

            $labels{ $fid } = 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_approx_midpoint_w( $tree2 );
        my $tree4  = aesthetic_newick_tree( $tree3 );
        $treeData .= join( "\n",
                           '<PRE>',
                           text_plot_newick( $tree4, 80, 2, 2 ),
                           '</PRE>',
                           ''
                         );

        #------------------------------------------------------------------
        # RAE Add the check all/uncheck all boxes.
        #------------------------------------------------------------------

        $treeData .= join ("\n", $cgi->br, &HTML::java_buttons("fid_checked", "checked"), $cgi->br, "");

        $treeData .= join("\n",
             "For selected (checked) sequences: "
             , $cgi->submit('align'),
             , $cgi->submit('view annotations')
             , $cgi->submit('show regions')
             , $cgi->br
             , ""
             );

        if ( $user && ! $sprout )
        {   
            $treeData .= $cgi->submit('assign/annotate') . "\n";
            
            if ($cgi->param('translate'))
            {   
                $treeData .= join("\n",
                     , $cgi->submit('add rules')
                     , $cgi->submit('check rules')
                     , $cgi->br
                     , ''
                     );
            }

            $treeData .= join( "\n", $cgi->br,
                                     "<a href='Html/help_for_assignments_and_rules.html'>Help on Assignments, Rules, and Checkboxes</a>",
                                     ""
                             );
        }
        
    }

    $treeData .= $cgi->end_form . "\n";

#  'align' with less than 2 sequences checked

} elsif ( $cgi->param('align') ) {

    print $cgi->header;
    $treeData .= "<h1>You need to check at least two sequences</h1>\n";

} elsif ($cgi->param('get sequences')) {

#==============================================================================
#  get sequences
#==============================================================================
    print $cgi->header;
    my ($prot, $seq, $desc, $org, $i);
    $treeData .= "<pre>\n";
    foreach $prot ( @checked ) {
        if ($seq = $fig->get_translation($prot))
        {
            $desc = $fig->function_of( $prot, $user );
            $org = $fig->org_of($prot);
            if ( $org ) { $desc .= " [$org]" }
            $treeData .= ">$prot $desc\n";
            for ($i=0; ($i < length($seq)); $i += 60)
            {
                $treeData .= substr($seq,$i,60) . "\n";
            }
        }
    }

    $treeData .=  "</pre>\n";
} elsif ($cgi->param('add rules') && (@checked > 0)) {

#==============================================================================
#  add rules
#==============================================================================

    print $cgi->header;
    my $to_func;
    my($from,$to,%tran,$line);

    if ((@from == 1) && ($from[0] =~ /^fig/) &&
        ($to_func = $fig->translate_function(scalar $fig->function_of($from[0]))))
    {
        my $col_hdrs = ["from","to"];
        my $tab = [];
        my($from_func,$peg);
        foreach $peg (@checked)
        {
            if (($from_func = $fig->translate_function(scalar $fig->function_of($peg))) &&
                ($from_func ne $to_func))
            {
                $tran{$from_func} = $to_func;
                push(@$tab,[$from_func,$to_func]);
            }
        }

        if (@$tab > 0)
        {
            $alignData .= join("\n", &HTML::make_table($col_hdrs,$tab,"Added Translation Rules"));

            if (open(TMP,"<$FIG_Config::global/function.synonyms")) {
                while (defined($line = <TMP>))
                {
                    chomp $line;
                    ($from,$to) = split(/\t/,$line);
                    if (($from ne $to) && (! $tran{$to}))
                    {
                        $tran{$from} = $to;
                    }
                }
                close(TMP);

                foreach $from (keys(%tran))
                {
                    $to = $tran{$from};
                    while ($tran{$to})
                    {
                        $to = $tran{$to};
                    }
                    $tran{$from} = $to;
                }
            }

            if (open(TMP,">$FIG_Config::global/function.synonyms"))
            {
                foreach $from (sort keys(%tran))
                {
                    print TMP "$from\t$tran{$from}\n";
                }
                close(TMP);
            }
            else
            {
                $alignData .= $cgi->h1("sorry, could not open function.synonyms; call support") . "\n";
            }
        }
    }
} elsif ($cgi->param('check rules')) {
    
#==============================================================================
#  check rules
#==============================================================================

    print $cgi->header;
    my($to_func,@rules,$i,$col_hdrs,$tab);
    if (! ($to_func = $cgi->param('to_func')))
    {
        if ($to_func = $fig->translate_function(scalar $fig->function_of($from[0])))
        {
            @rules = &rules_to($to_func);
            if (@rules > 0)
            {
                my $sprout = $cgi->param('SPROUT') ? 1 : "";

                $formData .= join("\n",$cgi->start_form(-method => 'post', -action => 'fid_checked.cgi'),
                            $cgi->hidden(-name => 'check rules', -value => 1,-override => 1),
                            $cgi->hidden(-name => 'SPROUT', -value => $sprout),
                            $cgi->hidden(-name => 'to_func',-value => $to_func, -override => 1),
                            "");

                $col_hdrs = ["delete","from","to"];
                $tab = [];
                for ($i=0; ($i < @rules); $i++)
                {
                    push(@$tab,[$cgi->checkbox(-name => 'rule_delete', -value => $i, -checked => 0, -label => ''),@{$rules[$i]}]);
                }
                $formData .= &HTML::make_table($col_hdrs,$tab,"Check Those to be Deleted") . "\n";
                $formData .= join("\n",$cgi->submit('delete'), $cgi->end_form, "");
            }
        }
        if (! $formData)
        {
            $alignData .= $cgi->h1("Sorry, no rules match") . "\n";
        }
    }
    else
    {
        my @rule_delete = $cgi->param('rule_delete');
        if (@rule_delete > 0)
        {
            &delete_rules($to_func,\@rule_delete);
            $alignData .= $cgi->h1("Done") . "\n";
        }
        else
        {
            $alignData .= $cgi->h1("Sorry, you need to select rules to be deleted") . "\n";
        }
    }
} elsif ($cgi->param('show regions') && (@checked > 1)) {

#==============================================================================
#  show regions
#==============================================================================

    my $pinned_to = "pinned_to=" . join("&pinned_to=",@checked);
    my $sprout = $cgi->param('SPROUT') ? 1 : "";
    $ENV{"REQUEST_METHOD"} = "GET";
    $ENV{"QUERY_STRING"} = "user=$user&$pinned_to&SPROUT=&sprout";
    my @out = `./chromosomal_clusters.cgi`;
    print join("",@out);
    exit;
} elsif ($cgi->param('view annotations') && (@checked > 0)) {

#==============================================================================
#  view annotations
#==============================================================================
    print $cgi->header;
    my $col_hdrs = ["who","when","annotation"];
    $alignData .= join("\n", "<table border=\"2\" align=\"center\">",
                             $cgi->Tr($cgi->th({ align => "center" }, $col_hdrs)),
                             "");
    foreach my $fid (@checked) {

        my $tab = [ map { [$_->[2],$_->[1],$_->[3]] } $fig->feature_annotations($fid) ];
        my $title = (@$tab == 0 ? "No " : "") . "Annotations for $fid";
        $alignData .= join("\n", $cgi->Tr($cgi->td({ colspan => 3, align => "center" }, $title)), "");
        if (@$tab > 0) {
            for my $row (@$tab) {
                $alignData .= $cgi->Tr($cgi->td($row));
            }
        }
    }
    $alignData .= "</table>\n";
    
} elsif ($cgi->param('Align DNA') && (@checked > 0)) {

#==============================================================================
#  Align DNA
#==============================================================================

    my $upstream = $cgi->param('upstream');
    if (! defined($upstream))   { $upstream = 0 }

    my $coding   = $cgi->param('gene');
    if (! defined($coding)) { $coding = "" }
    $ENV{'QUERY_STRING'} = join("&",map { "peg=$_" } grep { $_ =~ /^fig/ } @checked) .
                           "&upstream=$upstream&gene=$coding";
    $ENV{'REQUEST_METHOD'} = 'GET';
    print `./align_DNA.cgi`;
    exit;
    
} elsif ($cgi->param('assign/annotate') && (@checked > 0) && $user) {

#==============================================================================
#  assign/annotate
#==============================================================================

    print $cgi->header;
    my $func;
    if ((@from == 1) && ($func = $fig->function_of($from[0],$user)))
    {
	$func =~ s/\s+\#[^\#].*$//;
        foreach my $peg (@checked)
        {
            if ($user =~ /master:(.*)/)
            {
                my $userR = $1;
		if ($fig->assign_function($peg,$userR,$func,""))
		{
		    $fig->add_annotation($peg,$userR,"Set master function to\n$func\n");
		    $alignData .= $cgi->h1("Done");
		}
		else
		{
		    $alignData .= $cgi->h1("Failed for $peg");
		}
            }
            else
            {
                if ($fig->assign_function($peg,$user,$func,""))
		{
		    $fig->add_annotation($peg,$user,"Set function to\n$func\n");
		    $alignData .= $cgi->h1("Done");
		}
		else
		{
		    $alignData .= $cgi->h1("Failed for $peg");
		}
            }
        }
    }
    else
    {
        $alignData .= join("\n", "<table border=1>",
                      "<tr><td>Protein</td><td>Organism</td><td>Current Function</td><td>By Whom</td></tr>",
                      "");
        my $defaultann=''; # this will just be the last function with BUT NOT added if we are negating the function
        foreach my $peg ( @checked ) {
            my @funcs = $fig->function_of( $peg );
            if ( ! @funcs ) { @funcs = ( ["", ] ) }
            my $nfunc = @funcs;
            my $org = $fig->org_of( $peg );
            $alignData .= join("\n", "<tr>",
                          "<td rowspan=$nfunc>$peg</td>",
                          "<td rowspan=$nfunc>$org</td>",
                          ""
                );
            my ($who, $what);
            $alignData .=  join( "</tr>\n<tr>", map { ($who,$what) = @$_; "<td>$what</td><td>$who</td>" } @funcs );
            $alignData .= "</tr>\n";
            if ($cgi->param("negate")) {$defaultann="$what BUT NOT"}
        }
        $alignData .= "</table>\n";

        my $sprout = $cgi->param('SPROUT') ? 1 : "";
        $formData .= join("\n", $cgi->start_form(-action => "fid_checked.cgi"),
                      $cgi->br, $cgi->br,
                      ("<br><a href='Html/seedtips.html#gene_names' class='help' target='help'>Help on Annotations</a>"),
                      "<table>",
                      "<tr><td>New Function:</td>",
                      "<td>", $cgi->textfield(-name => "function", -default=>$defaultann, -size => 60), "</td></tr>",
                      "<tr><td colspan=2>", $cgi->hr, "</td></tr>",
                      "<tr><td>New Annotation:</td>",
                      "<td rowspan=2>", $cgi->textarea(-name => "annotation", -rows => 30, -cols => 60), "</td></tr>",
                      "<tr><td valign=top><br>", $cgi->submit('add annotation'), "</td></tr>",
                      "</table>",
                      $cgi->hidden(-name => 'user', -value => $user),
                      $cgi->hidden(-name => 'SPROUT', -value => $sprout),
                      $cgi->hidden(-name => 'checked', -value => [@checked]),
                      $cgi->end_form,
                      ""
             );
    }
} elsif ($cgi->param('batch_assign') && (@checked > 0) && $user) {


#==============================================================================
#  batch assign
#
# This comes from the "show missing including matches" code in ssa2.cgi.
#
# Modified by RAE to allow from=(.*) to be a peg or a function, and used in 
# check_subsys.cgi
#
#==============================================================================

    print $cgi->header;
    $alignData .= "<h2>Batch Assignments Made:\n";
    for my $ent (@checked)
    {
        if ($ent =~ /^to=(.*),from=(.*)$/)
        {
            my $to_peg = $1;
            my $from_peg = $2;
            
            # RAE: I only changed this line below
            # my $from_func = $fig->function_of($from_peg);
            my $from_func = ($from_peg =~ /\|/) ? $fig->function_of($from_peg) : $from_peg;


            next unless $from_func;

            my $link = &HTML::fid_link($cgi, $to_peg, 0);
            if ($user =~ /master:(.*)/)
            {
                $alignData .= "Master assigning $from_func to $link<br>\n";
                my $userR = $1;
                if ($fig->assign_function($to_peg,$userR,$from_func,""))
		{
		    $fig->add_annotation($to_peg,$userR,"Set master function to\n$from_func\n");
		}
            }
            else
            {
                $alignData .= "User $user assigning $from_func to $link<br>\n";
                if ($fig->assign_function($to_peg,$user,$from_func,""))
		{
		    $fig->add_annotation($to_peg,$user,"Set function to\n$from_func\n");
		}
            }
        }
    }
    $alignData .= $cgi->h1("Done");
} elsif ($cgi->param("lock_annotations") && (@checked > 0) && $user)
{
#==============================================================================
#  lock annotation
#==============================================================================

    print $cgi->header;
    my $userR = ($user =~ /^master:(.*)/) ? $1 : $user;
    foreach my $peg (@checked)
    {
	$fig->lock_fid($user,$peg);
    }
    $alignData .= $cgi->h1("Done") . "\n";

} elsif ($cgi->param("unlock_annotations") && (@checked > 0) && $user)
{
#==============================================================================
#  unlock annotations
#==============================================================================

    print $cgi->header;
    my $userR = ($user =~ /^master:(.*)/) ? $1 : $user;
    foreach my $peg (@checked)
    {
	$fig->unlock_fid($user,$peg);
    }
    $alignData .= $cgi->h1("Done") . "\n";

} elsif ($cgi->param("add annotation") && (@checked > 0) && $user && 
    ($function || ($annotation = $cgi->param('annotation'))))
{

#==============================================================================
#  add annotation
#==============================================================================

    print $cgi->header;
    my $userR = ($user =~ /^master:(.*)/) ? $1 : $user;
    
    foreach my $peg (@checked)
    {
        if ($function)
        {
            $userR = ($user =~ /^master:(.*)/) ? $1 : $user;
            if ($user =~ /master:(.*)/)
            {
		my $userR = $1;
                if ($fig->assign_function($peg,$userR,$function,""))
		{
		    $fig->add_annotation($peg,$userR,"Set master function to\n$function\n");
		}
		else
		{
		    $alignData .= $cgi->h1("Failed for $peg");
		}
            }
            else
            {
                if ($fig->assign_function($peg,$user,$function,""))
		{
		    $fig->add_annotation($peg,$user,"Set function to\n$function\n");
		}
		else
		{
		    $alignData .= $cgi->h1("Failed for $peg");
		}
            }
        }

        if ($annotation = $cgi->param('annotation'))
        {
#           print STDERR "adding annotation for $userR to $peg: $annotation\n";
            $fig->add_annotation($peg,$userR,"$annotation\n");
            $alignData .= $cgi->h2("added annotation to $peg") . "\n";
        }
    }


} elsif ( $cgi->param("view similarities") && ( @checked > 0 ) ) {

#==============================================================================
#  Similarities form
#==============================================================================

    print $cgi->header;
    my $sprout = $cgi->param('SPROUT') ? 1 : "";

    $formData .= join("\n", $cgi->start_form( -method => 'post',
                                   -target => "sims_window$$",
                                   -action => 'protein.cgi#Similarities',
                                 ),
                 $cgi->hidden( -name => 'SPROUT', -value => $sprout ),
                 $cgi->hidden( -name => 'sims',   -value => 1 ),
                 $cgi->hidden( -name => 'user',   -value => $user ),
                 "");

    $formData .= <<'End_Sims_Options';
        <H2>Similarities Option Settings</H2>

        Max sims:<input   type=text name=maxN       size=5 value=50   > &nbsp;&nbsp;
        Max expand:<input type=text name=max_expand size=5 value=5    > &nbsp;&nbsp;
        Max E-val:<input  type=text name=maxP       size=8 value=1e-05> &nbsp;&nbsp;
        <select name=select>
            <option value=all selected >Show all databases</option>
            <option value=fig_pref     >Prefer FIG IDs (to max exp)</option>
            <option value=figx_pref    >Prefer FIG IDs (all)</option>
            <option value=fig          >Just FIG IDs (to max exp)</option>
            <option value=figx         >Just FIG IDs (all)</option>
        </select> &nbsp;&nbsp;
        Show Env. samples:<input type=checkbox name=show_env   value=1> &nbsp;&nbsp;
        Hide aliases:<input      type=checkbox name=hide_alias value=1><br />

        Sort by
        <select name=sort_by>
            <option value=bits selected >score</option>
            <option value=id2           >percent identity*</option>
            <option value=bpp2          >score per position*</option>
            <option value=id            >percent identity</option>
            <option value=bpp           >score per position</option>
        </select> &nbsp;&nbsp;
        Group by genome:<input type=checkbox name=group_by_genome value=1 > &nbsp;&nbsp;&nbsp;
        <A href="Html/similarities_options.html" target="SEED_or_SPROUT_help">Help with SEED similarities options</A><br />
        <input type=hidden name=extra_opt value="1">

        Min similarity:<input type=text name=min_sim size=5 value=0>
        defined by
        <select name=sim_meas>
            <option value=id  selected >identities (0-100%)</option>
            <option value=bpp >score per position (0-2 bits)</option>
        </select> &nbsp;&nbsp;
        Min query cover (%):<input type=text name=min_q_cov size=5 value=0> &nbsp;&nbsp;
        Min subject cover (%):<input type=text name=min_s_cov size=5 value=0><p />

End_Sims_Options

    my $col_hdrs = [ 'Query sequence', 'Organism', 'Assignment' ];
    my $tab = [];
    foreach my $peg ( @checked )
    {
        push @$tab, [ $cgi->submit("prot", $peg),
                      "&nbsp;" . $fig->genus_species( $fig->genome_of( $peg ) ) . "&nbsp;",
                      "&nbsp;" . scalar $fig->function_of( $peg, $user ) . "&nbsp;"
                    ];
    }

    $formData .= join("\n", HTML::make_table( $col_hdrs, $tab, "Links to Protein Similaries" ),
                 $cgi->end_form, "");

} else {
        
#==============================================================================
#  failure
#==============================================================================

    print $cgi->header;
    $alignData .= $cgi->h1("invalid request");
}
$to->add(form  => $formData);
$to->add(align => $alignData);
$to->add(tree  => $treeData);
$to->add(param => $paramData);

print $to->finish();
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; $_ }


sub rules_to {
    my($to_func) = @_;

    my @rules = ();
    if (open(TMP,"<$FIG_Config::global/function.synonyms"))
    {
        my($line,$from,$to);
        while (defined($line = <TMP>))
        {
            chomp $line;
            ($from,$to) = split(/\t/,$line);
            if ($to eq $to_func)
            {
                push(@rules,[$from,$to]);
            }
        }
        close(TMP);
    }
    return @rules;
}

sub delete_rules {
    my($to_func,$which) = @_;

    my $to_funcQ = quotemeta $to_func;
    my $file = "$FIG_Config::global/function.synonyms";
    if ((rename($file,"$file~")) && open(TMPIN,"<$file~") && open(TMPOUT,">$file"))
    {
        my $n = 0;
        my($line,$i);
        while (defined($line = <TMPIN>))
        {
            if ($line =~ /\t$to_funcQ$/)
            {
                for ($i=0; ($i < @$which) && ($which->[$i] != $n); $i++) {}
                if ($i == @$which)
                {
                    print TMPOUT $line;
                }
                $n++;
            }
            else
            {
                print TMPOUT $line;
            }
        }
        close(TMPIN);
        close(TMPOUT);
        chmod 0777, $file, "$file~";
    }
    else
    {
        print STDERR "Failed to rename $file\n";
    }
}


#
#   @alignment = read_cached_align( $cache );
#  \@alignment = read_cached_align( $cache );
#
sub read_cached_align
{
    my $cache = shift;
    gjoseqlib::read_fasta( "$FIG_Config::temp/$cache.align" );
}


#
#  write_cached_align( $cache,  @alignment );
#  write_cached_align( $cache, \@alignment );
#
sub write_cached_align
{
    my $cache = shift;
    my $file = "$FIG_Config::temp/$cache.align";
    gjoseqlib::print_alignment_as_fasta( $file, @_ );
}


#
#  $tree = read_cached_tree( $cache );
#
sub read_cached_tree
{
    my $cache = shift;
    gjonewicklib::read_newick_tree( "$FIG_Config::temp/$cache.newick" );
}


#
#  write_cached_tree( $cache, $tree );
#
sub write_cached_tree
{
    my ( $cache, $tree ) = @_;
    my $file = "$FIG_Config::temp/$cache.newick";
    gjonewicklib::writeNewickTree( $tree, $file );
}

##################################################

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",$id) . " " . substr($seq,$i,50) . "\n";
	    push(@out,$line);
	}
	push(@out,"\n");
    }
    return join("","CLUSTAL W (1.8.3) multiple sequence alignment\n\n\n",@out);
}

			  

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3