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

View of /FigWebServices/ssa.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.32 - (download) (annotate)
Mon Dec 5 19:12:12 2005 UTC (13 years, 11 months ago) by olson
Branch: MAIN
CVS Tags: mgrast_dev_08112011, rast_rel_2009_05_18, mgrast_dev_08022011, rast_rel_2014_0912, rast_rel_2008_06_18, myrast_rel40, rast_rel_2008_06_16, mgrast_dev_05262011, rast_rel_2008_12_18, mgrast_dev_04082011, rast_rel_2008_07_21, rast_rel_2010_0928, rast_2008_0924, mgrast_version_3_2, mgrast_dev_12152011, rast_rel_2008_04_23, mgrast_dev_06072011, rast_rel_2008_09_30, rast_rel_2009_0925, rast_rel_2010_0526, rast_rel_2014_0729, mgrast_dev_02212011, rast_rel_2010_1206, caBIG-05Apr06-00, 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_0806, 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, caBIG-13Feb06-00, rast_rel_2009_03_26, mgrast_dev_10262011, rast_rel_2008_11_24, rast_rel_2008_08_07, HEAD
Changes since 1.31: +17 -0 lines
add license words

#
# 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 FIG;
my $fig = new FIG;

use HTML;
use strict;
use tree_utilities;

use CGI;
my $cgi = new CGI;

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 $request = $cgi->param("request");
if ($request && ($request eq "show_tree"))
{
    print $cgi->header;
    &show_tree;
    exit;
}

my $html = [];

my $user = $cgi->param('user');
if ((! $user) || ($user !~ /^master:\S+/))
{
    push(@$html,$cgi->h1("Sorry, you need to specify a master user to modify subsystem annotations"));
}
else
{
    $request = defined($request) ? $request : "";

    if    ($request eq "reset")
    {
	&reset_ssa($fig,$cgi,$html);
    }
    elsif    ($request eq "reset_to")
    {
	&reset_ssa_to($fig,$cgi,$html);
	&show_ssa($fig,$cgi,$html);
    }
    elsif    ($request eq "make_exchangable")
    {
	&make_exchangable($fig,$cgi,$html);
	&show_initial($fig,$cgi,$html);
    }
    elsif    ($request eq "make_unexchangable")
    {
	&make_unexchangable($fig,$cgi,$html);
	&show_initial($fig,$cgi,$html);
    }
    elsif    ($request eq "show_ssa")
    {
	&show_ssa($fig,$cgi,$html);
    }
    elsif ($request eq "show_ssa_noload")
    {
	&show_ssa_noload($fig,$cgi,$html);
    }
    elsif ($request eq "delete_or_export_ssa")
    {
	my($ssa,$exported);
	$exported = 0;
	foreach $ssa ($cgi->param('export'))
	{
	    if (! $exported)
	    {
		print $cgi->header;
		print "<pre>\n";
	    }
	    &export($fig,$cgi,$ssa);
	    $exported = 1;
	}

	foreach $ssa ($cgi->param('export_assignments'))
	{
	    &export_assignments($fig,$cgi,$ssa);
	}

	foreach $ssa ($cgi->param('delete'))
	{
	    system "rm -rf $FIG_Config::data/Subsystems/$ssa";
	}

	if (! $exported)
	{
	    &show_initial($fig,$cgi,$html);
	}
	else
	{
	    print "</pre>\n";
	    exit;
	}
    }
    elsif ($request eq "new_ssa")
    {
	&new_ssa($fig,$cgi,$html);
    }
    else
    {
	&show_initial($fig,$cgi,$html);
    }
}

&HTML::show_page($cgi,$html);

sub show_initial {
    my($fig,$cgi,$html) = @_;
    my($set,$when,$comment);

    my $user = $cgi->param('user');
    my @ssa = &existing_subsystem_annotations;

    if (@ssa > 0)
    {
	&format_ssa_table($html,$user,\@ssa);
    }

    my $target = "window$$";
    push(@$html, $cgi->h1('To Start a New Subsystem Annotation'),
                 $cgi->start_form(-action => "ssa.cgi",
				  -target => $target,
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'new_ssa', -override => 1),
	         "Name of New Subsystem Annotation: ",
	         $cgi->textfield(-name => "ssa_name", -size => 50),
	         $cgi->br,
	         $cgi->submit('start new subsystem annotation'),
	         $cgi->end_form
	 );
}		  

sub new_ssa {
    my($fig,$cgi,$html) = @_;

    my $user = $cgi->param('user');
    my $name = $cgi->param('ssa_name');

    if  (! $user)
    {
	push(@$html,$cgi->h1('You need to specify a user before starting a new subsystem annotation'));
	return;
    }

    if  (! $name)
    {
	push(@$html,$cgi->h1('You need to specify a subsystem name'));
	return;
    }

    my $ssa  = $name;
    $ssa =~ s/ /_/g;
    &FIG::verify_dir("$FIG_Config::data/Subsystems");

    if (-d "$FIG_Config::data/Subsystems/$ssa")
    {
	push(@$html,$cgi->h1("You need to specify a new subsystem name; $ssa already is being used"));
	return;
    }
    mkdir("$FIG_Config::data/Subsystems/$ssa",0777)
	|| die "could not make $FIG_Config::data/Subsystems/$ssa";
    chmod(0777,"$FIG_Config::data/Subsystems/$ssa");

    open(LOG,">$FIG_Config::data/Subsystems/$ssa/curation.log")
	|| die "could not open $FIG_Config::data/Subsystems/$ssa/curation.log";
    my $time = time;
    print LOG "$time\t$user\tstarted\n";
    close(LOG);
    chmod(0777,"$FIG_Config::data/Subsystems/$ssa");

    &show_ssa($fig,$cgi,$html);
}

