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

View of /FigWebServices/display_subsys.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.30 - (download) (annotate)
Tue Sep 16 18:22:29 2008 UTC (11 years, 6 months ago) by parrello
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, myrast_rel40, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2010_0928, rast_2008_0924, mgrast_version_3_2, mgrast_dev_12152011, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, mgrast_dev_02212011, rast_rel_2010_1206, mgrast_release_3_0, mgrast_dev_03252011, rast_rel_2010_0118, mgrast_rel_2008_0924, mgrast_rel_2008_1110_v2, rast_rel_2009_02_05, rast_rel_2011_0119, mgrast_rel_2008_0625, mgrast_release_3_0_4, mgrast_release_3_0_2, mgrast_release_3_0_3, mgrast_release_3_0_1, mgrast_dev_03312011, mgrast_release_3_1_2, mgrast_release_3_1_1, mgrast_release_3_1_0, mgrast_dev_04132011, rast_rel_2008_10_09, mgrast_dev_04012011, rast_release_2008_09_29, mgrast_rel_2008_0923, mgrast_rel_2008_0919, rast_rel_2009_07_09, rast_rel_2010_0827, mgrast_rel_2008_1110, myrast_33, rast_rel_2011_0928, rast_rel_2008_09_29, mgrast_rel_2008_0917, rast_rel_2008_10_29, mgrast_dev_04052011, mgrast_dev_02222011, rast_rel_2009_03_26, mgrast_dev_10262011, rast_rel_2008_11_24
Changes since 1.29: +3 -1 lines
Changed to use the SEED Viewer if invoked in NMPDR mode.

# -*- perl -*-
#
# Copyright (c) 2003-2006 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 CGI;
use CGI::Carp qw(fatalsToBrowser); # this makes debugging a lot easier by throwing errors out to the browser

my $cgi = new CGI;

# Tracing support: must precede FIG object creation and follow CGI creation.
use Tracer;
ETracing($cgi);

use FIG;
use SFXlate;
use FIGjs;  # mouseover()
# Create a FIG-like object.
my $is_sprout = FIGRules::nmpdr_mode($cgi);

my $fig;

if ($is_sprout)
{
    my $subsys = $cgi->param('ssa_name');
    print $cgi->redirect(-status => 301, -uri => "$FIG_Config::linkinSV?page=Subsystems;subsystem=$subsys");
    exit
}
else
{
    if (my $job = $cgi->param("48hr_job"))
    {
	my $jobdir = "/vol/48-hour/Jobs/$job";
	my $genome = &FIG::file_head("$jobdir/GENOME_ID");
	chomp $genome;
	if ($genome !~ /^\d+\.\d+/)
	{
	    die "Cannnot find genome ID for jobdir $jobdir\n";
	}
	my $orgdir = "$jobdir/rp/$genome";
	if (! -d $orgdir)
	{
	    die "Cannot find orgdir $orgdir\n";
	}
	$fig = new FIGV($orgdir);
    }
    else
    {
	$fig = FIG->new();
    }
}

use Subsystem;

use URI::Escape;		# uri_escape()
use HTML;
use strict;
use tree_utilities;
use TemplateObject;

use raelib;
my $raelib=new raelib; #this is for the excel workbook stuff.


if (0)
{
    my $VAR1;
    eval(join("",`cat /tmp/ssa_parms`));
    $cgi = $VAR1;
#   print STDERR &Dumper($cgi);
}

if (0)
{
    print $cgi->header;
    my @params = $cgi->param;
    print "<pre>\n";
    foreach $_ (@params)
    {
        print "$_\t:",join(",",$cgi->param($_)),":\n";
    }

    if (0)
    {
        if (open(TMP,">/tmp/ssa_parms"))
        {
            print TMP &Dumper($cgi);
            close(TMP);
        }
    }
    exit;
}

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


my $dbTitle = $fig->Title();
$to->add("<TITLE>$dbTitle Subsystems</TITLE>\n");

my $parameters = { fig_object  => $fig,
                   table_style => 'plain',
                   fig_disk    => $FIG_Config::fig_disk . "/",
                   form_target => 'display_subsys.cgi'
};

# Format the header information.
$to->titles($parameters);


