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

View of /FigWebServices/ssa2.cgi

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.15 - (download) (annotate)
Tue Jun 8 20:25:51 2004 UTC (15 years, 9 months ago) by olson
Branch: MAIN
Changes since 1.14: +83 -0 lines
add new stuff for show_msising

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"));
}
elsif ($cgi->param("export_align_input"))
{
    print $cgi->header;
    print "exporting alignment input\n";
    exit;
}
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);
    }
    #
    # Note that this is a little different; I added another submit button
    # to the delete_or_export_ssa form, so have to distinguish between them
    # here based on $cgi->param('delete_export') - the original button,
    # or $cgi->param('publish') - the new one.
    #
    elsif ($request eq "delete_or_export_ssa" and
	   defined($cgi->param('delete_export')))
    {
	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'))
	{
	    my $cmd = "rm -rf $FIG_Config::data/Subsystems/$ssa";
	    my $rc = system $cmd;
	}

	if (! $exported)
	{
	    &show_initial($fig,$cgi,$html);
	}
	else
	{
	    print "</pre>\n";
	    exit;
	}
    }
    elsif ($request eq "delete_or_export_ssa" and
	   defined($cgi->param('publish')))
    {
	my($ssa,$exported);
	my($ch) = $fig->get_clearinghouse();

	print $cgi->header;

	if (!defined($ch))
	{
	    print "cannot publish: clearinghouse not available\n";
	    exit;
	}
	
	foreach $ssa ($cgi->param('publish_to_clearinghouse'))
	{
	    print "<h2>Publishing $ssa to clearinghouse...</h2>\n";
	    $| = 1;
	    print "<pre>\n";
	    my $res = $fig->publish_subsystem_to_clearinghouse($ssa);
	    print "</pre>\n";
	    if ($res)
	    {
		print "Published <i>$ssa </i> to clearinghouse<br>\n";
	    }
	    else
	    {
		print "<b>Failed</b> to publish <i>$ssa</i> to clearinghouse<br>\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($cgi,$html,$user,\@ssa);
    }

    my $target = "window$$";
    push(@$html, $cgi->h1('To Start a New Subsystem Annotation'),
                 $cgi->start_form(-action => "ssa2.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->hidden(-name => 'can_alter', -value => 1, -override => 1),
	         $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;
	        my(%seen);
		while (defined($_ = <SSA>))
		{
		    chop;
		    my($entry,$checked);
		    my @row = split(/\t/,$_);
	            next if ($seen{$row[0]});
	            $seen{$row[0]} = 1;

		    if (@row > 0)
		    {
			$genome = shift @row;
			$cgi->param(-name => "genome$i", -value => $genome);
			$checked = shift @row;
			$cgi->param(-name => "vcode$i", -value => $checked);
		    }
		    else
		    {
			$cgi->param(-name => "vcode$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 = join("",`cat $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');
    my $can_alter = $cgi->param('can_alter');
    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 => "ssa2.cgi",
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'show_ssa_noload', -override => 1),
	         $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
	         $cgi->hidden(-name => 'ssa_name', -value => $name, -override => 1),
	         $cgi->br,
	 );

    my($roles,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR,$genomes,$rows) = &write_spreadsheet_from_input_parameters($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);

    if ($can_alter)
    {
	&format_extend_with($fig,$cgi,$html,$genomes,$roles);
	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'));
	push(@$html,$cgi->br);
	push(@$html,$cgi->submit('update spreadsheet'),$cgi->br);
    }
    else
    {
	push(@$html,$cgi->br);
	push(@$html,$cgi->submit('show spreadsheet'),$cgi->br);

    }
	
    push(@$html, $cgi->a({href => "ss_export.cgi?user=$user&ssa_name=$ssa"},
			 "Export subsystem data"),
	 $cgi->br);
			 
    push(@$html,$cgi->checkbox(-name => 'show_clusters', -value => 1, -checked => 0, -override => 1,-label => 'show clusters'),$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_missing_including_matches', -value => 1, -checked => 0, -override => 1,-label => 'show missing with matches'),$cgi->br);
    push(@$html,$cgi->checkbox(-name => 'refill', -value => 1, -checked => 0, -override => 1,-label => 'refill spreadsheet from scratch'),$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->checkbox(-name => "show_align_input",  -checked => 0,
			       -label => "show input to alignment tool"),
	        $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_missing_including_matches'))
    {
	&format_missing_including_matches($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 = join("",`cat $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 => 'vcode1',-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","Variant Code"];
	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,$col_hdrs);

	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,$col_hdrs) = @_;
    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 $vcode_value = $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('refill'))
		{
		    $rows->[$i]->[$j] = join(",",map { $_ =~ /(\d+)$/; $1 } &seqs_with_role_precisely($fig,$j,$genome,$roles));
		}
		elsif ($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];
	}

	@tmp = &group_by_clusters($fig,$genome,\@tmp);

	if ($subsetR->{$genome})
	{
	    my $variant = join("", map { ($_->[0] =~ /\S/) ? 1 : 0 } @tmp);

	    my($genomeV,$vcodeV);
	    if ($cgi->param('can_alter'))
	    {
		$genomeV = $cgi->textfield(-name => "genome$iR", -size => 15, -value => $genome, -override => 1);
		$vcodeV  = $cgi->textfield(-name => "vcode$iR", -value => $vcode_value, -size => 5);
	    }
	    else
	    {
		push(@$html,$cgi->hidden(-name => "genome$iR", -value => $genome, -override => 1),
			    $cgi->hidden(-name => "vcode$iR", -value => $vcode_value));
		$genomeV = $genome;
		$vcodeV  = $vcode_value;
	    }

	    $row = [[$genome,$variant],  # key for sorting
		    $genomeV,
		    &ext_genus_species($fig,$genome),
		    $vcodeV
		   ];
	    $j = 1;
	    while ($j < @$roles)
	    {
		if ($roles->[$j])
		{
		    push(@$html,$cgi->hidden(-name => "row$iR.$j", -value => $tmp[$j-1]->[0], -override => 1));
		    if ($subsetC->{$j})
		    {
			push(@$row,&fid_links($cgi,$tmp[$j-1],$genome));
		    }
		}
		$j++;
	    }
	    push(@tab1,$row);
	}
	else
	{
	    push(@$html,$cgi->hidden(-name => "genome$iR", -value => $genome, -override => 1),
		        $cgi->hidden(-name => "vcode$iR", -value => $vcode_value, -override => 1)
		 );

	    $j = 1;
	    while ($j < @$roles)
	    {
		if ($roles->[$j])
		{
		    push(@$html,$cgi->hidden(-name => "row$iR.$j", -value => $tmp[$j-1]->[0], -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)
    {
	if ((@$tab > 0) && ((@$tab % 10) == 0)) 
	{ 
	    push(@$tab,[map { "<b>$_</b>" } @$col_hdrs]) ;
	}
	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,$html,$tab,$subsetsC,\$n);
    if ($cgi->param('can_alter'))
    {
	for ($i=0; ($i < 5); $i++)
	{
	    &format_subsetC($cgi,$html,$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,$html,$tab,$subsetsC,$nP) = @_;
    my($nameCS);

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

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

    if ($nameCS ne "All")
    {
	my $subset = join(",",sort { $a <=> $b } keys(%$subsetC));
	my($posT,$subsetT);
	if ($cgi->param('can_alter'))
	{
	    $posT    = $cgi->textfield(-name => "nameCS$n", -size => 30, -value => $nameCS, -override => 1);
	    $subsetT = $cgi->textfield(-name => "subsetC$n", -size => 80, -value => $subset, -override => 1);
	}
	else
	{
	    push(@$html,$cgi->hidden(-name => "nameCS$n", -value => $nameCS, -override => 1),
		        $cgi->hidden(-name => "subsetC$n", -value => $subset, -override => 1));
	    $posT = $nameCS;
	    $subsetT = $subset;
	}
	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,$html,$tab,$roles,\$n,$genomes,$rows);
    if ($cgi->param('can_alter'))
    {
	for ($i=0; ($i < 5); $i++)
	{
	    &format_role($fig,$cgi,$html,$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,$html,$tab,$roles,$nP,$genomes,$rows) = @_;
    my($role,$i);

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

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

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

    my($posT,$abbrevT,$roleT);
    if ($cgi->param('can_alter'))
    {
	$posT = $cgi->textfield(-name => "posR$n", -size => 3, -value => $n, -override => 1);
	$abbrevT = $cgi->textfield(-name => "abbrev$n", -size => 7, -value => $abbrev, -override => 1);
	$roleT = $cgi->textfield(-name => "role$n", -size => 80, -value => $text, -override => 1);
    }
    else
    {
	push(@$html,$cgi->hidden(-name => "posR$n", -value => $n, -override => 1),
		    $cgi->hidden(-name => "abbrev$n", -value => $abbrev, -override => 1),
	            $cgi->hidden(-name => "role$n", -value => $text, -override => 1));
	$posT = $n;
	$abbrevT = $abbrev;
	$roleT = $text;
    }
    push(@$tab,[$posT,$abbrevT,$roleT]);
    if (! $cgi->param('refill'))
    {
	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 write_spreadsheet_from_input_parameters {
    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";

    if ($cgi->param('can_alter'))
    {
	&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++;
    }

    if ($cgi->param('can_alter'))
    {
	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 ($cgi->param('can_alter'))
	{
	    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;
	}
    }
    if ($cgi->param('can_alter'))
    {
	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;
    }
    if ($cgi->param('can_alter'))
    {
	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($vcode_value,$j,$row,$entry,$non_null);
    while (defined($vcode_value = $cgi->param("vcode$i")))
    {
	if ($genomes->[$i-1])
	{
	    $row = [$vcode_value];
	    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;
	    if ($cgi->param('can_alter'))
	    {
		print SSA join("\t",($genomes->[$i-1],@$row)),"\n";
	    }
	}
	$i++;
    }

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

    if ($cgi->param('can_alter'))
    {
	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";

    #
    # Update the subsystem index.
    #
    # (Put this in an eval in case we get a failure here).
    #

    eval {
	my $sub = $fig->get_subsystem($ssa, 1);
	$sub->db_sync();
    };
    
    return ($roles,$subsetsC,$active_subsetC,$subsetsR,$active_subsetR,$genomes,$rows);
}
    
sub format_ssa_table {
    my($cgi,$html,$user,$ssaP) = @_;
    my($ssa,$curator);
    my($url1,$link1);
    my($publish_checkbox);

    my $can_alter = $cgi->param('can_alter');
    push(@$html, $cgi->start_form(-action => "ssa2.cgi",
				  -method => 'post'),
	         $cgi->hidden(-name => 'user', -value => $user, -override => 1),
	         $cgi->hidden(-name => 'can_alter', -value => $can_alter, -override => 1),
	         $cgi->hidden(-name => 'request', -value => 'delete_or_export_ssa', -override => 1)
	 );
    push(@$html,"<font size=\"+2\">Please do not ever edit someone else\'s spreadsheet (by using their
	         user ID), and <b>never open multiple windows to
                 process the same spreadsheet</b></font>.  It is, of course, standard practice to open a subsystem 
                 spreadsheet and then to have multiple other SEED windows to access data and modify annotations.  Further,
	         you can access someone else's subsystem spreadsheet using your ID (which will make it impossible
                 for you to edit the spreadsheet).
                 Just do not open the same subsystem spreadsheet for editing in multiple windows simultaneously.",
	 $cgi->br,
	 $cgi->br
        );

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

	if (($fig->is_exchangable_subsystem($ssa)) && ($curator eq $cgi->param('user')))
	{
	    $url1  = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=make_unexchangable";
	    $link1 = "Exchangable<br><a href=$url1>Make not exchangable</a>";
	}
	elsif ($curator eq $cgi->param('user'))
	{
	    $url1  = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=make_exchangable";
	    $link1 = "Not exchangable<br><a href=$url1>Make exchangable</a>";
	}
	else
	{
	    $link1 = "";
	}

	#
	# Only allow publish for subsystems we are curating?
	#
	if ($curator eq $cgi->param('user'))
	{
	    $publish_checkbox = $cgi->checkbox(-name => "publish_to_clearinghouse",
					       -value => $ssa,
					       -label => "Publish"),

	}
	    
	push(@$tab,[
		    &ssa_link($ssa,$user),
		    $curator,
		    $link1,
	            $fig->subsystem_version($ssa),
		    $link,
		    ($curator eq $cgi->param('user')) ? $cgi->checkbox(-name => "delete", -value => $ssa) : "",
		    $cgi->checkbox(-name => "export", -value => $ssa, -label => "Export full"),
		    $cgi->checkbox(-name => "export_assignments", -value => $ssa, -label => "Export assignments"),
		    $publish_checkbox,
		    ]);
    }
    push(@$html,
	 &HTML::make_table($col_hdrs,$tab,$title),
	 $cgi->submit(-name => 'delete_export',
		      -label => 'Process marked deletions and exports'),
	 $cgi->submit(-name => 'publish',
		      -label => "Publish marked subsystems"),
	 $cgi->end_form
	 );
}

sub ssa_link {
    my($ssa,$user) = @_;
    my $name = $ssa; $name =~ s/_/ /g;
    my $target = "window$$";
    my $can_alter = &curator($ssa) eq $user;

    my $url = &FIG::cgi_url . "/ssa2.cgi?user=$user&ssa_name=$ssa&request=show_ssa&can_alter=$can_alter";
    return "<a href=$url target=$target>$name</a>";
}

sub tree_link {
    my $target = "window$$";
    my $url = &FIG::cgi_url . "/ssa2.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)));

	}

    }
    close(L);
}

sub format_missing_including_matches 
{
    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);

		#
		# All the way up here is code to retrieve the role name.
		#

		#
		# Invoke find_role_in_org to get the roles we might have.
		#

		my @hits = $fig->find_role_in_org($role, $org, $user, $cgi->param("sims_cutoff"));

		push(@$missing,@hits);
	    }
	}
	$genus_species = &ext_genus_species($fig,$org);
	push(@$html,$cgi->h2("$org: $genus_species"));

	if (@$missing > 0)
	{
	    my $colhdr = ["P-Sc", "PEG", "Len", "Current fn", "Matched peg", "Len", "Function"];
	    my $tbl = [];
	    
	    for my $hit (@$missing)
	    {
		my($psc, $my_peg, $my_len, $my_fn, $match_peg, $match_len, $match_fn) = @$hit;
		
		push(@$tbl, $hit);
	    }

	    push(@$html, &HTML::make_table($colhdr, $tbl, ""));
	}
	else
	{
	    push(@$html, $cgi->p("No matches."));
	}
	   

    }
}

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

}

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

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

    my $checked;

    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));
	}
	$checked = join("\' \'",@checked);
    }
    else
    {
	push(@$html,"<h1>You need to check at least two sequences</h1>\n");
	return;
    }


    #
    # See if we want to produce the alignment, or just produce the
    # input to the alignment.
    #

    if ($cgi->param("show_align_input"))
    {
	push(@$html, "<pre>\n");
	my $relabel;
        foreach my $id (@checked)
	{
	    my $seq;
	    if ($seq = $fig->get_translation($id))
	    {
		push(@$html,  ">$id\n$seq\n");
		my $func = $fig->function_of($id);
		$relabel->{$id} = "$id: $func";
	    }
	    else
	    {
		push(@$html, "could not find translation for $id\n");
	    }
	}
	push(@$html, "\n</pre>\n");
    }
    else
    {
	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 -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 -tree \'$checked\'`;

	#  More complex version the preserves double spaced tree tips
	my $tip = 0;
	my @out = ();

	foreach ( `$FIG_Config::bin/align_with_clustal -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");
    }
}

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 . "/ssa2.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");
    }
}

sub fid_links {
    my($cgi,$entry,$genome) = @_;
    my($pegN);

    my @links = ();
    foreach $pegN (split(/,/,$entry->[0]))
    {
	push(@links,&HTML::fid_link($cgi,"fig|$genome.peg.$pegN","local"));
    }
    my $color = "bgcolor=\"$entry->[1]\"\:";
    return "\@$color" . join(",",@links);
}

sub group_by_clusters {
    my($fig,$genome,$tmp) = @_;
    my(@pegs,$entry,$pegN,%pegs,$peg,$peg1,%conn,%seen,@entries);
    my($i,$x,@cluster,@clusters,%in,$best,$cluster,$which,$colors);

    if (! $cgi->param('show_clusters'))
    {
	return map { [$_,"#FFFFFF"] } @$tmp;
    }

    @pegs = ();
    foreach $entry (@$tmp)
    {
	foreach $pegN (split(/,/,$entry))
	{
	    push(@pegs,"fig|$genome.peg.$pegN");
	}
    }
    %pegs = map { $_ => 1 } @pegs;
    @pegs = keys(%pegs);

    foreach $peg (@pegs)
    {
	foreach $peg1 (grep { $pegs{$_} && ($_ ne $peg) } $fig->close_genes($peg,5000))
	{
	    push(@{$conn{$peg}},$peg1);
	}
    }

    @clusters = ();
    while ($peg = shift @pegs)
    {
	if (! $seen{$peg})
	{
	    @cluster = ($peg);
	    $seen{$peg} = 1;
	    for ($i=0; ($i < @cluster); $i++)
	    {
		$x = $conn{$cluster[$i]};
		foreach $peg1 (@$x)
		{
		    if (! $seen{$peg1})
		    {
			push(@cluster,$peg1);
			$seen{$peg1} = 1;
		    }
		}
	    }
	    push(@clusters,[@cluster]);
	}
    }

    @clusters = sort { @$b <=> @$a } @clusters;
    for ($i=0; ($i < @clusters); $i++)
    {
	$cluster = $clusters[$i];
	foreach $peg (@$cluster)
	{
	    $peg =~ /(\d+)$/;
	    $in{$1} = $i;
	}
    }

    $colors = 
        [
          '#C0C0C0',
          '#FF40C0',
          '#FF8040',
          '#FF0080',
          '#FFC040',
          '#40C0FF',
          '#40FFC0',
          '#C08080',
          '#C0FF00',
          '#00FF80',
          '#00C040'
        ];

    @entries = ();
    foreach $entry (@$tmp)
    {
	$best = undef;
	foreach $pegN (split(/,/,$entry))
	{
	    $which = $in{$pegN};
	    if ((! defined($best)) || ($best > $which))
	    {
		$best = $which;
	    }
	}

	if (defined($best) && (@{$clusters[$best]} > 1) && ($best < @$colors))
	{
	    push(@entries,[$entry,$colors->[$best]]);
	}
	else
	{
	    push(@entries,[$entry,'#FFFFFF']);
	}
    }
    return @entries;
}

MCS Webmaster
ViewVC Help
Powered by ViewVC 1.0.3