sub show_ssa {
    my($fig,$cgi,$html) = @_;

    my $user = $cgi->param('user');
    my $ssa  = $cgi->param('ssa_name');

    if  (! $user)
    {
	push(@$html,$cgi->h1('You need to specify a user to work on a subsystem annotation'));
	return;
    }

    if  (! $ssa)
    {
	push(@$html,$cgi->h1('You need to specify a subsystem'));
	return;
    }

    my $name  = $ssa;
    $name =~ s/_/ /g;
    $ssa  =~ s/ /_/g;

    if  (open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
    {
	$/ = "//\n";
	my($i,$role,%pos,$subset,$adj_subset,$genome,$row,$abbrev);
	if (defined($_ = <SSA>) && $_)
	{
	    $_ =~ s/\n?\/\/\n//s;
	    $i = 1;
	    foreach $role (split(/\n/,$_))
	    {
		if ($role =~ /^(.*)\t(.*)$/)
		{
		    $role = $2;
		    $abbrev = $1;
		}
		else
		{
		    $abbrev = "";
		}
		$cgi->param(-name => "posR$i", -value => $i);
		$cgi->param(-name => "role$i", -value => $role);
		$cgi->param(-name => "abbrev$i", -value => $abbrev);
		$pos{$role} = $i;
		$i++;
	    }
	    if (defined($_ = <SSA>) && $_)
	    {
		$_ =~ s/\n?\/\/\n//s;
		my($subsetsC,$subsetsR) = split(/\n\n/,$_);
		$i = 1;
		my @subsetsC = split(/\n/,$subsetsC);
		my $active_subsetC = (@subsetsC > 0) ? pop @subsetsC : "All";
		$cgi->param(-name => 'active_subsetC', -value => $active_subsetC);
		foreach $subset (@subsetsC)
		{
		    my($nameCS,@subset_members) = split(/\s+/,$subset);
		    $cgi->param(-name => "nameCS$i", -value => $nameCS);
		    $adj_subset = join(" ",map { $pos{$_} ? $pos{$_} : $_ } @subset_members);
		    $cgi->param(-name => "subsetC$i", -value => $adj_subset);
		    $i++;
		}

		my $active_subsetR = ($subsetsR && ($subsetsR =~ /^(\S[^\n]+\S)/)) ? $1 : "All";
		$cgi->param(-name => 'active_subsetR', -value => $active_subsetR);
		$/ = "\n";
		$i = 1;
		while (defined($_ = <SSA>))
		{
		    chop;
		    my($entry,$checked);
		    my @row = split(/\t/,$_);
		    if (@row > 0)
		    {
			$genome = shift @row;
			$cgi->param(-name => "genome$i", -value => $genome);
			$checked = shift @row;
			$cgi->param(-name => "checked_row$i", -value => $checked);
		    }
		    else
		    {
			$cgi->param(-name => "checked_row$i", -value => 0);
		    }
		    
		    my $j = 1;
		    foreach $entry (@row)
		    {
			$cgi->param(-name => "row$i.$j", -value => $entry);
			$j++;
		    }
		    $i++;
		}
	    }
	    close(SSA);
	}

	if (-s "$FIG_Config::data/Subsystems/$ssa/notes")
	{
	    my $notes = &FIG::file_read("$FIG_Config::data/Subsystems/$ssa/notes");
	    $cgi->param(-name => 'notes', -value => $notes);
	}
    }
    else
    {
	&format_empty_ssa("$FIG_Config::data/Subsystems/$ssa/spreadsheet");
    }
    &show_ssa_noload($fig,$cgi,$html);
}
	
sub format_empty_ssa {
    my($file) = @_;

    open(SSA,">$file") || die "aborted";
    print SSA "//\nAll\n\n";
    &print_default_genome_set(\*SSA);
    print SSA "//\n";
    close(SSA);
}
    
sub print_default_genome_set {
    my($fh) = @_;

    print $fh &default_genome_set, "\n";
}

sub default_genome_set { 
    return "All";
}

sub show_ssa_noload {
    my($fig,$cgi,$html) = @_;
    my($col);

    my $user = $cgi->param('user');
    my $ssa  = $cgi->param('ssa_name');

    if  (! $user)
    {
	push(@$html,$cgi->h1('You need to specify a user to work on a subsystem annotation'));
	return;
    }

    if  (! $ssa)
    {
	push(@$html,$cgi->h1('You need to specify a subsystem'));
	return;
    }

    my $name  = $ssa;
    $name =~ s/_/ /g;
    $ssa =~ s/ /_/g;

    push(@$html, $cgi->h1("Subsystem: $name"),
                 $cgi->start_form(-action => "ssa.cgi",
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'show_ssa_noload', -override => 1),
	         $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
	         $cgi->br,
	 );

    my($roles,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR,$genomes,$rows) = &get_existing($fig,$cgi,$html,$ssa,$user);
    &format_roles($fig,$cgi,$html,$roles,$genomes,$rows);
    &format_subsets($fig,$cgi,$html,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    &format_rows($fig,$cgi,$html,$roles,$genomes,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    &format_extend_with($fig,$cgi,$html,$genomes,$roles);
    push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'precise_fill', -value => 1, -checked => 0, -override => 1,-label => 'fill'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'aggressive_fill', -value => 1, -checked => 0, -override => 1,-label => 'aggressively fill'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'show_missing', -value => 1, -checked => 0, -override => 1,-label => 'show missing'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'show_dups', -value => 1, -checked => 0, -override => 1,-label => 'show duplicates'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'check_problems', -value => 1, -checked => 0, -override => 1,-label => 'show PEGs in roles that do not match precisely'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'show_excluded', -value => 1, -checked => 0, -override => 1,-label => 'show PEGs that have roles, but not in spreadsheet'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'add_solid', -value => 1, -checked => 0, -override => 1,-label => 'Add Genomes with Solid Hits'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'show_coupled_fast', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs fast [depends on existing pins/clusters]'),$cgi->br);
   push(@$html,$cgi->checkbox(-name => 'show_coupled', -value => 1, -checked => 0, -override => 1,-label => 'show coupled PEGs[figure 2 minutes per PEG in spreadsheet]'),$cgi->br);

    push(@$html,$cgi->br,"Align column: ",
	        $cgi->textfield(-name => "col_to_align", -size => 7),
	        $cgi->br,"Include homologs that pass the following threshhold: ",
	        $cgi->textfield(-name => "include_homo", -size => 10)," (leave blank to see just column)",
	        " Max homologous seqs: ",$cgi->textfield(-name => "max_homo", -value => 100, -size => 6),
	        $cgi->hr);

    if ($cgi->param('show_missing'))
    {
	&format_missing($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    }

    if ($cgi->param('show_dups'))
    {
	&format_dups($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    }

    if ($cgi->param('show_excluded'))
    {
	&format_excluded($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    }

    if ($cgi->param('show_coupled'))
    {
	&format_coupled($fig,$cgi,$html,$genomes,$roles,$rows,"careful",$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    }
    elsif ($cgi->param('show_coupled_fast'))
    {
	&format_coupled($fig,$cgi,$html,$genomes,$roles,$rows,"fast",$subsetsC,$active_subsetC,$subsetsR,$active_subsetR);
    }

    if ($col = $cgi->param('col_to_align'))
    {
	&align_column($fig,$cgi,$html,$col,$roles,$genomes,$rows,$subsetsR,$active_subsetR);
    }


    my $notes = "";
    if (-s "$FIG_Config::data/Subsystems/$ssa/notes")
    {
	$notes = &FIG::file_read("$FIG_Config::data/Subsystems/$ssa/notes");
    }
    push(@$html,$cgi->hr,"NOTES:\n",$cgi->br,$cgi->textarea(-name => 'notes', -rows => 40, -cols => 100, -value => $notes));
}

sub format_extend_with {
    my($fig,$cgi,$html,$genomes,$roles) = @_;
    my($org,$gs);
    
#    if (@$genomes > 0)
#    {
	my %genomes = map { $_ => 1 } @$genomes;
	my @orgs = sort map { $org = $_; $gs = &ext_genus_species($fig,$org); "$gs ($org)" } 
	                grep { ! $genomes{$_} } 
	                $fig->genomes("complete",undef);
	push(@$html,
	            $cgi->h1('Pick Organisms to Extend with'),
	            $cgi->scrolling_list(-name => 'korgs',
					 -values => [@orgs],
					 -size => 10,
					 -multiple => 1
					 ),
	            $cgi->hr
	     );
#    }
#    else
#    {
#	my $col_hdrs = ["Genome ID","Organism","not checked","checked"];
#	my @checked = $cgi->radio_group(-name => 'checked_row1',-values => [0,1], -nolabels => 1, -override => 1);
#	my $row = [$cgi->textfield(-name => "genome1", -size => 15),"",@checked];
#	my $i = 1;
#	my $role;
#	while ($i < @$roles)
#	{
#	    push(@$row,$cgi->textfield(-name => "row1.$i", -size => 15));
#	    $i++;
#	}
#	my $tab = [$row];
#	push(@$html,&HTML::make_table($col_hdrs,$tab,"Basic Spreadsheet"),
#	            $cgi->hr
#	     );
#    }
}

sub format_rows {
    my($fig,$cgi,$html,$roles,$genomes,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;

    my($i);
    my $subsetC = $subsetsC->{$active_subsetC};
    my $subsetR = $subsetsR->{$active_subsetR};
#    print &Dumper($subsetsC,$subsetC,$active_subsetC); die "aborted";
    if (@$rows > 0)
    {
	my $col_hdrs = ["Genome ID","Organism","not checked","checked"];
	for ($i=1; ($i < @$roles); $i++)
	{
	    if ($roles->[$i])
	    {
		if ($subsetC->{$i})
		{
		    if ($roles->[$i] =~ /^(.*\S.*)\t(.*)$/)
		    {
			push(@$col_hdrs,$1);
		    }
		    else
		    {
			push(@$col_hdrs,$i);
		    }
		}
	    }
	}
	my $tab = [];

	&format_existing_rows($fig,$cgi,$html,$tab,$genomes,$rows,$roles,$subsetC,$subsetR);

	push(@$html,&HTML::make_table($col_hdrs,$tab,"Basic Spreadsheet"),
	            $cgi->hr
	     );

	push(@$html,$cgi->scrolling_list(-name => 'sort', 
					 -value => ['unsorted','alphabetic','by_variant','by_phylo','by_tax_id'],
					 -default => 'unsorted'
					 ));
    }
}

sub format_existing_rows {
    my($fig,$cgi,$html,$tab,$genomes,$rows,$roles,$subsetC,$subsetR) = @_;
    my($i,$j,$genome,$row,$entries);
    my(@tab1);

    if (@$genomes != @$rows) 
    {
	print STDERR &Dumper($genomes,$rows); die "mismatch between genomes and rows";
    }

    my $iR = 1;
    for ($i=0; ($i < @$genomes); $i++)
    {
	$genome = $genomes->[$i];
	next if (! $genome);
	my $checked = $rows->[$i]->[0];

	my @tmp = ();
	for ($j=1; ($j < @$roles); $j++)
	{
	    $rows->[$i]->[$j] = &verify_entry($fig,$genome,$rows->[$i]->[$j]);
	    if ($subsetR->{$genome} && $subsetC->{$j})
	    {
		if ($cgi->param('aggressive_fill') && (! $rows->[$i]->[$j]))
		{
		    $rows->[$i]->[$j] = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_aggressively($fig,$j,$genome,$roles,$genomes,$rows));
		}
		elsif ($cgi->param('precise_fill') && (! $rows->[$i]->[$j]))
		{
		    $rows->[$i]->[$j] = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$j,$genome,$roles));
		}
	    }
	    $tmp[$j-1] = $rows->[$i]->[$j];
	}

	if ($subsetR->{$genome})
	{
	    my $variant = join("", map { ($_ =~ /\S/) ? 1 : 0 } @tmp);
	    my @checked = $cgi->radio_group(-name => "checked_row$iR",-values => [0,1], -nolabels => 1, -override => 1, -default => $checked);
	    $row = [[$genome,$variant],  # key for sorting
		    $cgi->textfield(-name => "genome$iR", -size => 15, -value => $genome, -override => 1),
		    &ext_genus_species($fig,$genome),
		    @checked
		    ];
	    $j = 1;
	    while ($j < @$roles)
	    {
		if ($roles->[$j])
		{
		    if ($subsetC->{$j})
		    {
			push(@$row,$cgi->textfield(-name => "row$iR.$j", -size => 15, -value => $tmp[$j-1], -override => 1));
		    }
		    else
		    {
			push(@$html,$cgi->hidden(-name => "row$iR.$j", -value => $tmp[$j-1], -override => 1));
		    }
		}
		$j++;
	    }
	    push(@tab1,$row);
	}
	else
	{
	    push(@$html,$cgi->hidden(-name => "genome$iR", -value => $genome, -override => 1),
		        $cgi->hidden(-name => "checked_row$iR", -value => $checked, -override => 1)
		 );

	    $j = 1;
	    while ($j < @$roles)
	    {
		if ($roles->[$j])
		{
		    push(@$html,$cgi->hidden(-name => "row$iR.$j", -value => $tmp[$j-1], -override => 1));
		}
		$j++;
	    }
	}
	$iR++;
    }

    my($sort);
    if ($sort = $cgi->param('sort'))
    {
	if ($sort eq "by_variant")
	{
	    @tab1 = sort { ($a->[0]->[1] cmp $b->[0]->[1]) or ($fig->genus_species($a->[0]->[0]) cmp $fig->genus_species($b->[0]->[0])) } @tab1;
	}
	elsif ($sort eq "by_phylo")
	{
	    @tab1 = map      { $_->[0] }
	            sort     { $a->[1] cmp $b->[1] }
	            map      { [$_, $fig->taxonomy_of($_->[0]->[0])] }
		    @tab1;
	}
        elsif ($sort eq "by_tax_id")
        {
            @tab1 = map      { $_->[0] }
                    sort     { $a->[1] <=> $b->[1] }
                    map      { [$_, $_->[0]->[0]] }
                    @tab1;
        }
	elsif ($sort eq "alphabetic")
	{
	    @tab1 = map      { $_->[0] }
	            sort     { $a->[1] cmp $b->[1] }
	            map      { [$_, $fig->genus_species($_->[0]->[0])] }
		    @tab1;
	}
    }

    my $x;
    foreach $x (@tab1)
    {
	shift @$x;    # eliminate sort key
	push(@$tab,$x);
    }
}

sub format_subsets {
    my($fig,$cgi,$html,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;

    &format_subsetsC($fig,$cgi,$html,$subsetsC,$active_subsetC);
    &format_subsetsR($fig,$cgi,$html,$subsetsR,$active_subsetR);
}

sub format_subsetsC {
    my($fig,$cgi,$html,$subsetsC,$active_subsetC) = @_;
    my($i);

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

    my $n = 1;
    &format_existing_subsetsC($cgi,$tab,$subsetsC,\$n);
    for ($i=0; ($i < 5); $i++)
    {
	&format_subsetC($cgi,$tab,$n,"");
	$n++;
    }
    push(@$html,&HTML::make_table($col_hdrs,$tab,"Subsets of Roles"),
	        $cgi->hr
	 );

    if (keys(%$subsetsC) > 1)
    {
	push(@$html,$cgi->scrolling_list(-name => 'active_subsetC',
					 -values => [sort keys(%$subsetsC)],
					 -default => $active_subsetC
					 ),
	            $cgi->br
	     );
    }
    else
    {
	push(@$html,$cgi->hidden(-name => 'active_subsetC', -value => $active_subsetC, -override => 1));
    }
}

sub format_subsetsR {
    my($fig,$cgi,$html,$subsets,$active_subsetR) = @_;
    my($i);

    my $link = &tree_link;
    push(@$html,$cgi->br,$link,$cgi->br);

    my @tmp = grep { $_ ne "All" } sort keys(%$subsets);
    push(@$html,$cgi->scrolling_list(-name => 'active_subsetR',
				     -values => ["All",@tmp],
				     -default => $active_subsetR,
				     -size => 5
				     ),
	        $cgi->br
	 );
}

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

    foreach $nameCS (sort keys(%$subsetsC))
    {
	&format_subsetC($cgi,$tab,$$nP,$nameCS,$subsetsC->{$nameCS});
	$$nP++;
    }
}

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

    if ($nameCS ne "All")
    {
	my $subset = join(",",sort { $a <=> $b } keys(%$subsetC));
	my $posT     = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1); 
	my $subsetT  = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1);
	push(@$tab,[$posT,$subsetT]);
    }
}

sub format_roles {
    my($fig,$cgi,$html,$roles,$genomes,$rows) = @_;
    my($i);

    my $col_hdrs = ["Column","Abbrev","Functional Role"];
    my $tab = [];

    my $n = 1;
    &format_existing_roles($fig,$cgi,$tab,$roles,\$n,$genomes,$rows);
    for ($i=0; ($i < 5); $i++)
    {
	&format_role($fig,$cgi,$tab,$n,"",$roles,$genomes,$rows);
	$n++;
    }
    push(@$html,&HTML::make_table($col_hdrs,$tab,"Functional Roles"),
	        $cgi->hr
	 );
}

sub format_existing_roles {
    my($fig,$cgi,$tab,$roles,$nP,$genomes,$rows) = @_;
    my($role,$i);

    
    for ($i=1; ($i < @$roles); $i++)
    {
	$role = $roles->[$i];
	&format_role($fig,$cgi,$tab,$$nP,$role,$roles,$genomes,$rows);
	$$nP++;
    }
}

sub format_role {
    my($fig,$cgi,$tab,$n,$role,$roles,$genomes,$rows) = @_;
    my($abbrev,$text);

    if ($role =~ /^(.*)\t(.*)$/)
    {
	$abbrev = $1;
	$text   = $2;
    }
    else
    {
	$abbrev = "";
	$text   = $role;
    }

    my $posT     = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1); 
    my $abbrevT  = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1);
    my $roleT    = $cgi->textfield(-name => "role$n", -size => 80, -value => $text, -override => 1);
    push(@$tab,[$posT,$abbrevT,$roleT]);
    my @roles    = grep { $_->[0] ne $text } &gene_functions_in_col($fig,$n,$roles,$genomes,$rows);
    my($x,$peg);
    foreach $x (@roles)
    {
	push(@$tab,["","",$x->[0]]);
	if ($cgi->param('check_problems'))
	{
	    push(@$tab,["","",join(",",map { &HTML::fid_link($cgi,$_) } @{$x->[1]})]);
	}
    }
}