my $ssa  = $cgi->param('ssa_name');
$ssa =~ s/[ \/]/_/g;

my $colors = $cgi->param('show_clusters') ? 1 : 0;
my $aliases = $cgi->param('ext_ids') ? 1 : 0;
my $active_subsetR = $cgi->param('active_subsetR') || "";
my $focus = $cgi->param('focus') || "";
my @color = $cgi->param('color');
my $specific_pegs_to_color = (@color > 0) ? [map { [$_,'#C0C0C0'] } @color] : undef;
my %ec2id=();
my %ec2gofunc=();

use UnvSubsys;


my($subsystem);
print $cgi->header();
print '<script src="./Html/css/FIG.js" type="text/javascript"></script>';
if  ((! $ssa) || (! ($subsystem = new UnvSubsys($ssa,
                                                $fig,
                                                $active_subsetR,
                                                $focus,
                                                $colors,
                                                $aliases,
                                                $specific_pegs_to_color)))) {
    $to->add(title => $cgi->h1('You need to specify a subsystem'));
} else {    
    #Load the hash into memory once
    &ec2hash;
    &produce_html_to_display_subsystem($fig,$subsystem,$cgi,$to,$ssa);
}

print $to->finish();

1;


sub produce_html_to_display_subsystem {
    my($fig,$subsystem,$cgi,$to,$ssa) = @_;

    my $curator = $subsystem->subsystem_curator;

    my $titles = join("\n", $cgi->h1("Subsystem: $ssa"),
                 $cgi->h1("Author: $curator"),
                 "");
    $to->add(title => $titles);
    $to->add($cgi->br);
	     
    &format_roles($fig,$cgi,$to,$subsystem);
    
    my $subsets = &format_subsets($fig,$cgi,$to,$subsystem);
    my $pegs_to_download = &format_rows($fig,$cgi,$to,$subsystem);

    my $focus = $cgi->param('focus');
    $focus = $focus ? $focus : "";

    my $active_subsetR = $cgi->param('active_subsetR');
    $active_subsetR = $active_subsetR ? $active_subsetR : "";

    &format_diagrams($fig,$cgi,$to,$subsystem);
    Trace("Diagrams generated.") if T(3);

    my $role_to_download;
    if ($cgi->param('download_fasta') && ($role_to_download = $cgi->param('role_to_download')) && (@$pegs_to_download > 0))
    {
	my $fasta_download = join("\n",($cgi->h2("Fasta for Pegs Implementing $role_to_download"),"<pre>",
					&downloaded_fasta($fig,$cgi,$pegs_to_download),
					"</pre><br><br>\n"));
	$to->add(fasta => $fasta_download);
    }

    my $options = $cgi->h2("Spreadsheet Options");
    my $sproutValue = $cgi->param("SPROUT") || 0;
    $options .= join("\n", $cgi->br,
                $cgi->start_form(-action => "display_subsys.cgi",
                                 -method => 'post'),
                $cgi->hidden(-name => 'ssa_name', -value => $ssa, -override => 1),
                $cgi->hidden(-name => 'focus', -value => $focus, -override => 1),
                $cgi->hidden(-name => 'SPROUT', -value => $sproutValue, -override => 1),
                $cgi->br,$cgi->br,
                "");

    $options .= join("\n", $cgi->scrolling_list(-name => 'active_subsetR',
                                     -values => $subsets,
                                     -default => $active_subsetR,
                                     -override => 1,
                                     -size => 5
                                     ),
                $cgi->br,
                $cgi->br,
                "");

    $options .= join("\n", $cgi->scrolling_list(-name => 'sort',
                                     -value => ['unsorted','alphabetic','by_pattern',
                                                'by_phylo','by_tax_id','by_variant'],
                                     -default => 'unsorted'
                                     ),
                $cgi->br,$cgi->br,
                "");

    $options .= join("\n",$cgi->submit('show spreadsheet'),$cgi->br,$cgi->br,$cgi->br,"");

    $options .= join("\n",$cgi->checkbox(-name => 'ignore_alt', -value => 1, -override => 1, -label => 'Ignore alternatives', -checked => ($cgi->param('ignore_alt'))),$cgi->br,"");
    $options .= join("\n",$cgi->checkbox(-name => 'ext_ids', -value => 1, -checked => 0, -label => 'Use external ids'),$cgi->br,"");
    $options .= join("\n",$cgi->checkbox(-name => 'show_clusters', -value => 1, -checked => 0,-label => 'Show clusters'),$cgi->br,"");
    $options .= join("\n",$cgi->checkbox(-name => 'show_minus1', -value=> 1, -checked => 0, -label => 'Show -1 variants'),$cgi->br,"");

    my $roles_to_pick_from = [sort $subsystem->get_roles];
    if (! $is_sprout) {

	$options .= join("\n",(
			       $cgi->checkbox(-name => 'keep_rep_seqs', -value=> 1, -checked => 0, -label => 'Keep Diverse Sequences'), 
			       $cgi->textfield(-name=>"how_many_reps", -size => 4, -value => 100), "\n",
			       $cgi->scrolling_list(-name => 'role_to_use_for_reps', 
						    -values => $roles_to_pick_from, 
						    -size => 1,
						    -multiple => 0),
			       $cgi->br,""
			       ));


        if ($cgi->param('create_excel')) {
            $options .= $raelib->excel_file_link() . "\n";
        }
        $options .= join("\n", $cgi->checkbox(-name => 'create_excel', -value=> 1, -checked => 0, -label => 'Create Excel file of these tables'), $cgi->br, "");
        $options .= join("\n", (
				$cgi->checkbox(-name => 'download_fasta', -value=> 1, -override => 1, -checked => 0, -label => 'Download Fasta for a Column'), 
				$cgi->checkbox(-name => 'mark_questionable', -value=> 1, -checked => 0, -label => 'Mark Questionable PEGs'),
				$cgi->scrolling_list(-name => 'role_to_download', 
						     -values => $roles_to_pick_from, 
						     -size => 1,
						     -multiple => 0),
			       $cgi->br, 
			 ""));
    }
    $options .= $cgi->end_form;
    $to->add(options => $options);
    my $notes = $subsystem->get_notes();
    $notes =~ s/(.{0,80}\s)/$1\n/g; # pre width=80 doesn't work at least in safari. This works.
    $notes =~ s/\n\s*\n/\n\n/g; # this just removes many empty lines (e.g. "\n \n \n \n" matches this regexp)
    $to->add(notes => $cgi->h2('notes') . "<pre width=80>$notes</pre>");

    $to->add($cgi->hr);
}

sub ec2hash {

    open (IN,"$FIG_Config::data/Global/ec2go") or warn $!;
    my $ec; my $func; my $id;

    while ($_ = <IN>) {
	chomp;

        $_ =~ /EC:([0-9\-\.]+)\s+\>\s+GO:\s*(\S.*\S)\s*\;\s+GO:(\d+)$/;
	($ec,$func,$id) = ($1,$2,$3);
	$ec2id{$ec}=$id;
	$ec2gofunc{$ec}=$func;
    }
    close (IN);
    
}


sub format_diagrams
{
    my($fig, $cgi, $to, $subsystem) = @_;

    my $result = "";
    my @diagrams = $subsystem->get_diagrams();
    my $diagramCount = @diagrams;
    Trace("$diagramCount diagrams found for subsystem.") if T(3);
    if ($diagramCount)
    {
        $result .= join("\n", $cgi->hr, $cgi->h2("Subsystem Diagrams"), "");

        my @hdr = ("Diagram Name");

        my @tbl;
        for my $dent (@diagrams)
        {
            my($id, $name, $link) = @$dent;
            Trace("Found diagram $id with name $name linking to $link.") if T(3);
            my @row;

            my $js = "showDiagram('$link', '$id'); return false;";

            push(@row, qq(<a href="$link" onclick="$js" target="show_ss_diagram_$id">$name</a>));

            push(@tbl, \@row);
        }
        my %options=(excelfile=>$ssa, no_excel_link=>1);
        $result .= &HTML::make_table(\@hdr, \@tbl, "", %options);
    }
    
    $to->add(diagrams => $result);

    return $diagramCount > 0;
}