sub get_existing {
    my($fig,$cgi,$html,$ssa,$user) = @_;
    my($i,$j,$pos,$role,$subset,@roles,$genome,$row,$nameCS,$nameRS,%role_map,%role_map2);
    my($param,@param,@tmp,$active_subsetC,$pair);
  
    my $roles          = [];
    my $genomes        = [];
    my $rows           = [];
    my $subsetsC       = {};
    my $active_subsetC = "All";
    my $subsetsR       = {};
    my $active_subsetR = "All";

    &log_update($ssa,$user);

    if (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet")
    {
	rename("$FIG_Config::data/Subsystems/$ssa/spreadsheet","$FIG_Config::data/Subsystems/$ssa/spreadsheet~");
	if (-s "$FIG_Config::data/Subsystems/$ssa/notes")
	{
    	    rename("$FIG_Config::data/Subsystems/$ssa/notes","$FIG_Config::data/Subsystems/$ssa/notes~");
	}
	else
	{
	    open(NOTES,">$FIG_Config::data/Subsystems/$ssa/notes");
	    close(NOTES);
	    chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
	}
    }
    open(SSA,">$FIG_Config::data/Subsystems/$ssa/spreadsheet")
	|| die "could not open $FIG_Config::data/Subsystems/$ssa/spreadsheet";

    @param = grep { $_ =~ /^posR/ } $cgi->param;
    foreach $param (@param)
    {
	if ($param =~ /^posR(\d+)/)
	{
	    $i = $1;
	    if (($pos = $cgi->param("posR$i")) && ($role = $cgi->param("role$i")))
	    {
		$role =~ s/^\s+//;
		$role =~ s/\s+$//;
		if ($role =~ /\S/)
		{
		    if ($_ = $cgi->param("abbrev$i"))
		    {
			$tmp[$pos] = "$_\t$role";
		    }
		    else
		    {
			$tmp[$pos] = "\t$role";
		    }
		    $role_map2{$pos} = $i;
		}
	    }
	}
    }

    $j = 1;
    foreach $pos (sort { $a <=> $b } keys(%role_map2))
    {
	$roles->[$j] = $tmp[$pos];
	$role_map{$role_map2{$pos}} = $j;
	$j++;
    }

    foreach $role (@$roles)
    {
	if ($role)
	{
	    print SSA "$role\n";
	}
    }
    print SSA "//\n";

    @param = grep { $_ =~ /^nameCS/ } $cgi->param;
    foreach $param (@param)
    {
	if ($param =~ /^nameCS(\d+)/)
	{
	    $i = $1;
	    if (($nameCS = $cgi->param("nameCS$i")) && ($subset = $cgi->param("subsetC$i")))
	    {
		foreach $_ (split(/[\t ,;]+/,$subset))
		{
		    if ($_ =~ /^\d+$/)
		    {
			$subsetsC->{$nameCS}->{$role_map{$_}} = 1;
		    }
		}
	    }
	}
    }

    foreach $nameCS (sort keys(%$subsetsC))
    {
	$subset = $subsetsC->{$nameCS};
	if ($subset)
	{
	    @roles = sort { $a <=> $b } keys(%$subset);
	}
	
	if (@roles > 1)
	{
	    print SSA join("\t",($nameCS,@roles)),"\n";
	}
	else
	{
	    push(@$html,$cgi->h2("invalid subset: $subset"));
	}
    }

    if (! ($active_subsetC = $cgi->param('active_subsetC')))
    {
	$active_subsetC = "All";
    }

    if (! $subsetsC->{"All"})
    {
	for ($i=1; ($i < @$roles); $i++)
	{
	    $subsetsC->{"All"}->{$i} = 1;
	}
    }
    print SSA "$active_subsetC\n";
    print SSA "\n";
    

    my($taxonomic_groups,$id,$members,$genome);
    $taxonomic_groups = $fig->taxonomic_groups_of_complete(10);
    foreach $pair (@$taxonomic_groups)
    {
	($id,$members) = @$pair;
	foreach $genome (@$members)
	{
	    $subsetsR->{$id}->{$genome} = 1;
	}
    }

    $active_subsetR = $cgi->param('active_subsetR');
    if (! ($active_subsetR && $subsetsR->{$active_subsetR}))
    {
	$active_subsetR = &default_genome_set;
    }
    print SSA "$active_subsetR\n";
    print SSA "//\n";

    $i = 1;
    while (defined($genome = $cgi->param("genome$i")))
    {
	if ($genome =~ /^\d+\.\d+$/)
	{
	    $genomes->[$i-1] = $genome;
	}
	$i++;
    }

    $i = 1;
    my($checked,$j,$row,$entry,$non_null);
    while (defined($checked = $cgi->param("checked_row$i")))
    {
	if ($genomes->[$i-1])
	{
	    $row = [$checked];
	    for ($j=1; ($j < (@$roles + 5)); $j++)
	    {
		if ($role_map{$j})
		{
		    if ($entry = $cgi->param("row$i.$j"))
		    {
			$row->[$role_map{$j}] = $entry;
		    }
		    else
		    {
			$row->[$role_map{$j}] = "";
		    }
		}
	    }
	    $rows->[$i-1] = $row;
	    print SSA join("\t",($genomes->[$i-1],@$row)),"\n";
	}
	$i++;
    }

    my @orgs = $cgi->param('korgs');
    @orgs = map { $_ =~ /\((\d+\.\d+)\)/; $1 } @orgs;

    my @orgs1 = ();
    if ($cgi->param('add_solid'))
    {
	my %genomes1 = map { $_ => 1 } (@$genomes,@orgs);;
	@orgs1    = sort  grep { ! $genomes1{$_} }  $fig->genomes("complete",undef);
    }
    &extend_ssa($fig,$genomes,$roles,$rows,\@orgs,\@orgs1,\*SSA);

    close(SSA);
    chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet");
    if (($_ = $cgi->param('notes')) && open(NOTES,">$FIG_Config::data/Subsystems/$ssa/notes"))
    {
	print NOTES $_;
	close(NOTES);
    }
    &backup("$FIG_Config::data/Subsystems/$ssa");

#    print &Dumper($roles,$subsets,$genomes,$rows); die "aborted";
    return ($roles,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR,$genomes,$rows);
}
    
sub format_ssa_table {
    my($html,$user,$ssaP) = @_;
    my($ssa,$curator);
    my($url1,$link1);

    push(@$html, $cgi->start_form(-action => "ssa.cgi",
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1)
	 );

    my $col_hdrs = ["Export Full Subsystem","Export Just Assignments","Reset to Previous Timestamp","Delete","Name","Curator","Exchangable","Version"];
    my $title    = "Existing Subsystem Annotations";
    my $tab = [];
    foreach $_ (@$ssaP)
    {
	($ssa,$curator) = @$_;
	my($url,$link);
	if (-d "$FIG_Config::data/Subsystems/$ssa/Backup")
	{
	    $url = &FIG::cgi_url . "/ssa.cgi?user=$user&ssa_name=$ssa&request=reset";
	    $link = "<a href=$url>reset</a>";
	}
	else
	{
	    $link = "no timestamped backups";
	}

	if ($fig->is_exchangable_subsystem($ssa))
	{
	    $url1  = &FIG::cgi_url . "/ssa.cgi?user=$user&ssa_name=$ssa&request=make_unexchangable";
	    $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>";
	}
	else
	{
	    $url1  = &FIG::cgi_url . "/ssa.cgi?user=$user&ssa_name=$ssa&request=make_exchangable";
	    $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>";
	}
	    
	push(@$tab,[$cgi->checkbox(-name => "export", -value => $ssa),
		    $cgi->checkbox(-name => "export_assignments", -value => $ssa),
		    $link,
		    $cgi->checkbox(-name => "delete", -value => $ssa),
		    &ssa_link($ssa,$user),
		    $curator,
		    $link1,
	            $fig->subsystem_version($ssa)
		    ]);
    }
    push(@$html,&HTML::make_table($col_hdrs,$tab,$title),
	                 $cgi->submit('delete or export checked entries'),
	 	         $cgi->end_form
	 );
}

sub ssa_link {
    my($ssa,$user) = @_;
    my $name = $ssa; $name =~ s/_/ /g;
    my $target = "window$$";
    my $url = &FIG::cgi_url . "/ssa.cgi?user=$user&ssa_name=$ssa&request=show_ssa";
    return "<a href=$url target=$target>$name</a>";
}

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


sub existing_subsystem_annotations {
    my($ssa,$name);
    my @ssa = ();
    if (opendir(SSA,"$FIG_Config::data/Subsystems"))
    {
	@ssa = map { $ssa = $_; $name = $ssa; $ssa =~ s/ /_/g; [$name,&curator($ssa)] } grep { $_ !~ /^\./ } readdir(SSA);
	closedir(SSA);
    }
    return @ssa;
}

sub curator {
    my($ssa) = @_;
    my($who) = "";

    if (open(DATA,"<$FIG_Config::data/Subsystems/$ssa/curation.log"))
    {
	$_  = <DATA>;
	if ($_ =~ /^\d+\t(\S+)\s+started/)
	{
	    $who = $1;
	}
	close(DATA);
    }
    return $who;
}

sub log_update {
    my($ssa,$user) = @_;

    $ssa =~ s/ /_/g;

    if (open(LOG,">>$FIG_Config::data/Subsystems/$ssa/curation.log"))
    {
	my $time = time;
	print LOG "$time\t$user\tupdated\n";
	close(LOG);
    }
    else
    {
	print STDERR "failed to open $FIG_Config::data/Subsystems/$ssa/curation.log\n";
    }
}

sub extend_ssa {
    my($fig,$genomes,$roles,$rows,$new_genomes,$poss_new_genomes,$fh) = @_;
    my($genome,$i,$row,$role);

    foreach $genome (@$new_genomes)
    {
	push(@$genomes,$genome);
	$row = [0];
	for ($i=1; ($i < @$roles); $i++)
	{
	    push(@$row,join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$i,$genome,$roles)));
	}
	push(@$rows,$row);
	print $fh join("\t",($genome,@$row)),"\n";
    }

    foreach $genome (@$poss_new_genomes)
    {
	$row = [0];
	my $bad = 0;
	for ($i=1; ($i < @$roles); $i++)
	{
	    my $entry = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$i,$genome,$roles));
	    if (! $entry)
	    {
		$bad = 1;
		last;
	    }
	    push(@$row,$entry);
	}
	if (! $bad)
	{
	    push(@$genomes,$genome);
	    push(@$rows,$row);
	    print $fh join("\t",($genome,@$row)),"\n";
	}
    }
}