sub format_roles {
    my($fig,$cgi,$to,$subsystem,$can_alter) = @_;
    my($i);

    my @roles = $subsystem->get_roles;
    my $reactions = $subsystem->get_reactions;
      
    
    my $n = 1;
    my $col_hdrs = ["Column","Abbrev","Functional Role", "GO"];

    if ($reactions)
    {
        push(@$col_hdrs,"Reactions");
    }

      
    push(@$col_hdrs,"Pre-Computed Publication(s)");
    push(@$col_hdrs,"Relevant Publication(s)");
    my $tab = [];

    &format_existing_roles($fig,$cgi,$subsystem,$tab,\$n,$reactions,\@roles);
    my %options=(excelfile=>$ssa, no_excel_link=>1);
    $to->add(roles => &HTML::make_table($col_hdrs,$tab,"Functional Roles", %options) .
                $cgi->hr . "\n");
}

sub format_existing_roles {
    my($fig,$cgi,$subsystem,$tab,$nP,$reactions,$roles) = @_;
    my($role);

    foreach $role (@$roles)
    {
        &format_role($fig,$cgi,$subsystem,$tab,$$nP,$role,$reactions);
        $$nP++;
    }
}

sub format_role {
    my($fig,$cgi,$subsystem,$tab,$n,$role,$reactions) = @_;
    #my($abbrev,$reactT);
    my($abbrev,$reactT,$go,$ec,$golink);

    my $react = $reactions ? join(",", map { &HTML::reaction_link($_) } @{$reactions->{$role}}) : "";
    ($ec) = ($role =~ /EC\s([0-9\-\.]+)/);
    if ($ec2id{$ec} ne "") {
	$go = $ec2id{$ec};
	my $go_display = "$ec2gofunc{$ec} \($go\)";
	$golink='<a href="http://www.godatabase.org/cgi-bin/amigo/go.cgi?action=query&view=query&search_constraint=terms&query='.$go.'">'.$go_display.'</a>';
    }
    
    $abbrev = $role ? $subsystem->get_role_abbr($subsystem->get_role_index($role)) : "";
    

    my $row = [$n,$abbrev,$role, $golink];
    if ($reactions)
    {
        push(@$row,$react);
    }

    my $pre_literature_num = $fig->get_attributes("Role:$role", "ROLE_PUBMED_NOTCURATED");
    my $rel_literature_num = $fig->get_attributes("Role:$role", "ROLE_PUBMED_CURATED_RELEVANT");
 
   if ($pre_literature_num)  {
	push(@$row, '<a href="display_role_literature.cgi?subsys='.$ssa.'&role='.$role.'">'.$pre_literature_num.' Publication(s) </a>');
    }
    else {
	push (@$row, '');
    }
   
    #This allows the curator to add literature 
    if ($rel_literature_num < 1) {
	push(@$row, '<a href="display_role_literature.cgi?subsys='.$ssa.'&role='.$role.'"> Add Publication(s) </a>');
    }
    else {
	push(@$row, '<a href="display_role_literature.cgi?subsys='.$ssa.'&role='.$role.'">'.$rel_literature_num.' Publication(s) </a>');
    }
    push(@$tab,$row);
}

sub format_subsets {
    my($fig,$cgi,$to,$subsystem) = @_;

    &format_subsetsC($fig,$cgi,$to,$subsystem);
    my $subsets = &format_subsetsR($fig,$cgi,$to,$subsystem);
    return $subsets;
}


sub tree_link {
    my $target = "window$$";
    my $url = &FIG::cgi_url . "/subsys.cgi?request=show_tree";
    return "<a href=$url target=$target>Show Phylogenetic Tree</a>";
}

sub format_subsetsR {
    my($fig,$cgi,$to,$subsystem) = @_;
    my($i);

    my $link = &tree_link;
    $to->add(tree_link => $cgi->br . $link . $cgi->br . "\n");

    my @row_subs       = $subsystem->get_subsetsR;
    my $active_subsetR = $cgi->param('active_subsetR');
    my $focus          = $cgi->param('focus');

    my $subsets = [];
    my $bestN   = undef;
    my $bestSz  = undef;

    my $tuple;
    foreach $tuple (@row_subs)
    {
        my($id,$genomes) = @$tuple;
        if (! $focus)
        {
            push(@$subsets,$id);
        }
        elsif (&in($focus,$genomes))
        {
            push(@$subsets,$id);
            if ((! $bestN) || (@$genomes < $bestSz))
            {
                $bestN  = $id;
                $bestSz = @$genomes;
            }
        }
    }

    if ($focus && (! $active_subsetR))
    {
        $active_subsetR = $bestN;
        $cgi->param(-name => 'active_subsetR', -value => $bestN);
    }

    if (! $active_subsetR)
    {
        $active_subsetR = 'All';
        $cgi->param(-name => 'active_subsetR', -value => 'All');
    }
    return $subsets;
}

sub in {
    my($x,$xL) = @_;

    my $i;
    for ($i=0; ($i < @$xL) && ($xL->[$i] ne $x); $i++) {}
    return ($i < @$xL);
}

sub format_subsetsC {
    my($fig,$cgi,$to,$subsystem) = @_;

    my $col_hdrs = ["Subset","Includes These Roles"];
    my $tab = [];

    my $n = 1;
    &format_existing_subsetsC($cgi,$subsystem,$tab,\$n);
    if ($n > 1)
    {
         my %options=(excelfile=>$ssa, no_excel_link=>1);
         $to->add(subsets => &HTML::make_table($col_hdrs,$tab,"Subsets of Roles", %options) .
                    $cgi->hr . "\n");
    }
}

sub format_existing_subsetsC {
    my($cgi,$subsystem,$tab,$nP) = @_;
    my($nameCS);

    foreach $nameCS (sort $subsystem->get_subset_namesC)
    {
        if ($nameCS !~ /all/i)
        {
            &format_subsetC($cgi,$subsystem,$tab,$$nP,$nameCS);
            $$nP++;
        }
    }
}

sub format_subsetC {
    my($cgi,$subsystem,$tab,$n,$nameCS) = @_;

    if ($nameCS ne "All")
    {
        my $subset = $nameCS ? join(",",map { $subsystem->get_role_index($_) + 1 } $subsystem->get_subsetC_roles($nameCS)) : "";
        $nameCS = $subset ? $nameCS : "";
        push(@$tab,[$nameCS,$subset]);
    }
}