sub seqs_with_role_aggressively {
    my($fig,$i,$genome,$roles,$genomes,$rows) = @_;

# The $i parm is a bit weird.  The actual role we want is in $roles->[$i].  Any existing versions are in
# $rows->[*]->[$i] entries.  You look for acceptable roles among $roles->[$i] (after tab) and the entries
# from the existing rows. 

    my(@roles,$peg,%pegs,$role);
    
    @roles = map { $_->[0] } &gene_functions_in_col($fig,$i,$roles,$genomes,$rows);
    foreach $role (@roles)
    {
	foreach $peg ($fig->seqs_with_role($role,"master",$genome))
	{
	    $pegs{$peg} = 1;
	}
    }
    return sort { &FIG::by_fig_id($a,$b) } keys(%pegs);;
}

sub seqs_with_role_precisely {
    my($fig,$i,$genome,$roles) = @_;

# The $i parm is a bit weird.  The actual role we want is in $roles->[$i].  Any existing versions are in
# $rows->[*]->[$i] entries.  You look for acceptable roles matching $roles->[$i] (after tab)

    my @pegs = ();
    if ($roles->[$i] =~ /([^\t]+)$/)
    {
	@pegs = $fig->seqs_with_role($1,"master",$genome);
    }
    return @pegs;
}