sub format_rows {
    my($fig,$cgi,$to,$subsystem) = @_;
    my($i,%alternatives);
    my $result = "";
    my $ignore_alt = $cgi->param('ignore_alt');
    my $pegs_for_selected_role = {};

    my $active_subsetR = $cgi->param('active_subsetR');
    my @subsetR = $subsystem->get_subsetR($active_subsetR);
    my %activeR = map { $_ => 1 } @subsetR;
    my $focus = $cgi->param('focus');
    if ($focus && (! $activeR{$focus})) { push(@subsetR,$focus); $activeR{$focus} = 1 }

    if (! $ignore_alt)
    {
        my $subset;
        foreach $subset (grep { $_ =~ /^\*/ } $subsystem->get_subset_namesC)
        {
            my @mem = $subsystem->get_subsetC_roles($subset);
            if (@mem > 1)
            {
                my $mem = [@mem];
                foreach $_ (@mem)
                {
                    $alternatives{$_}->{$subset} = $mem;
                }
            }
        }
    }
    my @in = $subsystem->get_genomes;

    if (@in > 0)
    {
        my $col_hdrs = ["Genome ID","Organism","Variant Code"];

        my @row_guide = ();

        my( $role, %in_col, %set_shown, $abbrev, $mem, $abbrev_html );
        foreach $role ($subsystem->get_roles)
        {
	    if ( $_ = $alternatives{ $role } )
	    {
		my @inA = grep { ! $set_shown{$_} } sort keys(%$_);
		foreach $abbrev (@inA)
		{
		    $set_shown{$abbrev} = 1;
		    $mem = $_->{$abbrev};

		    push( @row_guide, [ map { [ $_, "-" . ($subsystem->get_role_index($_) + 1) ] } @$mem ] );
		    foreach $_ ( @$mem ) { $in_col{ $_ } = 1 };  #  Mark the roles that are done
		    my $rolelist = join '<br>', map { substr($_->[1],1) . ". $_->[0]" } @{$row_guide[-1]};
		    $abbrev_html = "<a " . FIGjs::mouseover("Roles of $abbrev", $rolelist, '') . ">$abbrev</a>";
		    push( @$col_hdrs, $abbrev_html );
		}
	    }
	    elsif (! $in_col{$role})
	    {
		push( @row_guide, [ [ $role, "" ] ] );  #  No suffix on peg number
		$abbrev = $subsystem->get_role_abbr( $subsystem->get_role_index( $role ) );
		$abbrev_html = "<a " . FIGjs::mouseover("Role of $abbrev", $role, '') . ">$abbrev</a>";
		push( @$col_hdrs, $abbrev_html );
	    }
        }

        my $tab = [];
        my($genome,@pegs,@cells,$set,$peg_set,$pair,$suffix,$row,$peg,
           $color_of,$cell,%count,$color,@colors);

        #
        #  Simplified code for checking variants -- GJO
        #  If specific variants are requested, make a hash of those to keep:
        #

	my @active_genomes = grep { $activeR{$_} } @in;
	if ($cgi->param('keep_rep_seqs') && $cgi->param('role_to_use_for_reps') && $cgi->param('how_many_reps'))
	{
	    @active_genomes = &take_representative_genomes($fig,
							   $subsystem,
							   \@active_genomes,
							   $cgi->param('role_to_use_for_reps'),
							   $cgi->param('how_many_reps')
							  );
	}

        foreach $genome (@active_genomes)
        {
            my($genomeV,$vcodeV,$vcode_value);

            #  Get (and if necessary check) the variant code:

            $vcode_value = $subsystem->get_variant_code( $subsystem->get_genome_index( $genome ) );

            $row = [ $genome, &ext_genus_species($fig,$genome), $vcode_value ];

            @pegs = ();
            @cells = ();

            foreach $set (@row_guide)
            {
                $peg_set = [];
                foreach $pair (@$set)
                {
                    ($role,$suffix) = @$pair;
		    my @pegs_in_cell = $subsystem->get_pegs_from_cell($genome,$role);
		    my $num_in_cell = @pegs_in_cell;
                    foreach $peg (@pegs_in_cell)
                    {
			if ($cgi->param('role_to_download') eq $role)
			{
			    $pegs_for_selected_role->{$peg} = $num_in_cell;
			}
                        push(@$peg_set,[$peg,$suffix]);
                    }
                }
                push(@pegs,map { $_->[0] } @$peg_set);
                push(@cells,$peg_set);
            }

            foreach $cell ( @cells )  #  $cell = [peg, suffix]
            {
                #  Deal with the trivial case (no pegs) at the start

                if ( ! @$cell )
                {
                    #  Push an empty cell onto the row

                    push @$row, '@bgcolor="#FFFFFF": &nbsp; ';
                    next;
                }

                #  Figure out html text for each peg and cluster by color.
                my ( $peg, $suffix, $txt, $color );
                my @colors = ();
                my %text_by_color;   #  Gather like-colored peg text

                foreach $_ ( @$cell )
                {
                    ( $peg, $suffix ) = @$_;
                    #  Hyperlink each peg, and add its suffix:
                    $txt = ( $cgi->param('ext_ids') ? &ext_url($fig,$cgi,$peg)
                                                    : &HTML::fid_link($cgi,$peg, "local") )
                         . ( $suffix ? $suffix : '' );

                    $color = $subsystem->get_color_of($peg);
                    defined( $text_by_color{ $color } ) or push @colors, $color;
                    push @{ $text_by_color{ $color } }, $txt;
                }
                my $ncolors = @colors;
                #  Join text strings within a color (and remove last comma):

                my @str_by_color = map { [ $_, join( ', ', @{ $text_by_color{$_} }, '' ) ] } @colors;
                $str_by_color[-1]->[1] =~ s/, $//;

                #  Build the "superscript" string:
                my $superscript;
                my $sscript = "";
                if ( $superscript && @$cell )
                {
                    my ( %sscript, $ss );
                    foreach my $cv ( @$cell )  #  Should this be flattened across all pegs?
                    {
                        next unless ( $ss = $superscript->{ $cv->[0] } );
                        # my %flatten = map { ( $_, 1 ) } @$ss;
                        # $sscript{ join ",", sort { $a <=> $b } keys %flatten } = 1;  #  string of all values for peg
                        foreach ( @$ss ) { $sscript{ $_ } = 1 }
                    }
                    if (scalar keys %sscript)  # order by number, and format
                    {
                        my @ss = map  { $_->[0] }
                                 sort { $a->[1] <=> $b->[1] }
                                 map  { my ( $num ) = $_ =~ /\>(\d+)\</; [ $_, $num || 0 ] } keys %sscript;
                        $sscript = "&nbsp;<sup>[" . join( ", ", @ss ) . "]</sup>"
                    }
                }

                my $cell_data;

                #  If there is one color, just write a unicolor cell.

                if ( $ncolors == 1 )
                {
                    my ( $color, $txt ) = @{ shift @str_by_color };
                    $cell_data = qq(\@bgcolor="$color":) . $txt . $sscript;
                }

                #  Otherwise, write pegs into a subtable with one cell per color.

                else
                {
                    $cell_data = '<table><tr valign=bottom>'
                               . join( '', map { ( $color, $txt ) = @$_ ; qq(<td bgcolor="$color">$txt</td>) } @str_by_color )
                               . ( $sscript ? "<td>$sscript</td>" : '' )
                               . '</tr></table>';
                }

                #  Push the cell data onto the row:

                push(@$row, $cell_data);
            }

            push(@$tab,$row);
        }

        my($sort);
        if ($sort = $cgi->param('sort'))
        {
            if ($sort eq "by_pattern")
            {
                my @tmp = ();
                my $row;
                foreach $row (@$tab)
                {
                    my @var = ();
                    my $i;
                    for ($i=3; ($i < @$row); $i++)
                    {
                        push(@var, ($row->[$i] =~ /\|/) ? 1 : 0);
                    }
                    push(@tmp,[join("",@var),$row]);
                }
                $tab = [map { $_->[1] } sort { $a->[0] cmp $b->[0] } @tmp];
            }
            elsif ($sort eq "by_phylo")
            {
                $tab = [map      { $_->[0] }
                        sort     { ($a->[1] cmp $b->[1]) or ($a->[0]->[1] cmp $b->[0]->[1]) }
                        map      { [$_, $fig->taxonomy_of($_->[0])] }
                        @$tab];
            }
            elsif ($sort eq "by_tax_id")
            {
                $tab = [sort     { $a->[0] <=> $b->[0] } @$tab];
            }
            elsif ($sort eq "alphabetic")
            {
                $tab = [sort     { ($a->[1] cmp $b->[1]) or ($a->[0] <=> $b->[0]) } @$tab];
            }
            elsif ($sort eq "by_variant")
            {
                $tab = [sort     { ($a->[2] cmp $b->[2]) or ($a->[1] <=> $b->[1]) } @$tab];
            }
        }

        foreach $row (@$tab)
        {
            my($genomeV,$vcodeV,$vcode_value);
            $genome = $row->[0];
            $vcode_value = $row->[2];
            $result .= join("\n",$cgi->hidden(-name => "genome$genome", -value => $genome, -override => 1),
                        $cgi->hidden(-name => "vcode$genome", -value => $vcode_value),"");
            $genomeV = $genome;
            $vcodeV  = $vcode_value;
            $row->[0] = $genomeV;
            $row->[2] = $vcodeV;

        }

        my $tab1 = [];
        
        foreach $row (@$tab)
        {
            next if ($row->[2] == -1 && !$cgi->param('show_minus1')); # RAE don't show -1 variants if checked
            if ((@$tab1 > 0) && ((@$tab1 % 10) == 0))
            {
                push(@$tab1,[map { "<b>$_</b>" } @$col_hdrs]) ;
            }
            push(@$tab1,$row);
        }

         my %options=(excelfile=>$ssa, no_excel_link=>1);
         $to->add(rows => &HTML::make_table($col_hdrs,$tab1,"Basic Spreadsheet", %options) .
                    $cgi->hr ."\n");

    }
    return [map { [$_,$pegs_for_selected_role->{$_}] } 
	    keys(%$pegs_for_selected_role) 
	   ];
}

sub ext_url {
    my($fig,$cgi,$peg) = @_;

    my @tmp;
    my @aliases = $fig->feature_aliases($peg);
    if      ((@tmp = grep { $_ =~ /^uni\|/ } @aliases) > 0)
    {
        @aliases = map { &HTML::uni_link($cgi,$_) } @tmp;
    }
    elsif   ((@tmp = grep { $_ =~ /^sp\|/ } @aliases) > 0)
    {
        @aliases = map { &HTML::sp_link($cgi,$_) } @tmp;
    }
    elsif   ((@tmp = grep { $_ =~ /^gi\|/ } @aliases) > 0)
    {
        @aliases = map { &HTML::gi_link($cgi,$_) } @tmp;
    }
    elsif   ((@tmp = grep { $_ =~ /^kegg\|/ } @aliases) > 0)
    {
        @aliases = map { &HTML::kegg_link($cgi,$_) } @tmp;
    }
    else
    {
        return wantarray() ? (&HTML::fid_link($cgi,$peg)) : &HTML::fid_link($cgi,$peg);
    }

    if (wantarray())
    {
        return @aliases;
    }
    else
    {
        return $aliases[0];
    }
}

sub ext_genus_species {
    my($fig,$genome) = @_;

    my $gs = $fig->genus_species($genome);
    my $c  = substr($fig->taxonomy_of($genome),0,1);
    return "$gs [$c]";
}