sub gene_functions_in_col {
    my($fig,$i,$roles,$genomes,$rows) = @_;
    my(%roles,$j,$row,$genomeJ,$entry,@pegs,$peg,$func);

    if ($roles->[$i] =~ /([^\t]+)$/)
    {
	$roles{$1} = [];
    }
    
    for ($j=0; ($j < @$rows); $j++)
    {
	$row = $rows->[$j];
	$genomeJ = $genomes->[$j];
	if ($row->[$i] =~ /(\S.*\S)/)
	{
	    $entry = $1;
	    @pegs = map { "fig|$genomeJ.peg.$_" } split(/,/,$entry);
	    foreach $peg (@pegs)
	    {
		if ($func = $fig->function_of($peg))
		{
		    push(@{$roles{$func}},$peg);
		}
	    }
	}
    }
    return map { [$_,$roles{$_}] } sort keys(%roles);
}


sub verify_entry {
    my($fig,$genome,$entry) = @_;
    my($peg);

    my @verified = ();
    foreach $peg (split(/[, \t]+/,$entry))
    {
	if ($fig->is_real_feature("fig|$genome.peg.$peg"))
	{
	    push(@verified,$peg);
	}
    }
    return join(",",@verified);
}

sub export {
    my($fig,$cgi,$ssa) = @_;
    my($line);

    my ($exportable,$notes) = $fig->exportable_subsystem($ssa);
    foreach $line (@$exportable,@$notes)
    {
	print $line;
    }
}
	