sub peg_to_fasta {
    my($fig,$peg,$problems) = @_;

    my $func = $fig->function_of($peg);
    my $gs = $fig->genus_species(&FIG::genome_of($peg));
    my $seq = $fig->get_translation($peg);
    $seq =~ s/(.{1,60})/$1\n/g;
    return ">$peg $func [$gs] $problems\n$seq";
}

sub downloaded_fasta {
    my($fig,$cgi,$pegs_to_download) = @_;

    my(%by_func,$tuple,$peg,$num_in_cell,$func);
    my @fasta_download = ();
    foreach $tuple (@$pegs_to_download)
    {
	($peg,$num_in_cell) = @$tuple;
	$func = $fig->function_of($peg);
	push(@{$by_func{$func}},[$peg,$num_in_cell,$fig->get_translation($peg),$fig->possibly_truncated($peg)]);
    }
    foreach $func (sort keys(%by_func))
    {
	my @to_download = sort { length($a->[2]) <=> length($b->[2]) } @{$by_func{$func}};
	my $median_length = length($to_download[int(@to_download/2)]->[2]);
	foreach my $tuple (@to_download)
	{
	    my($peg,$num_in_cell,$pseq,$truncated) = @$tuple;
	    my $bad_len = (abs(length($pseq) - $median_length) > (0.2 * $median_length)) ? 1 : 0;
	    my @problems = ();
	    if ($cgi->param('mark_questionable'))
	    {
		if ($truncated)          { push(@problems,"possibly truncated") }
		if ($num_in_cell > 1)    { push(@problems,"multiple PEGs with functional role") }
		if ($bad_len)            { push(@problems,"unusual length") }
	    }
	    my $fasta = &peg_to_fasta($fig,$peg,(@problems > 0) ? "[" . join(",",@problems) . "]" : "");
	    push(@fasta_download,"$fasta\n");
	}
    }
    return join("",(@fasta_download,"</pre><br><br>\n"));
}

use representative_sequences;

sub take_representative_genomes {
    my($fig,$subsystem,$genomes,$role,$num_reps) = @_;
    my($genome);

    if ($num_reps < 1) { return @$genomes }
    my @seqs = ();
    foreach $genome (@$genomes)
    {
	my @pegs_in_cell = $subsystem->get_pegs_from_cell($genome,$role);
	if (@pegs_in_cell > 0)
	{
	    push(@seqs,[$pegs_in_cell[0],"",$fig->get_translation($pegs_in_cell[0])]);
	}
    }

    if (@seqs <= $num_reps)
    {
	return @$genomes;
    }
    my $parms = { seqs => \@seqs, max_iden => 0.99, max_rep => $num_reps };
    my($reps,undef) = &representative_sequences::n_rep_seqs($parms);
    return map { &FIG::genome_of($_->[0]) } @$reps;
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3