sub export_assignments {
    my($fig,$cgi,$ssa) = @_;
    my(@roles,$i,$entry,$id,$user);

    if (($user = $cgi->param('user')) && open(SSA,"<$FIG_Config::data/Subsystems/$ssa/spreadsheet"))
    {
	$user =~ s/^master://;
	&FIG::verify_dir("$FIG_Config::data/Assignments/$user");
	my $who = &curator($ssa);
	my $file = &FIG::epoch_to_readable(time) . ":$who:generated_from_subsystem_$ssa";
	
	if (open(OUT,">$FIG_Config::data/Assignments/$user/$file"))
	{
	    while (defined($_ = <SSA>) && ($_ !~ /^\/\//)) 
	    {
		chop;
		push(@roles,$_);
	    }
	    while (defined($_ = <SSA>) && ($_ !~ /^\/\//))	{}
	    while (defined($_ = <SSA>))
	    {
		chop;
		my @flds = split(/\t/,$_);
		my $genome = $flds[0];
		for ($i=2; ($i < @flds); $i++)
		{
		    my @entries = split(/,/,$flds[$i]);
		    foreach $id (@entries)
		    {
			my $peg = "fig|$genome.peg.$id";
			my $func = $fig->function_of($peg);
			print OUT "$peg\t$func\n";
		    }
		}
	    }
	    close(OUT);
	}
	close(SSA);
    }
}

sub format_missing {
    my($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
    my($i,$j,$missing,$user,$role,$org,$link,$genus_species,$abr);

    my $subsetC = $subsetsC->{$active_subsetC};
    my $subsetR = $subsetsR->{$active_subsetR};

    push(@$html,$cgi->h1('To Check Missing Entries:'));

    for ($i=0; ($i < @$rows); $i++)
    {
	$org = $genomes->[$i];
	next if (! $subsetR->{$org});

	$missing = [];

	for ($j=1; ($j < @$roles); $j++)
	{
	    if ((! $rows->[$i]->[$j]) && $subsetC->{$j})
	    {
		$user = $cgi->param('user');
		$role = $roles->[$j];
		if ($role =~ /^(.*)\t(.*)$/)
		{
		    ($abr,$role) = ($1,$2);
		}
		else
		{
		    $abr = "";
		}
		my $roleE = $cgi->escape($role);
		$link = "<a href=" . &FIG::cgi_url . "/pom.cgi?user=$user&request=find_in_org&role=$roleE&org=$org>$abr $role</a>";
		push(@$missing,$link);
	    }
	}
	if (@$missing > 0)
	{
	    $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));
	    push(@$html,$cgi->ul($cgi->li($missing)));
	}

    }
}

sub format_dups {
    my($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
    my($i,$j,$duplicates,$user,$role,$org,$link,$genus_species,$abr,$func,$peg);

    my $subsetC = $subsetsC->{$active_subsetC};
    my $subsetR = $subsetsR->{$active_subsetR};

    push(@$html,$cgi->h1('To Check Duplicates:'));

    for ($i=0; ($i < @$rows); $i++)
    {
	$org = $genomes->[$i];
	next if (! $subsetR->{$org});

	$duplicates = [];
	for ($j=1; ($j < @$roles); $j++)
	{
	    if (($rows->[$i]->[$j] =~ /,/) && $subsetC->{$j})
	    {
		$user = $cgi->param('user');
		$role = $roles->[$j];
		if ($role =~ /^(.*)\t(.*)$/)
		{
		    ($abr,$role) = ($1,$2);
		}
		else
		{
		    $abr = "";
		}
		push(@$duplicates,"$role<br>" . $cgi->ul($cgi->li([map { $peg = "fig|$org.peg.$_"; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } split(/,/,$rows->[$i]->[$j])])));
	    }
	}
	if (@$duplicates > 0)
	{
	    $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));
	    push(@$html,$cgi->ul($cgi->li($duplicates)));
	}
    }
}

sub format_excluded {
    my($fig,$cgi,$html,$genomes,$roles,$rows,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
    my($i,$j,$show,$user,$role,$org,$link,$genus_species,$abr,$func,$peg,@excluded,@in,%in);

    my $subsetC = $subsetsC->{$active_subsetC};
    my $subsetR = $subsetsR->{$active_subsetR};

    push(@$html,$cgi->h1('To PEGs with Role, but not in Spreadsheet:'));

    for ($i=0; ($i < @$rows); $i++)
    {
	$org = $genomes->[$i];
	next if (! $subsetR->{$org});

	$show = [];
	for ($j=1; ($j < @$roles); $j++)
	{
	    next if (! $subsetC->{$j});

	    if ($rows->[$i]->[$j])
	    {
		@in = map { "fig|$org.peg.$_" } split(/,/,$rows->[$i]->[$j]);
	    }
	    else
	    {
		@in = ();
	    }
	    %in = map { $_ => 1 } @in;
	    $user = $cgi->param('user');
	    $role = $roles->[$j];
	    if ($role =~ /^(.*)\t(.*)$/)
	    {
		($abr,$role) = ($1,$2);
	    }
	    else
	    {
		$abr = "";
	    }
	    @excluded = grep { ! $in{$_} } &seqs_with_role_precisely($fig,$j,$org,$roles);
	    if (@excluded > 0)
	    {
		push(@$show,"$role<br>" . $cgi->ul($cgi->li([map { $peg = $_; $func = $fig->function_of($peg,$user); &HTML::fid_link($cgi,$peg) . " $func" } @excluded])));
	    }
	}
	if (@$show > 0)
	{
	    $genus_species = &ext_genus_species($fig,$org);
	    push(@$html,$cgi->h2("$org: $genus_species"));
	    push(@$html,$cgi->ul($cgi->li($show)));
	}
    }
}

sub format_coupled {
    my($fig,$cgi,$html,$genomes,$roles,$rows,$type,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR) = @_;
    my($i,$j,@show,$user,$org,$link,$gs,$func,$peg,$peg1,$peg2,%in,%seen,%seen2);
    my(@cluster,$sc,$x,$id2,@in,$sim,@coupled);

    my $subsetC = $subsetsC->{$active_subsetC};
    my $subsetR = $subsetsR->{$active_subsetR};

    for ($i=0; ($i < @$rows); $i++)
    {
	$org = $genomes->[$i];
	next if (! $subsetR->{$org});

	for ($j=1; ($j < @$roles); $j++)
	{
	    if ($rows->[$i]->[$j] && $subsetC->{$j})
	    {
		push(@in,map { "fig|$org.peg.$_" } split(/,/,$rows->[$i]->[$j]));
	    }
	}
    }

    %in = map { $_ => 1 } @in;
    $user = $cgi->param('user');
    @show = ();
    foreach $peg1 (@in)
    {
	if ($type eq "careful")
	{
	    @coupled = $fig->coupling_and_evidence($peg1,5000,1.0e-10,0.2,1);
	}
	else
	{
	    @coupled = $fig->fast_coupling($peg1,5000,1);
	}

	foreach $x (@coupled)
	{
	    ($sc,$peg2) = @$x;
	    if ((! $in{$peg2}) && ((! $seen{$peg2}) || ($seen{$peg2} < $sc)))
	    {
		$seen{$peg2} = $sc;
#		print STDERR "$sc\t$peg1 -> $peg2\n";
	    }
	}
    }
	
    foreach $peg1 (sort { $seen{$b} <=> $seen{$a} } keys(%seen))
    {
	if (! $seen2{$peg1})
	{
	    @cluster = ($peg1);
	    $seen2{$peg1} = 1;
	    for ($i=0; ($i < @cluster); $i++)
	    {
		foreach $sim ($fig->sims($cluster[$i],1000,1.0e-10,"fig"))
		{
		    $id2 = $sim->id2;
		    if ($seen{$id2} && (! $seen2{$id2}))
		    {
			push(@cluster,$id2);
			$seen2{$id2} = 1;
		    }
		}
	    }
	    push(@show, [scalar @cluster,
			 $cgi->br .
			 $cgi->ul($cgi->li([map { $peg = $_; 
						  $sc = $seen{$peg};
						  $func = $fig->function_of($peg,$user); 
						  $gs = $fig->genus_species($fig->genome_of($peg));
						  $link = &HTML::fid_link($cgi,$peg);
						  "$sc: $link: $func \[$gs\]" } 
					    sort { $seen{$b} <=> $seen{$a} }
					    @cluster]))
			 ]);
	}
    }

    if (@show > 0)
    {
	@show = map { $_->[1] } sort { $b->[0] <=> $a->[0] } @show;
	push(@$html,$cgi->h1('Coupled, but not in Spreadsheet:'));
	push(@$html,$cgi->ul($cgi->li(\@show)));
    }
}

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 show_tree {

    my($id,$gs);   
    my($tree,$ids) = $fig->build_tree_of_complete;
    my $relabel = {};
    foreach $id (@$ids)
    {
	if ($gs = $fig->genus_species($id))
	{
	    $relabel->{$id} = "$gs ($id)";
	}
    }
    $_ = &display_tree($tree,$relabel);
    print $cgi->pre($_),"\n";
}

sub align_column {
    my($fig,$cgi,$html,$col,$roles,$genomes,$rows,$subsetsR,$active_subsetR) = @_;
    my($colN,@checked,$cutoff);

    my $subsetR = $subsetsR->{$active_subsetR};

    if (($colN = &which_column($col,$roles)) &&
	((@checked = &seqs_to_align($colN,$genomes,$rows,$subsetR)) > 1))
    {
	if ($cutoff = $cgi->param('include_homo'))
	{
	    my $max = $cgi->param('max_homo');
	    $max = $max ? $max : 100;
	    push(@checked,&get_homologs($fig,\@checked,$cutoff,$max));
	}
	my $checked = join("\' \'",@checked);
	push(@$html,"<pre>\n");
	my %org = map { ( $_, $fig->org_of($_) ) } @checked;
	#  Modified by GJO to compress tree and add organism names to tree:
	#  push(@$html,`$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'`);

	#  Simpler version
	# push @$html, map { chomp;
	#                    /^   *\|[ |]*$/      # line that adds only tree height
	#                    ? ()                 # remove it
	#                    : /- ([a-z]+\|\S+):/ && defined( $org{$1} ) # tree id?
	#                    ? "$_ [$org{$1}]\n"  # add the name
	#                    : "$_\n"             # otherwise leave unmodified
	#                  } `$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'`;

	#  More complex version the preserves double spaced tree tips
	my $tip = 0;
	my @out = ();
	foreach ( `$FIG_Config::bin/align_with_clustal -org -func -tree \'$checked\'` )
	{
	    chomp;
	    if    ( /^   *\|[ |]*$/ ) {}  # line that adds only tree height
	    elsif ( /- ([a-z]+\|\S+):/ )  # line with tree tip
	    {
	        if ( defined( $org{$1} ) ) { $_ .= " [$org{$1}]" }  # add org
	        if ( $tip ) { push @out, "  |\n" }  # 2 tips in a row? add line 
	        push @out, "$_\n";      # output current line
	        $tip = 1;
	    }
	    else                          # not a tip
	    {
	        push @out, "$_\n";
	        $tip = 0;
	    }
	}
	push(@$html,&set_links($cgi,\@out));
	push(@$html,"</pre>\n");
    }
    else
    {
	push(@$html,"<h1>You need to check at least two sequences</h1>\n");
    }
}

sub which_column {
    my($col,$roles) = @_;
    my($i);

    if (($col =~ /^(\d+)/) && ($1 <= @$roles))
    {
	return $1;
    }
    else
    {
	for ($i=1; ($i < @$roles) && ($roles->[$i] !~ /^$col\t/); $i++) {}
	return ($i < @$roles) ? $i : undef;
    }
}

sub seqs_to_align {
    my($colN,$genomes,$rows,$subsetR) = @_;
    my($i);

    my @seqs = ();
    for ($i=0; ($i < @$rows); $i++)
    {
	my $genome = $genomes->[$i];
	if ($subsetR->{$genome})
	{
	    push(@seqs,map { "fig|$genome.peg.$_" } split(/,/,$rows->[$i]->[$colN]));
	}
    }
    return @seqs;
}

sub get_homologs {
    my($fig,$checked,$cutoff,$max) = @_;
    my($peg,$sim,$id2);

    my @homologs = ();
    my %got = map { $_ => 1 } @$checked;

    foreach $peg (@$checked)
    {
	foreach $sim ($fig->sims($peg,$max,$cutoff,"fig"))
	{
	    $id2 = $sim->id2;
	    if (! $got{$id2})
	    {
		push(@homologs,[$sim->psc,$id2]);
		$got{$id2} = 1;
	    }
	}
    }
    @homologs = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @homologs;
    if (@homologs > $max) { $#homologs = $max-1 }

    return @homologs;
}

sub set_links {
    my($cgi,$out) = @_;
   
    my @with_links = ();
    foreach $_ (@$out)
    {
	if ($_ =~ /^(.*)(fig\|\d+\.\d+\.peg\.\d+)(.*)$/)
	{
	    my($before,$peg,$after) = ($1,$2,$3);
	    push(@with_links, $before . &HTML::fid_link($cgi,$peg) . $after . "\n");
	}
	else
	{
	    push(@with_links,$_);
	}
    }
    return @with_links;
}

sub backup {
    my($ssaD) = @_;

    my $sz1 = &size("$ssaD/spreadsheet") + &size("$ssaD/notes");
    my $sz2 = &size("$ssaD/spreadsheet~") + &size("$ssaD/notes~");
    if (abs($sz1-$sz2) > 10)
    {
	&make_backup($ssaD);
    }
}

sub make_backup {
    my($ssaD) = @_;

    &FIG::verify_dir("$ssaD/Backup");
    my $ts = time;
    rename("$ssaD/spreadsheet~","$ssaD/Backup/spreadsheet.$ts");
    rename("$ssaD/notes~","$ssaD/Backup/notes.$ts");
    &incr_version($ssaD);
}

sub incr_version {
    my($dir) = @_;
    my($ver);

    if (open(VER,"<$dir/VERSION"))
    {
	if (defined($ver = <VER>) && ($ver =~ /^(\S+)/))
	{
	    $ver = $1;
	}
	else
	{
	    $ver = 0;
	}
	close(VER);
    }
    else
    {
	$ver = 0;
    }
    open(VER,">$dir/VERSION") || die "could not open $dir/VERSION";
    chmod(0777,"$dir/VERSION");
    $ver++;
    print VER "$ver\n";
}
	

sub size {
    my($file) = @_;

    return (-s $file) ? -s $file : 0;
}

sub reset_ssa {
    my($fig,$cgi,$html) = @_;
    my($ssa,@spreadsheets,$col_hdrs,$tab,$t,$readable,$url,$link,@tmp);

    if (($ssa = $cgi->param('ssa_name')) && opendir(BACKUP,"$FIG_Config::data/Subsystems/$ssa/Backup"))
    {
	@spreadsheets = sort { $b <=> $a }
	                map { $_ =~ /^spreadsheet.(\d+)/; $1 }
			grep { $_ =~ /^spreadsheet/ } 
	                readdir(BACKUP);
	closedir(BACKUP);
	$col_hdrs = ["When","Number Genomes"];
	$tab = [];
	foreach $t (@spreadsheets)
	{
	    $readable = &FIG::epoch_to_readable($t);
	    $url = &FIG::cgi_url . "/ssa.cgi?user=$user&ssa_name=$ssa&request=reset_to&ts=$t";
	    $link = "<a href=$url>$readable</a>";
	    open(TMP,"<$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t")
		|| die "could not open $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$t";
	    $/ = "//\n";
	    $_ = <TMP>;
	    $_ = <TMP>;
	    $_ = <TMP>;
	    chomp;
	    $/ = "\n";

	    @tmp = grep { $_ =~ /^\d+\.\d+/ } split(/\n/,$_);
	    push(@$tab,[$link,scalar @tmp]);
	}
    }
    push(@$html,&HTML::make_table($col_hdrs,$tab,"Possible Points to Reset From"));
}

sub reset_ssa_to {
    my($fig,$cgi,$html) = @_;
    my($ts,$ssa);

    if (($ssa = $cgi->param('ssa_name')) &&
	 ($ts = $cgi->param('ts')) && 
	 (-s "$FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts"))
    {
	system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/spreadsheet.$ts $FIG_Config::data/Subsystems/$ssa/spreadsheet";
	chmod(0777,"$FIG_Config::data/Subsystems/$ssa/spreadsheet");
	if (-s "$FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts")
	{
	    system "cp -f $FIG_Config::data/Subsystems/$ssa/Backup/notes.$ts $FIG_Config::data/Subsystems/$ssa/notes";
	    chmod(0777,"$FIG_Config::data/Subsystems/$ssa/notes");
	}
	push(@$html,$cgi->h1("Reset"));
    }
}
		
sub make_exchangable {
    my($fig,$cgi,$html) = @_;
    my($ssa);

    if (($ssa = $cgi->param('ssa_name')) &&
	 (-s "$FIG_Config::data/Subsystems/$ssa/spreadsheet") &&
	open(TMP,">$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
    {
	print TMP "1\n";
	close(TMP);
	chmod(0777,"$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
    }
}

sub make_unexchangable {
    my($fig,$cgi,$html) = @_;
    my($ssa);

    if (($ssa = $cgi->param('ssa_name')) &&
	 (-s "$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE"))
    {
	unlink("$FIG_Config::data/Subsystems/$ssa/EXCHANGABLE");
    }
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3